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