#!ff needs
\ $Id: hanoi,v 1.2 2006-12-15 11:21:51 lavarenn Exp $
\ Hanoi Tours (with four conditionally compilable display variations)

'$' parse ( -- @ # ) dup>r here rot over r> ( -- # h @ h # ) dup allot ;
  "Hanoi Tours"  is  a classical mathematical problem  presented as a game,
that you can play  on a table corner  with a few coins  of different sizes.
Stack them up  by decreasing sizes, with the smallest one  on top of stack.
Given two other  stack locations, initially empty, move one coin  at a time
from the top of one stack to the top of another stack, but never put a coin
on top of a smaller one.  Move coins until you've moved the complete stack.
  The minimum number of moves is computed recursively: for N coins you need
to move the N-1 top coins to a second stack location, then move the biggest
one to the third stack location, then move the N-1 other ones on top of it,
i.e. twice the number of moves for a stack of N-1 coins plus one move, this
gives 2^N-1 moves for N coins.  This implementation is non-recursive :-)
$ cmove  : .intro` lit lit type ;  \ --

\ 0
\ 1        -|-                 |                  |
\ 2       --|--                |                  |
\ 3      ---|---               |                  |
\ 4     ----|----              |                  |
\ 5    -----|-----             |                  |
\ 6   ------|------            |                  |
\ 7  -------|-------           |                  |
\ 8 --------|--------          |                  |
\ 9         a                  b                  c

[0] [IF]  \ simplest variant ==========================================

variable #m  \ number of moves
variable #d  \ number of disks
create ds 8 allot  \ disk stack
[1] [IF]  \ simplest display with numbers --------------------
: ._  cls` ."Hanoi_Tours" 3 TIMES #d@ 2 r - cr 'a' over+ emit .":" over TIMES
    r ds+ c@ = drop IF r '1'+ emit swap 1- swap THEN
  REPEAT 2drop REPEAT
[ELSE]  \ "graphical" display with horizontal lines ----------
create -- 24 allot ; -- 24 32 fill -- 8+ 8 '-' fill
: .-  -- 2dup+ 8 type ."|" swap - 16+ 8 type ;  \ w --
: ._  cls` 3 TIMES #d@ r over TIMES
    r ds+ c@ = drop IF 2dup 17* swap atxy r 1+ .- swap 1- swap THEN
  REPEAT 17* swap TIMES dup r 1+ atxy 0 .- REPEAT drop REPEAT
  0 #d@ 1+ atxy 'a' 3 TIMES -- 8 type dup emit 1+ -- 8 type REPEAT drop
[THEN]  \ ----------------------------------------------------
  cr #m@ .
  ."(a:b<->c__b:c<->a__c:a<->b__i(n--):init__s(n--):solution__h:help)^J" ;
: top  ds #d@ TIMES tuck c@ <> drop swap WHILE 1+ REPEAT nip ;  \ s -- @
: i` ;` 1- 7& 1+  dup #d! ds swap erase  0 #m!  \ n -- ; init
: a` 1 2      SKIP
: b` 2 0 SKIP
: c` 0 1 THEN THEN over top over top = IF 2drop 2drop ._ ;THEN
  u< IF drop c! drop ELSE nip nip c! THEN 1 #m +! ._ ;
: d 333 ms ;
: s`  \ -- ; solution
  ;` i`  500 ms
  1 #d@ << BEGIN 1- WHILE d b` 1- WHILE d c` 1- WHILE d a` REPEAT drop ;

[ELSE]  \ variant with animations =======================================

variable #m  \ number of moves
create st 30 allot  \ 3 stacks
: >st  10* st+ ;  \ s -- @
[0] [IF]  \ simplest display with numbers ------------------
: ._  \ --
  50 ms cls` ."Hanoi_Tours"
  st 3 TIMES cr dup 9 type 10+ .":" 'c' r - emit REPEAT drop
[ELSE]  \ "graphical" display with horizontal lines --------
: -- "________--------________" drop ;
: .-  \ w c --
  swap -- 2dup+ 8 type swap - swap emit 16+ 8 type ;
: ._  \ --
  50 ms cls` 3 TIMES r >st  r 17*
  9 TIMES 2dup  r atxy  r + c@ $F&  r 0- 32_ IF '|'_ THEN  .- REPEAT
  2drop REPEAT  0 9 atxy  0 'a' 2dup .- 1+ 2dup .- 1+ .-
[THEN]  \ --------------------------------------------------
  cr #m@ .
  ."(a:b<->c__b:c<->a__c:a<->b__i(n--):init__s(n--):solution__h:help)^J" ;
: top  \ @ -- @'
  BEGIN c@+ $F& drop UNTIL 1- ;
: up  \ @ -- n
  dup>r top dupc@ 32$00+ swap BEGIN 1- 2dupw! ._ r = drop UNTIL
  32 swap c! rdrop ;
: dn  \ n @ --
  2dupc! swap 8 << 32+ swap  \ -- n<<8+32 @
  BEGIN ._ dupw@ $F00& drop 0= WHILE 2dupw! 1+ REPEAT 2drop ;
: a` 1 2 0      SKIP
: b` 2 0 1 SKIP
: c` 0 1 2 THEN THEN
  >st dup top 1- = 2drop IF 2drop ;THEN  >st swap >st  1 #m +!
  over top c@ over top c@ < 2drop IF swap THEN  up swap dn ;
: i`  \ n -- ; init
  ;` 1- 7& 1+  0 #m!  st 30 32 fill  '9' st 9+ 2dupc! 10+ 2dupc! 10+ c!
  0 >st swap TIMES r '1'+ over dn REPEAT drop ;
: s`  \ n -- ; solution
  ;` 1- 7& 1+  dup i`  500 ms
  1 swap << BEGIN 1- WHILE b` 1- WHILE c` 1- WHILE a` REPEAT drop ;

[THEN]  \ ================================================================

'$' parse ( -- @ # ) dup>r here rot over r> ( -- # h @ h # ) dup allot ;
Use: to move one coin between two stacks, enter the name of the third stack;
     to initialize a new stack of 4 coins (max 8) enter: 4 i
     to show the solution for a stack of 5 coins, enter: 5 s
$ cmove ;  : h` ._ lit lit type ;
3 s .intro EOF enjoy!