git.gag.com Git - fw/altos/blob - src/test/hanoi.lisp

   1 (defun move-to (col row)
   2   (patom "\033[" row ";" col "H" nil)
   3   )
   4
   5 (defun clear ()
   6   (patom "\033[2J" nil)
   7   )
   8
   9 (setq stack '("*" "**" "***" "****" "*****" "******" "*******"))
  10
  11 (setq stacks nil)
  12
  13 (defun display-string (x y str)
  14   (move-to x y)
  15   (patom str)
  16   )
  17
  18 (defun display-stack (x y stack)
  19   (cond (stack (progn
  20                  (display-string x y (car stack))
  21                  (display-stack x (1+ y) (cdr stack)))))
  22   )
  23
  24 (defun clear-stack (x y)
  25   (cond ((> y 0) (progn
  26                    (move-to x y)
  27                    (patom "            ")
  28                    (clear-stack x (1- y))
  29                    )
  30          )
  31         )
  32   )
  33
  34 (defun length (list)
  35   (cond (list (1+ (length (cdr list))))
  36         (0)
  37         )
  38   )
  39
  40 (defun stack-pos (y stack)
  41   (- y (length stack))
  42   )
  43
  44 (defun display-stacks (x y stacks)
  45   (cond (stacks (progn
  46                   (clear-stack x 20)
  47                   (display-stack x (stack-pos y (car stacks)) (car stacks))
  48                   (display-stacks (+ x 20) y (cdr stacks)))
  49                 )
  50         )
  51   )
  52
  53 (defun display ()
  54   (display-stacks 0 20 stacks)
  55   (move-to 1 21)
  56   (flush)
  57   )
  58
  59 (defun length (l)
  60   (cond (l (1+ (length (cdr l)))) (0))
  61   )
  62
  63 (defun reset-stacks ()
  64   (setq stacks (list stack nil nil))
  65   (length stack)
  66   )
  67
  68 (defun min (a b)
  69   (cond ((< a b) a)
  70         (b)
  71         )
  72   )
  73
  74 (defun nth (list n)
  75   (cond ((= n 0) (car list))
  76         ((nth (cdr list) (1- n)))
  77         )
  78   )
  79
  80 (defun replace (list pos member)
  81   (cond ((= pos 0) (cons member (cdr list)))
  82         ((cons (car list) (replace (cdr list) (1- pos) member)))
  83         )
  84   )
  85
  86 (defun move-piece (from to)
  87   (let ((from-stack (nth stacks from))
  88         (to-stack (nth stacks to))
  89         (piece (car from-stack)))
  90     (setq from-stack (cdr from-stack))
  91     (setq to-stack (cons piece to-stack))
  92     (setq stacks (replace stacks from from-stack))
  93     (setq stacks (replace stacks to to-stack))
  94     (display)
  95     (delay 100)
  96     )
  97   )
  98
  99 (defun _hanoi (n from to use)
 100   (cond ((= 1 n)
 101          (progn
 102           (move-piece from to)
 103           nil)
 104          )
 105         (t
 106          (progn
 107           (_hanoi (1- n) from use to)
 108           (_hanoi 1 from to use)
 109           (_hanoi (1- n) use to from)
 110           )
 111          )
 112         )
 113   )
 114
 115 (defun hanoi ()
 116   (setq len (reset-stacks))
 117   (clear)
 118   (_hanoi len 0 1 2)
 119   )