1 files changed, 129 insertions, 0 deletions
diff --git a/strigoform/level.scm b/strigoform/level.scm
new file mode 100644
index 0000000..f735049
--- /dev/null
+++ b/strigoform/level.scm
@@ -0,0 +1,129 @@
+(library (strigoform level)
+  (export tile-width
+          tile-height
+
+          make-level-object
+          level-object?
+          level-object-x
+          level-object-type
+          level-object-properties
+
+          make-level
+          level?
+          level-height
+          level-foreground
+          level-collision
+          level-objects
+          level-update!
+          draw-level-foreground
+
+          rect-collides-with-level?)
+  (import (scheme base)
+          (hoot match)
+          (strigoform assets)
+          (strigoform canvas)
+          (strigoform game-area)
+          (strigoform math)
+          (strigoform type))
+
+  ;; action id, sprite sheet offset, x, y
+  (define %tile-size (+ 4 8 8 8))
+  (define tile-width 16.0)
+  (define tile-height 16.0)
+  (define level-width 15)
+
+  (define-type level-object
+    make-level-object
+    level-object?
+    (x level-object-x set-level-object-x!)
+    (type level-object-type set-level-object-type!)
+    (properties level-object-properties set-level-object-properties!))
+
+  (define-type level
+    make-level
+    level?
+    (height level-height set-level-height!)
+    (foreground level-foreground set-level-foreground!)
+    (collision level-collision set-level-collision!)
+    (objects level-objects set-level-objects!))
+
+  (define (level-offset x y)
+    (+ (* level-width y) x))
+
+  (define (point-collides-with-level? level x y)
+    (match level
+      (#('level height foreground collision objects)
+       (let ((tx (exact (truncate (/ x tile-width))))
+             (ty (exact (truncate (/ y tile-height)))))
+         (and (>= tx 0) (< tx level-width)
+              (>= ty 0) (< tx height)
+              (= (bytevector-u8-ref collision (level-offset tx ty)) 1))))))
+
+  (define (rect-collides-with-level? level x y w h scroll)
+    (match level
+      (#('level height foreground collision objects)
+       (let* ((y (+ y (- (* height tile-height) game-height scroll)))
+              (tx0 (exact (truncate (/ x tile-width))))
+              (ty0 (exact (truncate (/ y tile-height))))
+              (tx1 (exact (truncate (/ (+ x w) tile-width))))
+              (ty1 (exact (truncate (/ (+ y h) tile-height)))))
+         (define (occupied? x y)
+           (and (>= x 0) (< x level-width)
+                (>= y 0) (< x height)
+                (= (bytevector-u8-ref collision (level-offset x y)) 1)))
+         (or (occupied? tx0 ty0)
+             (occupied? tx1 ty0)
+             (occupied? tx1 ty1)
+             (occupied? tx0 ty1))))))
+
+  (define (draw-level-layer context level layer parallax scroll)
+    (match level
+      (#('level height _ _ _)
+       (let* ((tw tile-width)
+              (th tile-height)
+              (scroll (* scroll parallax))
+              (pixel-y-offset (- (* height th) scroll game-height))
+              (scroll-y-offset (- height (exact (truncate (/ scroll tile-height)))))
+              (y-start (clamp (- scroll-y-offset 21) 0 height))
+              (y-end (clamp scroll-y-offset 0 height)))
+         (do ((y y-start (+ y 1)))
+             ((= y y-end))
+           (let* ((row (vector-ref layer y))
+                  (k (/ (bytevector-length row) 16))
+                  (ty (* y tile-height)))
+             (do ((x 0 (+ x 1)))
+                 ((= x k))
+               (let* ((offset (* x 16))
+                      (tx (f64-ref row offset))
+                      (ix (f64-ref row (+ offset 8))))
+                 (draw-image context image:map
+                             ix 0.0 tw th
+                             tx (- ty pixel-y-offset) tw th)))))))))
+
+  (define (draw-level-foreground context level scroll)
+    (match level
+      (#('level height foreground collision objects)
+       (draw-level-layer context level foreground 1.0 scroll))))
+
+  (define (level-update! level scroll last-row-scanned do-action)
+    (match level
+      (#('level height foreground collision objects)
+       (let ((row (max
+                   (exact
+                    (truncate
+                     (/ (- (* height tile-height)
+                           game-height scroll)
+                        tile-height)))
+                   0)))
+         (do ((y row (+ y 1)))
+             ((= y last-row-scanned))
+           (for-each (lambda (obj)
+                       (match obj
+                         (#('level-object x type properties)
+                          (let ((x* (+ (* x tile-width)
+                                       (/ tile-width 2.0)))
+                                (y* (+ (* (- y row 1) tile-height)
+                                       (/ tile-height 2.0))))
+                            (do-action type x* y* properties)))))
+                     (vector-ref objects y)))
+         row)))))