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")
  21   )
  22
  23 (defun clear ()
  24   (patom "\033[2J")
  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
  47                 (display-string x y (car stack))
  48                 (display-stack x (1+ y) 0 (cdr stack))
  49                 )
  50                )
  51          )
  52         (t
  53          (display-string x y "                   ")
  54          (display-stack x (1+ y) (1- clear) stack)
  55          )
  56         )
  57   )
  58
  59                                         ; Position of the top of the stack on the screen
  60                                         ; Shorter stacks start further down the screen
  61
  62 (defun stack-pos (y stack)
  63   (- y (length stack))
  64   )
  65
  66                                         ; Display all of the stacks, spaced 20 columns apart
  67
  68 (defun display-stacks (x y stacks)
  69   (cond (stacks
  70          (display-stack x 0 (stack-pos y (car stacks)) (car stacks))
  71          (display-stacks (+ x 20) y (cdr stacks)))
  72         )
  73   )
  74
  75                                         ; Display all of the stacks, then move the cursor
  76                                         ; out of the way and flush the output
  77
  78 (defun display ()
  79   (display-stacks 0 top stacks)
  80   (move-to 1 21)
  81   (flush)
  82   )
  83
  84                                         ; Reset stacks to the starting state, with
  85                                         ; all of the pieces in the first stack and the
  86                                         ; other two empty
  87
  88 (defun reset-stacks ()
  89   (setq stacks (list stack nil nil))
  90   (setq top (+ (length stack) 3))
  91   (length stack)
  92   )
  93
  94                                         ; more functions which could usefully
  95                                         ; be in the rom image
  96
  97 (defun min (a b)
  98   (cond ((< a b) a)
  99         (b)
 100         )
 101   )
 102
 103                                         ; Replace a stack in the list of stacks
 104                                         ; with a new value
 105
 106 (defun replace (list pos member)
 107   (cond ((= pos 0) (cons member (cdr list)))
 108         ((cons (car list) (replace (cdr list) (1- pos) member)))
 109         )
 110   )
 111
 112                                         ; Move a piece from the top of one stack
 113                                         ; to the top of another
 114
 115 (setq move-delay 100)
 116
 117 (defun move-piece (from to)
 118   (let ((from-stack (nth stacks from))
 119         (to-stack (nth stacks to))
 120         (piece (car from-stack)))
 121     (setq from-stack (cdr from-stack))
 122     (setq to-stack (cons piece to-stack))
 123     (setq stacks (replace stacks from from-stack))
 124     (setq stacks (replace stacks to to-stack))
 125     (display)
 126     (delay move-delay)
 127     )
 128   )
 129
 130 ; The implementation of the game
 131
 132 (defun _hanoi (n from to use)
 133   (cond ((= 1 n)
 134          (move-piece from to)
 135          )
 136         (t
 137          (_hanoi (1- n) from use to)
 138          (_hanoi 1 from to use)
 139          (_hanoi (1- n) use to from)
 140          )
 141         )
 142   )
 143
 144                                         ; A pretty interface which
 145                                         ; resets the state of the game,
 146                                         ; clears the screen and runs
 147                                         ; the program
 148
 149 (defun hanoi ()
 150   (setq len (reset-stacks))
 151   (clear)
 152   (_hanoi len 0 1 2)
 153   (move-to 0 23)
 154   t
 155   )