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
            ^floor-switch
            ^gem
            ^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 grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state) #f)
    (('alive?) #t)
    (('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 grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state)
     (match type
       ((or 'copper 'electron-head 'electron-tail)
        type)
       (_ #f)))
    (('set-wire-state type)
     (bcom (^wall bcom x y type)))
    (('alive?) #t)
    (('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 grid-info) ($ pushed? #f))
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #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)))))
    (('alive?) #t)
    (('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 grid-info) ($ timer (+ ($ timer) 1)))
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state)
     (let ((t ($ timer)))
       (cond
        ((= (modulo t interval) 0)
         'electron-head)
        ((= (modulo t interval) 1)
         'electron-tail)
        (else
         'copper))))
    (('alive?) #t)
    (('set-wire-state type) #f)
    (('describe) `(clock-emitter ,position))
    (('collide other offset grid-info) #f)))

(define (^floor-switch bcom x y)
  (define position (vector x y))
  (define on? (spawn ^cell))
  (match-lambda*
    (('type) 'switch)
    (('position) position)
    (('tick grid-info) #f)
    (('enter obj grid-info)
     ($ on? #t))
    (('exit obj grid-info)
     (when (= (length ($ grid-info 'occupants x y)) 1)
       (pk 'OFF)
       ($ on? #f)))
    (('wire-state) #f)
    (('alive?) #t)
    (('describe) `(floor-switch ,position ,($ on?)))
    (('collide other offset grid-info)
     (pk 'ON)
     ($ on? #t))))

(define (^gem bcom x y)
  (define position (vector x y))
  (define picked-up? (spawn ^cell))
  (match-lambda*
    (('type) 'gem)
    (('position) position)
    (('tick grid-info) #f)
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state) #f)
    (('alive?) (not ($ picked-up?)))
    (('describe) `(gem ,position))
    (('collide other offset grid-info)
     (when (eq? ($ other 'type) 'player)
       ($ picked-up? #t)))))

(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 grid-info)
     ($ event #f)
     (match ($ position)
       (#(x y)
        (match ($ velocity)
          (#(dx dy)
           ($ position (vector (+ x dx) (+ y dy)))
           ($ velocity #(0 0)))))))
    (('enter obj grid-info) #f)
    (('exit obj grid-info) #f)
    (('wire-state) #f)
    (('alive?) #t)
    (('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)))))
       ('switch ($ event '(switch)))
       ('gem ($ event '(gem)))
       (_
        (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)))))
      (('occupants x y)
       ($ (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))
                (remaining (delq obj ($ cell))))
           ($ cell remaining)
           (for-each (lambda (other)
                       ($ other 'exit obj grid-info))
                     remaining))))
      (match resolved-pos
        (#(x y)
         (let* ((cell (grid-ref grid x y))
                (occupants ($ cell)))
           ($ cell (cons obj occupants))
           (for-each (lambda (other)
                       ($ other 'enter obj grid-info))
                     occupants))))))
  (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.
    ($ objects
       (let lp ((objs ($ objects)))
         (match objs
           (() '())
           ((obj . rest)
            (let ((prev-pos ($ obj 'position)))
              ($ obj 'tick grid-info)
              ;; Only check collisions for movable objects.
              (let ((desired-pos ($ obj 'position)))
                (unless (equal? prev-pos desired-pos)
                  (collide obj desired-pos prev-pos)))
              ;; Cull dead objects.
              (if ($ obj 'alive?)
                  (cons obj (lp rest))
                  (lp rest)))))))
    ;; 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)))))))))