;;; -*-Lisp-*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "hanoi")

(defun hanoi-setup-screen (nrings ring)
  (let* ((width (window-columns))
	 (height (window-height))
	 (center (truncate width 2))
	 (width3 (truncate width 3))
	 (poll (list (- center width3 1) center (+ center width3 1))))
    (when (or (< (- center (* nrings 3) 1) 0)
	      (> (+ center (* nrings 3) 1) width)
	      (> (+ nrings 4) height))
      (error "ウィンドウが小さすぎます"))
    (set-buffer (or (find-buffer "*hanoi*")
		    (create-new-buffer "*hanoi*")))
    (erase-buffer (selected-buffer))
    (set-buffer-fold-width nil)
    (setq kept-undo-information nil)
    (setq need-not-save t)
    (setq auto-save nil)
    (goto-char 0)
    (insert #\LFD (- height 4 nrings))
    (let ((point (point)))
      (insert #\SPC (+ width 1))
      (insert #\LFD)
      (insert (buffer-substring point (point)) (+ nrings 1)))
    (insert #\= (+ width 1))
    (dotimes (x (+ nrings 1))
      (forward-line -1)
      (dolist (p poll)
	(goto-column p)
	(delete-char 1)
	(insert #\|)))
    (setq hanoi-top-of-line-number (1- (current-line-number)))
    (goto-char (point-max))
    (dolist (r ring)
      (forward-line -1)
      (goto-column (- (car poll) (car r)))
      (delete-char (cadr r))
      (insert (caddr r)))
    (goto-char 0)
    (refresh-screen)
    poll))

(defun hanoi (&optional (nrings 7))
  (interactive "p")
  (long-operation
    (let (ring)
      (dotimes (x nrings)
	(setq ring (cons (list (+ x 1)
			       (+ (* 2 (+ x 1)) 1)
			       (format nil "~v@{~a~:*~}" (+ (* x 2) 3) (code-char (+ #x30 x)))
			       (format nil "~v,1@t|~v,1@t" (+ x 1) (+ x 1))
			       (format nil "~v,1@t" (+ (* x 2) 3)))
			 ring)))
      (let ((poll (hanoi-setup-screen nrings ring)))
	(message "Tower of hanoi...")
	(gc)
	(unwind-protect
	    (let ((si:*find-motion* nil))
	      (tower-of-hanoi ring (first poll) (second poll) (third poll)))
	  (not-modified)
	  (goto-char 0)
	  (message "Tower of hanoi...done."))))))

(defun tower-of-hanoi (p a b c)
  (do-events)
  (when p
    (tower-of-hanoi (cdr p) a c b)
    (move-ring a c (car p))
    (tower-of-hanoi (cdr p) b a c)))

(defun move-ring (from to ring)
  (let ((width (first ring))
	(del (second ring))
	(disk (third ring))
	(poll (fourth ring))
	(white (fifth ring)))
    (let ((from-column (- from width))
	  (to-column (- to width)))
      (goto-char (point-max))
      (goto-column (- from 1))
      (while (not (looking-for " "))
	(next-line -1))
      (forward-line 1)
      (dotimes (x (- (current-line-number) hanoi-top-of-line-number))
	(goto-column from-column)
	(refresh-screen)
	(delete-char del)
	(insert poll)
	(forward-line -1)
	(goto-column from-column)
	(refresh-screen)
	(delete-char del)
	(insert disk))
      (if (> from to)
	  (do ((x from-column (1- x)))
	      ((= x to-column))
	    (goto-column x)
	    (refresh-screen)
	    (delete-char del)
	    (goto-column (1- x))
	    (insert disk))
	(do ((x from-column (1+ x)))
	    ((= x to-column))
	  (goto-column x)
	  (refresh-screen)
	  (delete-char del)
	  (goto-column (1+ x))
	  (insert disk)))
      (refresh-screen)
      (goto-column to-column)
      (delete-char del)
      (insert white)
      (refresh-screen)
      (forward-line 1)
      (goto-column to-column)
      (delete-char del)
      (insert disk)
      (let ((check (1- to)))
	(loop
	  (forward-line 1)
	  (goto-column check)
	  (unless (looking-for " ")
	    (return))
	  (forward-line -1)
	  (goto-column to-column)
	  (refresh-screen)
	  (delete-char del)
	  (insert poll)
	  (forward-line 1)
	  (goto-column to-column)
	  (refresh-screen)
	  (delete-char del)
	  (insert disk))))))
