(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-port 32767)

(define MAXDISK 64)
(define top-disk MAXDISK)
(define disks (make-vector MAXDISK))

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

(define (base64 n)
  (format "~a"
    (string-ref
     "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ+/" n)))

(define (show-hanoi tower)
  (let loop ((i top-disk) (d '()))
    (if (< i MAXDISK)
	(loop (vector-ref disks i) (cons (base64 i) d))
	(format (standard-output-port)
		"Tower~a: ~a\n" tower (string-join d "")))))

(define (do-hanoi tower input-left output-left input-right output-right even?)
  (let loop ((mode (case tower ((0) #f) ((1) (not even?)) ((2) even?))))
    (define (exchange d)
      (format (if mode output-left output-right) "DISK ~a\n" d)
      (let* ((line (read-line (if mode input-left input-right)))
	     (tokens (string-split line #[ ])))
	(cond ((string=? (car tokens) "ABORT")
	       (let ((n (cadr tokens)))
		 (if (string=? n "1")
		     (format (if (not mode) output-left output-right)
			     "ABORT 0\n"))
		 -1))
	      ((string=? (car tokens) "FIN")	       -1)
	      ((string=? (car tokens) "DISK")
	       (string->number (cadr tokens))))))
    (define (sync-receive-0)
      (read-line (if mode input-left input-right))) ; SYNC
    (define (sync-receive-1)
      (format (if mode output-left output-right) "SYNC\n"))
    (define (sync-send)
      (format (if mode output-left output-right) "SYNC\n")
      (read-line (if mode input-left input-right))) ; SYNC
    (let ((disk (exchange top-disk)))
      (if (<= top-disk disk)
	(if (= top-disk disk)
	    (begin
	      (if (not mode)
		  (format output-left "FIN\n"))
	      (show-hanoi tower))
	    (let ((next-disk (vector-ref disks top-disk)))
	      (set! top-disk next-disk)
	      (show-hanoi tower)
	      (sync-send)
	      (loop (not mode))))
	(if (>= disk 0)
	    (begin
	      (sync-receive-0)
	      (vector-set! disks disk top-disk)
	      (set! top-disk disk)
	      (sync-receive-1)
	      (show-hanoi tower)
	      (loop (not mode)))
	    (show-hanoi tower))))))

(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 (do-hanoi-server sock)
  (call-with-client-socket sock
    (lambda (input output)
      (let* ((cmd (read-line input))
	     (tokens (string-split cmd #[ ])))
	(format (standard-output-port) "~a\n" cmd)
	;; Commands:
	;;   ONE NEXT-HOSTNAME-AND-PORT ODD ORIGINATOR-PORT
	;;   TWO ORIGINATOR-IP:ORIGINATOR-PORT ODD
	(cond ((string=? (car tokens) "ONE")
	       (let* ((p2 (cadr tokens))
		      (port (cadddr tokens))
		      (odd (string->number (caddr tokens)))
		      (sock-right (hanoi-connect p2))
		      (ipaddr0
		       (car (string-split
			     (sockaddr-name (socket-address sock)) #\:))))
		 (call-with-client-socket sock-right
		   (lambda (input-right output-right)
		     (format output-right "TWO ~a:~a ~a\n" ipaddr0 port odd)
		     (do-hanoi (if (= odd 1) 1 2)
			       input output input-right output-right (= odd 0))))))
	      ((string=? (car tokens) "TWO")
	       (let* ((p0 (cadr tokens))
		      (odd (string->number (caddr tokens)))
		      (sock-right (hanoi-connect p0))
		      (host1-and-port (sockaddr-name (socket-address sock))))
		 (call-with-client-socket sock-right
		   (lambda (input-right output-right)
		     (format output-right "ACK ~a ~a\n" host1-and-port p0)
		     (do-hanoi (if (= odd 1) 2 1)
			       input output input-right output-right (= odd 0))))))
	      (else
	       (display "???\n")))))))

(define (hanoi-server port background?)
  (let ((server (make-server-socket 'inet port :reuse-addr? #t)))
    (let loop ((sock (socket-accept server)))
      (if background?
	  (begin
	    (set-signal-handler! SIGCHLD #f)
	    (let ((pid (sys-fork)))
	      (case pid
		((0)				; child process
		 (socket-close server)
		 (do-hanoi-server sock)
		 (exit 0))
		((-1)				; error
		 (display "fork failed\n"))
		(else				; parent
		 #t))
	      (socket-close sock)
	      (loop (socket-accept server))))
	  (begin
	    (socket-close server)
	    (do-hanoi-server sock))))))

(define (hanoi-client number-of-hanoi p1 p2)
  (init-hanoi-full-of-disk)
  (let ((oddp (odd? number-of-hanoi)))
    (if (not oddp)
	(let ((p p1))
	  (set! p1 p2)
	  (set! p2 p)))
    (let* ((host-and-port-1 (string-split p1 #\:))
	   (listen-sock (make-server-socket 'inet 0)) ; Kernel assigns the port
	   (port (sockaddr-port (socket-address listen-sock)))
	   (sock-right (make-client-socket 'inet
					   (car host-and-port-1)
					   (if (null? (cdr host-and-port-1))
					       hanoi-port
					       (string->number
						(cadr host-and-port-1))))))
      (call-with-client-socket sock-right
        (lambda (input-right output-right)
	  (format output-right "ONE ~a ~a ~a\n" p2 (if oddp 1 0) port)
	  (let ((sock-left (socket-accept listen-sock)))
	    (socket-close listen-sock)
	    (call-with-client-socket sock-left
	      (lambda (input-left output-left)
		(format (standard-output-port) "~a\n" (read-line input-left))
		(vector-set! disks (- number-of-hanoi 1) MAXDISK)
		(set! top-disk 0)
		(show-hanoi 0)
		(do-hanoi 0 input-left output-left
			  input-right output-right oddp)))))))))

(define (main args)
  (let ((len (length args))
	(option #f))
    (if (>= len 1)
	(set! option (string-ref (cadr args) 1)))
    (case option
      ((#\s)
       (if (null? (cddr args))
	   (hanoi-server hanoi-port #t)
	   (if (char=? (string-ref (caddr args) 0) #\-)
	       (if (null? (cdddr args))
		   (hanoi-server hanoi-port #f)
		   (hanoi-server (string->number (cadddr args)) #f))
	       (hanoi-server (string->number (caddr args)) #t)))
       (exit 0))
      ((#\i)
       #f) 				; Fall through...
      ((#\c)
       (hanoi-client (string->number (caddr args))
		     (cadddr args) (cadddr (cdr args)))
       (exit 0))
      (else
       (format (standard-output-port)
	       (string-append
		"Usage:\n"
		"  Server:	~a -s [-1] [port#]\n"
		"  Client:	~a -c n host:port host:port\n"
		"  Interactive:	~a -i [port#]\n")
	       (car args) (car args) (car args))
       (exit 1))))
  ;; interactive mode
  (let* ((port
	  (if (null? (cddr args))
	      hanoi-port
	      (string->number (caddr args))))
	 (pid (sys-fork)))
    (case pid
      ((0)				; child process
       (hanoi-server port #t)
       (exit 0))
      ((-1)				; error
       (display "fork failed\n")
       (exit 1))
      (else				; parent
       (dynamic-wind
	   (lambda () #f)
	   (lambda ()
	     (let loop ()
	       (display "> ")
	       (flush (standard-output-port))
	       (let ((line (read-line)))
		 (if (not (eof-object? line))
		     (let ((words (string-split line #[ ])))
		       (if (not (equal? words '("")))
			   (let ((n (string->number (car words))))
			     (if (null? (cdr words))
				 (hanoi-client n "localhost" "localhost")
				 (hanoi-client n (cadr words) (caddr words)))))
		       (loop))))))
	   (lambda ()
	     (sys-kill pid SIGTERM))))))
  0)