;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ４本ハノイの塔  
;;; [ 白黒キャラクタによるグラフィック表示/エスケープシーケンス使用 ]
;;;
;;;  (hanoi n)      --- 計算機が勝手に実行する
;;;  (hanoi-user n) --- 人間がやらされる
;;;
;;;             n は円盤の個数
;;;;;;
;;;      関数 enter-raw-mode, exit-raw-mode が処理系依存。
;;;      その他は Common Lisp 。
;;;;;;
;;;             
;;;  Copyright (C) GOMI Hiroshi
;;;  Implemented on Lisp-C Translator Lisp               1988
;;;                 TAO Common Lisp/ELIS                 1990
;;;                 Tachyon Common Lisp(OKI Common Lisp) 1991
;;;                 OKI ISLisp                           1998
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  グローバル変数
;;;
(defglobal *hanoi-level* t)	; t にすると円盤がアニメーションで動く
(defglobal *hanoi-speed* 10)	; スピード
(defglobal *beta* #\O)		; 円盤のキャラクタ
(defglobal *bou* #\I)		; 棒のキャラクタ
(defglobal *black* #\space)	; スペース(消しゴムのキャラクタ)

;;;------------------------------------------------------------
;;; for ISLISP
;;;------------------------------------------------------------
(defglobal *hanoi-num* 0)
(defglobal *standard-output* (standard-output))
(defglobal *disk* nil)

(defmacro dolist (bind &rest body)
  `(block nil
     (for ((,(elt bind 0) ,(elt bind 1) (cdr ,(elt bind 0))))
	  ((null ,(elt bind 0)) 
	   ,(if (= (length bind) 3) (elt bind 2) nil))
	  (let ((,(elt bind 0) (car ,(elt bind 0))))
	    ,@body))))

(defmacro dotimes (bind &rest body)
  `(block nil
     (for ((,(elt bind 0) 0 (+ ,(elt bind 0) 1)))
	  ((= ,(elt bind 0) ,(elt bind 1)) 
	   ,(if (= (length bind) 3) (elt bind 2) nil))
	  ,@body)))

(defmacro loop (&rest body)
  `(block nil
     (for ()
	  (nil)
	  ,@body)))
  
(defmacro incf (x)
  `(setf ,x (+ ,x 1)))

(defmacro nth (n list)
  `(elt ,list ,n))

(defmacro when (test &rest then)
  `(if ,test (progn ,@then)))

(defun write-char (char &rest r)
  (let ((stream *standard-output*))
    (if (consp r) 
	(setf stream (car r)))
    (format-char stream char)))

(defun princ (object &rest r)
  (let ((stream *standard-output*))
    (if (consp r) 
	(setf stream (car r)))
    (format-object stream object nil)))

(defun 1+ (x)
  (+ x 1))

(defun 1- (x)
  (- x 1))

(defun code-char (char)
  (convert char <character>))

(defun first (x)
  (car x))

(defun second (x)
  (car (cdr x)))

(defun third (x)
  (car (cdr (cdr x))))

(defun fourth (x)
  (car (cdr (cdr (cdr x)))))

(defun force-output (&rest r)
  (let ((stream *standard-output*))
    (if (consp r)
	(setf stream (car r)))
    (finish-output stream)))

;;; 円盤を動かす。
(defun move-disk (disk fx fy tx ty)
    (display-disk 'delete disk fx fy)
    (if *hanoi-level* (move-disk2 disk fx fy tx ty))
    (display-disk 'put    disk tx ty))

(defun move-disk2 (disk fx fy tx ty)
  (let ((skip nil))
    (display-disk2 'put disk fx 7)
    (dotimes (i 4) 
	(display-disk2 'delete disk fx (- 7 i))
	(display-disk2 'put    disk fx (- 6 i)))
    (setq skip 6)
    (if (> fx tx)
	(dotimes (i (truncate (quotient (- fx tx) 2)))
	   (reset-point (+ (- fx i i 1) disk disk) 3)
	   (set-point (- fx i i 2) 3)
	   (force-output))
	(dotimes (i (truncate (quotient (- tx fx) 2)))
	   (reset-point (+ fx i i) 3)
	   (set-point (+ fx i i 1 disk disk) 3)
	   (force-output)))
    (dotimes (i 4) 
	(display-disk2 'delete disk tx (+ 3 i))
	(display-disk2 'put    disk tx (+ 4 i)))
    (display-disk2 'delete disk tx 7)))      

;;; 円盤を表示する
(defun display-disk (command disk x y)
  (let ((koma nil))
    (locate x y)
    (if (eq command 'delete) (setq koma *black*) (setq koma *beta*))
    (dotimes (i disk) (write-char koma *standard-output*))
    (locate (+ x disk 1) y)
    (dotimes (i disk) (write-char koma *standard-output*))
    (force-output)
    ))

(defun display-disk2 (command disk x y)
    (locate x y)
    (if (eq command 'delete)
	(dotimes (i (1+ (* 2 disk))) (write-char *black* *standard-output*))
	(progn
	 (dotimes (i (1+ (* 2 disk))) (write-char *beta* *standard-output*))
	 (dotimes (i *hanoi-speed*) (* 1 2 3 4 5))	; 時間潰し
	 ))
    (force-output)
    )

;;; 指定された場所に円盤の一点を表示する
(defun set-point (x y)
    (locate x y)
    (write-char *beta* *standard-output*)
    (write-char *beta* *standard-output*))

;;; 指定された場所に円盤の一点を消す
(defun reset-point (x y)
    (locate x y)
    (write-char *black* *standard-output*)
    (write-char *black* *standard-output*))

;;; 初期画面の表示
(defun init-display-disk ()
  (let ((1st-len nil)
	(2nd-len nil)
	(3rd-len nil)
	(4th-len nil))
    (cls)
    (locate 3 1) 
    (princ "Welcome to Tachyon world. -- [HANOI] --")
    (locate 10 2) 
    (princ " 1988/06/14 14:43 version 0.99b             Copyright by Go")
    (locate 20 19) (princ " ----  HANOI TOWER  ----")
    (dotimes (i 10) (locate 10 (+ i 8)) (write-char *bou* *standard-output*))
    (dotimes (i 10) (locate 30 (+ i 8)) (write-char *bou* *standard-output*))
    (dotimes (i 10) (locate 50 (+ i 8)) (write-char *bou* *standard-output*))
    (dotimes (i 10) (locate 70 (+ i 8)) (write-char *bou* *standard-output*))
    (locate 10 18) (princ "1")
    (locate 30 18) (princ "2")
    (locate 50 18) (princ "3")
    (locate 70 18) (princ "4")
    (setq 1st-len (length (first *disk*)))
    (dolist (disk (first *disk*))
       (display-disk 'put disk (- 10 disk) (- 18 1st-len))
       (setq 1st-len (1- 1st-len)))
    (setq 2nd-len (length (second *disk*)))
    (dolist (disk (second *disk*))
       (display-disk 'put disk (- 30 disk) (- 18 2nd-len))
       (setq 2nd-len (1- 2nd-len)))
    (setq 3rd-len (length (third *disk*)))
    (dolist (disk (third *disk*))
       (display-disk 'put disk (- 50 disk) (- 18 3rd-len))
       (setq 3rd-len (1- 3rd-len)))
    (setq 4th-len (length (fourth *disk*)))
    (dolist (disk (fourth *disk*))
       (display-disk 'put disk (- 70 disk) (- 18 4th-len))
       (setq 4th-len (1- 4th-len)))))

;;; コマンド受けつけ
(defun hanoi-cmd (from to)
  (let ((disk nil))
    (incf *hanoi-num*)
    (setq disk (car (nth from *disk*)))
    (move-disk disk 
	       (- (+ (* from 20) 10) disk)
	       (- 18 (length (nth from *disk*)))
	       (- (+ (* to   20) 10) disk)
	       (- 17 (length (nth to *disk*))))
    (setf (nth from *disk*) (cdr (nth from *disk*)))
    (setf (nth to *disk*) (cons disk (nth to *disk*)))))

;;; ユーザハノイのメイン
(defun clip::hanoi-user (n) (hanoi-user n)) ;; impotant !!!
(defun hanoi-user (n)
  (let ((code nil)
	(code2 nil))
    (setq *hanoi-num* 0)
    (make-disk n)
    (init-display-disk)
    (locate 0 19) (princ "'q' is quit...")
    (loop 
     (locate 0 20) (princ "                ")
     (locate 0 20)
     (princ "From: ")
     (setq code (my-read-byte *standard-input*))
     (when (= code 113) 
       (locate 0 20) (princ "End  ") (terpri)
       (return 'end))
     (princ " To: ")
     (setq code2 (my-read-byte *standard-input*))
     (when (= code2 113) 
       (locate 0 20) (princ "End  ") (terpri)
       (return 'quit))
     (if (check-disk code code2)
	 (hanoi-cmd (- code 49) (- code2 49))
	 (progn (locate 0 20) (princ " No Good!!          ")
	     (sleep 2)))
     (when (not (or (nth 0 *disk*) (nth 1 *disk*) (nth 2 *disk*)))
       (locate 0 20) (princ "   --- Good !!! ---   ")
       (return *hanoi-num*)) )))

;;; 終了したかどうかのチェック
(defun check-disk (from to)
    (setq from (- from 48))
    (setq to (- to 48))
    (and (/= from to)
         (setq from (car (nth (1- from) *disk*)))
	 (or (null (setq to (car (nth (1- to) *disk*))))
	     (> to from))))

;;; チェック付き read-byte
(defun my-read-byte (stream)
  (let ((code nil))
    (loop
     (enter-raw-mode)
     (setq code (char-code (princ (read-char stream))))
     (exit-raw-mode)
     (if (= code 113) (return code))
     (if (and (<= 49 code) (<= code 52)) (return code)))))
     
;;; 計算機ハノイのメイン    
(defun clip::hanoi (n) (hanoi n)) ;; impotant !!!
(defun hanoi (n)
  (let ((ret nil))
    (setq *hanoi-num* 0)
    (make-disk n)
    (init-display-disk)
    (setq ret (hanoi-main n 0 3 1 2))
    (locate 0 20)
;    (disp-cursor t)
    (if (eq ret 999) t *hanoi-num*)))

;;; 円盤の初期状態の作る
(defun make-disk (n)
    (let ((a ()))
       (dotimes (i n)
         (setq a (cons (1+ i) a)))
       (setq *disk* (list (nreverse a) () () ()))))

;;;
;;; 本体
;;;   n    --- 円盤の数
;;;   from --- 最初に円盤のある位置
;;;   to   --- 最終的に円盤を持っていきたい位置
;;;
;;;        位置は 0 オリジン。other1, other2 も同様。
;;;
(defun hanoi-main (n from to other1 other2)
    (cond ((eq n 1) (hanoi-cmd from to))
	  ((eq n 2) (hanoi-cmd from other1)
	            (hanoi-cmd from to)
		    (hanoi-cmd other1 to))
	  ((eq n 3) (hanoi-cmd from other1)
	            (hanoi-cmd from other2)
		    (hanoi-cmd from to)
		    (hanoi-cmd other2 to)
		    (hanoi-cmd other1 to))
	  (t        (hanoi-main (- n 3) from other1 other2 to)
		    (hanoi3-main 3 from to other2)
		    (hanoi-main (- n 3) other1 to other2 from))))

;;; ３本ハノイの本体
(defun hanoi3-main (n from to other)
    (if (eq n 1) 
        (hanoi-cmd from to)
        (progn
	 (hanoi3-main (1- n) from other to)
	 (hanoi-cmd from to)
	 (hanoi3-main (1- n) other to from))))

;;;
;;; 画面制御
;;;

; 画面消去
(defun cls ()
    (write-char (code-char 27))
    (princ "[2J"))

; カーサー位置の指定
(defun locate (x y)
    (write-char (code-char 27))
    (write-char #\[ *standard-output*)
    (tyo-num y)					; (write-to-string y)
    (write-char #\; *standard-output*)
    (tyo-num x)					; (write-to-string x)
    (write-char #\H *standard-output*))

; locate の下請け
(defun tyo-num (x)
    (if (>= x 100) (write-char (code-char (+ 48 (truncate (quotient x 100))))))
    (if (>= x 10) (write-char (code-char (+ 48 (truncate (quotient x 10))))))
    (write-char (code-char (+ 48 (mod x 10)))))