lisp/play/hanoi.el

   1 ;;; hanoi.el --- towers of hanoi in GNUmacs
   2
   3 ; Author (a) 1985, Damon Anton Permezel
   4
   5 ;;;
   6 ;;; hanoi-topos - direct cursor addressing
   7 ;;;
   8 (defun hanoi-topos (row col)
   9   (goto-line row)
  10   (beginning-of-line)
  11   (forward-char col))
  12
  13 ;;;
  14 ;;; hanoi - user callable Towers of Hanoi
  15 ;;;
  16 ;;;###autoload
  17 (defun hanoi (nrings)
  18   "Towers of Hanoi diversion.  Argument is number of rings."
  19   (interactive
  20    (list (if (null current-prefix-arg)
  21              3
  22              (prefix-numeric-value current-prefix-arg))))
  23   (if (<= nrings 0) (error "Negative number of rings"))
  24   (let (pole-spacing
  25         floor-row
  26         fly-row
  27         (window-height (window-height (selected-window)))
  28         (window-width (window-width (selected-window))))
  29     (let ((h (+ nrings 2))
  30           (w (+ (* (1- nrings) 6) 2 5)))
  31       (if (not (and (>= window-width h)
  32                     (> window-width w)))
  33           (progn
  34             (delete-other-windows)
  35             (if (not (and (>= (setq window-height
  36                                     (window-height (selected-window))) h)
  37                           (> (setq window-width
  38                                    (window-width (selected-window))) w)))
  39                 (error "Screen is too small (need at least %dx%d)" w h))))
  40       (setq pole-spacing (/ window-width 6))
  41       (if (not (zerop (logand pole-spacing 1)))
  42           ;; must be even
  43           (setq pole-spacing (1+ pole-spacing)))
  44       (setq floor-row (if (> (- window-height 3) h)
  45                           (- window-height 3) window-height)))
  46     (let ((fly-row (- floor-row nrings 1))
  47           ;; pole: column . fill height
  48           (pole-1 (cons pole-spacing floor-row))
  49           (pole-2 (cons (* 3 pole-spacing) floor-row))
  50           (pole-3 (cons (* 5 pole-spacing) floor-row))
  51           (rings (make-vector nrings nil)))
  52       ;; construct the ring list
  53       (let ((i 0))
  54         (while (< i nrings)
  55           ;; ring: [pole-number string empty-string]
  56           (aset rings i (vector nil
  57                                 (make-string (+ i i 3) (+ ?0 i))
  58                                 (make-string (+ i i 3) ?\  )))
  59           (setq i (1+ i))))
  60       ;;
  61       ;; init the screen
  62       ;;
  63       (switch-to-buffer "*Hanoi*")
  64       (setq buffer-read-only nil)
  65       (buffer-disable-undo (current-buffer))
  66       (erase-buffer)
  67       (let ((i 0))
  68         (while (< i floor-row)
  69           (setq i (1+ i))
  70           (insert-char ?\  (1- window-width))
  71           (insert ?\n)))
  72       (insert-char ?= (1- window-width))
  73
  74       (let ((n 1))
  75         (while (< n 6)
  76           (hanoi-topos fly-row (* n pole-spacing))
  77           (setq n (+ n 2))
  78           (let ((i fly-row))
  79             (while (< i floor-row)
  80               (setq i (1+ i))
  81               (next-line 1)
  82               (insert ?\|)
  83               (delete-char 1)
  84               (backward-char 1)))))
  85       ;(sit-for 0)
  86       ;;
  87       ;; now draw the rings in their initial positions
  88       ;;
  89       (let ((i 0)
  90             ring)
  91         (while (< i nrings)
  92           (setq ring (aref rings (- nrings 1 i)))
  93           (aset ring 0 (- floor-row i))
  94           (hanoi-topos (cdr pole-1)
  95                        (- (car pole-1) (- nrings i)))
  96           (hanoi-draw-ring ring t nil)
  97           (setcdr pole-1 (1- (cdr pole-1)))
  98           (setq i (1+ i))))
  99       (setq buffer-read-only t)
 100       (sit-for 0)
 101       ;;
 102       ;; do it!
 103       ;;
 104       (hanoi0 (1- nrings) pole-1 pole-2 pole-3)
 105       (goto-char (point-min))
 106       (message "Done")
 107       (setq buffer-read-only t)
 108       (set-buffer-modified-p (buffer-modified-p))
 109       (sit-for 0))))
 110
 111 ;;;
 112 ;;; hanoi0 - work horse of hanoi
 113 ;;;
 114 (defun hanoi0 (n from to work)
 115   (cond ((input-pending-p)
 116          (signal 'quit (list "I can tell you've had enough")))
 117         ((< n 0))
 118         (t
 119          (hanoi0 (1- n) from work to)
 120          (hanoi-move-ring n from to)
 121          (hanoi0 (1- n) work to from))))
 122
 123 ;;;
 124 ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to'
 125 ;;;
 126 ;;;
 127 (defun hanoi-move-ring (n from to)
 128   (let ((ring (aref rings n))           ; ring <- ring: (ring# . row)
 129         (buffer-read-only nil))
 130     (let ((row (aref ring 0))           ; row <- row ring is on
 131           (col (- (car from) n 1))      ; col <- left edge of ring
 132           (dst-col (- (car to) n 1))    ; dst-col <- dest col for left edge
 133           (dst-row (cdr to)))           ; dst-row <- dest row for ring
 134       (hanoi-topos row col)
 135       (while (> row fly-row)            ; move up to the fly row
 136         (hanoi-draw-ring ring nil t)    ; blank out ring
 137         (previous-line 1)               ; move up a line
 138         (hanoi-draw-ring ring t nil)    ; redraw
 139         (sit-for 0)
 140         (setq row (1- row)))
 141       (setcdr from (1+ (cdr from)))     ; adjust top row
 142       ;;
 143       ;; fly the ring over to the right pole
 144       ;;
 145       (while (not (equal dst-col col))
 146         (cond ((> dst-col col)          ; dst-col > col: right shift
 147                (end-of-line 1)
 148                (delete-backward-char 2)
 149                (beginning-of-line 1)
 150                (insert ?\  ?\  )
 151                (sit-for 0)
 152                (setq col (1+ (1+ col))))
 153               ((< dst-col col)          ; dst-col < col: left shift
 154                (beginning-of-line 1)
 155                (delete-char 2)
 156                (end-of-line 1)
 157                (insert ?\  ?\  )
 158                (sit-for 0)
 159                (setq col (1- (1- col))))))
 160       ;;
 161       ;; let the ring float down
 162       ;;
 163       (hanoi-topos fly-row dst-col)
 164       (while (< row dst-row)            ; move down to the dest row
 165         (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring
 166         (next-line 1)                   ; move down a line
 167         (hanoi-draw-ring ring t nil)    ; redraw ring
 168         (sit-for 0)
 169         (setq row (1+ row)))
 170       (aset ring 0 dst-row)
 171       (setcdr to (1- (cdr to))))))      ; adjust top row
 172
 173 ;;;
 174 ;;; draw-ring - draw the ring at point, leave point unchanged
 175 ;;;
 176 ;;; Input:
 177 ;;;     ring
 178 ;;;     f1      -       flag: t -> draw, nil -> erase
 179 ;;;     f2      -       flag: t -> erasing and need to draw ?\|
 180 ;;;
 181 (defun hanoi-draw-ring (ring f1 f2)
 182   (save-excursion
 183     (let* ((string (if f1 (aref ring 1) (aref ring 2)))
 184            (len (length string)))
 185       (delete-char len)
 186       (insert string)
 187       (if f2
 188           (progn
 189             (backward-char (/ (+ len 1) 2))
 190             (delete-char 1) (insert ?\|))))))
 191