Category : Forth Source Code
Archive   : FIFTH.ZIP
Filename : TOWERS.FIV
CREATE (N)
EDIT
variable (N)
~UP
CREATE N
EDIT
: N (N) @ ;
~UP
CREATE RING
EDIT
variable ring
12 1+ allot
~UP
CREATE 4DUP
EDIT
: 4DUP
3 PICK 3 PICK 3 PICK 3 PICK ;
~UP
CREATE POS
EDIT
: POS
( location pos -> coordinate )
N N + 1+ * N + ;
~UP
CREATE HALFDISPLAY
EDIT
: HALFDISPLAY
( color size --- )
0 DO DUP EMIT LOOP DROP ;
~UP
CREATE
EDIT
:
( line color size --- )
2DUP HALFDISPLAY ROT 3 < IF 32 ELSE 186 ( | )
ENDIF EMIT HALFDISPLAY ;
~UP
CREATE DISPLAY
EDIT
: DISPLAY
( size pos line color --- )
SWAP >R ROT ROT OVER - R@ ( color size pos-size line )
GOTOXY R> ( color size line ) ROT ROT
~UP
CREATE PRESENCE
EDIT
: PRESENCE
( tower ring presence -> boolean )
RING + C@ = negate ;
~UP
CREATE LINE
EDIT
: LINE
( tower line -> display-line-of-top )
4 SWAP N 0 DO DUP I PRESENCE 0= negate ROT + SWAP LOOP DROP ;
~UP
CREATE RAISE
EDIT
: RAISE
( size tower --- )
DUP POS SWAP LINE 2 SWAP DO
2DUP I 32 DISPLAY 2DUP I 1- 205 DISPLAY
-1 +LOOP 2DROP ;
~UP
CREATE LOWER
EDIT
: LOWER
( size tower --- )
DUP POS SWAP LINE 1+ 2 DO
2DUP I 1- 32 DISPLAY 2DUP I 205 DISPLAY
LOOP 2DROP ;
~UP
CREATE MOVELEFT
EDIT
: MOVELEFT
( size source.tower destiny.tower --- )
POS SWAP POS 1- DO DUP I 1+ 1 32 DISPLAY
DUP I 1 205 DISPLAY -1 +LOOP DROP ;
~UP
CREATE MOVERIGHT
EDIT
: MOVERIGHT
( size source.tower destiny.tower --- )
POS 1+ SWAP POS 1+ DO DUP I 1- 1 32 DISPLAY
DUP I 1 205 DISPLAY LOOP DROP ;
~UP
CREATE TRAVERSE
EDIT
: TRAVERSE
( size source.tower destiny.tower --- )
2DUP > IF MOVELEFT ELSE MOVERIGHT ENDIF ;
~UP
CREATE MOVE
EDIT
: MOVE
( size source.tower destiny.tower --- )
?TERM if key 32 = not if 0 N 4 + GOTOXY ABORT endif endif
ROT ROT 2DUP RAISE >R 2DUP R> ROT TRAVERSE
2DUP RING + 1- C! SWAP LOWER ;
~UP
CREATE MULTIMOV
EDIT
: MULTIMOV
( size source destiny spare --- )
3 PICK 1 = IF DROP MOVE ELSE
>R >R SWAP 1- SWAP R> R> 4DUP SWAP MULTIMOV
4DUP DROP ROT 1+ ROT ROT MOVE
ROT ROT SWAP MULTIMOV ENDIF ;
~UP
CREATE MAKETOWER
EDIT
: MAKETOWER
( tower --- )
POS 4 N + 3 DO DUP I GOTOXY 186 EMIT LOOP DROP ;
~UP
CREATE MAKEBASE
EDIT
: MAKEBASE
( no arguments )
0 N 4 + GOTOXY N 6 * 3 + 0 DO 177 EMIT LOOP ;
~UP
CREATE MAKERING
EDIT
: MAKERING
( tower size --- )
2DUP RING + 1- C! SWAP LOWER ;
~UP
CREATE SETUP
EDIT
: SETUP ( no arguments )
CLS
N 1+ 0 DO 1 RING I + C! LOOP
3 0 DO I MAKETOWER LOOP
MAKEBASE
1 N DO 0 I MAKERING -1 +LOOP
;
~UP
CREATE TOWERS
EDIT
: TOWERS
( quantity --- )
1 MAX 12 MIN (N) !
SETUP
33 0 GOTOXY ." Fifth"
N 2 0 1
BEGIN
OVER POS N 4 + GOTOXY
ROT 4DUP MULTIMOV
2 0 do 7 emit loop
0 UNTIL ;
~UP
EDIT
: hanoi
depth 1 < if
cr cr
." Hanoi expects the number of pieces on the stack." cr
." For example, to solve a five piece towers of hanoi " cr
." puzzle, type: " cr cr
." 5 HANOI" cr cr
exit
endif
towers ;
~UP
ABORT
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/