home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / midnight.seq < prev    next >
Text File  |  1990-02-07  |  6KB  |  162 lines
  1. \ MIDNIGHT.SEQ  (C) Copyright 1979, 1989 Peter Midnight
  2.  
  3. comment:
  4.  
  5.    I first wrote this graphic presentation of the ancient Towers of Hanoi
  6. puzzle in Pascal.  The class assignment was to use recursion to produce a
  7. list of the moves required to solve the puzzle.  But I wanted to see the
  8. rings move.  That version was published in the Jan/Feb 1980 Newsletter of
  9. the Homebrew Computer Club.
  10.  
  11.    Next I translated this program into FIG Forth.  In order to compare the
  12. two languages, I resisted the temptation to improve the program in the
  13. process of translation.  That version is published in FORTH Dimensions
  14. Volume 2 Number 2 and in The Best of FORTH Dimensions.
  15.  
  16.    Now I have transported the same program into F-PC, again without
  17. improvement.  This is my first machine readable publication of this program.
  18.  
  19.    This program is my claim to fame.  As long as its popularity continues,
  20. I may never need another.   Peter Midnight
  21.  
  22. comment;
  23.  
  24. \ ************************** 10/19/89 TJZ **************************
  25. \ Use the following DOS command line to target compile MIDNIGHT.SEQ
  26. \ and build a MIDNIGHT.COM program file:
  27. \
  28. \       C:> TCOM MIDNIGHT /OPT <Enter>
  29. \
  30.  
  31. \ Modified 10/19/89 TJZ
  32. \ Don't need to select vocabulary order in the target compiler
  33. \ ONLY FORTH ALSO DEFINITIONS
  34.  
  35. DECIMAL
  36.  
  37. : GOTOXY        ( row col --- ) \ position cursor
  38.         AT ;
  39.  
  40. : CLEARSCREEN   ( --- )         \ clear screen
  41.         CLS ;
  42.  
  43. COLS 3 - 6 / VALUE NMAX         \ maximum rings for display size
  44.  
  45. NMAX VALUE N                    \ number of rings
  46.  
  47. FALSE CONSTANT HELL_FREEZES_OVER
  48.  
  49. TRUE CONSTANT THE_POPE_IS_A_CATHOLIC
  50.  
  51. ASCII + VALUE COLOR             \ character used to represent a ring
  52.  
  53. 13 ARRAY RING                   \ array (1..N) of tower numbers
  54.  
  55. : DELAY         ( centiseconds --- )    \ pause for clarity
  56.         10 * MS ;
  57.  
  58. : POS           ( tower --- col )       \ get display column for tower
  59.         N 2*   1+   *   N + ;
  60.  
  61. : HALFDISPLAY   ( color size --- )      \ display half a ring
  62.         0 DO   DUP EMIT   LOOP   DROP ;
  63.  
  64. : <DISPLAY>     ( line color size --- ) \ display a whole ring
  65.         2DUP   HALFDISPLAY   ROT 3 <   IF BL   ELSE ASCII |   THEN
  66.         EMIT   HALFDISPLAY ;
  67.  
  68. : DISPLAY       ( size col line color --- )     \ display at proper position
  69.         SWAP >R   -ROT   OVER - R@ GOTOXY
  70.         R>   -ROT   <DISPLAY> ;
  71.  
  72. : PRESENCE      ( tower ring --- f )    \ true if ring is on tower
  73.         RING +   C@   = ;
  74.  
  75. : LINE          ( tower --- line )      \ top of pile on tower
  76.         4   N 1+ 1 DO   OVER I PRESENCE   0= -   LOOP   NIP ;
  77.  
  78.  
  79. : RAISE         ( size tower --- )      \ raise ring
  80.         DUP POS   SWAP LINE   2 SWAP
  81.         DO      2DUP I    BL    DISPLAY \ erase ring where it is
  82.                 2DUP I 1- COLOR DISPLAY \ show it one line higher
  83.         -1 +LOOP   2DROP ;
  84.  
  85. : LOWER         ( size tower --- )      \ lower ring
  86.         DUP POS   SWAP LINE 1+   2
  87.         DO      2DUP I 1- BL    DISPLAY \ erase ring where it is
  88.                 2DUP I    COLOR DISPLAY \ show it one line lower
  89.         LOOP   2DROP ;
  90.  
  91. : MOVELEFT      ( size source destination --- ) \ move ring to left
  92.         POS   SWAP   POS 1-
  93.         DO      DUP I 1+ 1 BL    DISPLAY        \ erase it where it is
  94.                 DUP I    1 COLOR DISPLAY        \ show it 1 column left
  95.         -1 +LOOP   DROP ;
  96.  
  97. : MOVERIGHT     ( size source destination --- ) \ move ring to right
  98.         POS 1+   SWAP   POS 1+
  99.         DO      DUP I 1- 1 BL    DISPLAY        \ erase it where it is
  100.                 DUP I    1 COLOR DISPLAY        \ show it 1 column right
  101.         LOOP   DROP ;
  102.  
  103. : TRAVERSE      ( size source destination --- ) \ move ring sideways
  104.         2DUP >   IF MOVELEFT   ELSE MOVERIGHT   THEN ;
  105.  
  106. : MOVE          ( size source destination --- ) \ complete one move
  107.         KEY?   IF   0 N 6 + GOTOXY   CURSOR-ON   ABORT   THEN
  108.         -ROT 2DUP RAISE
  109.         >R 2DUP R> ROT TRAVERSE
  110.         2DUP   RING + C!                \ also update location array
  111.         SWAP LOWER ;
  112.  
  113. \ The following word is the recursive solution to the puzzle.
  114.  
  115. : MULTIMOVE     ( size source destination spare --- )   RECURSIVE
  116.         3 PICK   1 =                    \ test for case of smallest ring
  117.         IF      DROP MOVE               \ single ring move
  118.         ELSE    2>R SWAP 1- SWAP 2R>    \ refer to next smaller ring, above
  119.                 4DUP SWAP MULTIMOVE     \ move it to spare tower
  120.                 4DUP DROP               \ drop spare tower number
  121.                 ROT 1+ -ROT MOVE        \ move specified ring
  122.                 -ROT SWAP MULTIMOVE     \ move next smaller ring from spare
  123.         THEN ;
  124.  
  125. : MAKETOWER     ( tower --- )           \ draw tower on display
  126.         POS   4 N +   3
  127.         DO      DUP I GOTOXY
  128.                 ASCII | EMIT
  129.         LOOP   DROP ;
  130.  
  131. : MAKEBASE      ( --- )                 \ draw base on display
  132.         0 N 4 + GOTOXY
  133.         N 6 * 3 + 0 DO   ASCII - EMIT   LOOP ;
  134.  
  135. : MAKERING      ( tower size --- )      \ materialize ring on display
  136.         2DUP RING + C!                  \ mark ring location in array
  137.         SWAP LOWER ;
  138.  
  139. : SETUP         ( --- )                 \ initialize display of puzzle
  140.         CLEARSCREEN   CURSOR-OFF
  141.         N 1+ 0 DO   1 RING I + C!   LOOP        \ initialize array
  142.         3 0 DO   I MAKETOWER   LOOP             \ draw towers
  143.         MAKEBASE                                \ draw base
  144.         1 N DO   0 I MAKERING   -1 +LOOP ;      \ materialize rings
  145.  
  146. \ The following word performs the solution repeatedly.
  147.  
  148. : TOWERS        ( quantity --- )        \ use specified number of rings
  149.         1 MAX   NMAX MIN   !> N
  150.         SETUP   N 2 0 1
  151.         BEGIN   OVER POS   N 4 +   GOTOXY       \ put cursor under rings
  152.                 N 0 DO   BEEP   50 DELAY   LOOP \ announce completion
  153.                 ROT   4DUP   MULTIMOVE          \ move all to next tower
  154.         HELL_FREEZES_OVER UNTIL ;               \ repeat indefinitely
  155.  
  156. \ Modified 10/19/89 TJZ
  157. \ Add MAIN, the last ":" (colon) definition in the application as the
  158. \ definition to be executed.
  159. : MAIN          ( -- )
  160.                 7 TOWERS ;
  161.  
  162.