home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FIFTH21.ZIP / TOWERS.FIV < prev    next >
Encoding:
Text File  |  1986-03-30  |  3.2 KB  |  165 lines
  1. CREATE HANOI
  2. CREATE (N)
  3. EDIT
  4. variable (N)
  5. ~UP
  6. CREATE N
  7. EDIT
  8. : N (N) @ ;
  9. ~UP
  10. CREATE RING
  11. EDIT
  12. variable ring
  13. 12 1+ allot
  14. ~UP
  15. CREATE 4DUP
  16. EDIT
  17.  : 4DUP stack abcd|abcdabcd ;
  18. ~UP
  19. CREATE POS
  20. EDIT
  21.  : POS
  22. ( location pos -> coordinate )
  23.   N N + 1+ * N + ;
  24. ~UP
  25. CREATE HALFDISPLAY
  26. EDIT
  27.  : HALFDISPLAY
  28. ( color size --- )
  29.   0 DO DUP EMIT LOOP DROP ;
  30.  
  31. ~UP
  32. CREATE <DISPLAY>
  33. EDIT
  34.  : <DISPLAY>
  35. ( line color size --- )
  36.   stack ab|abab HALFDISPLAY stack abc|bca 3 < IF 32 ELSE 186 ( | )
  37.   ENDIF EMIT HALFDISPLAY ;
  38. ~UP
  39. CREATE DISPLAY
  40. EDIT
  41.  : DISPLAY
  42. ( size pos line color --- )
  43.   SWAP >R stack abc|caba - R@ ( color size pos-size line )
  44.   GOTOXY R> ( color size line ) stack abc|cab <DISPLAY> ;
  45. ~UP
  46. CREATE PRESENCE
  47. EDIT
  48.  : PRESENCE
  49. ( tower ring presence -> boolean )
  50.   RING + C@ = negate ;
  51. ~UP
  52. CREATE LINE
  53. EDIT
  54.  : LINE
  55. ( tower line -> display-line-of-top )
  56.   4 SWAP N 0 DO DUP I PRESENCE 0= negate stack abc|bca + SWAP LOOP DROP ;
  57. ~UP
  58. CREATE RAISE
  59. EDIT
  60.  : RAISE
  61. ( size tower --- )
  62.   DUP POS SWAP LINE 2 SWAP DO
  63.   stack ab|abab I 32 DISPLAY stack ab|abab I 1- 205 DISPLAY
  64.   -1 +LOOP drop DROP ;
  65. ~UP
  66. CREATE LOWER
  67. EDIT
  68.  : LOWER
  69. ( size tower --- )
  70.   DUP POS SWAP LINE 1+ 2 DO
  71.   stack ab|abab I 1- 32 DISPLAY stack ab|abab I 205 DISPLAY
  72.   LOOP drop DROP ;
  73. ~UP
  74. CREATE MOVELEFT
  75. EDIT
  76.  : MOVELEFT
  77. ( size source.tower destiny.tower --- )
  78.   POS    SWAP POS 1- DO DUP I 1+ 1 32 DISPLAY
  79.   DUP I 1 205 DISPLAY -1 +LOOP DROP ;
  80. ~UP
  81. CREATE MOVERIGHT
  82. EDIT
  83.  : MOVERIGHT
  84. ( size source.tower destiny.tower --- )
  85.   POS 1+ SWAP POS 1+ DO DUP I 1- 1 32 DISPLAY
  86.   DUP I 1 205 DISPLAY LOOP DROP ;
  87. ~UP
  88. CREATE TRAVERSE
  89. EDIT
  90.  : TRAVERSE
  91. ( size source.tower destiny.tower --- )
  92.   stack ab|abab > IF MOVELEFT ELSE MOVERIGHT ENDIF ;
  93. ~UP
  94. CREATE MOVE
  95. EDIT
  96.  : MOVE
  97. ( size source.tower destiny.tower --- )
  98.   ?TERM if key 32 = not if 0 N 4 + GOTOXY ABORT endif endif
  99.   stack abc|cabab RAISE stack abc|abbca TRAVERSE
  100.   stack ab|abab RING + 1- C! SWAP LOWER ;
  101. ~UP
  102. CREATE MULTIMOV
  103. EDIT
  104.  : MULTIMOV
  105. ( size source destiny spare --- )
  106.   3 PICK 1 = IF DROP MOVE ELSE
  107.   stack abcd|bcda 1- stack abcd|dabcdacb MULTIMOV
  108.   stack abcd|abcdbca 1+ stack abc|cab MOVE
  109.   stack abc|cba MULTIMOV ENDIF ;
  110. ~UP
  111. CREATE MAKETOWER
  112. EDIT
  113.  : MAKETOWER
  114. ( tower --- )
  115.   POS 4 N + 3 DO DUP I GOTOXY 186 EMIT LOOP DROP ;
  116. ~UP
  117. CREATE MAKEBASE
  118. EDIT
  119.  : MAKEBASE
  120. ( no arguments )
  121.   0 N 4 + GOTOXY N 6 * 3 + 0 DO 177 EMIT LOOP ;
  122. ~UP
  123. CREATE MAKERING
  124. EDIT
  125.  : MAKERING
  126. ( tower size --- )
  127.   stack ab|abab RING + 1- C! SWAP LOWER ;
  128. ~UP
  129. CREATE SETUP
  130. EDIT
  131.  : SETUP ( no arguments )
  132.   CLS
  133.   N 1+ 0 DO 1 RING I + C! LOOP
  134.   3 0 DO I MAKETOWER LOOP
  135.   MAKEBASE
  136.   1 N DO 0 I MAKERING -1 +LOOP
  137.  ;
  138. ~UP
  139. CREATE TOWERS
  140. EDIT
  141.  : TOWERS
  142. ( quantity --- )
  143.   1 MAX 12 MIN (N) !
  144.   SETUP
  145.   33 0 GOTOXY ." Fifth"
  146.   N 2 0 1
  147.   BEGIN
  148.   OVER POS N 4 + GOTOXY
  149.   stack abcd|acdbacdb MULTIMOV
  150.   2 0 do 7 emit loop
  151.   0 UNTIL ;
  152. ~UP
  153. EDIT
  154. : hanoi
  155.   depth 1 < if
  156.     cr cr
  157.     ."                  Hanoi expects the number of pieces on the stack." cr
  158.     ."                  For example, to solve a five piece towers of hanoi " cr
  159.     ."                  puzzle, type: " cr cr
  160.     ."                         5 HANOI" cr cr
  161.     exit
  162.   endif
  163.   towers ;
  164. ~UP
  165. ABORT