dotsandboxes/main.rkt

#lang racket

(provide (all-defined-out)) ; for testing module

(require racket/draw racket/random)

; a Grid contains:
; -- a list of lines. All lines in a grid must be specified as moving left to right, top to bottom ("to" coordinate higher than "from" coordinate")
; -- the width and height of the grid.
(struct grid (lines width height) #:transparent)

; represents a point in 2d space.
(struct point (x y) #:transparent)

; represents a line drawn from one point to another and which player drew it.
(struct line (from to player) #:transparent)

; represents the state of a game in play
; grid is the grid
; player is the current player
; scores is a list of numbers for the score of each player.
; players is a list of two players who are playing in the game
(struct GameState (grid player scores players) #:transparent)

; represents a player. func is a function with the signature:
; Grid Number -> Line
; where the grid is the current board state, the Number is if the player is player 1 or 2, and it returns the move it will play that turn.
; name is the player's name.
(struct player (name func) #:transparent)

; width and height of the playing grid.
(define GRID-WIDTH 6)
(define GRID-HEIGHT 6)

; size of one grid position in pixels
(define GRID-SCALE 16)

; image representing the empty grid
(define EMPTY-GRID
  (let* ([bitmap (make-bitmap (* GRID-WIDTH GRID-SCALE) (* GRID-HEIGHT GRID-SCALE))]
         [dc (new bitmap-dc% [bitmap bitmap])])
    (send dc set-brush "black" 'solid)
    (for ([x (in-range GRID-WIDTH)])
      (for ([y (in-range GRID-HEIGHT)])
        (send dc draw-ellipse (* x GRID-SCALE) (* y GRID-SCALE) (/ GRID-SCALE 2) (/ GRID-SCALE 2))))
    bitmap))

; Grid that contains all possible lines filled. Used for filtering valid moves. This is an ugly way, but i can't think of a better one right now.
(define FULL-GRID (grid
                   (flatten
                    (for/list ([x (in-range GRID-WIDTH)])
                      (for/list ([y (in-range GRID-HEIGHT)])
                        (list
                         (if (< x (- GRID-WIDTH 1)) (line (point x y) (point (+ x 1) y) 1) '())
                         (if (< y (- GRID-HEIGHT 1)) (line (point x y) (point x (+ y 1)) 1) '()))))) GRID-WIDTH GRID-HEIGHT))

; Line Line -> Bool
; tests if two lines are in the same position
(define (same-position? l1 l2)
  (or
   (and
    (equal? (line-from l1) (line-from l2))
    (equal? (line-to l1) (line-to l2)))
   (and
    (equal? (line-to l1) (line-from l2))
    (equal? (line-from l1) (line-to l2)))))

; Point Point -> Point
; adds two points together.
(define (point+ p1 p2)
  (point (+ (point-x p1) (point-x p2)) (+ (point-y p1) (point-y p2))))

; Grid -> List of Lines
; returns all valid moves on a grid.
; TODO optimise. This "filtering what is invalid out of all possible lines" method sucks.
; TODO write more tests
(define (valid-moves g)
    (filter (lambda (move) (valid-move? move g)) (grid-lines FULL-GRID)))

; Point Grid -> Number
; given a point that is the top-left corner of a square on the grid, returns the amount of edges surrounding that square.
(define (count-square p g)
  ; explanation:
  ; for every item in the grid (g), test it against every edge of the box for equality. if any are equal, it matches.
  ; then only those that match are kept and this list is checked for length to determine the matching lines.
  (length
   (filter (lambda (item)
             (member #t
                     (for/list ([x (list (point 0 0) (point 0 1) (point 1 0) (point 0 0))]
                                [y (list (point 0 1) (point 1 1) (point 1 1) (point 1 0))]) 
                       (same-position? item (line (point+ x p) (point+ y p) 0))))) (grid-lines g)))) ; for every position in the square, check if there's a line there

; Line -> Bool
; returns #t if the line is forwards (with forwards being moving right and down, higher end coord than start)
(define (forwards? line)
  (and
   (>= (point-x (line-to line)) (point-x (line-from line)))
   (>= (point-y (line-to line)) (point-y (line-from line)))))

; Line -> Bool
; returns #t if a line is valid in terms of length (only moving one point in one direction)
(define (valid-length? line)
  (= 1
     (+ (abs (- (point-x (line-from line)) (point-x (line-to line))))
        (abs (- (point-y (line-from line)) (point-y (line-to line)))))))

; Point -> Bool
; returns #t if a point is out of bounds (off the edge of the grid)
(define (out-of-bounds? p)
  (or
   (> 0 (point-x p))
   (> 0 (point-y p))
   (< (- GRID-WIDTH 1) (point-x p))
   (< (- GRID-WIDTH 1) (point-y p))))

; Line Grid -> Bool
; returns #t if adding the given move to the grid is valid.
(define (valid-move? line grid)
  (and
   (empty? (filter (lambda (l) (same-position? l line)) (grid-lines grid))) ; line doesn't already exist on board
   (valid-length? line)
   (forwards? line)
   (and
    (not (out-of-bounds? (line-from line)))
    (not (out-of-bounds? (line-to line))))))

; a Player that plays random moves
(define random-player
  (player
   "Random"
   (lambda (g n)
     (let ([m (car (random-sample (valid-moves g) 1))])
       (line (line-from m) (line-to m) n)))))

; Grid Line -> Grid
; adds line to grid, if it is a valid move. Otherwise skips the move.
(define (append-move g l)
  (if (valid-move? l g) (grid (append (grid-lines g) (list l)) (grid-width g) (grid-height g)) g))

; Line -> List of Points
; returns the positions of boxes the given line affects, assuming a valid line.
; TODO this is messy as fuck, especially with that (filter). Racket must have some way to do this more nicely.
(define (boxes-for line)
  (filter (lambda (x) (not (eq? x 0)))
          (list
           (if (and
                (not (= (- GRID-WIDTH 1) (point-x (line-from line))))
                (not (= (- GRID-HEIGHT 1) (point-y (line-from line))))) (line-from line) 0)
           (if (and
                (< (point-x (line-from line)) (point-x (line-to line))) ; horizontal line
                (> (point-y (line-from line)) 0))
                (point (point-x (line-from line)) (- (point-y (line-from line)) 1)) 0)
           (if (and
                (< (point-y (line-from line)) (point-y (line-to line))) ; vertical line
                (> (point-x (line-from line)) 0))
               (point (- (point-x (line-from line)) 1) (point-y (line-from line))) 0))))

; Grid Line -> bool or Number
; returns the number of boxes this completes
(define (completes-boxes grid l)
  (let
      ([boxes (boxes-for l)]
       [g (append-move grid l)])
    (length (filter (lambda (b) (= (count-square b g) 4)) boxes))))
    
; GameState -> GameState
; runs the game.
; If the game is over, returns the final game state
; else, lets a player play a move. If they complete a box, they stay on and earn a point. Else, the other player has a turn.
(define (play-game s)
  (let ([g (GameState-grid s)]
        [p (GameState-player s)])
    (cond
      [(= (length (grid-lines g)) (length (grid-lines FULL-GRID))) s] ; end of the game
      [else
       (let* ([move ((player-func (list-ref (GameState-players s) p)) g p)]
              [new-grid (append-move g move)]
              [boxes (completes-boxes g move)]
              [box (not (= 0 boxes))]
              [scores (GameState-scores s)])
         (play-game (GameState
                     new-grid
                     (if box p (abs (- p 1)))
                     (if box (list-set scores p (+ boxes (list-ref scores p))) scores) (GameState-players s))))])))

; Grid -> Image
; renders grid to an image for showing humans the game.
(define (render-grid-bitmap grid)
  (let* ([bitmap (make-bitmap (+ 10 (* GRID-WIDTH GRID-SCALE)) (+ 10 (* GRID-HEIGHT GRID-SCALE)))] ; add border for printing
         [dc (new bitmap-dc% [bitmap bitmap])])
    (render-grid grid dc)
    bitmap))

; Grid dc !
; renders grid on the given drawing context.
; TODO setting line color doesn't seem to be always working?
; TODO color in squares
(define (render-grid g dc)
  (define passed '())
  (for ([l (grid-lines g)]) ; reversed for fill-drawing malarkey.
    (if (empty? passed) (set! passed (list l)) (set! passed (append passed (list l))))
    (cond
      [(= (line-player l) 0) (send dc set-pen "red" 4 'solid)] ; player 1 draws in red
      [(= (line-player l) 1) (send dc set-pen "blue" 4 'solid)]) ; player 2 draws in blue
    (send dc draw-line
          (+ 4 (* GRID-SCALE (point-x (line-from l))))
          (+ 4 (* GRID-SCALE (point-y (line-from l))))
          (+ 4 (* GRID-SCALE (point-x (line-to l))))
          (+ 4 (* GRID-SCALE (point-y (line-to l))))) ; draw the line
    (let ([boxes (boxes-for l)])
      (for ([b boxes])
        (if (= (count-square b (grid passed (grid-width g) (grid-height g))) 4)
           (send dc draw-text
            (if (= (line-player l) 0) "R" "B")
            (+ 6 (* GRID-SCALE (point-x b)))
            (+ 3 (* GRID-SCALE (point-y b))))
            0))))
  (send dc draw-bitmap EMPTY-GRID 0 0)) ; overlay dot grid