From 6696a0b5fcb1b17895285d80d9636defb2df3f9d Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 10 Apr 2024 14:49:03 -0400
Subject: Sloppily refactor into modules.

---
 strigoform/math.scm | 144 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 144 insertions(+)
 create mode 100644 strigoform/math.scm

(limited to 'strigoform/math.scm')

diff --git a/strigoform/math.scm b/strigoform/math.scm
new file mode 100644
index 0000000..b769572
--- /dev/null
+++ b/strigoform/math.scm
@@ -0,0 +1,144 @@
+(library (strigoform math)
+  (export fmod
+          pi
+          pi/2
+          tau
+          do-circle
+          clamp
+          smoothstep
+          lerp
+
+          s32-ref
+          s32-set!
+          f64-ref
+          f64-set!
+
+          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!
+
+          make-rect
+          rect-x
+          rect-y
+          rect-w
+          rect-h
+          within?
+          rect-within?)
+  (import (scheme base)
+          (scheme inexact)
+          (only (hoot bytevectors)
+                bytevector-s32-native-ref
+                bytevector-s32-native-set!
+                bytevector-ieee-double-native-ref
+                bytevector-ieee-double-native-set!)
+          (strigoform type))
+
+  (define (assert-float x)
+    (unless (and (number? x) (inexact? x) (rational? x))
+      (error "expected inexact rational" x)))
+
+  (define (fmod x y)
+    (assert-float x)
+    (assert-float y)
+    (- x (* (truncate (/ x y)) y)))
+
+  (define pi (* 4.0 (atan 1.0)))
+  (define pi/2 (/ pi 2.0))
+  (define tau (* pi 2.0))
+
+  (define (do-circle proc k)
+    (do ((i 0 (+ i 1)))
+        ((= i k))
+      (proc (* tau (inexact (/ i k))))))
+
+  (define (clamp x min max)
+    (cond ((< x min) min)
+          ((> x max) max)
+          (else x)))
+
+  (define (smoothstep t)
+    (* t t (- 3.0 (* 2.0 t))))
+
+  (define (lerp start end alpha)
+    (+ (* start (- 1.0 alpha))
+       (* end alpha)))
+
+  (define s32-ref bytevector-s32-native-ref)
+  (define s32-set! bytevector-s32-native-set!)
+  (define f64-ref bytevector-ieee-double-native-ref)
+  (define f64-set! bytevector-ieee-double-native-set!)
+
+  (define-type vec2
+    make-vec2
+    vec2?
+    (bv vec2-bv set-vec2-bv!))
+  (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)))
+
+  (define (make-rect x y w h)
+    (let ((r (make-bytevector (* 8 4))))
+      (f64-set! r 0 x)
+      (f64-set! r 8 y)
+      (f64-set! r 16 w)
+      (f64-set! r 24 h)
+      r))
+  (define (rect-x r)
+    (f64-ref r 0))
+  (define (rect-y r)
+    (f64-ref r 8))
+  (define (rect-w r)
+    (f64-ref r 16))
+  (define (rect-h r)
+    (f64-ref r 24))
+
+  (define (within? x y rx ry rw rh)
+    (and (>= x rx)
+         (>= y ry)
+         (< x (+ rx rw))
+         (< y (+ ry rh))))
+  (define (rect-within? ax ay aw ah bx by bw bh)
+    (let ((ax* (+ ax aw))
+          (ay* (+ ay ah)))
+      (or (within? ax ay bx by bw bh)
+          (within? ax* ay bx by bw bh)
+          (within? ax* ay* bx by bw bh)
+          (within? ax ay* bx by bw bh)))))
-- 
cgit v1.2.3