( file: WORM.4th -- 8 July 88 -- MFB )
(
This file contains the game "WORM".  To use, configure for your
terminal by changing the DATA[ tables below.  It is already set up for the
IBM AT and will work as-is. For the first try,
change only the critical ones, which are CRTLINES, CRTCOLS, and
CPLEADIN.  To load:  " WORM.4TH" LOAD  (RANDOM.4TH must be on disk)
To execute: WORM
This can be made into a COM file with MAKECOM.4TH
)

OFF PRINTLOAD

" RANDOM.4TH" LOAD


DATA[ BYTE 24 ] CRTLINES        ( number of lines on crt)
DATA[ BYTE 80 ] CRTCOLS		( number of columns)
DATA[ WORD 40 ] XPRTXDLY	( expert x direction delay factor)
DATA[ WORD 100 ] XPRTYDLY	(        y )
DATA[ WORD 60H ] BEGXDLY		( beginner delay)
DATA[ WORD 160H ] BEGYDLY
DATA[ WORD 50 ] XDELAY		( delay used if player does not set options)
DATA[ WORD 150 ] YDELAY
DATA[ BYTE "A" ] UPKEY		( direction keys)
DATA[ BYTE "K" ] LEFTKEY
DATA[ BYTE "L" ] RIGHTKEY
DATA[ BYTE "Z" ] DOWNKEY

( next is clear screen string.  If it is null, then line feeds are used)
DATA[ BYTE " \27\\91\2J" 0 0 0 0 0 0 0 ] CLRSCREEN
( DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] CLRSCREEN)

( next few tell how to position cursor)
DATA[ BYTE " \27\\91\" 0 0 0 0 0 0 0 0 ] CPLEADIN ( lead-in esc seq.)
DATA[ BYTE " ;" 0 0 0 0 0 0 0 0 0 0 ] CPBETRC     ( any thing needed between
						 row and column)
DATA[ BYTE 0 ] CPOFSET				( offsets)
DATA[ BYTE 0 ] COLBEFROW			( column before row flag)
DATA[ BYTE " H" 0 0 0 0 0 0 0 0 0 0 ] CPSUFIX	( esc seq. suffix)


DATA[ BYTE " -" 0 0 0 0 0 0 0 0 0 ] HBORDERCHAR ( playfield border horiz)
DATA[ BYTE " I" 0 0 0 0 0 0 0 0 0 ] VBORDERCHAR ( vertical)
DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] TLCORNER     ( the corners)
DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] BLCORNER
DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] TRCORNER
DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] BRCORNER
DATA[ BYTE " #" 0 0 0 0 0 0 0 0 ] FOODCHAR
DATA[ BYTE " @" 0 0 0 0 0 0 0 0 0 ] WORMCHAR
DATA[ BYTE " \7\" 0 0 0 0 0 0 0 0 0 ] BELLCHAR
DATA[ BYTE "  " 0 0 0 0 0 0 0 0 0 ] BLANKCHAR
DATA[ BYTE " \13 10 0 0 0 0 0 0\" 0 0 0 0 0 ] CRLFCHAR  ( note nulls for delay)
DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0  ] INITSTR      ( terminal init string)
DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0  ] UNINITSTR    ( un-init)

DATA[ BYTE 00001000B ] OPTIONBITS
( bit 0 means move food,
  bit 1 means attract mode,
  bit 2 means 2 rooms
  bit 3 means sound)

DATA[ WORD 20 ] OPRESCALE		( food value countdown)
DATA[ WORD 0 ] SCORE
DATA[ WORD 0 ] WORMLENGTH
DATA[ WORD 0 ] HISCORE
DATA[ WORD 0 ] HILENGTH
DATA[ BYTE "    " ] INITIALS
DATA[ BYTE 10 ] INITFOODV		( initial food value)
DATA[ WORD 5 ] IWLENSHORT		( initial worm lengths)
DATA[ WORD 25 ] IWLENLONG
DATA[ WORD 5 ] INITWORMLENGTH

2 BLOCK PLAYFIELDSIZE
132 64 * BLOCK PLAYFIELD


1 BLOCK XHEAD
1 BLOCK YHEAD
1 BLOCK XTAIL
1 BLOCK YTAIL
1 BLOCK XFOOD
1 BLOCK YFOOD
1 BLOCK DIRECTION
1 BLOCK FOODEATEN
1 BLOCK COLLISION
1 BLOCK FOODV
2 BLOCK PRESCALE

: INKEY ( sample input, return 0 if no input else return ASCII)
  0FFH 6 MON2 ;

: GETKEY
  0 BEGIN
    DROP INKEY DUP
  END
;

CODE UPCASE
  H POP, A L MOV, "a" CPI, IFNC
    "z" 1+ CPI, IFC
      0DFH ANI, L A MOV,
    THEN
  THEN
  ;PUSH 


: .B ( output char on top of stack)
   6 MON1 ;


: GETUPCASE
  0 BEGIN DROP GETKEY UPCASE DUP END[ "A" THRU "Z" ] DUP .B ;

: .S ( output string whose addr is on tos)
  DUPB@ ?DUP IF
    1 DO
      1+ DUPB@ .B
    LOOP
  THEN
  DROP ;


: .S1
  INITSTR .S .S UNINITSTR .S
;

: YESNO
  " \13 10\" .S .S "  (Y/N)? " .S
  0 BEGIN DROP INKEY DUP 0DFH AND END[ "Y" "N" ]
  DUP .B "Y" =
;

: .2
  10 /MOD "0" + .B "0" + .B
;

: .4 ( print 4 digit number)
  1000 /MOD "0" + .B 100 /MOD "0" + .B .2
;


: SETCUR ( set cursor: tos = line, nos = col)
  COLBEFROW B@ IF ( column before row flag set)
    SWAP ( swap args on tos)
  THEN
  CPLEADIN .S ( print esc seq)
  CPOFSET B@ + .L ( .B) ( print line (or col))
  CPBETRC .S ( print seq between row and col)
  CPOFSET B@ + .L ( .B) ( print column (or line))
  CPSUFIX .S ( print remaining esc seq) ;  


: CLRCRT ( clear screen)
  ( first clear the playfield image)
  PLAYFIELDSIZE @ 1- 0 DO 0 PLAYFIELD I + B! LOOP
  ( now the screen)
  CLRSCREEN B@ IF ( there is a control code to do it)
    CLRSCREEN .S
  ELSE ( use line feeds)
    0 CRTLINES B@ 1- SETCUR
    CRTLINES B@ 3 * 1 DO
      CRLFCHAR .S
    LOOP 
  THEN
;

: DRAWBORDER
  ( first set the border in the playfield image)
  PLAYFIELD   ( do top)
    CRTCOLS B@ 1 DO 1 OVER B! 1+ LOOP DROP
  PLAYFIELD PLAYFIELDSIZE @ + CRTCOLS B@ - ( do bottom)
    CRTCOLS B@ 1 DO 1 OVER B! 1+ LOOP DROP
  PLAYFIELDSIZE @ 1- 0 DO
    1 PLAYFIELD I + B! ( left)
    1 PLAYFIELD I + CRTCOLS B@ 1- + B! ( right)
  CRTCOLS B@ +LOOP
  ( do rooms if needed)
  OPTIONBITS B@ 4 AND IF
    PLAYFIELD CRTLINES B@ 2 / CRTCOLS B@ * + 10 +
    CRTCOLS B@ 20 - 1 DO
      1 OVER B! 1+
    LOOP DROP
  THEN

  ( now draw on CRT)
  1 0 SETCUR
  CRTCOLS B@ 2 - 1 DO HBORDERCHAR .S LOOP
  1 CRTLINES B@ 1- SETCUR
  CRTCOLS B@ 2 - 1 DO HBORDERCHAR .S LOOP
  CRTLINES B@ 2 - 1 DO
    0 I SETCUR VBORDERCHAR .S
    CRTCOLS B@ 1- I SETCUR VBORDERCHAR .S
  LOOP 
  0 0 SETCUR TLCORNER .S
  0 CRTLINES B@ 1- SETCUR BLCORNER .S
  CRTCOLS B@ 1- 0 SETCUR TRCORNER .S
  CRTCOLS B@ 1- CRTLINES B@ 1- SETCUR BRCORNER .S
  OPTIONBITS B@ 4 AND IF
    10 CRTLINES B@ 2 / SETCUR
    CRTCOLS B@ 20 - 1 DO  HBORDERCHAR .S LOOP
  THEN
;

: COMPUTERMOVE
    DIRECTION B@ CASE
      00010100B OF ( going down)
        YFOOD B@ YHEAD B@ > IF
          00010100B ( continue)
        ELSE ( go x)
          XHEAD B@ XFOOD B@ < IF
            10000100B ( go right)
          ELSE
            01000100B ( go left)
          THEN
        THEN
      ENDOF
      00100100B OF ( going up)
        YHEAD B@ YFOOD B@ > IF
          00100100B ( continue)
        ELSE ( go x)
          XHEAD B@ XFOOD B@ < IF
            10000100B ( go right)
          ELSE
            01000100B ( go left)
          THEN
        THEN
      ENDOF
      01000100B OF ( going left)
        XHEAD B@ XFOOD B@ > IF
          01000100B ( continue)
        ELSE ( go y)
          YHEAD B@ YFOOD B@ > IF
            00100100B ( go up)
          ELSE
            00010100B ( go down)
          THEN
        THEN
      ENDOF
      10000100B OF ( going right)
        XFOOD B@ XHEAD B@ > IF
          10000100B ( continue)
        ELSE ( go y)
          YHEAD B@ YFOOD B@ > IF
            00100100B ( go up)
          ELSE
            00010100B ( go down)
          THEN
        THEN
      ENDOF
      DROP 0
    ENDCASE
    DIRECTION B!
;

: CHECKINPUT
  INKEY ?DUP IF
    UPCASE CASE
      DOWNKEY   B@  OF   00010100B  DIRECTION B!   ENDOF
      UPKEY     B@  OF   00100100B  DIRECTION B!   ENDOF
      LEFTKEY   B@  OF   01000100B  DIRECTION B!   ENDOF
      RIGHTKEY  B@  OF   10000100B  DIRECTION B!   ENDOF
      ( else)         DROP
    ENDCASE
  THEN
;

: ARRAY
  CRTCOLS B@ * + PLAYFIELD + ;

: MOVEWORM
  DIRECTION B@ XHEAD B@ YHEAD B@ ARRAY B! ( set link to new head)
  DIRECTION B@ CASE
    00010100B OF   YHEAD B@ 1+ YHEAD B!  ENDOF
    00100100B OF   YHEAD B@ 1- YHEAD B!  ENDOF
    01000100B OF   XHEAD B@ 1- XHEAD B!  ENDOF
    10000100B OF   XHEAD B@ 1+ XHEAD B!  ENDOF
      DROP ( just in case)
  ENDCASE
  XHEAD B@ YHEAD B@ SETCUR WORMCHAR .S
  XHEAD B@ YHEAD B@ ARRAY DUPB@ IF
    1 COLLISION B! DUPB@ 010B AND IF
      1 FOODEATEN B!
    THEN
  THEN
  0100B SWAP B! ( set new head in image)
  COLLISION B@ 0= IF
    XTAIL B@ YTAIL B@ SETCUR BLANKCHAR .S ( erase old tail on crt)
    XTAIL B@ YTAIL B@ ARRAY DUPB@ CASE
      00010100B OF   YTAIL B@ 1+ YTAIL B!  ENDOF
      00100100B OF   YTAIL B@ 1- YTAIL B!  ENDOF
      01000100B OF   XTAIL B@ 1- XTAIL B!  ENDOF
      10000100B OF   XTAIL B@ 1+ XTAIL B!  ENDOF
      DROP ( just in case)
    ENDCASE
    0 SWAP B! ( delete old tail from image)
  THEN ;

: MOVEFOOD
  RANDOM 7 AND DUP 4 < IF
    CASE
      0  OF  1 0  ENDOF
      1  OF  -1 0 ENDOF
      2  OF  0 1  ENDOF
      3  OF  0 -1 ENDOF
    ENDCASE
    XFOOD B@ + SWAP YFOOD B@ + OVER OVER ARRAY DUPB@ IF
      3 KILL
    ELSE
      0 XFOOD B@ YFOOD B@ OVER OVER SETCUR BLANKCHAR .S ARRAY B!
      010B SWAP B! OVER OVER SETCUR FOODCHAR .S YFOOD B! XFOOD B!
    THEN
  ELSE
    DROP
  THEN ;



: NEWFOOD
  BEGIN
    RANDOM CRTCOLS B@ 2 - /MOD DROP 1+ XFOOD B!
    RANDOM CRTLINES B@ 2 - /MOD DROP 1+ YFOOD B!
    XFOOD B@ YFOOD B@ ARRAY B@
  0= END
  XFOOD B@ YFOOD B@ OVER OVER ARRAY 010B SWAP B!
  SETCUR FOODCHAR .S ( display food character)
  OPTIONBITS B@ 8 AND IF ( want sound)
    OPTIONBITS B@ 2 AND 0= IF ( and not attract)
      BELLCHAR .S
    THEN
  THEN ;

: FOODVAL
  -1 PRESCALE +! PRESCALE @ 0= IF
    OPRESCALE @ PRESCALE !
    FOODV B@ 1 > IF
      FOODV B@ 1- FOODV B! 16 0 SETCUR FOODV B@ .2
    THEN
  THEN
;
 
: WORMGAME
  INITSTR .S
  CLRCRT DRAWBORDER

  SCORE @ HISCORE @ > IF
    SCORE @ HISCORE ! WORMLENGTH @ HILENGTH !
  THEN
  

  10000100B DIRECTION B! ( initial direction)
  INITWORMLENGTH @  DUP WORMLENGTH !
  1- 0 DO
    10 I + 10 OVER OVER ARRAY 10000100B SWAP B!
    OVER OVER SETCUR WORMCHAR .S
    YHEAD B! XHEAD B!
  LOOP
  10 YTAIL B! 10 XTAIL B!
  
  0 SCORE !

  NEWFOOD
(
          1         2         3
0123456789012345678901234567890123456789
**0000***0000***00***0000***0000***ABC**
  SCORE LENGTH FVAL HISCOR HILENG INIT
)
  OPRESCALE @ PRESCALE !
  21 0 SETCUR HISCORE @ .4
  28 0 SETCUR HILENGTH @ .4
  35 0 SETCUR INITIALS .S


  BEGIN
    2 0 SETCUR SCORE @ .4
    9 0 SETCUR WORMLENGTH @ .4
    16 0 SETCUR INITFOODV B@ DUP FOODV B! .2
    0 FOODEATEN B!
    0 COLLISION B!
    BEGIN
      DIRECTION B@ 0F0H AND 64 >= IF
        XDELAY
      ELSE
        YDELAY
      THEN
      OPTIONBITS B@ 2 AND IF COMPUTERMOVE THEN ( attract)
      @ 1 DO    CHECKINPUT    LOOP
      OPTIONBITS B@ 1 AND IF  MOVEFOOD  THEN
      MOVEWORM
      FOODVAL
      COLLISION B@
    END
    FOODEATEN B@ IF
     NEWFOOD 1 WORMLENGTH +!  FOODV B@ SCORE +!
    THEN
    FOODEATEN B@ 0=
  END
  0 1 SETCUR
  UNINITSTR .S ;

: DELAY
  0 SWAP 0 DO
    2 1 / DROP INKEY ?DUP IF
      SWAP DROP EXIT
    THEN
  LOOP ;


: WORM

  CRTLINES B@ CRTCOLS B@ * PLAYFIELDSIZE !

  CLRCRT 0 0 SETCUR
  " \13 10 10\Welcome to ..." .S
  " \13 10 10\   W O R M   W A R S" .S
  BEGIN
    " \13 10 10\Need Instructions (Y/N)? " .S
    0 0 BEGIN
      DROP 1+ INKEY DUP
    END[ "Y" "y" "N" "n" ]
    0DFH AND DUP .B SWAP ( get seed)
    1 OR DUP 13 * DUP 5 * RANDOMIZE
    "Y" = IF ( ins. wanted)
      " \13 10\Objective: Maneuver the WORM around the " .S
      " \13 10\  room trying to eat the food as it" .S
      " \13 10\  appears. Do this in the least amount" .S
      " \13 10\  of time. The quicker you eat the food," .S
      " \13 10\  the higher your score will be." .S
      " \13 10 10\Two small snags:" .S
      " \13 10\  1. The more food that you eat, the" .S
      " \13 10\     longer the worm gets." .S
      " \13 10\  2. If the worm runs into a wall or " .S
      " \13 10\     itself - the game is then over" .S
      " \13 10 10\Hit any key to continue" .S
      BEGIN INKEY END
         " \13 10 10\Cast: WORM= " .S WORMCHAR .S1
         " \13 10\      FOOD= " .S FOODCHAR .S1
         " \13 10\     WALLS= " .S HBORDERCHAR .S1 20H .B VBORDERCHAR .S1
         " \13 10 10\Directions:    UP= " .S UPKEY B@ .B
         " \13 10\             LEFT= " .S LEFTKEY B@ .B
         " \13 10\            RIGHT= " .S RIGHTKEY B@ .B
         " \13 10\             DOWN= " .S DOWNKEY B@ .B
         " \13 10 10\Good Luck !" .S
    THEN

    " \13 10 10\Want to set options" YESNO IF
      " High speed" YESNO IF
        XPRTXDLY @ XDELAY ! XPRTYDLY @ YDELAY !
      ELSE
        BEGXDLY @ XDELAY ! BEGYDLY @ YDELAY !
      THEN
      OPTIONBITS B@ ( set option bits)
      " Moving food" YESNO IF    1 OR    ELSE    FEH AND    THEN
      " Two rooms" YESNO IF  4 OR  ELSE  FBH AND  THEN
      " Want sound" YESNO IF 8 OR ELSE F7H AND THEN
      OPTIONBITS B!
      " Long worm" YESNO IF
        IWLENLONG B@
      ELSE
        IWLENSHORT B@
      THEN
      INITWORMLENGTH B!
      " Want to redefine movement keys" YESNO IF
        " \13 10\Up key " .S GETKEY UPCASE UPKEY B!
        " \13 10\Down key " .S GETKEY UPCASE DOWNKEY B!
        " \13 10\Left key " .S GETKEY UPCASE LEFTKEY B!
        " \13 10\Right key " .S GETKEY UPCASE RIGHTKEY B!
      THEN
    THEN

    BEGIN
      WORMGAME
      1000 1 DO 
        INKEY 
      DROP LOOP 
      2 1 SETCUR " Score Length Food   Hi     Hi   Best" .S
      2 2 SETCUR "              Value Score Length Player" .S
      SCORE @ HISCORE @ > IF
        OPTIONBITS B@ 2 AND IF ( attract mode)
          "  I " INITIALS $!
        ELSE
          2 3 SETCUR " Initials ?" .S
          INITIALS 3 1 DO
            I 34 + 0 SETCUR GETUPCASE OVER I + B!
          LOOP
          DROP
        THEN
      THEN
      2 3 SETCUR " ESC to end; any other to continue" .S
      OPTIONBITS B@ 2 AND 0= 10000 * 3500 + DELAY DUP IF ( key pressed)
        OPTIONBITS B@ FDH AND ( clear attract mode)
      ELSE
        OPTIONBITS B@ 2 OR ( set attract mode)
      THEN
      OPTIONBITS B!
      27 =
    END
    CLRCRT
    " Do you want to start over" YESNO 0= 
  END
;