; 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))