#! /usr/bin/gosh
;;;
;;;                  Towers of Hanoi (Networking/GTK+)
;;;
;;; Copyright (C) 2004  NIIBE Yutaka  <gniibe@fsij.org>
;;;
;;; $Id: gtk-toh.scm,v 1.6 2004/03/05 05:09:07 gniibe Exp $
;;;
;;; This program 'Towers of Hanoi (Networking/GTK+)' 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.
;;;

;; Todo:
;;   precise resource handling (closing sockets...)
;;   abort protcol

(use gtk)
(use gauche.net)

;; Following three lines are a kludge to disable IPv6 feature.
(select-module gauche.net)
(set! ipv6-capable #f)			; I don't have IPv6 protocol stack
(select-module user)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define hanoi-about-message
  "Copyright (C) 2004  NIIBE Yutaka  <gniibe@fsij.org>")

(define MAXDISK 64)

(define top-disk 0)
(define disk-moving -1)
(define disks (make-vector MAXDISK))
(define current-number-of-disks 0)

(define number-of-disks MAXDISK)
(define host-and-port-1 "localhost")
(define host-and-port-2 "localhost")

(define hanoi-port 32767)
(define hanoi-interval 10)		; msec

(define (init-hanoi-full-of-disk)
  (let loop ((i 0))
    (vector-set! disks i (+ i 1))
    (if (< i (- number-of-disks 1))
	(loop (+ i 1))))
  (vector-set! disks (- number-of-disks 1) MAXDISK)
  (set! top-disk 0)
  (set! current-number-of-disks number-of-disks))

;; Controls
(define stop #f)
(define abort #f)
(define go-next-step (lambda () #f))

(define step 0)

;;; Graphics
(define disk-border-color (gdk-color-parse "red"))
(define disk-color (gdk-color-parse "blue"))
(define base-color (gdk-color-parse "green"))
(define pole-color (gdk-color-parse "black"))

(define mag 1)
(define x-margin 10)
(define y-margin 10)
(define disk-height 5)
(define disk-width-unit 2)
(define pole-width 2)
(define x-size (+ (* (+ 2 (* 2 disk-width-unit (+ MAXDISK 2)) pole-width) mag)
		  (* x-margin 2)))
(define y-size (+ (* (+ MAXDISK 3 1) disk-height mag) (* y-margin 2)))

(define drawable #f)
(define gc #f)
(define bg #f)

(define set-step! (lambda (n) #f))

(define (disk-width d)
  (+ (* 2 (+ d 1) disk-width-unit) pole-width))

(define (draw-disk x y d)
  (let ((dw (disk-width d)))
    (gdk-gc-set-foreground gc disk-color)
    (gdk-draw-rectangle drawable gc #t (+ x mag) (+ y mag)
			(* dw mag) (* (- disk-height 1) mag))
    (gdk-gc-set-foreground gc disk-border-color)
    (gdk-draw-rectangle drawable gc #t x y mag (* disk-height mag))
    (gdk-draw-rectangle drawable gc #t x y (* (+ dw 2) mag) mag)
    (gdk-draw-rectangle drawable gc #t (+ x (* (+ dw 1) mag)) y
			mag (* disk-height mag))
    #t))				; Return #t to continue animation

(define (draw-pole-clearing-disk x y d)
  (let ((pole-x (+ x-margin (* (+ (* disk-width-unit (+ MAXDISK 2)) 1) mag))))
    (gdk-gc-set-foreground gc bg)
    (gdk-draw-rectangle drawable gc #t x y
			(* (+ (disk-width d) 2) mag) (* disk-height mag))
    (gdk-gc-set-foreground gc pole-color)
    (gdk-draw-rectangle drawable gc #t pole-x y
			(* pole-width mag) (* disk-height mag))))

(define (clear-disk x y d)
  (gdk-gc-set-foreground gc bg)
  (gdk-draw-rectangle drawable gc #t x y
		      (* (+ (disk-width d) 2) mag) (* disk-height mag)))

(define (clear-disk-partially move-from? mode d x y)
  (let ((x0 (+ x (if (or (and mode (not move-from?))
			 (and (not mode) move-from?))
		     (* (- (+ (disk-width d) 2) disk-width-unit) mag)
		     0))))
    (gdk-gc-set-foreground gc bg)
    (gdk-draw-rectangle drawable gc #t x0 y
			(* disk-width-unit mag) (* disk-height mag))))

(define (draw-one-move d current move-from? mode cont)
  (let ((n (- (+ MAXDISK 1) current))
	(m (+ (* MAXDISK 2) 2))
	(x 0)
	(y 0)
	(proc #f))
    (define (draw-vertical-disk-move-on-top-of-pole)
      (if (= m 0)
	  (begin
	    (set! proc draw-vertical-disk-move)
	    (dec! n))
	  (begin
	    (dec! m)
	    (clear-disk x y d)
	    (inc! y (* disk-height mag))
	    (draw-disk x y d))))
    (define (draw-horizontal-disk-move)
      (if (= m 0)
	  (if move-from?
	      (begin
		(set! proc draw-vertical-disk-move-on-top-of-pole)
		(set! m 2))
	      (begin (cont) #f))
	  (begin
	    (clear-disk-partially move-from? mode d x y-margin)
	    (dec! m)
	    (if move-from?
		(if mode
		    (inc! x (* disk-width-unit mag))
		    (dec! x (* disk-width-unit mag)))
		(if mode
		    (dec! x (* disk-width-unit mag))
		    (inc! x (* disk-width-unit mag))))
	    (draw-disk x y-margin d))))
    (define (draw-vertical-disk-move)
      (if (= n 0)
	  (if move-from?
	      (begin (cont) #f)	; Return #f to stop animation
	      (begin
		(clear-disk x y d)
		(dec! y (* disk-height mag))
		(draw-disk x y d)
		(set! proc draw-horizontal-disk-move)))
	  (begin
	    (draw-pole-clearing-disk x y d)
	    (dec! n)
	    (if move-from?
		(inc! y (* disk-height mag))
		(dec! y (* disk-height mag)))
	    (draw-disk x y d))))
    (if move-from?
	(let ((x0 (+ x-margin (* disk-width-unit (- (+ MAXDISK 1) d) mag))))
	  (if mode
	      (set! x (- x0 (* m disk-width-unit mag)))
	      (set! x (+ x0 (* m disk-width-unit mag))))
	  (set! y y-margin)
	  (set! proc draw-horizontal-disk-move))
	(begin
	  (set! x (+ x-margin (* disk-width-unit (- (+ MAXDISK 1) d) mag)))
	  (set! y (- y-size y-margin (* disk-height (+ current 2) mag)))
	  (set! proc draw-vertical-disk-move)))
    (set-step! (inc! step))
    (gtk-timeout-add hanoi-interval (lambda () (proc)))))

(define (draw)
  (define (scan-disks)
    (let loop ((r '())
	       (d top-disk)
	       (i -1))
      (if (< d MAXDISK)
	  (loop (cons d r) (vector-ref disks d) (+ i 1))
	  (values (- MAXDISK i) r))))
  (define (draw-disks-and-pole pole d-list)
    (let loop ((l d-list)
	       (y (- y-size y-margin (* 2 disk-height mag))))
      (if (null? l)
	  (let ((base-width (+ (* disk-width-unit (+ MAXDISK 2)) 1)))
	    (gdk-gc-set-foreground gc pole-color)
	    (gdk-draw-rectangle drawable gc #t
				(+ x-margin (* base-width mag))
				(+ y-margin (* 2 disk-height mag))
				(* pole-width mag) (* disk-height pole mag)))
	  (let* ((d (car l))
		 (x (+ x-margin (* disk-width-unit (- (+ MAXDISK 1) d) mag))))
	    (draw-disk x y d)
	    (loop (cdr l) (- y (* disk-height mag)))))))
  (receive (width height) (gdk-drawable-get-size drawable)
    ;; clear
    (gdk-gc-set-foreground gc bg)
    (gdk-draw-rectangle drawable gc #t 0 0 width height)
    ;; draw base
    (gdk-gc-set-foreground gc base-color)
    (gdk-draw-rectangle drawable gc #t
			x-margin (- y-size y-margin (* disk-height mag))
			(- width (* 2 x-margin)) (* disk-height mag))
    (receive (pole d-list) (scan-disks)
      (draw-disks-and-pole pole d-list))
    #t))

;;
;; [     Towers of Hanoi     ] <---- Title by Window Manager
;; +-------------------------+
;; | _______       [ Quit  ] | <---- Quit/Abort button
;; | |     |^                | <---- Spinbox for number-of-disks
;; | |   N |v      [ Start ] | <---- Start/Stop/Resume/Reset button
;; | ~~~~~~~       [ About ] | <---- About button
;; | [ Steps ]               | <---- Label showing steps
;; |-------------------------|
;; |            |            | <---- Towers of Hanoi Display
;; |            |            |
;; |       -----------       |
;; |    -----------------    |
;; |  =====================  |
;; |-------------------------|
;; |[left:6809]  [right:6502]| <---- Buttons showing hosts and ports
;; +-------------------------+
;;

(define h&p-1-button #f)
(define h&p-2-button #f)

(define (set-host-and-port w b set)
  (let* ((dialog
	  (gtk-dialog-new-with-buttons "Setting: host and port"
				       w
				       GTK_DIALOG_DESTROY_WITH_PARENT
				       GTK_STOCK_OK
				       GTK_RESPONSE_ACCEPT))
	 (vbox (ref dialog 'vbox))
	 (entry (gtk-entry-new)))
    (define (done . args)
      (let ((v (gtk-entry-get-text entry)))
	(set v)
	(gtk-button-set-label b v)
	(gtk-widget-destroy dialog)))
    (gtk-entry-set-text entry (slot-ref b 'label-text))
    (gtk-box-pack-start vbox entry #t #t 10)
    (g-signal-connect entry "activate" done)
    (g-signal-connect dialog "response" done)
    (gtk-widget-show-all dialog)))

(define spinner #f)

(define (change-n adj)
  (set! number-of-disks (inexact->exact (gtk-adjustment-get-value adj)))
  (init-hanoi-full-of-disk)
  (draw))

(define qa-button #f)
(define qa-status 'quit)

(define (quit-abort _)
  (case qa-status
    ((quit)
     (gtk-main-quit))
    ((abort)
     (set! abort #t)
     (let ((s stop))
       (set! stop #f)
       (if s
	   (go-next-step))))))

(define ssr-button #f)
(define ssr-status 'start)

(define (start-stop-resume-reset)
  (gtk-button-set-label qa-button "Quit")
  (set! qa-status 'quit)
  (gtk-button-set-label ssr-button "Reset")
  (set! ssr-status 'reset))

(define (start-stop-resume _)
  (case ssr-status
    ((start)
     (set! ssr-status 'stop)
     (set! qa-status 'abort)
     (gtk-button-set-label ssr-button "Stop")
     (gtk-button-set-label qa-button "Abort")
     (gtk-widget-set-sensitive h&p-1-button #f)
     (gtk-widget-set-sensitive h&p-2-button #f)
     (gtk-widget-set-sensitive spinner #f)
     (hanoi-client number-of-disks host-and-port-1 host-and-port-2))
    ((stop)
     (set! ssr-status 'resume)
     (gtk-button-set-label ssr-button "Resume")
     (set! stop #t))
    ((resume)
     (set! ssr-status 'stop)
     (gtk-button-set-label ssr-button "Stop")
     (set! stop #f)
     (go-next-step))
    ((reset)
     (set! ssr-status 'start)
     (set! step 0)
     (set-step! 0)
     (set! abort #f)
     (gtk-widget-set-sensitive h&p-1-button #t)
     (gtk-widget-set-sensitive h&p-2-button #t)
     (gtk-widget-set-sensitive spinner #t)
     (gtk-button-set-label ssr-button "Start")
     (init-hanoi-full-of-disk)
     (draw))))

(define (hanoi-gtk-init disable-control)
  (let1 w (gtk-window-new GTK_WINDOW_TOPLEVEL)
    (g-signal-connect w "destroy" (lambda _ (gtk-main-quit) #f))
    (gtk-window-set-title w "Towers of Hanoi")
    (let1 vbox (gtk-vbox-new #f 5)	; homogeneous spacing
      (gtk-container-set-border-width vbox 5)
      (gtk-container-add w vbox)
      (let1 hbox (gtk-hbox-new #f 2)
	(gtk-box-pack-start vbox hbox #f #t 2) ; expand fill padding
	(let1 vbox1 (gtk-vbox-new #f 5)
	  (gtk-box-pack-start hbox vbox1 #f #t 5)
	  (let1 hbox1 (gtk-hbox-new #f 0)
	    (gtk-box-pack-start vbox1 hbox1 #f #t 5)
	    (let1 label (gtk-label-new "Number of disks:")
	      (gtk-misc-set-alignment label 0 0.5) ; x-align y-align
	      (gtk-box-pack-start hbox1 label #f #t 0))
	    (let* ((adj (gtk-adjustment-new number-of-disks 1 64 1 1 0))
		   ;; initial lower upper step-incr page-incr page-size
		   (s (gtk-spin-button-new adj 0.0 0)))
	                                   ;; climb_rate digits
	      (if disable-control
		  (gtk-widget-set-sensitive s #f))
	      (set! spinner s)
	      (gtk-spin-button-set-wrap s #f)
	      (g-signal-connect adj "value_changed" change-n)
	      (gtk-box-pack-start hbox1 s #f #t 0)))
	  (let1 hbox2 (gtk-hbox-new #f 0)
	    (gtk-box-pack-start vbox1 hbox2 #f #t 5)
	    (let1 label (gtk-label-new "Steps:")
	      (gtk-box-pack-start hbox2 label #f #t 0))
	    (let1 value (gtk-label-new "0")
	      (set! set-step!
		    (lambda (n)
		      (gtk-label-set-text value (number->string n))))
	      (gtk-box-pack-end hbox2 value #f #t 0))))
	(let1 vbox2 (gtk-vbox-new #f 2)
	  (gtk-box-pack-start hbox vbox2 #t #t 5)
	  (let1 button (gtk-button-new-with-label "Quit")
	    (set! qa-button button)
	    (g-signal-connect button "clicked" quit-abort)
	    (gtk-box-pack-start vbox2 button #t #t 5))
	  (let1 button (gtk-button-new-with-label "Start")
	    (gtk-box-pack-start vbox2 button #t #t 5)
	    (set! ssr-button button)
	    (g-signal-connect button "clicked" start-stop-resume))
	  (let1 button (gtk-button-new-with-label "About")
	    (g-signal-connect button "clicked" (lambda _ (hanoi-about w)))
	    (gtk-box-pack-start vbox2 button #t #t 5))))
      (let ((area (gtk-drawing-area-new))
	    (size-hints (make <gdk-geometry>
			  :min-width x-size :max-width x-size
			  :min-height y-size :max-height y-size)))
	(define (realize w)
	  (let ((colormap (gdk-colormap-get-system)))
	    (set! drawable (ref area 'window))
	    (set! gc (gdk-gc-new drawable))
	    (set! bg (ref (ref (ref area 'style) 'bg) 0))
	    (gdk-colormap-alloc-color colormap disk-border-color #f #t)
	    (gdk-colormap-alloc-color colormap disk-color #f #t)
	    (gdk-colormap-alloc-color colormap base-color #f #t)
	    (gdk-colormap-alloc-color colormap pole-color #f #t)))
	(gtk-box-pack-start vbox area #f #t 5)
	(g-signal-connect area "realize" realize)
	(g-signal-connect area "expose_event" (lambda (w event) (draw)))
	(gtk-widget-set-size-request area x-size y-size)
	(gtk-window-set-geometry-hints w area size-hints
				       (logior GDK_HINT_MIN_SIZE
					       GDK_HINT_MAX_SIZE)))
      (let1 hbox (gtk-hbox-new #f 0)
	(gtk-box-pack-start vbox hbox #f #t 5)
	(let1 button (gtk-button-new-with-label host-and-port-1)
	  (g-signal-connect button "clicked"
			    (lambda _ (set-host-and-port w button
					 (lambda (v)
					   (set! host-and-port-1 v)))))
	  (if disable-control
	      (gtk-widget-set-sensitive button #f))
	  (set! h&p-1-button button)
	  (gtk-box-pack-start hbox button #f #t 5))
	(let1 button (gtk-button-new-with-label host-and-port-2)
	  (g-signal-connect button "clicked"
			    (lambda _ (set-host-and-port w button
					 (lambda (v)
					   (set! host-and-port-2 v)))))
	  (if disable-control
	      (gtk-widget-set-sensitive button #f))
	  (set! h&p-2-button button)
	  (gtk-box-pack-end hbox button #f #t 5))))
    (gtk-widget-show-all w)))

(define hanoi-about-dialog #f)

(define (hanoi-about w)
  (if (not hanoi-about-dialog)
      (let* ((dialog
	      (gtk-dialog-new-with-buttons "About Towers of Hanoi (GTK+)"
					   w
					   GTK_DIALOG_DESTROY_WITH_PARENT
					   GTK_STOCK_OK
					   GTK_RESPONSE_ACCEPT))
	     (vbox (ref dialog 'vbox))
	     (label (gtk-label-new hanoi-about-message)))
	(gtk-box-pack-start vbox label #t #t 10)
	(g-signal-connect dialog "response"
			  (lambda _ (gtk-widget-hide-all dialog)))
	(set! hanoi-about-dialog dialog)))
  (gtk-widget-show-all hanoi-about-dialog))

(define (finalize-hanoi)
  (start-stop-resume-reset))

(define (make-do-hanoi input output move)
  (define (do-hanoi mode)
    (define (exchange d handler) (output mode 'disk d) (input mode handler))
    (define (sync-receive cont)
      (input mode (lambda (cmd . args) (if (eq? cmd 'sync) (cont) (exit 1)))))
    (define (one-step cmd . args)
      (case cmd
	((disk)
	 (let ((disk (car args)))
	   (if (<= top-disk disk)
	       (if (= top-disk disk)
		   (begin
		     (if (not mode) (output #t 'fin))
		     (finalize-hanoi))
		   (let ((t top-disk))
		     (dec! current-number-of-disks)
		     (set! top-disk (vector-ref disks top-disk))
		     (set! disk-moving t)
		     (move t current-number-of-disks #f mode
			   (lambda ()
			     (output mode 'sync)
			     (sync-receive
			      (lambda () (do-hanoi (not mode))))))))
	       (sync-receive
		(lambda ()
		  (set! disk-moving disk)
		  (move disk current-number-of-disks #t mode
			(lambda ()
			  (vector-set! disks disk top-disk)
			  (set! top-disk disk)
			  (inc! current-number-of-disks)
			  (output mode 'sync)
			  (do-hanoi (not mode)))))))))
	((fin)
	 (finalize-hanoi))
	((abort)
	 (if (= (car args) 1)
	     (output (not mode) 'abort 0))
	 (finalize-hanoi))
	(else
	 (exit 1))))
    (if stop
	(set! go-next-step (lambda () (do-hanoi mode)))
	(if abort
	    (begin
	      (if mode
		  (output #t 'abort 1)
		  (begin
		    (output #f 'abort 0)
		    (output #t 'abort 0)))
	      (finalize-hanoi))
	    (exchange top-disk one-step))))
  do-hanoi)

(define (hanoi-connect p)
  (let ((host-and-port (string-split p #\:)))
    (make-client-socket 'inet (car host-and-port)
			(if (null? (cdr host-and-port))
			    hanoi-port
			    (string->number (cadr host-and-port))))))

(define (hanoi-listen-accept p output oddp)
  (let* ((listen-sock (make-server-socket 'inet 0)) ; Kernel assign the port
	 (port (sockaddr-port (socket-address listen-sock))))
    (format output "ONE ~a ~a ~a\n" p (if oddp 1 0) port)
    (let ((sock (socket-accept listen-sock)))
      (socket-close listen-sock)
      sock)))

(define (hanoi-mode tower even?)
  (case tower ((0) #f) ((1) (not even?)) ((2) even?)))

(define (make-hanoi-output output-left output-right)
  (lambda (mode cmd . args)
    (let ((output-port (if mode output-left output-right)))
      (case cmd
	((abort)
	 (format output-port "ABORT ~a\n" (car args)))
	((fin)
	 (format output-port "FIN\n"))
	((sync)
	 (format output-port "SYNC\n"))
	((disk)
	 (format output-port "DISK ~a\n" (car args)))))))

(define (make-hanoi-input input-left input-right)
  (lambda (mode handler)
    (define (handle-input port)
      (let* ((line (read-line port))
	     (tokens (string-split line #[ ])))
	(cond ((string=? (car tokens) "FIN")	(handler 'fin))
	      ((string=? (car tokens) "SYNC")	(handler 'sync))
	      ((string=? (car tokens) "ABORT")
	       (if (string=? (cadr tokens) "1")
		   (handler 'abort 1)
		   (handler 'abort 0)))
	      ((string=? (car tokens) "DISK")
	       (handler 'disk (string->number (cadr tokens)))))))
    (let ((id #f))
      (set! id (gtk-input-add (if mode input-left input-right) GDK_INPUT_READ
			      (lambda (port flag)
				(gtk-input-remove id)
				(handle-input port)))))))

(define (hanoi-client-sub oddp p1 p2)
  (receive (input output)
    (let* ((sock-right (hanoi-connect p1))
	   (input-right (socket-input-port sock-right))
	   (output-right (socket-output-port sock-right))
	   (sock-left (hanoi-listen-accept p2 output-right oddp))
	   (input-left (socket-input-port sock-left))
	   (output-left (socket-output-port sock-left)))
      (format #t "~a\n" (read-line input-left))		; receive ACK
      (values (make-hanoi-input input-left input-right)
	      (make-hanoi-output output-left output-right)))
    (let ((do-hanoi (make-do-hanoi input output draw-one-move)))
      (do-hanoi (hanoi-mode 0 oddp)))))

(define (hanoi-client number-of-disks p1 p2)
  (let ((oddp (odd? number-of-disks)))
    (if oddp
	(hanoi-client-sub oddp p1 p2)
	(hanoi-client-sub oddp p2 p1))))

(define (hanoi-server-establish-connection sock-left)
  (let* ((input-left (socket-input-port sock-left))
	 (output-left (socket-output-port sock-left))
	 (cmd (read-line input-left))
	 (tokens (string-split cmd #[ ])))
    (format (standard-output-port) "~a\n" cmd) ; Debug
    (set! top-disk MAXDISK)
    (set! current-number-of-disks 0)
    (set! ssr-status 'stop)
    (set! qa-status 'abort)
    (hanoi-gtk-init #t)
    (gtk-button-set-label ssr-button "Stop")
    (gtk-button-set-label qa-button "Abort")
    (let* ((h&p (cadr tokens))
	   (odd (string->number (caddr tokens)))
	   (sock-right (hanoi-connect h&p))
	   (input-right (socket-input-port sock-right))
	   (output-right (socket-output-port sock-right))
	   (tower 0))
      ;; Commands:
      ;;   ONE NEXT-HOSTNAME-AND-PORT ODD INITIATOR-PORT
      ;;   TWO INITIATOR-IP:INITIATOR-PORT ODD
      (cond ((string=? (car tokens) "ONE")
	     (let ((initiator-port (cadddr tokens))
		   (ip0 (car (string-split
			      (sockaddr-name (socket-address sock-left))
			      #\:))))
	       (set! tower (if (= odd 1) 1 2))
	       (format output-right "TWO ~a:~a ~a\n" ip0 initiator-port odd)))
	    ((string=? (car tokens) "TWO")
	     (let ((host1-and-port (sockaddr-name (socket-address sock-left))))
	       (set! tower (if (= odd 1) 2 1))
	       (format output-right "ACK ~a ~a\n" host1-and-port h&p)
	       (format #t "send ACK ~a\n" h&p)))
	    (else
	     (display "???\n")
	     (sys-exit 1)))
      (values (make-hanoi-input input-left input-right)
	      (make-hanoi-output output-left output-right) odd tower))))

(define (make-hanoi-server do-hanoi mode)
  (define (go)
    (gtk-idle-remove-by-data go)
    (do-hanoi mode))
  go)

(define (hanoi-server port)
  (let ((server (make-server-socket 'inet port :reuse-addr? #t)))
    (set-signal-handler! SIGCHLD #f)
    (let loop ((sock (socket-accept server)))
      (let ((pid (sys-fork)))
	(case pid
	  ((0)				; child process
	   (socket-close server)
	   (gtk-init '())
	   (gtk-idle-add
	    (receive (input output odd tower)
		     (hanoi-server-establish-connection sock)
	      (let ((mode (hanoi-mode tower (= odd 0)))
		    (do-hanoi (make-do-hanoi input output draw-one-move)))
		(make-hanoi-server do-hanoi mode))))
	   (gtk-main)
	   (exit 0))
	  ((-1)				; error
	   (display "fork failed\n"))
	  (else				; parent
	   #t))
	(socket-close sock)
	(loop (socket-accept server))))))

(define (main args)
  (let ((len (length args))
	(option #f))
    (if (and (> len 1) (eq? (string-ref (cadr args) 0) #\-))
	(set! option (string-ref (cadr args) 1)))
    (if (and (not option) (<= len 2))
	(set! option #\i))
    (case option
      ((#\s)				; server only mode
       (if (null? (cddr args))
	   (hanoi-server hanoi-port)
	   (hanoi-server (string->number (caddr args))))
       (exit 0))
      ((#\c)				; client only mode
       (gtk-init args)
       (set! number-of-disks (string->number (caddr args)))
       (set! host-and-port-1 (cadddr args))
       (set! host-and-port-2 (cadddr (cdr args)))
       (init-hanoi-full-of-disk)
       (hanoi-gtk-init #f)
       (gtk-main)
       (exit 0))
      ((#\i)
       (let ((pid (sys-fork)))
	 (case pid
	   ((0)
	    (if (= len 2)
		(hanoi-server (string->number (cadr args)))
		(hanoi-server hanoi-port)))
	   ((-1)
	    (display "fork failed\n")
	    (exit 1))
	   (else
	    (gtk-init args)
	    (init-hanoi-full-of-disk)
	    (hanoi-gtk-init #f)
	    (gtk-main)
	    (sys-kill pid SIGTERM)
	    (exit 0)))))
      (else
       (format (standard-output-port)
	       (string-append
		"Usage:\n"
		"  Server:	~a -s [port#]\n"
		"  Client:	~a -c n host1:port1 host2:port2\n"
		"  Both:	~a [port#]\n")
	       (car args) (car args) (car args))
       (exit 1))))
  0)