Go prototype in CHICKEN Scheme

go.scm

(import chicken scheme)
(use hypergiant srfi-42 miscmacros)

;;;
;;; Game logic
;;;

;; Turns
(define turn (make-parameter 'black))

(define (next-turn)
  (turn (if (eq? (turn) 'black)
            'white
            'black)))


;; Nodes
(define grid-rows 19)

(define-record node
  index color scene-node)

(define (neighbours node)
  (let* ((index (node-index node))
         (x (car index))
         (y (cdr index))
         (north (and (< (add1 y) grid-rows) (get-node (cons x (add1 y)))))
         (south (and (>= (sub1 y) 0) (get-node (cons x (sub1 y)))))
         (west (and (>= (sub1 x) 0) (get-node (cons (sub1 x) y))))
         (east (and (< (add1 x) grid-rows) (get-node (cons (add1 x) y)))))
    (remove not (list north east south west))))

(define (find-chained-nodes node predicate)
  ;; Find nodes chained to the given one, that satisfy PREDICATE
  (let ((chain '()))
    (let find ((node node))
      (when (and (not (member node chain))
                 (predicate node))
        (set! chain (cons node chain))
        (map find (neighbours node))))
    chain))


;; Chains
(define-record chain
  color members liberties)

(define (get-chain node)
  (if* (find (lambda (chain) (find (cut equal? (node-index node) <>)
                              (chain-members chain)))
         (state-chains (game-state)))
       it
       (error 'get-chain "Tried to find node that is not in any chain" node)))

(define (add-to-chain chain node liberties)
  (chain-members-set! chain (cons (node-index node) (chain-members chain)))
  (chain-liberties-set! chain (append (map node-index liberties)
                                      (chain-liberties chain))))

(define (remove-from-chain chain node)
  (chain-members-set! chain (delete (node-index node) (chain-members chain)))
  (chain-liberties-set! chain (cons (node-index node) (chain-liberties chain))))

(define (delete-liberty chain node)
  (chain-liberties-set! chain (delete (node-index node) (chain-liberties chain))))

(define (add-liberty chain node)
  (chain-liberties-set! chain (cons (node-index node) (chain-liberties chain))))

(define (join-chains chainz)
  (let ((joined (make-chain (chain-color (car chainz))
                            (append-map chain-members chainz)
                            (append-map chain-liberties chainz))))
    (update-state-chains! (lambda (chains)
                            (cons joined
                                  (remove (cut member <> chainz) chains))))
    joined))

(define (new-chain color node open)
  (update-state-chains! (lambda (chains)
                          (cons (make-chain color
                                            (list (node-index node))
                                            (map node-index open))
                                chains))))

(define (update-chains-with-node node)
  (define (add-stone color)
    (receive (occupied open)
        (partition node-color (neighbours node))
      (receive (friendlies enemies)
          (partition (lambda (n)
                       (equal? (node-color n)
                               color))
                     occupied)
        (if (null? friendlies)
            (new-chain color node open)
            (let ((chains (delete-duplicates (map get-chain friendlies))))
              (add-to-chain (if (> (length chains) 1)
                                (join-chains chains)
                                (car chains))
                            node open)))
        (for-each (cut delete-liberty <> node)
                  (delete-duplicates (map get-chain occupied))))))
  (define (remove-stone node)
    (let ((chain (get-chain node)))
      (remove-from-chain chain node)
      (when (null? (chain-members chain))
        (update-state-chains! (lambda (chains)
                                (delete chain chains eq?))))
      (let ((neighbouring-chains (delete-duplicates
                                  (remove not
                                          (map (lambda (node)
                                                 (and (node-color node)
                                                    (not (member (node-index node)
                                                               (chain-members chain)))
                                                    (get-chain node)))
                                               (neighbours node))))))
        (map (cut add-liberty <> node) neighbouring-chains))))
  (if* (node-color node)
       (add-stone it)
       (remove-stone node)))

(define (delete-chain chain)
  (for-each delete-stone 
            (map get-node (chain-members chain))))

(define (check-for-dead-chains color)
  (define (suicide-exn chain)
    (make-property-condition 'game-logic 'suicide chain))
  (receive (friendly-chains enemy-chains)
      (partition (lambda (chain)
                   (eq? (chain-color chain)
                        color))
                 (state-chains (game-state)))
    (for-each (lambda (chain)
                (when (null? (chain-liberties chain))
                  (delete-chain chain)))
              enemy-chains)
    (for-each (lambda (chain)
                (when (null? (chain-liberties chain))
                  (signal (suicide-exn chain))))
              friendly-chains)))


;; Game state
(define-record state
  nodes chains)

(define game-state
  (make-parameter
   (make-state (list-ec (: i grid-rows)
                        (: j grid-rows)
                        (make-node (cons j i) #f #f))
               '())))

(define (copy-state state)
  (define (copy-node node)
    (make-node (node-index node)
               (node-color node)
               (node-scene-node node)))
  (define (copy-chain chain)
    (make-chain (chain-color chain)
                (chain-members chain)
                (chain-liberties chain)))
  (make-state (map copy-node (state-nodes state))
              (map copy-chain (state-chains state))))

(define (compress-state)
  (map node-color (state-nodes (game-state))))

(define (update-state-chains! fun)
  (state-chains-set! (game-state) (fun (state-chains (game-state)))))

(define (get-node index)
  (list-ref (state-nodes (game-state))
            (+ (car index)
               (* (cdr index)
                  grid-rows))))


;; History
(define game-history (make-parameter '()))
(define history-check-limit 20)

(define (check-for-repeated-state)
  (let ((compressed (compress-state))
        (recent-history (if (> (length (game-history))
                               history-check-limit)
                            (take (game-history) history-check-limit)
                            (game-history))))
    (when (member compressed recent-history)
      (signal (make-property-condition 'game-logic 'repeated compressed)))
    (game-history (cons compressed (game-history)))))


;; Stones
(define (delete-stone node)
  (node-color-set! node #f)
  (update-chains-with-node node))

(define (add-stone node color)
  (when (node-color node)
    (signal (make-property-condition 'game-logic 'occupied node)))
  (node-color-set! node color)
  (update-chains-with-node node))

(define (place-stone index)
  (let ((color (turn))
        (new-state (copy-state (game-state))))
    (game-state
     (let ((old-state (game-state)))
       (parameterize ((game-state new-state))
         (let ((node (get-node index)))
           (condition-case
               (begin
                 (add-stone node color)
                 (check-for-dead-chains color)
                 (check-for-repeated-state)
                 (update-scene old-state (game-state))
                 (next-turn)
                 (game-state))
             ((game-logic) old-state))))))))


;; Scoring
(define (get-score)
  (define empty-chains (make-parameter '()))
  (define (get-chain node)
    (find (lambda (chain) (find (cut equal? (node-index node) <>)
                           (chain-members chain)))
          (empty-chains)))
  (define (add-node-to-empty-chains node)
    (unless (get-chain node)
      (let* ((color #f)
             (nodes (find-chained-nodes
                     node
                     (lambda (node)
                       (if* (node-color node)
                            (begin
                              (unless (eq? color 'none)
                                (if color
                                    (when (not (eq? color it))
                                      (set! color 'none))
                                    (set! color it)))
                                   #f)
                            #t)))))
        (empty-chains (cons (make-chain color (map node-index nodes) #f)
                           (empty-chains))))))
  (let ((score (map (cut cons <> 0) '(black white))))
    (for-each (lambda (node)
                (if* (node-color node)
                     (alist-update! it
                                    (add1 (alist-ref it score))
                                    score)
                     (add-node-to-empty-chains node)))
              (state-nodes (game-state)))
    (for-each (lambda (chain)
                (if* (chain-color chain)
                     (when (not (eq? it 'none))
                       (alist-update! it
                                      (+ (length (chain-members chain))
                                         (alist-ref it score))
                                      score))))
              (empty-chains))
    (for-each (lambda (color)
                (if (= (alist-ref color score) 361)
                    (alist-update! color 1 score)))
              '(black white))
    score))


;;;
;;; Scene and graphics
;;;

(define scene (make-parameter #f))
(define camera (make-parameter #f))

(define (update-scene old-state new-state)
  (for-each (lambda (old-node new-node)
              (let ((old-stone (node-color old-node))
                    (new-stone (node-color new-node)))
                (unless (eq? old-stone new-stone)
                  (when old-stone
                    (delete-node (node-scene-node old-node)))
                  (when new-stone
                    (add-stone-to-scene new-node)))))
            (state-nodes old-state)
            (state-nodes new-state)))

(define board-mesh (rectangle-mesh 1.2 1.2
                                   color: (lambda (_)
                                            '(0.5 0.4 0.2))))

(define line-width (/ 256))
(define grid-line (rectangle-mesh (+ 1 line-width) line-width
                                  centered?: #f))

(define (build-grid)
  (let* ((-line-width/2 (- (/ line-width 2)))
         (line-spacing (/ (sub1 grid-rows)))
         (lateral-lines
          (let loop ((i 0) (lines '()))
            (if (= i grid-rows)
                lines
                (loop (add1 i)
                      (cons
                       (cons grid-line
                             (translation
                              (make-point -line-width/2
                                          (+ (* i line-spacing)
                                             -line-width/2)
                                          0)))
                       lines)))))
         (vertical-lines
          (map (lambda (a)
                 (cons grid-line
                       (translate (make-point 0 1 0)
                                  (rotate-z (- pi/2)
                                            (copy-mat4 (cdr a))))))
                 lateral-lines)))
    (append lateral-lines
            vertical-lines)))

(define marker (circle-mesh (/ 120) 12))

(define (build-markers)
  (let* ((3nodes (/ 3 (sub1 grid-rows)))
         (15nodes (/ 15 (sub1 grid-rows)))
         (marker-points `((,3nodes  . ,3nodes)
                          (,3nodes  . 0.5)
                          (,3nodes  . ,15nodes)
                          (0.5      . ,3nodes)
                          (0.5      . 0.5)
                          (0.5      . ,15nodes)
                          (,15nodes . ,3nodes)
                          (,15nodes . 0.5)
                          (,15nodes . ,15nodes))))
    (map (lambda (p)
           (cons marker
                 (translation (make-point (car p) (cdr p) 0))))
         marker-points)))

(define board-grid-mesh (mesh-transform-append
                         'position
                         (append (build-grid)
                                 (build-markers))))

(define (init-board)
  (add-node (scene) color-pipeline-render-pipeline
            mesh: board-mesh
            position: (make-point 0.5 0.5 0))
  (add-node (scene) mesh-pipeline-render-pipeline
            mesh: board-grid-mesh
            color: black
            position: (make-point 0 0 0.0003)))


(define stone-radius (/ 40))
(define stone-mesh (circle-mesh stone-radius 12))
(define colors `((white . ,white)
                 (black . ,black)))

(define (add-stone-to-scene node)
  (let* ((index (node-index node))
         (n (add-node (scene) mesh-pipeline-render-pipeline
                      mesh: stone-mesh
                      color: (alist-ref (node-color node) colors)
                      position: (make-point (/ (car index) (sub1 grid-rows))
                                            (/ (cdr index) (sub1 grid-rows))
                                            0.0006)
                      radius: stone-radius)))
    (node-scene-node-set! node n)))

;;;
;;; Input and main loop
;;;
(define keys (make-bindings
              `((quit ,+key-escape+ press: ,stop))))

(define (get-cursor-board-position)
  (receive (near far) (get-cursor-world-position (camera))
    (let ((u (/ (point-z near) (- (point-z near) (point-z far)))))
      (make-point (+ (point-x near) (* u (- (point-x far) (point-x near))))
                  (+ (point-y near) (* u (- (point-y far) (point-y near))))
                  0))))

(define (get-nearest-index)
  (let ((n (vround (v* (vclamp (get-cursor-board-position) 0 1)
                       (sub1 grid-rows)))))
    (cons (inexact->exact (point-x n))
                    (inexact->exact (point-y n)))))

(define (cursor-board-press)
  (place-stone (get-nearest-index)))

(define mouse (make-bindings
               `((left-click ,+mouse-button-left+
                  press: ,cursor-board-press))))

(define (init)
  (push-key-bindings keys)
  (push-mouse-bindings mouse)
  (scene (make-scene))
  (camera (make-camera #:perspective #:position (scene)
                       near: 0.001 angle: 35))
  (set-camera-position! (camera) (make-point 0.5 0.5 2))
  (init-board))

(start 800 600 "Go" resizable: #f init: init)