1 files changed, 124 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull/utils.scm b/chickadee/graphics/seagull/utils.scm
new file mode 100644
index 0000000..af155a6
--- /dev/null
+++ b/chickadee/graphics/seagull/utils.scm
@@ -0,0 +1,124 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; 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.
+
+(define-module (chickadee graphics seagull utils)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (language cps intmap)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (float?
+            sourcev->string
+            stage:vertex
+            stage:fragment
+            shader-stage?
+            vertex-stage?
+            fragment-stage?
+
+            environment?
+            fresh-environment
+            environment
+            bound?
+            lookup
+            extend
+            compose-environments
+
+            intmap->alist
+            alist->intmap))
+
+(define (float? x)
+  (and (number? x) (inexact? x)))
+
+(define (sourcev->string sourcev)
+  (match sourcev
+    (#f
+     "unknown location")
+    (#(#f line column)
+     (format #f "unknown:~a:~a" line column))
+    (#(file line column)
+     (format #f "~a:~a:~a" file line column))))
+
+
+;;;
+;;; Shader stages
+;;;
+
+(define-record-type <shader-stage>
+  (shader-stage name)
+  shader-stage?
+  (name shader-stage-name))
+
+(define stage:vertex (shader-stage 'vertex))
+(define stage:fragment (shader-stage 'fragment))
+
+(define (vertex-stage? obj)
+  (eq? obj stage:vertex))
+
+(define (fragment-stage? obj)
+  (eq? obj stage:fragment))
+
+
+;;;
+;;; Environments
+;;;
+
+;; Environments provide a lookup table.  Used for lexical scoping,
+;; alpha conversion, etc.
+(define-record-type <environment>
+  (make-environment bindings)
+  environment?
+  (bindings environment-bindings))
+
+(define (fresh-environment)
+  (make-environment '()))
+
+(define-syntax-rule (environment (key value) ...)
+  (make-environment (list (cons 'key value) ...)))
+
+(define (lookup name env)
+  (assq-ref (environment-bindings env) name))
+
+(define (bound? name env)
+  (not (not (lookup name env))))
+
+(define (extend name value env)
+  (make-environment
+    (alist-cons name value (environment-bindings env))))
+
+(define (compose-environments . envs)
+  (match envs
+    ((a b)
+     (make-environment
+       (append (environment-bindings a)
+               (environment-bindings b))))
+    (_
+     (make-environment
+       (concatenate
+        (map environment-bindings envs))))))
+
+
+;;;
+;;; Intmap helpers
+;;;
+
+(define (intmap->alist intmap)
+  (intmap-fold-right alist-cons intmap '()))
+
+(define (alist->intmap alist)
+  (fold (lambda (pair intmap)
+          (match pair
+            ((k . v)
+             (intmap-add intmap k v))))
+        empty-intmap alist))