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

   1 #!/home/keithp/bin/ao-scheme
   2 ;
   3 ; Towers of Hanoi
   4 ;
   5 ; Copyright © 2016 Keith Packard <keithp@keithp.com>
   6 ;
   7 ; This program is free software; you can redistribute it and/or modify
   8 ; it under the terms of the GNU General Public License as published by
   9 ; the Free Software Foundation, either version 2 of the License, or
  10 ; (at your option) any later version.
  11 ;
  12 ; This program is distributed in the hope that it will be useful, but
  13 ; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ; General Public License for more details.
  16 ;
  17
  18                                         ; ANSI control sequences
  19
  20 (define (move-to col row)
  21   (for-each display (list "\033[" row ";" col "H"))
  22   )
  23
  24 (define (clear)
  25   (display "\033[2J")
  26   )
  27
  28 (define (display-string x y str)
  29   (move-to x y)
  30   (display str)
  31   )
  32
  33 (define (make-piece num max)
  34                                         ; A piece for position 'num'
  35                                         ; is num + 1 + num stars
  36                                         ; centered in a field of max *
  37                                         ; 2 + 1 characters with spaces
  38                                         ; on either side. This way,
  39                                         ; every piece is the same
  40                                         ; number of characters
  41
  42   (define (chars n c)
  43     (if (zero? n) ""
  44       (+ c (chars (- n 1) c))
  45       )
  46     )
  47   (+ (chars (- max num 1) " ")
  48      (chars (+ (* num 2) 1) "*")
  49      (chars (- max num 1) " ")
  50      )
  51   )
  52
  53 (define (make-pieces max)
  54                                         ; Make a list of numbers from 0 to max-1
  55   (define (nums cur max)
  56     (if (= cur max) ()
  57       (cons cur (nums (+ cur 1) max))
  58       )
  59     )
  60                                         ; Create a list of pieces
  61
  62   (map (lambda (x) (make-piece x max)) (nums 0 max))
  63   )
  64
  65                                         ; Here's all of the towers of pieces
  66                                         ; This is generated when the program is run
  67
  68 (define towers ())
  69
  70                                         ; position of the bottom of
  71                                         ; the stacks set at runtime
  72 (define bottom-y 0)
  73 (define left-x 0)
  74
  75 (define move-delay 25)
  76
  77                                         ; Display one tower, clearing any
  78                                         ; space above it
  79
  80 (define (display-tower x y clear tower)
  81   (cond ((= 0 clear)
  82          (cond ((not (null? tower))
  83                 (display-string x y (car tower))
  84                 (display-tower x (+ y 1) 0 (cdr tower))
  85                 )
  86                )
  87          )
  88         (else
  89          (display-string x y "                    ")
  90          (display-tower x (+ y 1) (- clear 1) tower)
  91          )
  92         )
  93   )
  94
  95                                         ; Position of the top of the tower on the screen
  96                                         ; Shorter towers start further down the screen
  97
  98 (define (tower-pos tower)
  99   (- bottom-y (length tower))
 100   )
 101
 102                                         ; Display all of the towers, spaced 20 columns apart
 103
 104 (define (display-towers x towers)
 105   (cond ((not (null? towers))
 106          (display-tower x 0 (tower-pos (car towers)) (car towers))
 107          (display-towers (+ x 20) (cdr towers)))
 108         )
 109   )
 110
 111                                         ; Display all of the towers, then move the cursor
 112                                         ; out of the way and flush the output
 113
 114 (define (display-hanoi)
 115   (display-towers left-x towers)
 116   (move-to 1 23)
 117   (flush-output)
 118   (delay move-delay)
 119   )
 120
 121                                         ; Reset towers to the starting state, with
 122                                         ; all of the pieces in the first tower and the
 123                                         ; other two empty
 124
 125 (define (reset-towers len)
 126   (set! towers (list (make-pieces len) () ()))
 127   (set! bottom-y (+ len 3))
 128   )
 129
 130                                         ; Move a piece from the top of one tower
 131                                         ; to the top of another
 132
 133 (define (move-piece from to)
 134
 135                                         ; references to the cons holding the two towers
 136
 137   (define from-tower (list-tail towers from))
 138   (define to-tower (list-tail towers to))
 139
 140                                         ; stick the car of from-tower onto to-tower
 141
 142   (set-car! to-tower (cons (caar from-tower) (car to-tower)))
 143
 144                                         ; remove the car of from-tower
 145
 146   (set-car! from-tower (cdar from-tower))
 147   )
 148
 149                                         ; The implementation of the game
 150
 151 (define (_hanoi n from to use)
 152   (cond ((= 1 n)
 153          (move-piece from to)
 154          (display-hanoi)
 155          )
 156         (else
 157          (_hanoi (- n 1) from use to)
 158          (_hanoi 1 from to use)
 159          (_hanoi (- n 1) use to from)
 160          )
 161         )
 162   )
 163
 164                                         ; A pretty interface which
 165                                         ; resets the state of the game,
 166                                         ; clears the screen and runs
 167                                         ; the program
 168
 169 (define (hanoi len)
 170   (reset-towers len)
 171   (clear)
 172   (display-hanoi)
 173   (_hanoi len 0 1 2)
 174   #t
 175   )
 176
 177 (unless (null? (command-line)) (hanoi 6))