;;
;; Text-based pente game.
;;

(define-struct board (size row free))
(define-struct player (num file type))
(define-struct move (num x y time))

;;
;; 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)))

(define print-board
  (lambda (board port num)
    (let ((n  (board-size board)))
      (fprintf port " ~s ~n" n)
      (let y-loop ((y  0))
	(when (< y n)
	  (let x-loop ((x  0))
	    (when (< x n)
	      (let ((val  (get-square board x y)))
		(fprintf port " ~s " 
			 (cond ((= val 0)  0)
			       ((= val num)  +1)
			       (else  -1)))
		(x-loop (+ x 1)))))
	  (newline port)
	  (y-loop (+ y 1)))))))

;;
;; Check moves and victory conditions.
;; returns: string describing why game over, or else #f.
;;

(define why-game-over
  (lambda (board move)
    (let/ec done
      (letrec*
	  ((n  (board-size board))
	   (n-1  (- n 1))
	   (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)))
		(if (>= sum 5)
		    (done (format "Player ~s wins" num))
		    #f))))
	   (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))
	    "Game is a draw"
	    #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 player->command
  (lambda (player)
    (let ((file  (player-file player))
	  (type  (player-type player))
	  (scheme-prefix  "exec mzscheme -l macro.ss -q -m -r ")
	  (exec-prefix    "exec "))
      (if (eq? type 'scheme)
	  (string-append scheme-prefix file)
	  (string-append exec-prefix file)))))

(define get-player-move
  (lambda (board player limit)
    (let
	((num   (player-num player))
	 (proc  (with-handlers
		    (((lambda (x) #t) (lambda (x) #f)))
		  (process (player->command player)))))
      (if proc
	  (read-with-timeout proc board num limit)
          "Unable to start program."))))

;; return string of program's output, up to max.
;; remember, l is reversed.

(define output-prefix
  (lambda (l)
    (let ((max  100))
      (list->string
       (reverse
	(let loop ((l  l) (n  (- (length l) max)))
	  (if (< n 0) l (loop (cdr l) (- n 1))))))))) 

;; Try to clean up crashed processes.
;; maybe kill pid and pid + 1, very dangerous.

(define kill-process
  (lambda (pid)
    (system (format "kill ~s" pid))
    (system (format "kill ~s" (+ pid 1)))))

;; In main loop, l = list of chars from stdout (reversed),
;; n = limit on chars from stdout,
;; k = limit on read's before check other conditions.
;; now = current time, but only rechecked after entire loop.
;; really need to rework this.

(define read-with-timeout
  (lambda (proc board num limit)
    (let*
	((stdout  (car proc))
	 (stdin   (cadr proc))
	 (pid     (caddr proc))
	 (stderr  (cadddr proc)))
      (print-board board stdin num)
      (close-output-port stdin)
      (begin0
	(let* ((start  (current-milliseconds))
	       (timeout  (+ start limit)))
	  (let loop ((l  null) (n  1000) (k  10)
		     (now  (current-milliseconds)))
	    (cond
	      ((and (char-ready? stderr)
		    (not (eof-object? (read-char stderr))))
	       "Program crashed.")
	      ((and (> k 0) (char-ready? stdout))
	       (let ((c  (read-char stdout)))
		 (if (eof-object? c)
		     (with-handlers
			 (((lambda (x) #t)
			   (lambda (x) 
			     (format "Program produced bad output: ~a"
				     (output-prefix l)))))
		       (let* ((p  (open-input-string
				   (list->string (reverse l))))
			      (x  (read p))
			      (y  (read p)))
			 (make-move num x y (- now start))))
		     (loop (cons c l) (- n 1) (- k 1) now))))
	      ((> now timeout)
	       (kill-process pid)
	       "Program exceeded time limit.")
	      ((<= n 0)
	       (kill-process pid)
	       "Program produced too much ouput.")
	      (else
	       (sleep 0.020)
	       (loop l n 10 (current-milliseconds))))))
	(close-input-port stdout)
	(close-input-port stderr)))))

;;
;; Simple text-level play game.
;; But now with full error checking/reporting.
;;

;; 
;; 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)))))

(define text-display-move
  (lambda (move)
    (let ((num  (move-num move))
	  (x    (move-x move))
	  (y    (move-y move))
	  (msec (move-time move)))
      (printf "Player ~s moves to (~s, ~s) in time ~s ~n"
	      num x y (/ msec 1000.0)))))

;; User time limits are in seconds, internally are milliseconds.

(define text-play-game
  (lambda (size secs quiet? player1 player2)
    (let ((board  (make-empty-board size))
	  (msec   (* 1000 secs)))
      (unless quiet? (printf "Starting game ...~n"))
      (let loop
        ((player1  player1)
         (player2  player2))
        (let ((move  (get-player-move board player1 msec))
	      (num   (player-num player1)))
	  (if (string? move)
	      ;; original: (printf "Player ~s: ~a~n" num move)
	      (printf "Player ~s error: ~a~n" num move)
	      (let ((mesg  (check-and-make-move board move)))
		(if (string? mesg)
		    (printf "Player ~s: ~a~n" num mesg)
		    (begin
		      (unless quiet? (text-display-move move))
		      (let ((why  (why-game-over board move)))
			(if (string? why)
			    (printf "~a~n" why)
			    (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 arg (lambda (n) (vector-ref argv n)))

(when (>= (vector-length argv) 7)
  (let*
      ((size   (string->number (arg 0)))
       (secs   (string->number (arg 1)))
       (quiet  (string=? (arg 2) "quiet"))
       (type1  (if (string=? (arg 5) "scheme") 'scheme 'other))
       (type2  (if (string=? (arg 6) "scheme") 'scheme 'other))
       (file1  (check-file (arg 3) type1 1))
       (file2  (check-file (arg 4) 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))
    (text-play-game 
     size secs quiet
     (make-player 1 file1 type1)
     (make-player 2 file2 type2))
    (exit)))