home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FORTHCMP.ZIP / HANOI.4TH < prev    next >
Encoding:
Text File  |  1992-03-30  |  4.1 KB  |  131 lines
  1. \  Towers of Hanoi, by Peter Midnight  
  2. \   from FORTH DIMENSIONS, Vol II, No. 2, page 32 )
  3.  
  4. \  NOTICE: THIS SAMPLE PROGRAM IS FOR IBM-PC'S OR COMPATIBLES ONLY!
  5.  
  6. 256 MSDOS     
  7.  
  8. 2 0 IN/OUT 
  9. CODE GOTOXY  
  10.   AL DH MOV  BL DL MOV  BH BH XOR  2 # AH MOV  16 INT  RET END-CODE
  11.  
  12. 0 0 IN/OUT 
  13. CODE CLEARSCREEN 
  14.   3 # AX MOV  16 INT  RET  END-CODE
  15.  
  16. 0 0 IN/OUT 
  17. : ABORT 0 0 BDOS ; ( NEVER RETURNS )
  18.  
  19. 2 0 IN/OUT  
  20. CODE CCHARS ( character+color count -- )
  21.      AX CX MOV  BL AL MOV  BH BL MOV   BH BH XOR  9 # AH MOV  16 INT  RET
  22.     END-CODE   
  23.  
  24. 12              CONSTANT NMAX
  25.                 VARIABLE N   ( formerly a constant )
  26.                 VARIABLE DELAY-TIME
  27. 0               CONSTANT FALSE
  28. 219  4 256 * +  CONSTANT COLOR ( ring )
  29. 219  12 256 * + CONSTANT BRIGHT ( bright ring )
  30. 186  2 256 * +  CONSTANT STAKE ( vertical bar )
  31. 176  1 256 * +  CONSTANT STAND ( flat base )
  32. DSEG            CREATE   RING  NMAX 2+ ALLOT  
  33.  
  34. : 4DUP          3 PICK 3 PICK 3 PICK 3 PICK ;
  35.  
  36. 1 0 IN/OUT 
  37. : DELAY         ( centiseconds delay )
  38.                 0 DO 1000 0 DO LOOP LOOP ;
  39.  
  40. 0 0 IN/OUT 
  41. : SLOWER  DELAY-TIME @  0 DO LOOP ;
  42.  
  43. 1 1 IN/OUT 
  44. : POS           ( location pos -> coordinate )
  45.                 N @ 2* 1+ * N @ + ;
  46.  
  47. : DISPLAY       ( size pos line color --- )
  48.             2 PICK 4 PICK - 2 PICK GOTOXY
  49.             OVER 3 <  OVER BL <> OR
  50.               IF  -ROT 2DROP SWAP 2* 1+ CCHARS ELSE
  51.                   DUP 4 PICK CCHARS
  52.                   2 PICK 2 PICK GOTOXY  STAKE 1 CCHARS
  53.                   -ROT SWAP 1+ SWAP GOTOXY  SWAP CCHARS THEN ;
  54.  
  55. 2 1 IN/OUT 
  56. : PRESENCE      ( tower ring presence -> boolean )
  57.                 RING + C@ = ;
  58.  
  59. : LINE          ( tower line -> display-line-of-top )
  60.                 4 SWAP N @ 0 
  61.                 DO DUP I PRESENCE 0= IF SWAP 1+ SWAP THEN LOOP 
  62.                 DROP ;
  63.  
  64. : RAISE         ( size tower --- )
  65.                 DUP POS SWAP LINE 2 SWAP 
  66.                 DO 2DUP I BL DISPLAY 2DUP I 1- BRIGHT DISPLAY SLOWER -1 +LOOP 
  67.                 2DROP ;
  68.  
  69. : LOWER         ( size tower --- )
  70.                 DUP POS SWAP LINE DUP >R 1+ 2 
  71.                 DO 2DUP I 1- BL DISPLAY 2DUP I BRIGHT DISPLAY SLOWER LOOP  
  72.                 R> COLOR DISPLAY  ;   
  73.  
  74. : MOVELEFT      ( size source.tower destiny.tower --- )
  75.                 POS  SWAP POS 1- 
  76.                 DO DUP I 1+ 1 BL DISPLAY DUP I 1 BRIGHT DISPLAY SLOWER -1 +LOOP 
  77.                 DROP ;
  78.  
  79. : MOVERIGHT     ( size source.tower destiny.tower --- )
  80.                 POS 1+ SWAP POS 1+ 
  81.                 DO DUP I 1- 1 BL DISPLAY DUP I 1 BRIGHT DISPLAY SLOWER LOOP 
  82.                 DROP ;
  83.  
  84. : TRAVERSE      ( size source.tower destiny.tower --- )
  85.                 2DUP > IF MOVELEFT ELSE MOVERIGHT THEN ;
  86.  
  87. : MOVE          ( size source.tower destiny.tower --- )
  88.                 ?TERMINAL IF 0 N @ 4 + GOTOXY ABORT THEN
  89.                 -ROT 2DUP RAISE 
  90.                 >R 2DUP R> ROT TRAVERSE
  91.                 2DUP RING + 1- C! SWAP LOWER ;
  92.  
  93. : MULTIMOV      ( size source destiny spare --- )
  94.                 3 PICK 1 = IF DROP MOVE ELSE
  95.                 >R >R SWAP 1- SWAP R> R> 4DUP SWAP MULTIMOV
  96.                 4DUP DROP ROT 1+ -ROT MOVE
  97.                 -ROT SWAP MULTIMOV THEN ;
  98.  
  99. : MAKETOWER     ( tower --- )   POS 4 N @ + 3
  100.                 DO DUP I GOTOXY STAKE 1 CCHARS LOOP 
  101.                 DROP ;
  102.  
  103. : MAKEBASE      ( no arguments ) 0 N  @  4 + GOTOXY
  104.                 STAND N @ 6 * 3 + CCHARS ;
  105.  
  106. : MAKERING      ( tower size --- )
  107.                 2DUP RING + 1- C! SWAP LOWER ;
  108.  
  109. : SETUP         ( no arguments ) 
  110.                 CLEARSCREEN  N @ 1+ 0 DO 1 RING I + C! LOOP 
  111.                 3 0 DO I MAKETOWER LOOP 
  112.                 MAKEBASE 
  113.                 1 N @ DO 0 I MAKERING -1 +LOOP ;
  114.  
  115. : TOWERS        ( quantity --- )
  116.                 1 MAX NMAX MIN N !
  117.                 SETUP N @ 2 0 1
  118.                 BEGIN
  119.                   OVER POS N @ 4 + GOTOXY N @ 0
  120.                   DO   7 EMIT 20 DELAY LOOP
  121.                   ROT 4DUP MULTIMOV
  122.                   FALSE
  123.                 UNTIL ;
  124.  
  125. : MAIN CR ." DELAY TIME? "  #IN 1 MAX DELAY-TIME !
  126.        CR ." HOW MANY RINGS? "  #IN TOWERS ;
  127.  
  128. INCLUDE FORTHLIB
  129. END
  130.  
  131.