#! /usr/bin/gosh
;;;
;;;                  Towers of Hanoi by Threads (in Gauche)
;;;
;;; Copyright (C) 2004  NIIBE Yutaka  <gniibe@fsij.org>
;;;
;;; $Id: towers-of-hanoi.scm,v 1.1 2004/03/05 05:07:10 gniibe Exp $
;;;
;;; This program 'Towers of Hanoi by Threads' 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.
;;;

(use gauche.threads)

(define number-of-disks 6)
(define direction 1)

(define towers (make-vector 3))
(define disks #f)

(define debug #f)
(define (debug-display s)
  (if debug
      (display s)))

(define (make-port)
  (define mutex (make-mutex))
  (define cv (make-condition-variable))
  (define status 'NONE)			; SYN, ACK, ESTABLISHED, FIN
  (define value 0)

  (define (exchange v)
    (dynamic-wind
	(lambda ()
	  (debug-display (format "LOCK: ~a\n" mutex))
	  (mutex-lock! mutex))
	(lambda ()
	  (case status
	    ((NONE)
	     (set! status 'SYN)
	     (set! value v)
	     (debug-display (format "WAIT: ~a\n" cv))
	     (let loop ()
	       (if (eq? status 'SYN)
		   (begin
		     (mutex-unlock! mutex cv)
		     (mutex-lock! mutex)
		     (loop))))
	     (debug-display (format "....: ~a\n" cv))
	     (set! status 'ESTABLISHED)
	     (debug-display (format "WakeuP: ~a\n" cv))
	     (condition-variable-signal! cv)
	     value)
	    ((SYN)
	     (let ((r value))
	       (set! value v)
	       (set! status 'ACK)
	       (debug-display (format "WAKEUP: ~a\n" cv))
	       (condition-variable-signal! cv)
	       r))
	    (else
	     (debug-display (format "~a????\n" status))
	     (exit 1))))
	(lambda ()
	  (debug-display (format "UNLOCK: ~a\n" mutex))
	  (mutex-unlock! mutex))))

  (define (sync)
    (dynamic-wind
	(lambda ()
	  (debug-display (format "lock: ~a\n" mutex))
	  (mutex-lock! mutex))
	(lambda ()
	  (debug-display (format "wait: ~a\n" cv))
	  (let loop ()
	    (if (eq? status 'ACK)
		(begin
		  (mutex-unlock! mutex cv)
		  (mutex-lock! mutex)
		  (loop))))
	  (debug-display (format "....wait: ~a\n" cv))
	  (cond ((eq? status 'ESTABLISHED)
		 (begin
		   (set! status 'FIN)
		   (debug-display (format "waiT: ~a\n" cv))
		   (let loop ()
		     (if (eq? status 'FIN)
			 (begin
			   (mutex-unlock! mutex cv)
			   (mutex-lock! mutex)
			   (loop))))
		   (debug-display (format "...waiT: ~a\n" cv))))
		((eq? status 'FIN)
		 (begin
		   (set! status 'NONE)
		   (debug-display (format "wakeup: ~a\n" cv))
		   (condition-variable-signal! cv)))
		(else
		 (begin
		   (display "?????\n")
		   (exit 1)))))
	(lambda ()
	  (debug-display (format "unlock: ~a\n" mutex))
	  (mutex-unlock! mutex))))

  (lambda (msg . args)
    (case msg
      ((exchange) (exchange (car args)))
      ((sync) (sync)))))

(define ports (make-vector 3))

(define (forward n)
  (if direction
      (remainder (+ n 2) 3)
      (remainder (+ n 1) 3)))

(define (hanoi tower mode)
  (let* ((d0 (vector-ref towers tower))
	 (p (vector-ref ports (if mode (forward tower) tower)))
	 (d1 (p 'exchange d0)))
    (if (<= d0 d1)
	(if (= d0 d1)
	    (begin
	      (if (not mode)
		  ((vector-ref ports (forward tower)) 'exchange -1))
	      #f)
	    (let ((d2 (vector-ref disks d0)))
	      (vector-set! towers tower d2)
	      (if mode
		  (display (format "Move disk~a from ~a to ~a\n"
				   d0 tower (forward tower)))
		  (display (format "Move disk~a from ~a to ~a\n"
				   d0 tower (forward (forward tower)))))
	      (p 'sync)
	      #t))
	(if (< d1 0)
	    #f
	    (begin
	      (p 'sync)
	      (vector-set! disks d1 d0)
	      (vector-set! towers tower d1)
	      #t)))))

(define (main args)
  (let ((t0 (make-thread
	     (lambda ()
	       (let loop ((mode #f))
		 (if (hanoi 0 mode) (loop (not mode)))))))
	(t1 (make-thread
	     (lambda ()
	       (let loop ((mode direction))
		 (if (hanoi 1 mode) (loop (not mode)))))))
	(t2 (make-thread
	     (lambda ()
	       (let loop ((mode (not direction)))
		 (if (hanoi 2 mode) (loop (not mode))))))))
    (set! number-of-disks (string->number (cadr args)))
    (set! direction (odd? number-of-disks))
    (set! disks (make-vector (+ number-of-disks 1)))

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

    (vector-set! towers 0 0)
    (vector-set! towers 1 number-of-disks)
    (vector-set! towers 2 number-of-disks)

    (vector-set! ports 0 (make-port))
    (vector-set! ports 1 (make-port))
    (vector-set! ports 2 (make-port))

    (thread-start! t0)
    (thread-start! t1)
    (thread-start! t2)
    (thread-join! t0)
    (thread-join! t1)
    (thread-join! t2))
  0)