gib-gab-gob/gib-gab-gob/ui/catbird.scm

(define-module (gib-gab-gob ui catbird)
  #:use-module (gib-gab-gob board)
  #:use-module (gib-gab-gob rps)
  #:use-module (gib-gab-gob util chickadee-vat)
  #:use-module (gib-gab-gob game)
  #:use-module (goblins)
  #:use-module (goblins ocapn captp)
  #:use-module (goblins ocapn ids)
  #:use-module (goblins ocapn netlayer onion)
  #: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 camera)
  #: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 graphics path)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (oop goops)
  #:use-module (srfi srfi-43)
  #:export (make-initiator make-joiner))

(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 (initialize (board-view <board-view>) initargs)
  (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))))
  (next-method)
  (attach-to board-view tile-container)
  (rebuild-tiles board-view))

(define-method (tile-ref (board-view <board-view>) x y)
  (vector-ref (vector-ref (tiles board-view) 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 board-view)
          (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-view <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-view (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>)
    (format #t "moving ~a ~a\n" board node))))

(bind-input <board-mode> (mouse-press 'left) make-move)

(define* (launch-game node-thunk)
  (run-catbird
   (lambda ()
     (let ((region (make <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))


(define-class <initiator> (<node>)
  (vat #:accessor vat))

(define-method (initialize (initiator <initiator>) initargs)
  (next-method)
  (run-script initiator
    (set! (vat initiator) (make-chickadee-vat #:agenda (agenda initiator)))
    (vat-start! (vat initiator))
    (let ((board (make-board)))
      (with-vat (vat initiator)
                (format #t "inside vat\n")
                (let* ((my-turn+ (make-channel))
                       (init (spawn ^game-initiator ^ggg-controller board my-turn+)))
                  #f))
      (attach-to initiator (make <board-view> #:vat (vat initiator) #:board board)))))

(define (make-initiator)
  (launch-game
   (λ ()
     (make <initiator> #:name 'root))))

(define-class <joiner> (<node>)
  (vat #:accessor vat)
  (addr #:accessor addr #:init-keyword #:addr))

(define-method (initialize (joiner <joiner>) initargs)
  (next-method)
  (run-script joiner
    (let ((board (make-board)))
      (set! (vat joiner) (make-chickadee-vat #:agenda (agenda joiner)))
      (vat-start! (vat joiner))
      (with-vat (vat joiner)
                (let* ((mycapn (spawn-mycapn (new-onion-netlayer)))
                       (my-turn+ (make-channel))
                       (init-sref (string->ocapn-id addr))
                       (initiator ($ mycapn 'enliven init-sref))
                       (joiner (spawn ^game-joiner initiator ^ggg-controller board my-turn+))
                       (sealed ($ joiner 'get-sealed-pick)))
                  (on (<- initiator 'register-opponent joiner sealed)
                      (λ (_)
                        (on ($ joiner 'initialize!)
                            (λ (status) (format #f "TODO: need to tell it to start here") #f))))))
      (attach-to joiner (make <board-view> #:vat (vat joiner) #:board board)))))

(define (make-joiner addr)
  (launch-game
   (λ ()
     (make <joiner> #:name 'root #:addr addr))))