Miscellany

; Main:
; Connect 4 game
; Game board is 7 tall and 8 high
; Players are 'red and 'blue


(define done 'okay)

;board related
;a row-col pair
(define lm cons) ;loc-make
(define lr car)  ;loc-row
(define lc cdr)  ;loc-col

(define (board-ref board loc)
  (vector-ref (vector-ref board (lr loc))
              (lc loc)))

(define (board-set! board loc value)
  (vector-set! (vector-ref board (lr loc))
               (lc loc)
               value))

(define BOARD_ROWS 7)
(define BOARD_COLS 8)
(define (make-board)
  (let ((ret (make-vector 7)))
    (define (loop i)
      (if (< i BOARD_ROWS)
          (begin
            (vector-set! ret i (make-vector 8 'empty))
            (loop (+ i 1)))
          ret))
    (loop 0)))

(define dummy-board (make-board))

;generic iterator
;cell-proc called for every cell
;(&#955; (board loc) (stuff))
;row-proc called for every row
;(&#955; (loc) (stuff))
;knowing board is not important as
;loc does not refer to an actual cell
(define (board-loop board cell-proc row-proc)
  (define (loop i j)
    (cond ((>= i BOARD_ROWS) done)
          ((>= j BOARD_COLS)
           (row-proc (lm i j))
           (loop (+ i 1) 0))
          (else
           (cell-proc board (lm i j))
           (loop i (+ j 1)))))
  (loop 0 0))

;specialized iterator that only cares for values
;cellproc is (&#955; (value) (stuff))
;rowproc is (&#955; () (stuff))
(define (board-iter board cell-proc row-proc)
  (board-loop (&#955; (board loc) (cell-proc (board-get board loc)))
              (&#955; (loc) (row-proc))))


; GUI STUFF

(define current-game #f) ;board that gets painted
(define main-window #f)
(define cursor-col #f)

(define (update-window)
  (if main-canvas 
      (send main-canvas refresh)))

(define canvas-w-offset 0) ;ugly hacks
(define canvas-cell-size 0)
(define main-canvas #f)
(define turn-display #f)

(define game-canvas%
  (class canvas%
    (override on-event)
    (define on-event 
      (&#955; (event)
        (let ((col (floor (/ (- (send event get-x)
                                canvas-w-offset) 
                             canvas-cell-size))))
          (cond ((or (>= col BOARD_COLS)
                      (< col 0))
                 (set! cursor-col #f)
                 (update-window))
                ((not (eqv? cursor-col col))
                 (set! cursor-col col)
                 (update-window))
                ((send event leaving?)
                 (set! cursor-col #f))
                (else done)))))
    (super-instantiate ())))

;row=height
;col=width
(define (painter canvas dc) 
  (let* ((width (send canvas get-width))
         (height (- (send canvas get-height) 20))
         (col-size (/ width BOARD_COLS))
         (row-size (/ height BOARD_ROWS))
         (cellsize (min col-size row-size))
         (w-offset (/ (- width (* BOARD_COLS cellsize)) 2))
         (h-offset (/ (- height (* BOARD_ROWS cellsize)) 2)))
    (define (paint-grid)
      (define (draw-col i)
        (if (> i BOARD_COLS)
            done
            (begin
              (send dc draw-line 
                    (+ (* i cellsize) w-offset) h-offset
                    (+ (* i cellsize) w-offset) (- height h-offset))
              (draw-col (+ i 1)))))
      (define (draw-row i)
        (if (> i BOARD_ROWS)
            done
            (begin
              (send dc draw-line
                    w-offset (+ (* i cellsize) h-offset)
                    (- width w-offset) (+ (* i cellsize) h-offset))
              (draw-row (+ i 1)))))
      (send dc set-pen "black" 3 'solid)
      (draw-row 0)
      (draw-col 0))
    (define (paint-cells size)
      (if (not current-game)
          done
          (begin
            (send dc set-pen "black" 0 'transparent)
            (board-loop (current-game 'board)
                        (&#955; (board loc)
                          (define draw #t)
                          (cons ((eq? (board-get board loc) 'red)
                                 (send dc set-brush "red" solid))
                                ((eq? (board-get board loc) 'blue)
                                 (send dc set-brush "blue" solid))
                                (else #f))
                          (send dc draw-ellipse
                                (+ w-offset (lc loc))
                                (+ h-offset (lr loc))
                                size
                                size))
                        (&#955; (loc) done)))))
    (define (paint-cursor-mark)
      (if (not cursor-col)
          done
          (begin
            (send dc set-pen "black" 0 'transparent)
            (send dc set-brush "green" 'solid)
            (send dc draw-rectangle
                  (+ w-offset (* cellsize cursor-col))
                  (- height h-offset)
                  cellsize
                  20))))
    (set! canvas-w-offset w-offset)
    (set! canvas-cell-size cellsize)
    (paint-cursor-mark)
    (paint-grid)
    (paint-cells cellsize)))

(define (button-new-game button event) 
  (set! current-game (make-game))
  (update-window))
(define (button-quit-game button event) done)

(define (build-gui)
  (set! main-window (instantiate frame% ("Connect 4")))
  (let* ((main-panel 
          (instantiate horizontal-pane% 
            (main-window)
            (alignment '(center center))))
         (ctrl-panel
          (instantiate vertical-pane%
            (main-panel)
            (alignment '(center top))
            (stretchable-height #t)
            (stretchable-width #f)
            (min-width 100)))
         (game-panel
          (instantiate game-canvas%
            (main-panel)
            (paint-callback painter)
            (min-width 400)
            (min-height 400))))
    (instantiate button% () (parent ctrl-panel) (label "New")
      (callback button-new-game))
    (instantiate button% () (parent ctrl-panel) (label "Quit")
      (callback button-quit-game))
    (instantiate pane% () (parent ctrl-panel) (min-height 20)
      (stretchable-height #f))
    (let ((turn-pane (instantiate horizontal-pane% () 
                       (parent ctrl-panel)
                       (alignment '(left top))
                       (stretchable-height #f)
                       (border 4))))
      (instantiate message% () (parent turn-pane) (label "Turn:"))
      (set! turn-display (instantiate message% () 
                           (parent turn-pane) 
                           (label "Unknown"))))
    (set! main-canvas game-panel))
  (send main-window show #t))

(build-gui)

; Game

;returns a new game
(define (make-game)
  (let ((board (make-board))
        (turn 'red)
        (winner #f))
    (&#955; (cmd . args)
      (cond ((eq? cmd 'move!)
             (make-move (lm (car args) (cadr args)))
             (update-window))
            ((eq? cmd 'board) board)
            ((eq? cmd 'winner) winner)
            ((eq? cmd 'turn) turn)
            (else (error 'game-unknown-cmd))))))