1 files changed, 113 insertions, 0 deletions
diff --git a/lisparuga/actor.scm b/lisparuga/actor.scm
new file mode 100644
index 0000000..c7caab2
--- /dev/null
+++ b/lisparuga/actor.scm
@@ -0,0 +1,113 @@
+;;; Lisparuga
+;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Lisparuga is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Lisparuga is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Lisparuga.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; A class representing a scripted or player-controller object in the
+;; game world.  Actors can emit bullets and have many hitboxes.
+;;
+;;; Code:
+
+
+(define-module (lisparuga actor)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee math rect)
+  #:use-module (lisparuga node)
+  #:use-module (lisparuga node-2d)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-9)
+  #:export (make-hitbox
+            hitbox?
+            hitbox-name
+            hitbox-rect
+
+            world-hitbox?
+            world-hitbox-collision?
+            world-hitbox-parent
+
+            <actor>
+            polarity
+            velocity
+            hitboxes
+            world-hitboxes
+            on-collision
+            bullet-field))
+
+
+;;;
+;;; Hitboxes
+;;;
+
+(define-record-type <hitbox>
+  (make-hitbox name rect)
+  hitbox?
+  (name hitbox-name)
+  (rect hitbox-rect))
+
+(define-record-type <world-hitbox>
+  (%make-world-hitbox parent rect)
+  world-hitbox?
+  (parent world-hitbox-parent)
+  (rect world-hitbox-rect))
+
+(define (make-world-hitbox parent)
+  (let ((r (hitbox-rect parent)))
+    (%make-world-hitbox parent
+                        (make-rect 0.0 0.0 (rect-width r) (rect-height r)))))
+
+(define (sync-world-hitbox world-hitbox position)
+  (rect-move-vec2! (world-hitbox-rect world-hitbox) position))
+
+(define (world-hitbox-collision? a b)
+  (if (world-hitbox? b)
+      (rect-intersects? (world-hitbox-rect a) (world-hitbox-rect b))
+      (rect-intersects? (world-hitbox-rect a) b)))
+
+
+;;;
+;;; Actors
+;;;
+
+(define-class <actor> (<node-2d>)
+  (polarity #:accessor polarity #:init-form 'none #:init-keyword #:polarity)
+  (velocity #:getter velocity #:init-form (vec2 0.0 0.0))
+  (hitboxes #:accessor hitboxes #:init-form '() #:init-keyword #:hitboxes)
+  (world-hitboxes #:accessor world-hitboxes #:init-form '())
+  (bullet-field #:accessor bullet-field #:init-keyword #:bullet-field))
+
+(define-method (initialize (actor <actor>) initargs)
+  (next-method)
+  (set! (world-hitboxes actor)
+    (map make-world-hitbox (hitboxes actor))))
+
+(define-method (update (actor <actor>) dt)
+  (let ((v (velocity actor)))
+    (unless (and (= (vec2-x v) 0.0)
+                 (= (vec2-y v) 0.0))
+      ;; Move by current velocity.
+      (vec2-add! (position actor) v)
+      ;; Sync hitboxes to world coordinates.
+      (let ((pos (position actor)))
+        (for-each (lambda (world-hitbox)
+                    (sync-world-hitbox world-hitbox pos))
+                  (world-hitboxes actor)))
+      ;; Mark for matrix updates.
+      (dirty! actor))))
+
+;; Actor-actor collision event.
+(define-method (on-collision (actor <actor>) (other-actor <actor>)
+                             hitbox other-hitbox)
+  #t)