First commit!

modules/math/rect.scm

@@ -0,0 +1,96 @@
+;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; Commentary:
+;;;
+;;; Rectangle data type.
+;;;
+;;; Code:
+
+(define-module (math rect)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module ((hoot bytevectors)
+                #:select
+                (bytevector-ieee-double-native-ref
+                 bytevector-ieee-double-native-set!))
+  #:export (make-rect
+            rect?
+            rect-x
+            rect-y
+            rect-width
+            rect-height
+            set-rect-x!
+            set-rect-y!
+            set-rect-width!
+            set-rect-height!
+            rect-intersects?
+            rect-clip))
+
+;; For speed, a rect is a wrapper around a bytevector so that we can
+;; use unboxed floats.
+(define-record-type <rect>
+  (%make-rect bv)
+  rect?
+  (bv rect-bv))
+
+(define f64-ref  bytevector-ieee-double-native-ref)
+(define f64-set! bytevector-ieee-double-native-set!)
+
+(define (make-rect x y w h)
+  (let ((bv (make-bytevector (* 8 4))))
+    (f64-set! bv 0 x)
+    (f64-set! bv 8 y)
+    (f64-set! bv 16 w)
+    (f64-set! bv 24 h)
+    (%make-rect bv)))
+
+(define (rect-x r)
+  (f64-ref (rect-bv r) 0))
+
+(define (rect-y r)
+  (f64-ref (rect-bv r) 8))
+
+(define (rect-width r)
+  (f64-ref (rect-bv r) 16))
+
+(define (rect-height r)
+  (f64-ref (rect-bv r) 24))
+
+(define (set-rect-x! r x)
+  (f64-set! (rect-bv r) 0 x))
+
+(define (set-rect-y! r y)
+  (f64-set! (rect-bv r) 8 y))
+
+(define (set-rect-width! r width)
+  (f64-set! (rect-bv r) 16 width))
+
+(define (set-rect-height! r height)
+  (f64-set! (rect-bv r) 24 height))
+
+(define (rect-intersects? a b)
+  (and (< (rect-x a) (+ (rect-x b) (rect-width b)))
+       (< (rect-y a) (+ (rect-y b) (rect-height b)))
+       (> (+ (rect-x a) (rect-width a)) (rect-x b))
+       (> (+ (rect-y a) (rect-height a)) (rect-y b))))
+
+(define (rect-clip a b)
+  (let* ((x1 (max (rect-x a) (rect-x b)))
+         (x2 (min (+ (rect-x a) (rect-width a))
+                  (+ (rect-x b) (rect-width b))))
+         (y1 (max (rect-y a) (rect-y b)))
+         (y2 (min (+ (rect-y a) (rect-height a))
+                  (+ (rect-y b) (rect-height b)))))
+    (make-rect x1 y1 (- x2 x1) (- y2 y1))))

modules/math/vector.scm

@@ -0,0 +1,94 @@
+;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+;;; Commentary:
+;;;
+;;; Vectors, in the linear algebra sense.
+;;;
+;;; Code:
+
+(define-module (math vector)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (scheme inexact)
+  #:use-module ((hoot bytevectors)
+                #:select
+                (bytevector-ieee-double-native-ref
+                 bytevector-ieee-double-native-set!))
+  #:use-module (math)
+  #:export (vec2
+            vec2?
+            vec2-x
+            vec2-y
+            set-vec2-x!
+            set-vec2-y!
+            vec2-add!
+            vec2-sub!
+            vec2-mul-scalar!
+            vec2-magnitude
+            vec2-normalize!
+            vec2-clamp!))
+
+;; For speed, a vec2 is a wrapper around a bytevector so that we can
+;; use unboxed floats.
+(define-record-type <vec2>
+  (make-vec2 bv)
+  vec2?
+  (bv vec2-bv))
+
+(define f64-ref  bytevector-ieee-double-native-ref)
+(define f64-set! bytevector-ieee-double-native-set!)
+
+(define (vec2 x y)
+  (let ((v (make-vec2 (make-bytevector 16))))
+    (set-vec2-x! v x)
+    (set-vec2-y! v y)
+    v))
+
+(define (vec2-x v)
+  (f64-ref (vec2-bv v) 0))
+
+(define (vec2-y v)
+  (f64-ref (vec2-bv v) 8))
+
+(define (set-vec2-x! v x)
+  (f64-set! (vec2-bv v) 0 x))
+
+(define (set-vec2-y! v y)
+  (f64-set! (vec2-bv v) 8 y))
+
+(define (vec2-add! v w)
+  (set-vec2-x! v (+ (vec2-x v) (vec2-x w)))
+  (set-vec2-y! v (+ (vec2-y v) (vec2-y w))))
+
+(define (vec2-sub! v w)
+  (set-vec2-x! v (- (vec2-x v) (vec2-x w)))
+  (set-vec2-y! v (- (vec2-y v) (vec2-y w))))
+
+(define (vec2-mul-scalar! v x)
+  (set-vec2-x! v (* (vec2-x v) x))
+  (set-vec2-y! v (* (vec2-y v) x)))
+
+(define (vec2-magnitude v)
+  (sqrt (+ (* (vec2-x v) (vec2-x v)) (* (vec2-y v) (vec2-y v)))))
+
+(define (vec2-normalize! v)
+  (unless (and (= (vec2-x v) 0.0) (= (vec2-y v) 0.0))
+    (let ((m (vec2-magnitude v)))
+      (set-vec2-x! v (/ (vec2-x v) m))
+      (set-vec2-y! v (/ (vec2-y v) m)))))
+
+(define (vec2-clamp! v xmin ymin xmax ymax)
+  (set-vec2-x! v (clamp (vec2-x v) xmin xmax))
+  (set-vec2-y! v (clamp (vec2-y v) ymin ymax)))