home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / 4th_86.lzh / WORM.4TH < prev   
Text File  |  1989-02-18  |  14KB  |  507 lines

  1. ( file: WORM)
  2. (
  3. This file contains the game "WORM".  To use, configure for your
  4. terminal by changing the DATA[ tables below.  For the first try,
  5. change only the critical ones, which are CRTLINES, CRTCOLS, and
  6. CPLEADIN.  To load:  " WORM.4TH" LOAD  (RANDOM.4TH must be on disk)
  7. To execute: WORM
  8. This can be made into a COM file with MAKECOM.4TH
  9. )
  10.  
  11. OFF PRINTLOAD
  12.  
  13. " RANDOM.4TH" LOAD
  14.  
  15.  
  16. DATA[ BYTE 24 ] CRTLINES        ( number of lines on crt)
  17. DATA[ BYTE 80 ] CRTCOLS        ( number of columns)
  18. DATA[ WORD 40 ] XPRTXDLY    ( expert x direction delay factor)
  19. DATA[ WORD 100 ] XPRTYDLY    (        y )
  20. DATA[ WORD 60H ] BEGXDLY        ( beginner delay)
  21. DATA[ WORD 160H ] BEGYDLY
  22. DATA[ WORD 50 ] XDELAY        ( delay used if player does not set options)
  23. DATA[ WORD 150 ] YDELAY
  24. DATA[ BYTE "A" ] UPKEY        ( direction keys)
  25. DATA[ BYTE "K" ] LEFTKEY
  26. DATA[ BYTE "L" ] RIGHTKEY
  27. DATA[ BYTE "Z" ] DOWNKEY
  28.  
  29. ( next is clear screen string.  If it is null, then line feeds are used)
  30. DATA[ BYTE " ^27^^91^2J" 0 0 0 0 0 0 0 ] CLRSCREEN
  31. ( DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] CLRSCREEN)
  32.  
  33. ( next few tell how to position cursor)
  34. DATA[ BYTE " ^27^^91^" 0 0 0 0 0 0 0 0 ] CPLEADIN ( lead-in esc seq.)
  35. DATA[ BYTE " ;" 0 0 0 0 0 0 0 0 0 0 ] CPBETRC     ( any thing needed between
  36.                          row and column)
  37. DATA[ BYTE 0 ] CPOFSET                ( offsets)
  38. DATA[ BYTE 0 ] COLBEFROW            ( column before row flag)
  39. DATA[ BYTE " H" 0 0 0 0 0 0 0 0 0 0 ] CPSUFIX    ( esc seq. suffix)
  40.  
  41.  
  42. DATA[ BYTE " -" 0 0 0 0 0 0 0 0 0 ] HBORDERCHAR ( playfield border horiz)
  43. DATA[ BYTE " |" 0 0 0 0 0 0 0 0 0 ] VBORDERCHAR ( vertical)
  44. DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] TLCORNER     ( the corners)
  45. DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] BLCORNER
  46. DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] TRCORNER
  47. DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0 ] BRCORNER
  48. DATA[ BYTE " #" 0 0 0 0 0 0 0 0 ] FOODCHAR
  49. DATA[ BYTE " @" 0 0 0 0 0 0 0 0 0 ] WORMCHAR
  50. DATA[ BYTE " ^7^" 0 0 0 0 0 0 0 0 0 ] BELLCHAR
  51. DATA[ BYTE "  " 0 0 0 0 0 0 0 0 0 ] BLANKCHAR
  52. DATA[ BYTE " ^13 10 0 0 0 0 0 0^" 0 0 0 0 0 ] CRLFCHAR  ( note nulls for delay)
  53. DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0  ] INITSTR      ( terminal init string)
  54. DATA[ BYTE 0 0 0 0 0 0 0 0 0 0 0  ] UNINITSTR    ( un-init)
  55.  
  56. DATA[ BYTE 00001000B ] OPTIONBITS
  57. ( bit 0 means move food,
  58.   bit 1 means attract mode,
  59.   bit 2 means 2 rooms
  60.   bit 3 means sound)
  61.  
  62. DATA[ WORD 20 ] OPRESCALE        ( food value countdown)
  63. DATA[ WORD 0 ] SCORE
  64. DATA[ WORD 0 ] WORMLENGTH
  65. DATA[ WORD 0 ] HISCORE
  66. DATA[ WORD 0 ] HILENGTH
  67. DATA[ BYTE "    " ] INITIALS
  68. DATA[ BYTE 10 ] INITFOODV        ( initial food value)
  69. DATA[ WORD 5 ] IWLENSHORT        ( initial worm lengths)
  70. DATA[ WORD 25 ] IWLENLONG
  71. DATA[ WORD 5 ] INITWORMLENGTH
  72.  
  73. 2 BLOCK PLAYFIELDSIZE
  74. 132 64 * BLOCK PLAYFIELD
  75.  
  76.  
  77. 1 BLOCK XHEAD
  78. 1 BLOCK YHEAD
  79. 1 BLOCK XTAIL
  80. 1 BLOCK YTAIL
  81. 1 BLOCK XFOOD
  82. 1 BLOCK YFOOD
  83. 1 BLOCK DIRECTION
  84. 1 BLOCK FOODEATEN
  85. 1 BLOCK COLLISION
  86. 1 BLOCK FOODV
  87. 2 BLOCK PRESCALE
  88.  
  89. : INKEY ( sample input, return 0 if no input else return ASCII)
  90.   0FFH 6 MON2 ;
  91.  
  92. : GETKEY
  93.   0 BEGIN
  94.     DROP INKEY DUP
  95.   END
  96. ;
  97.  
  98. CODE UPCASE
  99.   H POP, A L MOV, "a" CPI, IFNC
  100.     "z" 1+ CPI, IFC
  101.       0DFH ANI, L A MOV,
  102.     THEN
  103.   THEN
  104.   ;PUSH 
  105.  
  106.  
  107. : .B ( output char on top of stack)
  108.    6 MON1 ;
  109.  
  110.  
  111. : GETUPCASE
  112.   0 BEGIN DROP GETKEY UPCASE DUP END[ "A" THRU "Z" ] DUP .B ;
  113.  
  114. : .S ( output string whose addr is on tos)
  115.   DUPB@ ?DUP IF
  116.     1 DO
  117.       1+ DUPB@ .B
  118.     LOOP
  119.   THEN
  120.   DROP ;
  121.  
  122.  
  123. : .S1
  124.   INITSTR .S .S UNINITSTR .S
  125. ;
  126.  
  127. : YESNO
  128.   " ^13 10^" .S .S "  (Y/N)? " .S
  129.   0 BEGIN DROP INKEY 0DFH AND dup END[ "Y" "N" ]
  130.   DUP .B "Y" =
  131. ;
  132.  
  133. : .2
  134.   10 /MOD "0" + .B "0" + .B
  135. ;
  136.  
  137. : .4 ( print 4 digit number)
  138.   1000 /MOD "0" + .B 100 /MOD "0" + .B .2
  139. ;
  140.  
  141.  
  142. : SETCUR ( set cursor: tos = line, nos = col)
  143.   COLBEFROW B@ IF ( column before row flag set)
  144.     SWAP ( swap args on tos)
  145.   THEN
  146.   CPLEADIN .S ( print esc seq)
  147.   CPOFSET B@ + .L ( .B) ( print line (or col))
  148.   CPBETRC .S ( print seq between row and col)
  149.   CPOFSET B@ + .L ( .B) ( print column (or line))
  150.   CPSUFIX .S ( print remaining esc seq) ;  
  151.  
  152.  
  153. : CLRCRT ( clear screen)
  154.   ( first clear the playfield image)
  155.   PLAYFIELDSIZE @ 1- 0 DO 0 PLAYFIELD I + B! LOOP
  156.   ( now the screen)
  157.   CLRSCREEN B@ IF ( there is a control code to do it)
  158.     CLRSCREEN .S
  159.   ELSE ( use line feeds)
  160.     0 CRTLINES B@ 1- SETCUR
  161.     CRTLINES B@ 3 * 1 DO
  162.       CRLFCHAR .S
  163.     LOOP 
  164.   THEN
  165. ;
  166.  
  167. : DRAWBORDER
  168.   ( first set the border in the playfield image)
  169.   PLAYFIELD   ( do top)
  170.     CRTCOLS B@ 1 DO 1 OVER B! 1+ LOOP DROP
  171.   PLAYFIELD PLAYFIELDSIZE @ + CRTCOLS B@ - ( do bottom)
  172.     CRTCOLS B@ 1 DO 1 OVER B! 1+ LOOP DROP
  173.   PLAYFIELDSIZE @ 1- 0 DO
  174.     1 PLAYFIELD I + B! ( left)
  175.     1 PLAYFIELD I + CRTCOLS B@ 1- + B! ( right)
  176.   CRTCOLS B@ +LOOP
  177.   ( do rooms if needed)
  178.   OPTIONBITS B@ 4 AND IF
  179.     PLAYFIELD CRTLINES B@ 2 / CRTCOLS B@ * + 10 +
  180.     CRTCOLS B@ 20 - 1 DO
  181.       1 OVER B! 1+
  182.     LOOP DROP
  183.   THEN
  184.  
  185.   ( now draw on CRT)
  186.   1 0 SETCUR
  187.   CRTCOLS B@ 2 - 1 DO HBORDERCHAR .S LOOP
  188.   1 CRTLINES B@ 1- SETCUR
  189.   CRTCOLS B@ 2 - 1 DO HBORDERCHAR .S LOOP
  190.   CRTLINES B@ 2 - 1 DO
  191.     0 I SETCUR VBORDERCHAR .S
  192.     CRTCOLS B@ 1- I SETCUR VBORDERCHAR .S
  193.   LOOP 
  194.   0 0 SETCUR TLCORNER .S
  195.   0 CRTLINES B@ 1- SETCUR BLCORNER .S
  196.   CRTCOLS B@ 1- 0 SETCUR TRCORNER .S
  197.   CRTCOLS B@ 1- CRTLINES B@ 1- SETCUR BRCORNER .S
  198.   OPTIONBITS B@ 4 AND IF
  199.     10 CRTLINES B@ 2 / SETCUR
  200.     CRTCOLS B@ 20 - 1 DO  HBORDERCHAR .S LOOP
  201.   THEN
  202. ;
  203.  
  204. : COMPUTERMOVE
  205.     DIRECTION B@ CASE
  206.       00010100B OF ( going down)
  207.         YFOOD B@ YHEAD B@ > IF
  208.           00010100B ( continue)
  209.         ELSE ( go x)
  210.           XHEAD B@ XFOOD B@ < IF
  211.             10000100B ( go right)
  212.           ELSE
  213.             01000100B ( go left)
  214.           THEN
  215.         THEN
  216.       ENDOF
  217.       00100100B OF ( going up)
  218.         YHEAD B@ YFOOD B@ > IF
  219.           00100100B ( continue)
  220.         ELSE ( go x)
  221.           XHEAD B@ XFOOD B@ < IF
  222.             10000100B ( go right)
  223.           ELSE
  224.             01000100B ( go left)
  225.           THEN
  226.         THEN
  227.       ENDOF
  228.       01000100B OF ( going left)
  229.         XHEAD B@ XFOOD B@ > IF
  230.           01000100B ( continue)
  231.         ELSE ( go y)
  232.           YHEAD B@ YFOOD B@ > IF
  233.             00100100B ( go up)
  234.           ELSE
  235.             00010100B ( go down)
  236.           THEN
  237.         THEN
  238.       ENDOF
  239.       10000100B OF ( going right)
  240.         XFOOD B@ XHEAD B@ > IF
  241.           10000100B ( continue)
  242.         ELSE ( go y)
  243.           YHEAD B@ YFOOD B@ > IF
  244.             00100100B ( go up)
  245.           ELSE
  246.             00010100B ( go down)
  247.           THEN
  248.         THEN
  249.       ENDOF
  250.       DROP 0
  251.     ENDCASE
  252.     DIRECTION B!
  253. ;
  254.  
  255. : CHECKINPUT
  256.   INKEY ?DUP IF
  257.     UPCASE CASE
  258.       DOWNKEY   B@  OF   00010100B  DIRECTION B!   ENDOF
  259.       UPKEY     B@  OF   00100100B  DIRECTION B!   ENDOF
  260.       LEFTKEY   B@  OF   01000100B  DIRECTION B!   ENDOF
  261.       RIGHTKEY  B@  OF   10000100B  DIRECTION B!   ENDOF
  262.       ( else)         DROP
  263.     ENDCASE
  264.   THEN
  265. ;
  266.  
  267. : ARRAY
  268.   CRTCOLS B@ * + PLAYFIELD + ;
  269.  
  270. : MOVEWORM
  271.   DIRECTION B@ XHEAD B@ YHEAD B@ ARRAY B! ( set link to new head)
  272.   DIRECTION B@ CASE
  273.     00010100B OF   YHEAD B@ 1+ YHEAD B!  ENDOF
  274.     00100100B OF   YHEAD B@ 1- YHEAD B!  ENDOF
  275.     01000100B OF   XHEAD B@ 1- XHEAD B!  ENDOF
  276.     10000100B OF   XHEAD B@ 1+ XHEAD B!  ENDOF
  277.       DROP ( just in case) 
  278.   ENDCASE
  279.   XHEAD B@ YHEAD B@ SETCUR WORMCHAR .S
  280.   XHEAD B@ YHEAD B@ ARRAY DUPB@ IF
  281.     1 COLLISION B! DUPB@ 010B AND IF
  282.       1 FOODEATEN B!
  283.     THEN
  284.   THEN
  285.   0100B SWAP B! ( set new head in image)
  286.   COLLISION B@ 0= IF
  287.     XTAIL B@ YTAIL B@ SETCUR BLANKCHAR .S ( erase old tail on crt)
  288.     XTAIL B@ YTAIL B@ ARRAY DUPB@ CASE
  289.       00010100B OF   YTAIL B@ 1+ YTAIL B!  ENDOF
  290.       00100100B OF   YTAIL B@ 1- YTAIL B!  ENDOF
  291.       01000100B OF   XTAIL B@ 1- XTAIL B!  ENDOF
  292.       10000100B OF   XTAIL B@ 1+ XTAIL B!  ENDOF
  293.       DROP ( just in case)
  294.     ENDCASE
  295.     0 SWAP B! ( delete old tail from image)
  296.   THEN ;
  297.  
  298. : MOVEFOOD
  299.   RANDOM 7 AND DUP 4 < IF
  300.     CASE
  301.       0  OF  1 0  ENDOF
  302.       1  OF  -1 0 ENDOF
  303.       2  OF  0 1  ENDOF
  304.       3  OF  0 -1 ENDOF
  305.     ENDCASE
  306.     XFOOD B@ + SWAP YFOOD B@ + OVER OVER ARRAY DUPB@ IF
  307.       3 KILL
  308.     ELSE
  309.       0 XFOOD B@ YFOOD B@ OVER OVER SETCUR BLANKCHAR .S ARRAY B!
  310.       010B SWAP B! OVER OVER SETCUR FOODCHAR .S YFOOD B! XFOOD B!
  311.     THEN
  312.   ELSE
  313.     DROP
  314.   THEN ;
  315.  
  316.  
  317.  
  318. : NEWFOOD
  319.   BEGIN
  320. ( mfb)
  321.     RANDOM CRTCOLS B@ 2 - /MOD DROP 2+ ( 1+ ) XFOOD B!
  322.     RANDOM CRTLINES B@ 2 - /MOD DROP 2+ ( 1+ ) YFOOD B!
  323.     XFOOD B@ YFOOD B@ ARRAY B@
  324.   0= END
  325.   XFOOD B@ YFOOD B@ OVER OVER ARRAY 010B SWAP B!
  326.   SETCUR FOODCHAR .S ( display food character)
  327.   OPTIONBITS B@ 8 AND IF ( want sound)
  328.     OPTIONBITS B@ 2 AND 0= IF ( and not attract)
  329.       BELLCHAR .S
  330.     THEN
  331.   THEN ;
  332.  
  333. : FOODVAL
  334.   -1 PRESCALE +! PRESCALE @ 0= IF
  335.     OPRESCALE @ PRESCALE !
  336.     FOODV B@ 1 > IF
  337.       FOODV B@ 1- FOODV B! 16 0 SETCUR FOODV B@ .2
  338.     THEN
  339.   THEN
  340. ;
  341.  
  342. : WORMGAME
  343.   INITSTR .S
  344.   CLRCRT DRAWBORDER
  345.  
  346.   SCORE @ HISCORE @ > IF
  347.     SCORE @ HISCORE ! WORMLENGTH @ HILENGTH !
  348.   THEN
  349.   
  350.  
  351.   10000100B DIRECTION B! ( initial direction)
  352.   INITWORMLENGTH @  DUP WORMLENGTH !
  353.   1- 0 DO
  354.     10 I + 10 OVER OVER ARRAY 10000100B SWAP B!
  355.     OVER OVER SETCUR WORMCHAR .S
  356.     YHEAD B! XHEAD B!
  357.   LOOP
  358.   10 YTAIL B! 10 XTAIL B!
  359.   
  360.   0 SCORE !
  361.  
  362.   NEWFOOD
  363. (
  364.           1         2         3
  365. 0123456789012345678901234567890123456789
  366. **0000***0000***00***0000***0000***ABC**
  367.   SCORE LENGTH FVAL HISCOR HILENG INIT
  368. )
  369.   OPRESCALE @ PRESCALE !
  370. ( mfbok)
  371.   21 0 SETCUR HISCORE @ .4
  372.   28 0 SETCUR HILENGTH @ .4
  373.   35 0 SETCUR INITIALS .S
  374.  
  375.  
  376.   BEGIN
  377. ( mfbok)
  378.     2 0 SETCUR SCORE @ .4
  379.     9 0 SETCUR WORMLENGTH @ .4
  380.     16 0 SETCUR INITFOODV B@ DUP FOODV B! .2
  381.     0 FOODEATEN B!
  382.     0 COLLISION B!
  383.     BEGIN
  384.       DIRECTION B@ 0F0H AND 64 >= IF
  385.         XDELAY
  386.       ELSE
  387.         YDELAY
  388.       THEN
  389.       OPTIONBITS B@ 2 AND IF COMPUTERMOVE THEN ( attract)
  390.       @ 1 DO    CHECKINPUT    LOOP
  391.       OPTIONBITS B@ 1 AND IF  MOVEFOOD  THEN
  392.       MOVEWORM
  393.       FOODVAL
  394.       COLLISION B@
  395.     END
  396.     FOODEATEN B@ IF
  397.      NEWFOOD 1 WORMLENGTH +!  FOODV B@ SCORE +!
  398.     THEN
  399.     FOODEATEN B@ 0=
  400.   END
  401.   0 1 SETCUR
  402.   UNINITSTR .S ;
  403.  
  404. : DELAY
  405.   0 SWAP 0 DO
  406.     2 1 / dup / DROP INKEY ?DUP IF
  407.       SWAP DROP EXIT
  408.     THEN
  409.   LOOP ;
  410.  
  411.  
  412. : WORM
  413.  
  414.   CRTLINES B@ CRTCOLS B@ * PLAYFIELDSIZE !
  415.  
  416.   CLRCRT 0 0 SETCUR
  417.   " ^13 10 10^Welcome to ..." .S
  418.   " ^13 10 10^   W O R M   W A R S" .S
  419.   BEGIN
  420.     " ^13 10 10^Need Instructions (Y/N)? " .S
  421.     0 0 BEGIN
  422.       DROP 1+ INKEY DUP
  423.     END[ "Y" "y" "N" "n" ]
  424.     0DFH AND DUP .B SWAP ( get seed)
  425.     1 OR DUP 13 * DUP 5 * RANDOMIZE
  426.     "Y" = IF ( ins. wanted)
  427.       " ^13 10^Objective: Maneuver the WORM around the " .S
  428.       " ^13 10^  room trying to eat the food as it" .S
  429.       " ^13 10^  appears. Do this in the least amount" .S
  430.       " ^13 10^  of time. The quicker you eat the food," .S
  431.       " ^13 10^  the higher your score will be." .S
  432.       " ^13 10 10^Two small snags:" .S
  433.       " ^13 10^  1. The more food that you eat, the" .S
  434.       " ^13 10^     longer the worm gets." .S
  435.       " ^13 10^  2. If the worm runs into a wall or " .S
  436.       " ^13 10^     itself - the game is then over" .S
  437.       " ^13 10 10^Hit any key to continue" .S
  438.       BEGIN INKEY END
  439.          " ^13 10 10^Cast: WORM= " .S WORMCHAR .S1
  440.          " ^13 10^      FOOD= " .S FOODCHAR .S1
  441.          " ^13 10^     WALLS= " .S HBORDERCHAR .S1 20H .B VBORDERCHAR .S1
  442.          " ^13 10 10^Directions:    UP= " .S UPKEY B@ .B
  443.          " ^13 10^             LEFT= " .S LEFTKEY B@ .B
  444.          " ^13 10^            RIGHT= " .S RIGHTKEY B@ .B
  445.          " ^13 10^             DOWN= " .S DOWNKEY B@ .B
  446.          " ^13 10 10^Good Luck !" .S
  447.     THEN
  448.  
  449.     " ^13 10 10^Want to set options" YESNO IF
  450.       " High speed" YESNO IF
  451.         XPRTXDLY @ XDELAY ! XPRTYDLY @ YDELAY !
  452.       ELSE
  453.         BEGXDLY @ XDELAY ! BEGYDLY @ YDELAY !
  454.       THEN
  455.       OPTIONBITS B@ ( set option bits)
  456.       " Moving food" YESNO IF    1 OR    ELSE    FEH AND    THEN
  457.       " Two rooms" YESNO IF  4 OR  ELSE  FBH AND  THEN
  458.       " Want sound" YESNO IF 8 OR ELSE F7H AND THEN
  459.       OPTIONBITS B!
  460.       " Long worm" YESNO IF
  461.         IWLENLONG B@
  462.       ELSE
  463.         IWLENSHORT B@
  464.       THEN
  465.       INITWORMLENGTH B!
  466.       " Want to redefine movement keys" YESNO IF
  467.         " ^13 10^Up key " .S GETKEY UPCASE UPKEY B!
  468.         " ^13 10^Down key " .S GETKEY UPCASE DOWNKEY B!
  469.         " ^13 10^Left key " .S GETKEY UPCASE LEFTKEY B!
  470.         " ^13 10^Right key " .S GETKEY UPCASE RIGHTKEY B!
  471.       THEN
  472.     THEN
  473.  
  474.     BEGIN
  475.       WORMGAME
  476.       1000 1 DO 
  477.         INKEY 
  478.       DROP LOOP 
  479. ( mfbok)
  480.       2 2 ( 1 ) SETCUR " Score Length Food   Hi     Hi   Best" .S
  481.       2 3 ( 2 ) SETCUR "              Value Score Length Player" .S
  482.       SCORE @ HISCORE @ > IF
  483.         OPTIONBITS B@ 2 AND IF ( attract mode)
  484.           "  I " INITIALS $!
  485.         ELSE
  486.           2 3 SETCUR " Initials ?" .S
  487.           INITIALS 3 1 DO
  488.             I 34 + 0 SETCUR GETUPCASE OVER I + B!
  489.           LOOP
  490.           DROP
  491.         THEN
  492.       THEN
  493. ( mfbok)
  494.       2 13 SETCUR " ESC to end; any other to continue" .S
  495.       OPTIONBITS B@ 2 AND 0= 10000 * 3500 + DELAY DUP IF ( key pressed)
  496.         OPTIONBITS B@ FDH AND ( clear attract mode)
  497.       ELSE
  498.         OPTIONBITS B@ 2 OR ( set attract mode)
  499.       THEN
  500.       OPTIONBITS B!
  501.       27 =
  502.     END
  503.     CLRCRT
  504.     " Do you want to start over" YESNO 0= 
  505.   END
  506. ;
  507.