(load-relative "sig.ss")
(unit/sig top^
  (import args^ struct^ ui^)
  (define do-debug #f)
  (define kill "/bin/kill")
  
  ;;
  ;; Representation of the board.
  ;;  0 = empty, 1/2 = Player 1/2.
  ;;
  ;;       0   n-1
  ;;     +--------> x
  ;;    0| 1 2 3
  ;;     | 4 5 6
  ;;  n-1| 7 8 9
  ;;     |
  ;;  y  V
  ;;
  
  ;;
  ;; The board primitives are based on (x, y, num) where
  ;; (x, y) = coordinates, num = player number.
  ;;
  
  (define make-empty-board
    (lambda (n)
      (let ((row  (make-vector n)))
	(let loop ((i 0))
	  (when (< i n)
	    (vector-set! row i (make-vector n 0))
	    (loop (+ i 1))))
	(make-board n row (* n n)))))
  
  (define set-square!
    (lambda (board x y val)
      (set-board-free! board (sub1 (board-free board)))
      (vector-set! 
       (vector-ref (board-row board) x)
       y
       val)))
  
  (define get-square
    (lambda (board x y)
      (vector-ref
       (vector-ref (board-row board) x)
       y)))
  

  ; bored is a vector-of-vector-of-{+1,0,-1}.
  ; Return a corresponding list-of-list-of-{'X,'-,'O}.
  ; Note that player-num indicates who is X or O;
  ; we translate so each player sees themselves as 'X.
  ;
  (define (board->list-of-lists bored player-num)
    (let* {[board-list (map vector->list (vector->list (board-row bored)))]
           [piece->char (lambda (p) (cond [(= p  0)         '-]
                                          [(= p player-num) 'X]
                                          [else             'O]))]
           [row->chars (lambda (r) (map piece->char r))]}
       (map row->chars board-list)))
           

;  (define (print-board board port num)
;    (begin 
;      (when do-debug (printf "Printing board ~s for player ~s.~n" (board->list-of-lists board num) num))
;      (fprintf port "~s~n" (board->list-of-lists board num))))
  

  (define (print-board board port num)
    (begin 
      (when do-debug (printf "Printing board ~s for player ~s.~n" (board->list-of-lists board num) num))
      (fprintf port "{")
      (map (lambda (row) (fprintf port "~s~n " row))  
           (board->list-of-lists board num))
      (fprintf port "}~n")))

  ;;
  ;; Check moves and victory conditions.
  ;; returns: the number of the player who won or #f if it's not over
  ;;
  
  (define why-game-over
    (lambda (board move)
      (let/ec done
	(letrec ;(letrec* JJB CHANGE
	    ((n  (board-size board))
	     (n-1  (sub1 n))
	     (num  (move-num move))
	     (inside?  (lambda (x y) (and (<= 0 x n-1) (<= 0 y n-1))))
	     (ray
	      (lambda (x0 y0 dx dy)
		(cond
		  ((not (inside? x0 y0))  0)
		  ((= (get-square board x0 y0) num)
		   (+ 1 (ray (+ x0 dx) (+ y0 dy) dx dy)))
		  (else  0))))
	     (line
	      (lambda (x0 y0 dx dy)
		(let* ((fwd   (ray (+ x0 dx) (+ y0 dy) dx dy))
		       (back  (ray x0 y0 (- dx) (- dy)))
		       (sum   (+ fwd back)))
		  (when (>= sum 5)
		      (done num)))))
	     (x0  (move-x move))
	     (y0  (move-y move)))
	  (line x0 y0 +1 0)
	  (line x0 y0 +1 +1)
	  (line x0 y0 0 +1)
	  (line x0 y0 +1 -1)
	  (if (= 0 (board-free board))
	      0
	      #f)))))
  
  
  ;;
  ;; Read from process until:
  ;;  1. eof or too much output from stdout,
  ;;  2. non-eof from stderr,
  ;;  3. timeout.
  ;;
  ;; returns: move struct, or string explaining the problem.
  ;;
  
  (define primitive-exception-handler (current-exception-handler))
  
  (define player->move
    (lambda (board player limit)
      (let* ([file  (player-file player)]
	     [type  (player-type player)]
	     [num (player-num player)]
	     [start (current-seconds)]
	     [go
	      (lambda (wait-player killer err-msg stdin stdout)
		(print-board board stdin num)
		(close-output-port stdin)
		(wait-player)
		(kill-thread killer)
		(or (err-msg)
		    (with-handlers ([void (lambda (_) "Invalid output.")])
		      (let* [(answer (read stdout))  ; (list col row)
                             (y (car  answer))
			     (x (cadr answer))]
			(close-input-port stdout)
			(make-move num x y (- (current-seconds) start))))))])
	(if (eq? type 'scheme)
	    (let*-values (((in-in in-out) (make-pipe))
			  ((out-in out-out) (make-pipe))
			  ((cust) (make-custodian))
			  ((oops) "Player timed out.")
			  ((player)
			   (parameterize ([current-custodian cust])
			     (thread (lambda ()
                                         (let/ec k
					     (current-exception-handler primitive-exception-handler)
					     (error-escape-handler (lambda () (k (void))))
					     (exit-handler void)
					     (current-input-port in-in)
					     (current-output-port out-out)
					     (current-namespace (make-namespace))
					     (eval '(require-library "core.ss"))  ; User's program gets "first", etc.
                                             (eval '(require-library "errortrace.ss" "errortrace")) ; On error, print stack.

					     (with-handlers ([(lambda (x) #f) ; #f means don't override errors.
							      (lambda (e) (fprintf 
									   [current-error-port]
									   " ~a failed:~n~s~n" file
									   [if [exn? e]
									       [exn-message e]
									       e]))])
					       (load file)))
				       (set! oops #f)))))
			  ((killer) (thread (lambda ()
					      (sleep limit)
					      (custodian-shutdown-all cust)))))
	      (go (lambda ()
		    (thread-wait player)
		    (close-output-port out-out))
		  killer
		  (lambda () oops)
		  in-out
		  out-in))
	    (let*-values ([(stdout stdin pid _ cntl) 
			   (with-handlers ([void
					    (lambda (e) (printf "Script error: (process* ~a) failed.~n~a" file e))])
			     (apply values (process* file)))]
			  [(killer) (thread (lambda ()
					      (sleep limit)
					      (system* kill "-9" (number->string pid))))])
	      (close-input-port _)
	      (go (lambda () (cntl 'wait))
		  killer
		  (lambda () (if (eq? (cntl 'status) 'done-ok)
				 #f
				 "Player timed out."))
		  stdin
		  stdout))))))
  
  (define get-player-move
    (lambda (board player limit)
      (or (with-handlers ([void (lambda (x) #f)])
	    (player->move board player limit))
	  "Unable to start program.")))
  
  ;; 
  ;; Update board with next move.
  ;; return: string describing the problem, 
  ;;   or else #f if everything ok.
  ;;
  
  (define check-and-make-move
    (lambda (board move)
      (let ((size  (board-size board))
	    (num   (move-num move))
	    (x  (move-x move))
	    (y  (move-y move)))
	(if (and (number? x)  (number? y)
		 (exact? x)   (exact? y)
		 (<= 0 x (- size 1))  (<= 0 y (- size 1)))
	    (if (= (get-square board x y) 0)
		(begin (set-square! board x y num) #f)
		(format "Move to occupied square: ~s ~s" x y))
	    (format "Returned illegal move: ~s ~s" x y)))))
  
  ;; User time limits are in seconds, internally are milliseconds.
  
  (define play-game
    (lambda (player1 player2)
      (let ((board  (make-empty-board size)))
	(unless quiet (printf "Starting game ...~n~a vs ~a~n"
                               (player-file player1)
                               (player-file player2)))
	(let loop
	  ((player1  player1)
	   (player2  player2))
	  (let ((move  (get-player-move board player1 secs))
		(num   (player-num player1)))
	    (if (string? move)
		(begin (show-mesg (format "Player ~s error: ~a~n" num move))
		       (- 3 num)) ; the other player wins.
		(let ((mesg  (check-and-make-move board move)))
		  (if (string? mesg)
		      ;(begin (show-mesg (format "Player ~s: ~a~n" num mesg)) ; changed by Sitaram
		      (begin (unless quiet (show-mesg (format "Player ~s: ~a~n" num mesg)))
                             (show-mesg (format "Player ~s wins~n" (player-num player2))) ; added by Sitaram
			     (- 3 num)) ; the other player wins.
		      (begin
			(unless quiet (display-move move))
			(let ([why-done (why-game-over board move)])
			  (if why-done
			      (begin0
				why-done
                                (unless quiet (print-board board (current-output-port) +1))
				(case why-done
			          ((0)   (show-mesg "Game is a draw~n"))
				  ((1 2) (show-mesg (format "Player ~s wins~n"
							    (player-num player1))))))
			      (loop player2 player1))))))))))))
  
  ;;
  ;; If called with full args, then check args and start game.
  ;; Else, let the user start the game himself.
  ;;
  
  ;; All files must exist, also
  ;; scheme must be readable, others executable.
  
  (define check-file
    (lambda (file type num)
      (let ((perms  (file-or-directory-permissions file)))
	(unless (file-exists? file)
	  (printf "Player ~s file does not exist: ~a~n" num file)
	  (exit))
	(if (eq? type 'scheme)
	    (unless (member 'read perms)
	      (printf "Player ~s file is not readable: ~a~n" num file)
	      (exit))
	    (unless (member 'execute perms)
	      (printf "Player ~s file is not executable: ~a~n" num file)
	      (exit)))
	file)))
  
  (define (file-type fname)
    (let ([lst (reverse (string->list fname))])
      (if (and (< 3 (length lst))
	       (eq? #\s (car lst))
	       (eq? #\s (cadr lst))
	       (eq? #\. (caddr lst)))
	  'scheme
	  'other)))

  (define (run file1 file2)
    (let* ((type1  (file-type file1))
	   (type2  (file-type file2)))
      (check-file file1 type1 1)
      (check-file file2 type2 2)
      (unless (and (number? size) (exact? size) 
		   (integer? size) (<= 5 size 20))
	(printf "Invalid board size, must be exact number 5..20.~n")
	(exit))
      (unless (and (number? secs) (> secs  0))
	(printf "Invalid time limit, must be positive number.~n")
	(exit))
      (play-game 
       (make-player 1 file1 type1)
       (make-player 2 file2 type2))))
  
  )