![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hanoi.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp|
Return to hanoi.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 ! root 1: ; ! 2: ; hanoi - towers of hanoi in GNUmacs ! 3: ; ! 4: ; Author (a) 1985, Damon Anton Permezel ! 5: ; ! 6: ! 7: ;;; ! 8: ;;; hanoi-topos - direct cursor addressing ! 9: ;;; ! 10: (defun hanoi-topos (row col) ! 11: (goto-line row) ! 12: (beginning-of-line) ! 13: (forward-char col)) ! 14: ! 15: ;;; ! 16: ;;; hanoi - user callable Towers of Hanoi ! 17: ;;; ! 18: (defun hanoi (n-rings) ! 19: "Towers of Hanoi diversion. Arg is number of rings." ! 20: (interactive "p") ! 21: (if (or (> n-rings 9) (<= n-rings 0)) ! 22: (error "Funny number of rings")) ! 23: ! 24: (let ((floor-row 21) ! 25: (fly-row (- 21 n-rings 1)) ! 26: (pole-1 (cons 20 20)) ; pole: column . fill height ! 27: (pole-2 (cons 40 20)) ; (these must be consed, not '(x . y) ! 28: (pole-3 (cons 60 20)) ; otherwise we are not reentrant) ! 29: (rings '(t (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0) ! 30: (6 . 0) (7 . 0) (8 . 0) (9 . 0)))) ! 31: ;; ! 32: ;; init the screen ! 33: ;; ! 34: (switch-to-buffer " *Hanoi*") ! 35: (delete-other-windows) ! 36: (erase-buffer) ! 37: ! 38: (let ((i 1)) ; 21 copies of a line of 78 blanks ! 39: (while (< i floor-row) ! 40: (setq i (1+ i)) ! 41: (insert " \n"))) ! 42: ! 43: (let ((i 0)) ; draw the base ! 44: (while (< i 78) ! 45: (setq i (1+ i)) ! 46: (insert ?=))) ! 47: ! 48: (mapcar (function (lambda (x) ; draw the towers ! 49: (hanoi-topos fly-row x) ! 50: (let ((i fly-row)) ! 51: (while (< i floor-row) ! 52: (setq i (1+ i)) ! 53: (next-line 1) ! 54: (insert ?|) ! 55: (delete-char 1) ! 56: (backward-char 1))))) ! 57: '(20 40 60)) ! 58: (sit-for 0) ! 59: ;; ! 60: ;; now init the rings ! 61: ;; ! 62: (let ((where (1- floor-row)) ! 63: (i n-rings) ! 64: r) ! 65: (while (> i 0) ! 66: (setq r (car (nthcdr i rings))) ; extract desired ring ! 67: (setcdr r where) ; indicate ring row ! 68: (setq where (1- where)) ! 69: (hanoi-move-ring i pole-1 pole-1) ! 70: (setq i (1- i)))) ! 71: (sit-for 0) ! 72: (hanoi0 n-rings pole-1 pole-2 pole-3)) ! 73: (message "Done")) ! 74: ! 75: ;;; ! 76: ;;; hanoi0 - work horse of hanoi ! 77: ;;; ! 78: (defun hanoi0 (n from to work) ! 79: (if (> n 0) ! 80: (progn ! 81: (hanoi0 (1- n) from work to) ! 82: (hanoi-move-ring n from to) ! 83: (hanoi0 (1- n) work to from)))) ! 84: ! 85: ;;; ! 86: ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to' ! 87: ;;; ! 88: ;;; from and to are dotted pairs consisting of (pole col . fill height) ! 89: ;;; ! 90: (defun hanoi-move-ring (n from to) ! 91: (let ((r (car (nthcdr n rings)))) ; r <- ring: (ring# . row) ! 92: (if (eq from to) ; must change poles? ! 93: ;; ! 94: ;; ring on same pole - used for initialization ! 95: ;; ! 96: (progn ! 97: (hanoi-topos (cdr to) (- (car to) n)) ! 98: (hanoi-draw-ring n t nil) ! 99: (setcdr to (1- (cdr to)))) ! 100: (let ((row (cdr r)) ; row <- row ring is on ! 101: (col (- (car from) n)) ; col <- left edge of ring ! 102: (dst-col (- (car to) n)) ; dst-col <- dest col for left edge ! 103: (dst-row (cdr to))) ; dst-row <- dest row for ring ! 104: (hanoi-topos row col) ! 105: (while (> row fly-row) ; move up to the fly row ! 106: (hanoi-draw-ring n nil nil) ; blank out ring ! 107: (previous-line 1) ; move up a line ! 108: (hanoi-draw-ring n t nil) ; redraw ! 109: (sit-for 0) ! 110: (setq row (1- row))) ! 111: (setcdr from (1+ (cdr from))) ; adjust top row ! 112: ;; ! 113: ;; fly the ring over to the right pole ! 114: ;; ! 115: (while (not (equal dst-col col)) ! 116: (cond ((> dst-col col) ; dst-col > col: right shift ! 117: (end-of-line 1) ! 118: (delete-backward-char 2) ! 119: (beginning-of-line 1) ! 120: (insert " ") ! 121: (sit-for 0) ! 122: (setq col (1+ (1+ col)))) ! 123: ((< dst-col col) ; dst-col < col: left shift ! 124: (beginning-of-line 1) ! 125: (delete-char 2) ! 126: (end-of-line 1) ! 127: (insert " ") ! 128: (sit-for 0) ! 129: (setq col (1- (1- col)))))) ! 130: ;; ! 131: ;; let the ring float down ! 132: ;; ! 133: (hanoi-topos fly-row dst-col) ! 134: (while (< row dst-row) ; move down to the dest row ! 135: (hanoi-draw-ring n nil (equal row fly-row)) ; blank out ring ! 136: (next-line 1) ; move down a line ! 137: (hanoi-draw-ring n t nil) ; redraw ring ! 138: (sit-for 0) ! 139: (setq row (1+ row))) ! 140: (setcdr r dst-row) ! 141: (setcdr to (1- (cdr to))))))) ; adjust top row ! 142: ! 143: ;;; ! 144: ;;; hanoi-draw-ring - draw the ring at dot, leave dot unchanged ! 145: ;;; ! 146: ;;; Input: ! 147: ;;; n - ring #. used to select drawing character ! 148: ;;; f1 - flag: t -> draw, nil -> erase ! 149: ;;; f2 - flag: t -> erasing ring from fly-row -> dont redraw ?| ! 150: ;;; ! 151: (defun hanoi-draw-ring (n f1 f2) ! 152: (save-excursion ! 153: (let ((i 0) ! 154: (repl (if f1 ! 155: (car (nthcdr n '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))) ! 156: ? ))) ! 157: (delete-char (+ 1 (* 2 n))) ! 158: (while (< i n) ! 159: (insert repl) ! 160: (setq i (1+ i))) ! 161: (insert (if f1 repl (if f2 ? ?|))) ! 162: (setq i 0) ! 163: (while (< i n) ! 164: (insert repl) ! 165: (setq i (1+ i)))))) ! 166:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.