145 lines
4.5 KiB
Scheme
145 lines
4.5 KiB
Scheme
(define-module (gib-gab-gob ui catbird)
|
|
#:use-module (catbird)
|
|
#:use-module (catbird input-map)
|
|
#:use-module (catbird mode)
|
|
#:use-module (catbird node)
|
|
#:use-module (catbird node-2d)
|
|
#:use-module (catbird region)
|
|
#:use-module ((catbird scene)
|
|
#:select (<scene> current-scene replace-major-mode))
|
|
#:use-module (chickadee)
|
|
#:use-module (chickadee graphics color)
|
|
#:use-module (chickadee graphics texture)
|
|
#:use-module (chickadee math vector)
|
|
#:use-module (chickadee scripting)
|
|
#:use-module (oop goops))
|
|
|
|
(define %window-width 1024)
|
|
(define %window-height 768)
|
|
|
|
(define %tile-width 64.0)
|
|
(define %tile-height 64.0)
|
|
|
|
(define-class <tile> (<node-2d>)
|
|
(tile-x #:getter tile-x #:init-keyword #:tile-x)
|
|
(tile-y #:getter tile-y #:init-keyword #:tile-y))
|
|
|
|
(define-class <board-view> (<node-2d>)
|
|
(vat #:getter vat #:init-keyword #:vat)
|
|
(board #:getter board #:init-keyword #:board)
|
|
(tiles #:accessor tiles #:init-value #()))
|
|
|
|
(define-method (on-boot (board-view <board-view>))
|
|
(define tile-container
|
|
(make <node-2d>
|
|
#:name 'tile-container
|
|
#:rank 1))
|
|
(define background
|
|
(make <canvas>
|
|
#:name 'background
|
|
#:painter
|
|
(with-style ((fill-color db32-elf-green))
|
|
(fill
|
|
rectangle (vec2 0.0 0.0)
|
|
%window-width
|
|
%window-height))))
|
|
(resize board-view %window-width %window-height)
|
|
(attach-to board-view tile-container))
|
|
|
|
(define-method (tile-ref (garden <garden-view>) x y)
|
|
(vector-ref (vector-ref (tiles garden) y) x))
|
|
|
|
(define-method (rebuild-tiles (board-view <board-view>))
|
|
(let* ((container (& board-view tile-container)))
|
|
(for-each-tile
|
|
(λ (x y tile)
|
|
(detach tile))
|
|
(tiles board-view))
|
|
(set! (tiles garden)
|
|
(vector-unfold
|
|
(λ (y)
|
|
(vector-unfold
|
|
(λ (x)
|
|
(let* ((painter (with-style
|
|
((fill-color db32-rope)
|
|
(stroke-color db32-oiled-cedar))
|
|
(fill-and-stroke
|
|
(rectangle (vec2 0.0 0.0)
|
|
%tile-width %tile-height))))
|
|
(bg (make <canvas>
|
|
#:name 'background
|
|
#:painter painter))
|
|
(sprite (make <sprite>
|
|
#:name 'sprite
|
|
#:texture null-texture))
|
|
(tile (make <tile>
|
|
#:tile-x x
|
|
#:tile-y y)))
|
|
(set! (width tile) %tile-width)
|
|
(set! (height tile) %tile-height)
|
|
(attach-to tile bg sprite)
|
|
(attach-to container tile)
|
|
tile))
|
|
3))
|
|
3))
|
|
(for-each-tile
|
|
(λ (x y tile)
|
|
(if (= y 0)
|
|
(set! (position-y tile)
|
|
(* %tile-height (- 3 1)))
|
|
(place-below (tile-ref board-view x (- y 1)) tile))
|
|
(unless (= x 0)
|
|
(place-right (tile-ref board-view (- x 1) y) tile)))
|
|
(tiles board-view))
|
|
(set! (width container) (* 3 %tile-width))
|
|
(set! (height container) (* 3 %tile-height))
|
|
(center-in-parent container)))
|
|
|
|
(define (for-each-tile proc tiles)
|
|
(vector-for-each
|
|
(lambda (y row)
|
|
(vector-for-each
|
|
(lambda (x tile)
|
|
(proc x y tile))
|
|
row))
|
|
tiles))
|
|
|
|
(define-method (board-pick (board <board-view>) x y)
|
|
(define (find-tile node)
|
|
(cond
|
|
((not node)
|
|
#f)
|
|
((is-a? node <tile>)
|
|
node)
|
|
((parent node)
|
|
(find-tile (parent node)))
|
|
(else #f)))
|
|
(find-tile (pick board (vec2 x y) (lambda _ #t))))
|
|
|
|
(define-class <board-mode> (<major-mode>))
|
|
|
|
(define-method (make-move (mode <board-mode>) x y)
|
|
(define board (& (current-scene) root board))
|
|
(define node (board-pick board x y))
|
|
(cond
|
|
((is-a? node <tile>)
|
|
(board-make-move board node))))
|
|
|
|
(bind-input <board-mode> (mouse-press 'left) make-move)
|
|
|
|
(define* (launch-game node-thunk)
|
|
(run-catbird
|
|
(lambda ()
|
|
(let ((region (create-full-region #:name 'main))
|
|
(scene (make <scene> #:name 'board)))
|
|
(replace-scene region scene)
|
|
(replace-major-mode scene (make <board-mode>))
|
|
(set! (camera region)
|
|
(make <camera-2d>
|
|
#:width %window-width
|
|
#:height %window-height))
|
|
(attach-to scene (node-thunk))))
|
|
#:title "Gib Gab Gob"
|
|
#:width %window-width
|
|
#:height %window-height))
|