dap@terak.UUCP (Damon Anton Permezel) (10/11/85)
At last ... what you have all been waiting for ... Towers of Hanoi
in GNUmacs to soak up all those surplus CPU cycles!
Enjoy,
dap
====cut here - make sure you compile it too==================================
;
; hanoi - towers of hanoi in GNUmacs
;
; Author (a) 1985, Damon Anton Permezel
;
;
; topos - direct cursor addressing
;
(defun topos (row col)
(goto-line row)
(beginning-of-line)
(forward-char col))
;
; hanoi - user callable Towers of Hanoi
;
(defun hanoi (n-rings)
"Towers of Hanoi diversion"
(interactive "p")
(if (or (> n-rings 9) (<= n-rings 0))
(error "Funny number of rings"))
(let ((floor-row 21)
(fly-row (- 21 n-rings 1))
(pole-1 (cons 20 20)) ; pole: column . fill height
(pole-2 (cons 40 20)) ; (these must be consed, not '(x . y)
(pole-3 (cons 60 20)) ; otherwise we are not reentrant)
(rings '(t (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0)
(6 . 0) (7 . 0) (8 . 0) (9 . 0))))
;
; init the screen
;
(switch-to-buffer " *Hanoi*")
(delete-other-windows)
(erase-buffer)
(let ((i 0)) ; Create a line of 79 blanks
(while (< i 78)
(setq i (1+ i))
(insert " ")))
(newline)
(previous-line 1) ; delete it to kill buffer
(beginning-of-line)
(kill-line 1)
(let ((i 1)) ; yank 21 copies of it
(while (< i floor-row)
(setq i (1+ i))
(yank)))
(let ((i 0)) ; draw the base
(while (< i 78)
(setq i (1+ i))
(insert "=")))
(mapcar (function (lambda (x) ; draw the towers
(topos fly-row x)
(let ((i fly-row))
(while (< i floor-row)
(setq i (1+ i))
(next-line 1)
(insert ?|)
(delete-char 1)
(backward-char 1)))))
'(20 40 60))
(sit-for 0)
;
; now init the rings
;
(let ((where (1- floor-row))
(i n-rings)
r)
(while (> i 0)
(setq r (car (nthcdr i rings))) ; extract desired ring
(rplacd r where) ; indicate ring row
(setq where (1- where))
(move-ring i pole-1 pole-1)
(setq i (1- i))
))
(sit-for 0)
(hanoi0 n-rings pole-1 pole-2 pole-3)
))
;
; hanoi0 - work horse of hanoi
;
(defun hanoi0 (n from to work)
(if (> n 0)
(progn
(hanoi0 (1- n) from work to)
(move-ring n from to)
(hanoi0 (1- n) work to from))))
;
; move-ring - move ring 'n' from 'from' to 'to'
;
; from and to are dotted pairs consisting of (pole col . fill height)
;
(defun move-ring (n from to)
(let ((r (car (nthcdr n rings))) ; r <- ring: (ring# . row)
)
(if (not (eq from to)) ; must change poles?
(let ((row (cdr r)) ; row <- row ring is on
(col (- (car from) n)) ; col <- left edge of ring
(dst-col (- (car to) n)) ; dst-col <- dest col for left edge
(dst-row (cdr to)) ; dst-row <- dest row for ring
)
(topos row col)
(while (> row fly-row) ; move up to the fly row
(draw-ring n nil nil) ; blank out ring
(previous-line 1) ; move up a line
(draw-ring n t nil) ; redraw
(sit-for 0)
(setq row (1- row)))
(rplacd from (1+ (cdr from))) ; adjust top row
;
; fly the ring over to the right pole
;
(while (not (equal dst-col col))
(cond
((> dst-col col) ; dst-col > col: right shift
(end-of-line 1)
(delete-backward-char 2)
(beginning-of-line 1)
(insert " ")
(sit-for 0)
(setq col (1+ (1+ col))))
((< dst-col col) ; dst-col < col: left shift
(beginning-of-line 1)
(delete-char 2)
(end-of-line 1)
(insert " ")
(sit-for 0)
(setq col (1- (1- col))))))
;
; let the ring float down
;
(topos fly-row dst-col)
(while (< row dst-row) ; move down to the dest row
(draw-ring n nil (equal row fly-row)) ; blank out ring
(next-line 1) ; move down a line
(draw-ring n t nil) ; redraw ring
(sit-for 0)
(setq row (1+ row)))
(rplacd r dst-row)
(rplacd to (1- (cdr to))) ; adjust top row
)
;
; ring on same pole - used for initialisation
;
(progn
(topos (cdr to) (- (car to) n))
(draw-ring n t nil)
(rplacd to (1- (cdr to)))))))
;
; draw-ring - draw the ring at dot, leave dot unchanged
;
; Input:
; n - ring #. used to select drawing character
; f1 - flag: t -> draw, nil -> erase
; f2 - flag: t -> erasing ring from fly-row -> dont redraw ?|
;
(defun draw-ring (n f1 f2)
(save-excursion
(let ((i 0)
(repl (if f1
(car (nthcdr n '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
? )))
(delete-char (+ 1 (* 2 n)))
(while (< i n)
(insert repl)
(setq i (1+ i))
)
(insert (if f1 repl (if f2 ? ?|)))
(setq i 0)
(while (< i n)
(insert repl)
(setq i (1+ i))
))))