;;;
;;;                  Towers of Hanoi by Gauche
;;;
;;; Copyright (C) 2004  NIIBE Yutaka  <gniibe@fsij.org>
;;; Copyright (C) 2004  Tanaka Akira  <akr@m17n.org>
;;;
;;; $Id: hanoi.scm,v 1.2 2006/01/07 07:43:19 gniibe Exp $
;;;
;;; This program 'Towers of Hanoi by Gauche' is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU General
;;; Public License as published by the Free Software Foundation; either
;;; version 2 or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;

;;;
;;; This program is intended to be used with a CGI script like:
;;; ------------------------------------------
;;; #! /usr/bin/gosh
;;; 
;;; (use hanoi)
;;; (use www.cgi)
;;; (use srfi-11)
;;; (use text.html-lite)
;;; 
;;; (define (main args)
;;;   (cgi-main
;;;    (lambda (params)
;;;      (let-values (((step html-output) (hanoi "hanoi.dat" 10 :border 0.5)))
;;;        `(,(cgi-header)
;;;          ,(html:html
;;;            (html:head (html:title "Towers of Hanoi"))
;;;            (html:body step html-output)))))))
;;; ------------------------------------------
;;;

(define-module hanoi
  (use text.html-lite)
  (use gauche.fcntl)

  (export hanoi))
(select-module hanoi)

;;;
(define (towers-of-hanoi input-port output-port number-of-disks options)
  (define step (if data (vector-ref data 0) 0))
  (define remaining-steps 
    (if data (vector-ref data 1) (- (expt 2 number-of-disks) 1)))
  (define towers (if data (vector-ref data 2) (make-vector 3)))
  (define pole-height (if data (vector-ref data 3) (make-vector 3)))
  (define disks (if data (vector-ref data 4) (make-vector number-of-disks)))

  (define data
    (if input-port
	(vector
	 (read input-port)
	 (read input-port)
	 (read input-port)
	 (read input-port)
	 (read input-port))
	#f))

  ;; ??? Integrity check could be here: Data to be (read) and number-of-disks

  (define (init-towers-of-hanoi)
    (vector-set! towers 0 0)
    (vector-set! towers 1 -1)
    (vector-set! towers 2 -1)

    (vector-set! pole-height 0 2)
    (vector-set! pole-height 1 (+ number-of-disks 2))
    (vector-set! pole-height 2 (+ number-of-disks 2))

    (vector-set! disks (- number-of-disks 1) -1)
    (let loop ((i 0))
      (vector-set! disks i (+ i 1))
      (if (< i (- number-of-disks 2))
	  (loop (+ i 1)))))

  (define (get-disk-to-move)
    (let loop ((i 0) (s remaining-steps))
      (if (= (modulo s 2) 0)
	  i
	  (loop (+ i 1) (quotient s 2)))))

  ;; Type a: 0 --> 1 --> 2 --> 0
  ;; Type b: 0 --> 2 --> 1 --> 0
  (define (get-tower-from disk step)
    (let* ((n (quotient step (expt 2 (+ disk 1)))))
      (if (odd? (- number-of-disks disk))
	  (remainder n 3)
	  (- 2 (remainder (+ n 2) 3)))))

  (define (get-tower-to disk step)
    (get-tower-from disk (+ step (expt 2 (+ disk 1)))))

  (define (proceed-one-step)
    (set! remaining-steps (- remaining-steps 1))
    (set! step (+ step 1))
    (let* ((disk (get-disk-to-move))
	   (from (get-tower-from disk step))
	   (to (get-tower-to disk step)))
      (vector-set! towers from (vector-ref disks disk))
      (vector-set! pole-height from (+ (vector-ref pole-height from) 1))
      (vector-set! disks disk (vector-ref towers to))
      (vector-set! towers to disk)
      (vector-set! pole-height to (- (vector-ref pole-height to) 1))))

  (let-keywords* options
    ((border 1)
     (disk-unit-height 3)
     (disk-unit-width 2)
     (font-size 1.5)
     (pole-width 1)
     (pole-color "black")
     (base-color "green")
     (disk-color "blue")
     (disk-border-color "red"))
    ;;   N*disk-unit-size ||
    ;; <----------------->||
    ;;  ______________________________________
    ;; |                                      |
    ;; <---- 2N*disk-unit-size + pole-width -->
    (define (div:pole-style)
      (string-append
       (format "font-size: ~apt;" font-size)
       (format "color: ~a;" pole-color)
       (format "background: ~a;" pole-color)
       (format "margin-left: ~aem;"
	       (- (* (+ number-of-disks 1) disk-unit-width) border))
       (format "width: ~aem;" pole-width)
       (format "height: ~aem;" disk-unit-height)
       (format "border-width: ~aem;" border)
       "border-style: solid;"))

    (define (div:disk-style n)
      (string-append
       (format "font-size: ~apt;" font-size)
       (format "color: ~a;" disk-color)
       (format "background: ~a;" disk-color)
       (format "width: ~aem;" (+ (* (+ (* 2 n) 2) disk-unit-width) pole-width))
       (format "margin-left: ~aem;"
	       (- (* (- number-of-disks n) disk-unit-width) border))
       (format "height: ~aem;" disk-unit-height)
       (format "border-top-color: ~a;" disk-border-color)
       (format "border-left-color: ~a;" disk-border-color)
       (format "border-right-color: ~a;" disk-border-color)
       (format "border-width: ~aem;" border)
       "border-style: solid;"))

    (define (div:base-style)
      (string-append
       (format "font-size: ~apt;" font-size)
       (format "color: ~a;" base-color)
       (format "background: ~a;" base-color)
       (format "width: ~aem;"
	       (+ pole-width (* 2 (+ number-of-disks 1) disk-unit-width)))
       (format "height: ~aem;" disk-unit-height)))

    (define (draw-pole h)
      (let loop ((i 0))
	(if (= i h)
	    '()
	    (cons (html:div :style (div:pole-style)
			    :align "center" "|")
		  (loop (+ i 1))))))

    (define (draw-disk n)
      (html:div :style (div:disk-style n)
		:align "center"
		(make-string (+ (* 2 n) 3) #\#)))

    (define (draw-base)
      (list
       (html:div 
	:style (div:base-style)
	(make-string (+ (* 2 number-of-disks) 3) #\=))))

    (define (draw-tower t)
      (html:td
       (draw-pole (vector-ref pole-height t))
       (let loop ((n (vector-ref towers t)))
	 (if (negative? n)
	     (draw-base)
	     (cons (draw-disk n)
		   (loop (vector-ref disks n)))))))

    (if input-port
	(if (not (zero? remaining-steps))
	    (proceed-one-step))
	(init-towers-of-hanoi))

    (write step output-port)(newline output-port)
    (write remaining-steps output-port)(newline output-port)
    (write towers output-port)(newline output-port)
    (write pole-height output-port)(newline output-port)
    (write disks output-port)(newline output-port)
    (write number-of-disks output-port)(newline output-port)

    (values
     step
     (html:table :style "display: inline; vertical-align: text-bottom"
		 (html:tr (draw-tower 0) (draw-tower 1) (draw-tower 2))))))

;;;
;;; Options           	Default-Value
;;;  :border           	      1
;;;  :disk-unit-height 	      3
;;;  :disk-unit-width  	      2
;;;  :font-size        	    1.5
;;;  :pole-width       	      1
;;;  :pole-color       	  "black"
;;;  :base-color       	  "green"
;;;  :disk-color       	  "blue"
;;;  :disk-border-color	  "red"
;;;
(define (hanoi file-name number-of-disks . options)
  (define (lock-file-name name)
    (string-append name ".lock"))

  (let ((lock (make <sys-flock> :type F_WRLCK))
	(lock-port (open-output-file (lock-file-name file-name)
				     :if-exists :overwrite
				     :if-does-not-exist :create))
	(input-port #f)
	(output-port #f))
    (dynamic-wind
	(lambda ()
	  (sys-fcntl lock-port F_SETLKW lock)
	  (set! output-port (open-output-file file-name
					      :if-exists :overwrite
					      :if-does-not-exist :create))
	  (if (> (sys-stat->size (sys-fstat output-port)) 0)
	      (set! input-port (open-input-file file-name))))
	(lambda ()
	  (towers-of-hanoi input-port output-port number-of-disks options))
	(lambda ()
	  (if input-port (close-input-port input-port))
	  (close-output-port output-port)
	  ;; Closing port automatically unlocks the file
	  (close-output-port lock-port)))))

(provide "hanoi")