1 files changed, 113 insertions, 0 deletions
diff --git a/catbird/camera.scm b/catbird/camera.scm
new file mode 100644
index 0000000..ad7425c
--- /dev/null
+++ b/catbird/camera.scm
@@ -0,0 +1,113 @@
+(define-module (catbird camera)
+  #:use-module (catbird config)
+  #:use-module (catbird mixins)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math matrix)
+  #:use-module (chickadee math rect)
+  #:use-module (chickadee math vector)
+  #:use-module (oop goops)
+  #:export (<camera>
+            projection-matrix
+            view-matrix
+            width
+            height
+            current-camera
+
+            <camera-2d>
+            view-bounding-box
+            move-to
+            move-by
+
+            <camera-3d>
+            field-of-vision
+            near-clip
+            far-clip
+            direction
+            up))
+
+(define-root-class <camera> ()
+  (width #:accessor width #:init-keyword #:width)
+  (height #:accessor height #:init-keyword #:height)
+  (projection-matrix #:getter projection-matrix #:init-thunk make-identity-matrix4)
+  (view-matrix #:getter view-matrix #:init-thunk make-identity-matrix4))
+
+(define-generic refresh-projection)
+(define-generic refresh-view)
+
+(define-method (initialize (camera <camera>) args)
+  (next-method)
+  (refresh-projection camera)
+  (refresh-view camera))
+
+(define current-camera (make-parameter #f))
+
+
+;;;
+;;; 2D Camera
+;;;
+
+(define-class <camera-2d> (<camera> <movable-2d>)
+  (view-bounding-box #:accessor view-bounding-box #:init-thunk make-null-rect))
+
+(define-method (initialize (camera <camera-2d>) initargs)
+  (next-method)
+  (let ((bb (view-bounding-box camera)))
+    (set-rect-width! bb (width camera))
+    (set-rect-height! bb (height camera))))
+
+(define-method (refresh-projection (camera <camera-2d>))
+  (orthographic-projection! (projection-matrix camera)
+                            0.0 (width camera)
+                            (height camera) 0.0
+                            0.0 1.0))
+
+(define-method (refresh-view (camera <camera-2d>))
+  (let ((p (position camera))
+        (bb (view-bounding-box camera)))
+    (matrix4-translate! (view-matrix camera) p)
+    (set-rect-x! bb (vec2-x p))
+    (set-rect-y! bb (vec2-y p))))
+
+(define-method (move-to (camera <camera-2d>) p)
+  (vec2-copy! p (position camera))
+  (refresh-view camera))
+
+(define-method (move-by (camera <camera-2d>) d)
+  (vec2-add! (position camera) d)
+  (refresh-view camera))
+
+
+;;;
+;;; 3D Camera
+;;;
+
+(define-class <camera-3d> (<camera> <movable-3d>)
+  (field-of-vision #:getter field-of-vision #:init-keyword #:field-of-vision
+                   #:init-value (degrees->radians 60))
+  (near-clip #:getter near-clip #:init-keyword #:near-clip #:init-value 0.1)
+  (far-clip #:getter far-clip #:init-keyword #:far-clip #:init-value 5.0)
+  (direction #:getter direction #:init-keyword #:direction
+             #:init-form (vec3 0.0 0.0 -1.0))
+  (up #:getter up #:init-keyword #:up
+      #:init-form (vec3 0.0 1.0 0.0)))
+
+(define-method (refresh-projection (camera <camera-3d>))
+  (perspective-projection! (projection-matrix camera)
+                           (field-of-vision camera)
+                           (/ (width camera) (height camera))
+                           (near-clip camera)
+                           (far-clip camera)))
+
+(define-method (refresh-view (camera <camera-3d>))
+  (look-at! (view-matrix camera)
+            (position camera)
+            (direction camera)
+            (up camera)))
+
+(define-method (move-to (camera <camera-3d>) p)
+  (vec3-copy! p (position camera))
+  (refresh-view camera))
+
+(define-method (move-by (camera <camera-3d>) d)
+  (vec3-add! (position camera) d)
+  (refresh-view camera))