1 files changed, 142 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull/primitives.scm b/chickadee/graphics/seagull/primitives.scm
new file mode 100644
index 0000000..dc74a5f
--- /dev/null
+++ b/chickadee/graphics/seagull/primitives.scm
@@ -0,0 +1,142 @@
+;;; 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 primitives)
+  #:use-module (chickadee graphics seagull base)
+  #:use-module (chickadee graphics seagull syntax)
+  #:use-module (chickadee graphics seagull types)
+  #:use-module (chickadee graphics seagull utils)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (make-primitive-operator
+            define-primitive-operator
+            lookup-primitive-operator
+            primitive-operator?
+            primitive-operator-name
+            primitive-operator-glsl-name
+            primitive-operator-stages
+            primitive-operator-arity
+            primitive-operator-expand
+            primitive-operator-infix?
+            primitive-operator-type))
+
+(define-record-type <primitive-operator>
+  (%make-primitive-operator name glsl-name stages arity expand infix? type)
+  primitive-operator?
+  (name primitive-operator-name)
+  (glsl-name primitive-operator-glsl-name)
+  (stages primitive-operator-stages)
+  (arity primitive-operator-arity)
+  (expand primitive-operator-expand)
+  (infix? primitive-operator-infix?)
+  (type primitive-operator-type))
+
+(define (make-default-expander name)
+  (lambda (args src expand)
+    (make-primitive-call src name (map expand args))))
+
+(define* (make-primitive-operator #:key name type proc arity
+                                  (glsl-name name)
+                                  (stages (list stage:vertex stage:fragment))
+                                  (expand (make-default-expander name))
+                                  infix?)
+  (%make-primitive-operator name glsl-name stages arity expand infix? type))
+
+(define *primitive-operators* (make-hash-table))
+
+(define (register-primitive-operator! primitive-operator)
+  (hashq-set! *primitive-operators*
+              (primitive-operator-name primitive-operator)
+              primitive-operator)
+  *unspecified*)
+
+(define (lookup-primitive-operator name)
+  (hashq-ref *primitive-operators* name))
+
+(define-syntax-rule (define-primitive-operator name args ...)
+  (register-primitive-operator!
+   (make-primitive-operator #:name 'name args ...)))
+
+(define int (lookup-type 'int))
+(define -> make-function-type)
+
+(define-primitive-operator +
+  #:arity 2
+  #:type (-> (list int int) (list int))
+  #:infix? #t
+  #:expand
+  (lambda (args src expand)
+    (let loop ((args args))
+      (match args
+        (()
+         (make-constant src 0))
+        ((n)
+         (expand n))
+        ((n . rest)
+         (make-primitive-call src '+ (list (expand n) (loop rest))))))))
+
+(define-primitive-operator -
+  #:arity 2
+  #:type (-> (list int int) (list int))
+  #:infix? #t
+  #:expand
+  (lambda (args src expand)
+    (let loop ((args args))
+      (match args
+        ((n) (make-primitive-call src '- (list (expand n) (make-constant src 0))))
+        ((m n)
+         (make-primitive-call src '- (list (expand m) (expand n))))
+        ((n . rest)
+         (make-primitive-call src '- (list (expand n) (loop rest))))))))
+
+(define-primitive-operator *
+  #:arity 2
+  #:type (-> (list int int) (list int))
+  #:infix? #t
+  #:expand
+  (lambda (args src expand)
+    (let loop ((args args))
+      (match args
+        (() (make-constant src 1))
+        ((n) (expand n))
+        ((n . rest)
+         (make-primitive-call src '* (list (expand n) (loop rest))))))))
+
+(define-primitive-operator /
+  #:arity 2
+  #:type (-> (list int int) (list int))
+  #:infix? #t
+  #:expand
+  (lambda (args src expand)
+    (match args
+      ((n)
+       (make-primitive-call src '/ (list (make-constant src 1) (expand n))))
+      ((m n)
+       (make-primitive-call src '/ (list (expand m) (expand n))))
+      ((m n . rest)
+       (let loop ((rest rest)
+                  (exp (make-primitive-call src '/ (list (expand m) (expand n)))))
+         (match rest
+           ((l)
+            (make-primitive-call src '/ (list exp (expand l))))
+           ((l . rest)
+            (loop rest (make-primitive-call src '/ (list exp (expand l)))))))))))
+
+(define-primitive-operator = #:arity 2 #:infix? #t)
+
+(define-primitive-operator vec2 #:arity 2)
+(define-primitive-operator vec3 #:arity 3)
+(define-primitive-operator vec4 #:arity 4)