;;
;; Pente with pretty little pictures.
;;

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

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



;; 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 size   (string->number (getenv "SIZE")))
(define secs   (string->number (getenv "TIME")))
(define quiet  (string=? (getenv "QUIET") "quiet"))
(define type1  (if (string=? (getenv "TYPEONE") "scheme") 'scheme 'other))
(define type2  (if (string=? (getenv "TYPETWO") "scheme") 'scheme 'other))
(define file1  (check-file (getenv "PLAYONE") type1 1))
(define file2  (check-file (getenv "PLAYTWO") 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))


;;
;; Pente canvas.
;; Some hacks onto Robby's design: put the stones in the middle
;; of the squares, and some fiddling with sizes.
;;

(define MIN-STONE-SIZE 30)
(define BORDER-THICKNESS 2)

; some brushes and pens
(define RED-BRUSH (send wx:the-brush-list find-or-create-brush "RED" wx:const-solid))
(define YELLOW-BRUSH (send wx:the-brush-list find-or-create-brush "YELLOW" wx:const-solid))
(define RED-PEN (send wx:the-pen-list find-or-create-pen "RED" 1 wx:const-solid))
(define YELLOW-PEN (send wx:the-pen-list find-or-create-pen "YELLOW" 1 wx:const-solid))
(define BLACK-PEN (send wx:the-pen-list find-or-create-pen "BLACK" 1 wx:const-solid))
(define BLACK-BRUSH (send wx:the-brush-list find-or-create-brush "BLACK" wx:const-solid))

; the pente canvas
(define pente-canvas%
  (class mred:canvas% (arg-board . args)
    (inherit user-min-width user-min-height
	     get-client-size get-dc begin-drawing end-drawing)
    (public
      [board arg-board]
      [set-board
       (lambda (new-board)
	 (set! board new-board)
	 (user-min-width (* (board-size board) MIN-STONE-SIZE))
	 (user-min-height (* (board-size board) MIN-STONE-SIZE))
	 (on-paint))]
      [draw-grid
       (lambda ()
	 (begin-drawing)
	 (let*
	     ((w  (box 0))
	      (h  (box 0))
	      (_  (get-client-size w h))
	      (width  (inexact->exact (unbox w)))
	      (height (inexact->exact (unbox h)))
	      (size   (board-size board))
	      (h-spacing  (/ width size))
	      (v-spacing  (/ height size))
	      (dc  (get-dc))
	      (old-pen  (send dc get-pen)))
	   (send dc set-pen BLACK-PEN)
	   (let loop ((k 1))
	     (when (< k size)
	       (let ((x  (* k h-spacing))
		     (y  (* k v-spacing)))
		 (send* dc
		   (draw-line x 0 x height)
		   (draw-line 0 y width y))
		 (loop (+ k 1)))))
	   (send dc set-pen old-pen))
	 (end-drawing))]
      [draw-square
       (lambda (i j)
	 ; begin/end-drawing calls necessary since
	 ; draw-square is not always called from on-paint
	 (begin-drawing)
	 (let*
	     ((w  (box 0))
	      (h  (box 0))
	      (_  (get-client-size w h))
	      (width  (inexact->exact (unbox w)))
	      (height (inexact->exact (unbox h)))
	      [size (board-size board)]
	      [h-spacing (/ width size)]
	      [v-spacing (/ height size)]
	      [x-border (/ h-spacing 2)]
	      [y-border (/ v-spacing 2)]
	      [num  (get-square board i j)]
	      [left (* i h-spacing)]
	      [top (* j v-spacing)]
	      [dc (get-dc)]
	      [old-pen (send dc get-pen)]
	      [old-brush (send dc get-brush)])
	   (unless (= num 0)
	     (let*
		 ((brush  (if (= num 1) YELLOW-BRUSH RED-BRUSH))
		  (pen    (if (= num 1) YELLOW-PEN RED-PEN))
		  [nl (+ left BORDER-THICKNESS)]
		  [nt (+ top BORDER-THICKNESS)]
		  [nw (- h-spacing (* 2 BORDER-THICKNESS))]
		  [nh (- v-spacing (* 2 BORDER-THICKNESS))])
	       (send* dc 
		 (set-brush BLACK-BRUSH)
		 (set-pen BLACK-PEN)
		 (draw-ellipse (+ 2 left) (+ 2 top) (- h-spacing 2) (- v-spacing 2))
		 ;; (draw-ellipse left top h-spacing v-spacing)
		 (set-pen pen)
		 (set-brush brush)
		 (draw-ellipse (+ 2 nl) (+ 2 nt) (- nw 2) (- nh 2)))))
	   ;; (draw-ellipse nl nt nw nh))))
	   (send dc set-pen old-pen)
	   (send dc set-brush old-brush))
	 (end-drawing))] 
      [on-paint
       (lambda ()
	 ; these begin/end drawing calls just optimize a little
	 (begin-drawing)
	 (draw-grid)	   
	 (let x-loop ([i (board-size board)])
	   (unless (= i 0)
	     (let y-loop ([j (board-size board)])
	       (unless (= j 0)
		 (draw-square (sub1 i) (sub1 j))
		 (y-loop (sub1 j))))
	     (x-loop (sub1 i))))
	 (end-drawing))])
    (sequence 
      (apply super-init args)
      (set-board arg-board))))

(define last
  (lambda (str)
    (let-values (((base name dir) (split-path str)))
      name)))

(define request-quit #f)

(define board  (make-empty-board size))

(define frame  (make-object mred:frame% null "Connect 5"))
(define panel  (make-object mred:vertical-panel% frame))
(define canvas (make-object pente-canvas% board panel))
(define play1  (make-object mred:message% panel
                            (format "Player 1 (Yellow): ~a" (last file1))))
(define play2  (make-object mred:message% panel
                            (format "Player 2 (Red): ~a" (last file2))))
(define bottom-panel (make-object mred:horizontal-panel% panel))
(define message-panel (make-object mred:horizontal-panel% bottom-panel))

(send bottom-panel stretchable-in-y #f)

(define already-started #f)

(define start-game
  (lambda ()
    (gui-play-game size secs 
      (make-player 1 file1 type1)
      (make-player 2 file2 type2))))

(define start
  (make-object mred:button%
    message-panel
    (lambda (self event)
      (when (not already-started)
        (set! already-started #t)
        (thread start-game)))
    "Start"))

(define quit   
  (make-object 
    mred:button% 
    message-panel
    (lambda (self event) 
      (set! request-quit #t)
      (send frame show #f)
      (exit))
    "Quit"))


(define show-mesg
  (lambda (str)
    (make-object mred:message% message-panel str)))


(define gui-play-game
  (lambda (size secs player1 player2)
    (let ((msec  (* 1000 secs)))
      (let loop
        ((player1  player1)
         (player2  player2))
        (let ((move  (get-player-move board player1 msec))
              (num   (player-num player1)))
          (if (string? move)
              ;; original: (show-mesg (format "Player ~s: ~a" num move))
              (show-mesg (format "Player ~s error: ~a" num move))
              (let ((mesg  (check-and-make-move board move)))
                (if (string? mesg)
                    (show-mesg (format "Player ~s: ~a" num mesg))
                    (begin
                      (send canvas draw-square (move-x move) (move-y move))
                      (let ((why  (why-game-over board move)))
                        (if (string? why)
                            (show-mesg why)
                            (loop player2 player1))))))))))))


(define mred:startup
  (lambda ()
    (send frame show #t)
    frame))