145 lines
5.0 KiB
Common Lisp
145 lines
5.0 KiB
Common Lisp
; File: HANOI.LSP (c) 12/29/85 Soft Warehouse, Inc.
|
||
|
||
|
||
; * * * The Tower of Hanoi Puzzle * * *
|
||
|
||
(LOOP (PRIN1 (QUOTE *)) (EVAL (READ)) ((NULL RDS)) )
|
||
|
||
(SETQ *BLOCK-CHAR* (ASCII 219)) ; Character used to make rings
|
||
|
||
(DEFUN HANOI (
|
||
*RINGS* *HIGH-SPEED* *COLOR* *TONE* *TIME* *ROWS* MAX-RINGS
|
||
PEG1-RINGS PEG2-RINGS PEG3-RINGS PEG1-COLUMN PEG2-COLUMN PEG3-COLUMN
|
||
*AUTO-NEWLINE* )
|
||
(SETQ *ROWS* (CADDR (MAKE-WINDOW)))
|
||
(LOOP
|
||
(SETQ *TIME* 120)
|
||
(CLEAR-SCREEN)
|
||
(SETQ *HIGH-INTENSITY* T)
|
||
(CENTER "T H E T O W E R O F H A N O I")
|
||
(SETQ *HIGH-INTENSITY*)
|
||
(CLEAR-INPUT)
|
||
(TERPRI 2)
|
||
(SETQ MAX-RINGS (MIN
|
||
(TRUNCATE (SUB1 (TRUNCATE (CADDDR (MAKE-WINDOW)) 2)) 3)
|
||
(SUB1 (CADDR (MAKE-WINDOW))) ))
|
||
(LOOP
|
||
(WRITE-STRING (PACK* " Number of rings to use (1 to " MAX-RINGS ")? "))
|
||
((AND
|
||
(SETQ *RINGS* (SYMBOL-TO-INTEGER (READ-LINE)))
|
||
(<= 1 *RINGS* MAX-RINGS))) )
|
||
(TERPRI)
|
||
(SETQ *HIGH-SPEED* (NOT (Y-OR-N-P " Run program at normal speed?")))
|
||
( ((NOT *HIGH-SPEED*)
|
||
(TERPRI)
|
||
(SETQ *TONE* (Y-OR-N-P " Do you want sound effects?")) ) )
|
||
(TERPRI)
|
||
(SETQ *COLOR* (Y-OR-N-P "Are you using a color monitor?"))
|
||
(CLEAR-SCREEN)
|
||
(SETQ *HIGH-INTENSITY* T)
|
||
(CENTER "T H E T O W E R O F H A N O I")
|
||
(SETQ *HIGH-INTENSITY*)
|
||
(PUT 'PEG2 'COLUMN (TRUNCATE (CADDDR (MAKE-WINDOW)) 2))
|
||
(PUT 'PEG1 'COLUMN (- (GET PEG2 'COLUMN) *RINGS* *RINGS* 1))
|
||
(PUT 'PEG3 'COLUMN (+ (GET PEG2 'COLUMN) *RINGS* *RINGS* 1))
|
||
(PRINT-PEG *RINGS* *ROWS* (GET 'PEG1 'COLUMN))
|
||
(PRINT-PEG *RINGS* *ROWS* (GET 'PEG2 'COLUMN))
|
||
(PRINT-PEG *RINGS* *ROWS* (GET 'PEG3 'COLUMN))
|
||
(PUT PEG1 'RINGS (MAKE-TOWER *RINGS* *ROWS* (GET 'PEG1 'COLUMN)))
|
||
(PUT PEG2 'RINGS NIL)
|
||
(PUT PEG3 'RINGS NIL)
|
||
(UNWIND-PROTECT (MOVE-RINGS *RINGS* 'PEG1 'PEG2 'PEG3)
|
||
(FOREGROUND-COLOR 7) )
|
||
(SET-CURSOR 2 0)
|
||
((NOT (Y-OR-N-P "Run the puzzle again?"))) ) )
|
||
|
||
(DEFUN MOVE-RINGS (RINGS SOURCE-PEG TARGET-PEG SPARE-PEG
|
||
SOURCE-RINGS )
|
||
((ZEROP RINGS))
|
||
(MOVE-RINGS (SUB1 RINGS) SOURCE-PEG SPARE-PEG TARGET-PEG)
|
||
(SETQ SOURCE-RINGS (GET SOURCE-PEG 'RINGS))
|
||
(PUT TARGET-PEG 'RINGS (CONS (CAR SOURCE-RINGS) (GET TARGET-PEG 'RINGS)))
|
||
(PUT SOURCE-PEG 'RINGS (CDR SOURCE-RINGS))
|
||
(SET-CURSOR (- *ROWS* (LENGTH SOURCE-RINGS))
|
||
(- (GET SOURCE-PEG 'COLUMN) (CAAR SOURCE-RINGS)))
|
||
(SPACES (CAAR SOURCE-RINGS))
|
||
(PRINC *BLOCK-CHAR*)
|
||
(SPACES (CAAR SOURCE-RINGS))
|
||
(IF *COLOR* (FOREGROUND-COLOR (CAAR SOURCE-RINGS)))
|
||
( ((IDENTITY *HIGH-SPEED*))
|
||
(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS) SOURCE-PEG *TIME*)
|
||
(IF (OR (EQ SOURCE-PEG 'PEG2) (EQ TARGET-PEG 'PEG2)) NIL
|
||
(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS) 'PEG2 *TIME*) )
|
||
(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS) TARGET-PEG *TIME*) )
|
||
(SET-CURSOR (- *ROWS* (LENGTH (GET TARGET-PEG 'RINGS)))
|
||
(- (GET TARGET-PEG 'COLUMN) (CAAR SOURCE-RINGS)))
|
||
(PRINC (CDAR SOURCE-RINGS))
|
||
(IF *COLOR* (FOREGROUND-COLOR 7))
|
||
(IF *HIGH-SPEED* NIL (TONE NIL *TIME*))
|
||
; (IF (> *TIME* 10) (DECQ *TIME*)) ;Optional accelerator
|
||
(MOVE-RINGS (SUB1 RINGS) SPARE-PEG TARGET-PEG SOURCE-PEG) )
|
||
|
||
(DEFUN PRINT-RING (RING-SIZE RING-STRING PEG TIME)
|
||
((SET-CURSOR (- *ROWS* *RINGS* 3) (- (GET PEG 'COLUMN) RING-SIZE))
|
||
(WRITE-STRING RING-STRING)
|
||
(SET-CURSOR (- *ROWS* *RINGS* 3) (- (GET PEG 'COLUMN) RING-SIZE))
|
||
(TONE (IF *TONE* (CDR (ASSOC (CAAR SOURCE-RINGS) *NOTES*))) TIME)
|
||
(SPACES (ADD1 (* 2 RING-SIZE))) )
|
||
(TONE (IF *TONE* (CDR (ASSOC (CAAR SOURCE-RINGS) *NOTES*))) TIME) )
|
||
|
||
(SETQ *NOTES* '((1 . 523) (2 . 494) (3 . 440) (4 . 392) (5 . 349) (6 . 330)
|
||
(7 . 294) (8 . 262) (9 . 247) (10 . 220) (11 . 196) (12 . 175)
|
||
(13 . 165) (14 . 147) (15 . 131)))
|
||
|
||
(DEFUN PRINT-PEG (RINGS ROW COLUMN)
|
||
(LOOP
|
||
(SET-CURSOR (DECQ ROW) COLUMN)
|
||
(PRINC *BLOCK-CHAR*)
|
||
((ZEROP RINGS))
|
||
(DECQ RINGS) ) )
|
||
|
||
(DEFUN MAKE-TOWER (RINGS ROW COLUMN
|
||
PEG-RINGS )
|
||
(LOOP
|
||
((ZEROP RINGS)
|
||
(IF *COLOR* (FOREGROUND-COLOR 7))
|
||
PEG-RINGS )
|
||
(PUSH (CONS RINGS (PACK (MAKE-LIST (ADD1 (* 2 RINGS)) *BLOCK-CHAR*)))
|
||
PEG-RINGS)
|
||
(SET-CURSOR (DECQ ROW) (- COLUMN RINGS))
|
||
(IF *COLOR* (FOREGROUND-COLOR RINGS))
|
||
(PRINC (CDAR PEG-RINGS))
|
||
(DECQ RINGS) ) )
|
||
|
||
(DEFUN CENTER (MSG)
|
||
(SET-CURSOR (ROW)
|
||
(TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
|
||
(WRITE-LINE MSG) )
|
||
|
||
(DEFUN SYMBOL-TO-INTEGER (SYMBOL
|
||
NUM )
|
||
((SETQ SYMBOL (UNPACK SYMBOL))
|
||
(SETQ NUM 0)
|
||
(LOOP
|
||
((NOT (<= 48 (ASCII (CAR SYMBOL)) 57)) NIL)
|
||
(SETQ NUM (+ (* NUM 10) (- (ASCII (POP SYMBOL)) 48)))
|
||
((NULL SYMBOL) NUM) ) ) )
|
||
|
||
(DEFUN Y-OR-N-P (MSG
|
||
CHAR READ-CHAR RDS WRS )
|
||
( ((NULL MSG))
|
||
(FRESH-LINE)
|
||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||
(CLEAR-INPUT)
|
||
(LOOP
|
||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||
((EQ CHAR 'Y)
|
||
(WRITE-LINE CHAR)
|
||
T )
|
||
((EQ CHAR 'N)
|
||
(WRITE-LINE CHAR)
|
||
NIL )
|
||
(WRITE-BYTE 7) ) )
|
||
|
||
(HANOI (RDS))
|
||
|