Return to hanoi.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp

Annotation of 43BSDReno/contrib/emacs-18.55/lisp/hanoi.el, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.