foss-mmo/modules/game/actors.scm

(define-module (game actors)
  #:use-module (dom canvas)
  #:use-module (goblins core)
  #:use-module (ice-9 match)
  #:export (^cell
            ^level))

;; ^wall
;; ^wire
;; ^electron-head
;; ^electron-tail

(define* (^cell bcom #:optional val)
  (case-lambda
    (() val)
    ((new-val)
     (bcom (^cell bcom new-val)))))

(define (^wall bcom type)
  (match-lambda*
    (('tick) #f)
    (('wire-state)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('set-wire-state type)
     (bcom (^wall bcom type)))
    (('describe) `(wall ,type))
    (('collide) 'stop)))

(define (^block bcom type)
  (match-lambda*
    (('tick) #f)
    (('wire-state)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('set-wire-state type)
     (bcom (^block bcom type)))
    (('describe) `(block ,type))
    (('collide) 'displace)))

(define (^clock-emitter bcom interval)
  (define timer (spawn ^cell 0))
  (match-lambda*
    (('tick) ($ timer (+ ($ timer) 1)))
    (('wire-state)
     (let ((t ($ timer)))
       (cond
        ((= (modulo t interval) 0)
         'electron-head)
        ((= (modulo t interval) 1)
         'electron-tail)
        (else
         'copper))))
    (('set-wire-state type) #f)
    (('describe) '(clock-emitter))
    (('collide) 'stop)))

(define (^player bcom)
  (match-lambda*
    (('tick) #f)
    (('wire-state) #f)
    (('describe) '(player))))

(define (^level bcom width height)
  (define player (spawn ^player))
  (define player-coords (spawn ^cell))
  (define (make-grid)
    (make-vector (* width height)))
  (define grid (make-grid))
  (define (grid-ref grid x y)
    (vector-ref grid (+ (* y width) x)))
  (define (grid-ref/wrap grid x y)
    (grid-ref grid (modulo x width) (modulo y height)))
  (define (grid-set! grid x y val)
    (vector-set! grid (+ (* y width) x) val))
  (define (for-each-coord proc)
    (let y-loop ((y 0))
      (when (< y height)
        (let x-loop ((x 0))
          (when (< x width)
            (proc x y)
            (x-loop (1+ x))))
        (y-loop (1+ y)))))
  (define (wrap-x x)
    (modulo x width))
  (define (wrap-y y)
    (modulo y height))
  ;; Assumes that dx/dy are in the range [0,1].
  (define (move-player dx dy)
    (match ($ player-coords)
      (#(old-x old-y)
       (let* ((x (wrap-x (+ old-x dx)))
              (y (wrap-y (+ old-y dy)))
              (old-cell (grid-ref grid old-x old-y))
              (cell (grid-ref grid x y)))
         (match ($ cell)
           (#f
            ($ old-cell #f)
            ($ cell player)
            ($ player-coords (vector x y)))
           (occupant
            (match ($ occupant 'collide)
              ('stop #f)
              ('displace
               (let ((next-cell (grid-ref grid (wrap-x (+ x dx)) (wrap-y (+ y dy)))))
                 (match ($ next-cell)
                   (#f
                    ($ next-cell ($ cell))
                    ($ cell player)
                    ($ old-cell #f)
                    ($ player-coords (vector x y)))
                   (_ #f)))))))))))
  (define (warp-player x y)
    ($ (grid-ref grid x y) player)
    (match ($ player-coords)
      (#f
       ($ player-coords (vector x y)))
      (#(old-x old-y)
       ($ player-coords (vector x y))
       ($ (grid-ref grid old-x old-y) #f))))
  (define (tick)
    (define (neighbors x y)
      (define (check x y)
        (match ($ (grid-ref/wrap grid x y))
          (#f 0)
          (refr
           (match ($ refr 'wire-state)
             ('electron-head 1)
             (_ 0)))))
      (+ (check (- x 1) (- y 1))
         (check x (- y 1))
         (check (+ x 1) (- y 1))
         (check (+ x 1) y)
         (check (+ x 1) (+ y 1))
         (check x (+ y 1))
         (check (- x 1) (+ y 1))
         (check (- x 1) y)))
    (for-each (match-lambda
                ((refr . wire-state)
                 ($ refr 'set-wire-state wire-state)))
              (let y-loop ((y 0) (updates '()))
                (if (< y height)
                    (y-loop (1+ y)
                            (let x-loop ((x 0) (updates updates))
                              (if (< x width)
                                  (match ($ (grid-ref grid x y))
                                    (#f (x-loop (1+ x) updates))
                                    (refr
                                     ($ refr 'tick)
                                     (match ($ refr 'wire-state)
                                       (#f (x-loop (1+ x) updates))
                                       ('copper
                                        (if (<= 1 (neighbors x y) 2)
                                            (x-loop (1+ x) (cons `(,refr . electron-head) updates))
                                            (x-loop (1+ x) updates)))
                                       ('electron-head
                                        (x-loop (1+ x) (cons `(,refr . electron-tail) updates)))
                                       ('electron-tail
                                        (x-loop (1+ x) (cons `(,refr . copper) updates))))))
                                  updates)))
                    updates))))

  ;; Initialize grid cells
  (for-each-coord
   (lambda (x y)
     (grid-set! grid x y (spawn ^cell))))

  ;; TODO: actually write levels
  (warp-player 10 8)
  ($ (grid-ref grid 4 4) (spawn ^wall 'brick))

  ($ (grid-ref grid 4 3) (spawn ^clock-emitter 3))
  ($ (grid-ref grid 5 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 6 4) (spawn ^block 'copper))
  ($ (grid-ref grid 7 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 8 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 9 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 10 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 11 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 12 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 13 2) (spawn ^wall 'copper))
  ($ (grid-ref grid 13 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 13 4) (spawn ^wall 'copper))
  ($ (grid-ref grid 14 2) (spawn ^wall 'copper))
  ($ (grid-ref grid 14 4) (spawn ^wall 'copper))
  ($ (grid-ref grid 15 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 16 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 17 3) (spawn ^wall 'copper))
  ($ (grid-ref grid 18 3) (spawn ^wall 'copper))

  (match-lambda*
    (('describe)
     (let ((grid* (make-grid)))
       (for-each-coord
        (lambda (x y)
          (grid-set! grid* x y
                     (match ($ (grid-ref grid x y))
                       (#f #f)
                       (refr ($ refr 'describe))))))
       grid*))
    (('move-player dir)
     (match dir
       ('up (move-player 0 -1))
       ('down (move-player 0 1))
       ('left (move-player -1 0))
       ('right (move-player 1 0)))
     (tick))))