(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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment