foss-mmo/modules/game/actors.scm

(define-module (game actors)
  #:use-module (goblins core)
  #:use-module (ice-9 match)
  #:export (^cell
            ^exit
            ^wall
            ^block
            ^clock-emitter
            ^player
            ^level))

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

;; TODO: Add layer info to 'describe' output for sorting sprites when
;; rendering.

;; TODO: Port actor-lib methods and use it.
(define (^exit bcom x y)
  (define position (vector x y))
  (match-lambda*
    (('type) 'exit)
    (('position) position)
    (('tick) #f)
    (('wire-state) #f)
    (('set-wire-state) #f)
    (('describe) `(exit ,position))
    (('collide other offset grid-info) #f)))

;; TODO: Maybe make separate actors for conductive vs. inert walls.
(define (^wall bcom x y type)
  (define position (vector x y))
  (match-lambda*
    (('type) 'wall)
    (('position) position)
    (('tick) #f)
    (('wire-state)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('set-wire-state type)
     (bcom (^wall bcom x y type)))
    (('describe) `(wall ,position ,type))
    (('collide other offset grid-info) #f)))

;; TODO: Maybe make separate actors for conductive vs. inert blocks.
(define (^block bcom x y type)
  (define position (spawn ^cell (vector x y)))
  (define pushed? (spawn ^cell))
  (match-lambda*
    (('type) 'block)
    (('position) ($ position))
    (('tick) ($ pushed? #f))
    (('wire-state)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('set-wire-state type)
     (match ($ position)
       (#(x y)
        (bcom (^block bcom x y type)))))
    (('describe) `(block ,($ position) ,type))
    (('collide other offset grid-info)
     (match ($ position)
       (#(x y)
        (match offset
          (#(dx dy)
           (let ((x (+ x dx))
                 (y (+ y dy)))
             (unless ($ grid-info 'occupied? x y)
               ($ pushed? #t)
               ($ position (vector x y)))))))))
    (('pushed?) ($ pushed?))))

(define (^clock-emitter bcom x y interval)
  (define timer (spawn ^cell 0))
  (define position (vector x y))
  (match-lambda*
    (('type) 'emitter)
    (('position) position)
    (('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 ,position))
    (('collide other offset grid-info) #f)))

(define (^player bcom x y)
  (define position (spawn ^cell (vector x y)))
  (define velocity (spawn ^cell #(0 0)))
  (define event (spawn ^cell))
  (match-lambda*
    (('type) 'player)
    (('position) ($ position))
    (('move dir)
     ($ velocity
        (match dir
          ('left #(-1 0))
          ('right #(1 0))
          ('up #(0 -1))
          ('down #(0 1))
          (_ (error "invalid direction" dir)))))
    (('tick)
     ($ event #f)
     (match ($ position)
       (#(x y)
        (match ($ velocity)
          (#(dx dy)
           ($ position (vector (+ x dx) (+ y dy)))
           ($ velocity #(0 0)))))))
    (('wire-state) #f)
    (('describe) `(player ,($ position)))
    (('collide other offset grid-info)
     (define (reverse-move)
       (match ($ position)
         (#(x y)
          (match offset
            (#(dx dy)
             ($ position (vector (- x dx) (- y dy))))))))
     (match ($ other 'type)
       ('exit ($ event '(exit)))
       ('block
        (if ($ other 'pushed?)
            ($ event '(push))
            (begin
              (reverse-move)
              ($ event '(bump)))))
       (_
        (reverse-move)
        ($ event '(bump)))))
    (('event) ($ event))))

(define (^level bcom width height)
  (define objects (spawn ^cell '()))

  ;; Spatial partition
  (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 (make-grid init)
    (let ((grid (make-vector (* width height))))
      (for-each-coord
       (lambda (x y)
         (grid-set! grid x y (spawn ^cell init))))
      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 grid (make-grid '()))

  ;; Read-only access to query the grid.
  (define (^grid-info bcom)
    (match-lambda*
      (('occupied? x y)
       (not (null? ($ (grid-ref grid x y)))))))
  (define grid-info (spawn ^grid-info))

  (define (delq item lst)
    (let lp ((lst lst))
      (match lst
        (() '())
        ((head . tail)
         (if (eq? item head)
             tail
             (cons head (lp tail)))))))
  (define (maybe-update-grid obj prev-pos resolved-pos)
    (unless (equal? prev-pos resolved-pos)
      (match prev-pos
        (#(x y)
         (let ((cell (grid-ref grid x y)))
           ($ cell (delq obj ($ cell))))))
      (match resolved-pos
        (#(x y)
         (let ((cell (grid-ref grid x y)))
           ($ cell (cons obj ($ cell))))))))
  (define (collide obj pos prev-pos)
    (match pos
      (#(x y)
       (let lp ((objects ($ (grid-ref grid x y))))
         (match objects
           (() (maybe-update-grid obj prev-pos ($ obj 'position)))
           ((other . rest)
            (if (eq? obj other)
                (lp rest)
                (let ((other-prev-pos ($ other 'position)))
                  (match prev-pos
                    (#(prev-x prev-y)
                     (let ((offset (vector (- x prev-x) (- y prev-y))))
                       (pk 'collision! ($ obj 'type) ($ other 'type))
                       ($ other 'collide obj offset grid-info)
                       ($ obj 'collide other offset grid-info)
                       (maybe-update-grid other other-prev-pos ($ other 'position))
                       (lp rest))))))))))))
  (define (tick)
    (define (neighbors x y)
      (define (check x y)
        (match ($ (grid-ref/wrap grid x y))
          (() 0)
          ;; TODO: Handle tiles with many occupants.
          ((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)))
    ;; Tick each object and check for collisions.
    (for-each (lambda (obj)
                (let ((prev-pos ($ obj 'position)))
                  ($ obj 'tick)
                  ;; Only check collisions for movable objects.
                  (let ((desired-pos ($ obj 'position)))
                    (unless (equal? prev-pos desired-pos)
                      (collide obj desired-pos prev-pos)))))
              ($ objects))
    ;; Advance Wirewold simulation.
    (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))
                                    (() (x-loop (1+ x) updates))
                                    ;; TODO: Handle many occupants
                                    ((refr . _)
                                     (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))))

  (match-lambda*
    (('tick) (tick))
    (('describe)
     (map (lambda (obj) ($ obj 'describe)) ($ objects)))
    (('add-object obj)
     ($ objects (cons obj ($ objects)))
     (match ($ obj 'position)
       (#(x y)
        (let ((cell (grid-ref grid x y)))
          ($ cell (cons obj ($ cell)))))))))