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