(require-library "errortrace.ss" "errortrace") ; On error, print stack.
;;
;; 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)))







  ; 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 
      (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: 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 -l functioc.ss -q -m -r ")
	  (scheme-prefix  "exec mzscheme -l core.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)))]
                              [answer (read p)]
			      [y  (car  answer)]
			      [x  (cadr answer)]}
			 (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.") ; More than the initial n char's worth.
	      (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)))
      (if (relative-path? file)
	  (normalize-path file)
	  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 the-brush-list find-or-create-brush "RED" 'solid))
(define YELLOW-BRUSH (send the-brush-list find-or-create-brush "YELLOW" 'solid))
(define RED-PEN (send the-pen-list find-or-create-pen "RED" 1 'solid))
(define YELLOW-PEN (send the-pen-list find-or-create-pen "YELLOW" 1 'solid))
(define BLACK-PEN (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
(define BLACK-BRUSH (send the-brush-list find-or-create-brush "BLACK" 'solid))

; the pente canvas
(define pente-canvas%
  (class canvas% (arg-board . args)
    (inherit min-client-width min-client-height
	     get-client-size get-dc)
    (override 
      [on-paint
       (lambda ()
	 (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))))
	 )]
      )
    (public
      [board arg-board]
      [set-board
       (lambda (new-board)
	 (set! board new-board)
	 (min-client-width (* (board-size board) MIN-STONE-SIZE))
	 (min-client-height (* (board-size board) MIN-STONE-SIZE))
	 )]
      [draw-grid
       (lambda ()
	 (let*
	     {
	      [dims   (let-values ([(w h) (get-client-size)]) (list w h))]
	      [width  (inexact->exact (car  dims))]
	      [height (inexact->exact (cadr dims))]
	      [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)
		 (send dc draw-line 0 y width y)
		 (loop (+ k 1)))))
	   (send dc set-pen old-pen))
	 )]
      [draw-square
       (lambda (i j)
	 (let*
	     (
	      [dims   (let-values ([(w h) (get-client-size)]) (list w h))]
	      [width  (inexact->exact (car  dims))]
	      [height (inexact->exact (cadr dims))]
	      [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 (* j h-spacing)]
	      [top  (* i 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)
		(send dc set-pen BLACK-PEN)
		 (send dc draw-ellipse (+ 2 left) (+ 2 top) (- h-spacing 2) (- v-spacing 2))
		 ;; (draw-ellipse left top h-spacing v-spacing)
		 (send dc set-pen pen)
		 (send dc set-brush brush)
		 (send dc 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))
	 )] 
         )
    (sequence 
      (apply super-init args)
      (set-board arg-board))))

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

;; str is something like "/home/ian/comp210/connect5/connect5.ss"
;;
(define connect5pathname->user
  (lambda (str)
    (last (all-but-last (all-but-last (all-but-last str))))))

(define request-quit #f)

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

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

(send bottom-panel stretchable-height #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 button%
    "Start"
    message-panel
    (lambda (self event)
      (when (not already-started)
        (set! already-started #t)
        (thread start-game)))
    ))

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


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


(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 startup
  (lambda ()
    (send frame show #t)
    frame))

;(fprintf (current-output-port) "hello")
;(fprintf (current-error-port) "hmmmm")

(startup)