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

   1 ;
   2 ; Towers of Hanoi
   3 ;
   4 ; Copyright © 2016 Keith Packard <keithp@keithp.com>
   5 ;
   6 ; This program is free software; you can redistribute it and/or modify
   7 ; it under the terms of the GNU General Public License as published by
   8 ; the Free Software Foundation, either version 2 of the License, or
   9 ; (at your option) any later version.
  10 ;
  11 ; This program is distributed in the hope that it will be useful, but
  12 ; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ; General Public License for more details.
  15 ;
  16
  17                                         ; ANSI control sequences
  18
  19 (defun move-to (col row)
  20   (patom "\033[" row ";" col "H" nil)
  21   )
  22
  23 (defun clear ()
  24   (patom "\033[2J" nil)
  25   )
  26
  27 (defun display-string (x y str)
  28   (move-to x y)
  29   (patom str)
  30   )
  31
  32                                         ; Here's the pieces to display
  33
  34 (setq stack '("     *     " "    ***    " "   *****   " "  *******  " " ********* " "***********"))
  35
  36                                         ; Here's all of the stacks of pieces
  37                                         ; This is generated when the program is run
  38
  39 (setq stacks nil)
  40
  41                                         ; Display one stack, clearing any
  42                                         ; space above it
  43
  44 (defun display-stack (x y clear stack)
  45   (cond ((= 0 clear)
  46          (cond (stack (progn
  47                         (display-string x y (car stack))
  48                         (display-stack x (1+ y) 0 (cdr stack))
  49                         )
  50                       )
  51                )
  52          )
  53         (t (progn
  54              (display-string x y "                    ")
  55              (display-stack x (1+ y) (1- clear) stack)
  56              )
  57            )
  58         )
  59   )
  60
  61                                         ; Position of the top of the stack on the screen
  62                                         ; Shorter stacks start further down the screen
  63
  64 (defun stack-pos (y stack)
  65   (- y (length stack))
  66   )
  67
  68                                         ; Display all of the stacks, spaced 20 columns apart
  69
  70 (defun display-stacks (x y stacks)
  71   (cond (stacks (progn
  72                   (display-stack x 0 (stack-pos y (car stacks)) (car stacks))
  73                   (display-stacks (+ x 20) y (cdr stacks)))
  74                 )
  75         )
  76   )
  77
  78                                         ; Display all of the stacks, then move the cursor
  79                                         ; out of the way and flush the output
  80
  81 (defun display ()
  82   (display-stacks 0 top stacks)
  83   (move-to 1 21)
  84   (flush)
  85   )
  86
  87                                         ; Reset stacks to the starting state, with
  88                                         ; all of the pieces in the first stack and the
  89                                         ; other two empty
  90
  91 (defun reset-stacks ()
  92   (setq stacks (list stack nil nil))
  93   (setq top (+ (length stack) 3))
  94   (length stack)
  95   )
  96
  97                                         ; more functions which could usefully
  98                                         ; be in the rom image
  99
 100 (defun min (a b)
 101   (cond ((< a b) a)
 102         (b)
 103         )
 104   )
 105
 106                                         ; Replace a stack in the list of stacks
 107                                         ; with a new value
 108
 109 (defun replace (list pos member)
 110   (cond ((= pos 0) (cons member (cdr list)))
 111         ((cons (car list) (replace (cdr list) (1- pos) member)))
 112         )
 113   )
 114
 115                                         ; Move a piece from the top of one stack
 116                                         ; to the top of another
 117
 118 (defun move-piece (from to)
 119   (let ((from-stack (nth stacks from))
 120         (to-stack (nth stacks to))
 121         (piece (car from-stack)))
 122     (setq from-stack (cdr from-stack))
 123     (setq to-stack (cons piece to-stack))
 124     (setq stacks (replace stacks from from-stack))
 125     (setq stacks (replace stacks to to-stack))
 126     (display)
 127     (delay 100)
 128     )
 129   )
 130
 131 ; The implementation of the game
 132
 133 (defun _hanoi (n from to use)
 134   (cond ((= 1 n)
 135          (progn
 136           (move-piece from to)
 137           nil)
 138          )
 139         (t
 140          (progn
 141           (_hanoi (1- n) from use to)
 142           (_hanoi 1 from to use)
 143           (_hanoi (1- n) use to from)
 144           )
 145          )
 146         )
 147   )
 148
 149                                         ; A pretty interface which
 150                                         ; resets the state of the game,
 151                                         ; clears the screen and runs
 152                                         ; the program
 153
 154 (defun hanoi ()
 155   (setq len (reset-stacks))
 156   (clear)
 157   (_hanoi len 0 1 2)
 158   )
 159
 160                                         ; Run many in a row to time them
 161
 162 (defun hanois(n)
 163   (cond ((> n 0)
 164          (progn
 165            (hanoi)
 166            (hanois (1- n))
 167            )
 168          )
 169         )
 170   )