From 8be55a844debe4fa152d86a2d7db42d0059a8bf3 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Fri, 24 Feb 2023 08:12:51 -0500
Subject: Add -> convenience macro.

---
 chickadee/graphics/seagull.scm | 191 +++++++++++++++++++----------------------
 1 file changed, 87 insertions(+), 104 deletions(-)

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 8409503..b2058d0 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -491,6 +491,9 @@
     (and (seagull-primitive? primitive)
          (memq stage (seagull-primitive-stages primitive)))))
 
+(define-syntax-rule (-> (params ...) (returns ...))
+  (function-type (list params ...) (list returns ...)))
+
 (define-syntax overload
   (syntax-rules (->)
     ((_ ((var types ...) ...) (-> (args ...) (returns ...)))
@@ -536,11 +539,10 @@
          ...))))))
 
 (define-seagull-primitive +
-  #:type
-  (overload ((a type:int type:float
-                type:vec2 type:vec3 type:vec4
-                type:mat3 type:mat4))
-            (-> (a a) (a)))
+  #:type (overload ((a type:int type:float
+                       type:vec2 type:vec3 type:vec4
+                       type:mat3 type:mat4))
+                   (-> (a a) (a)))
   #:proc +
   #:expand
   (lambda (args stage env)
@@ -553,11 +555,10 @@
   #:emit (make-infix-emitter '+))
 
 (define-seagull-primitive -
-  #:type
-  (overload ((a type:int type:float
-                type:vec2 type:vec3 type:vec4
-                type:mat3 type:mat4))
-            (-> (a a) (a)))
+  #:type (overload ((a type:int type:float
+                       type:vec2 type:vec3 type:vec4
+                       type:mat3 type:mat4))
+                   (-> (a a) (a)))
   #:proc -
   #:expand
   (lambda (args stage env)
@@ -571,26 +572,25 @@
   #:emit (make-infix-emitter '-))
 
 (define-seagull-primitive *
-  #:type
-  (a+b->c (type:int type:int type:int)
-          (type:float type:float type:float)
-          (type:int type:float type:float)
-          (type:float type:int type:float)
-          (type:vec2 type:vec2 type:vec2)
-          (type:vec2 type:float type:vec2)
-          (type:float type:vec2 type:vec2)
-          (type:vec3 type:vec3 type:vec3)
-          (type:vec3 type:float type:vec3)
-          (type:float type:vec3 type:vec3)
-          (type:vec4 type:vec4 type:vec4)
-          (type:vec4 type:float type:vec4)
-          (type:float type:vec4 type:vec4)
-          (type:mat3 type:mat3 type:mat3)
-          (type:mat3 type:vec3 type:vec3)
-          (type:vec3 type:mat3 type:vec3)
-          (type:mat4 type:mat4 type:mat4)
-          (type:mat4 type:vec4 type:vec4)
-          (type:vec4 type:mat4 type:vec4))
+  #:type (a+b->c (type:int type:int type:int)
+                 (type:float type:float type:float)
+                 (type:int type:float type:float)
+                 (type:float type:int type:float)
+                 (type:vec2 type:vec2 type:vec2)
+                 (type:vec2 type:float type:vec2)
+                 (type:float type:vec2 type:vec2)
+                 (type:vec3 type:vec3 type:vec3)
+                 (type:vec3 type:float type:vec3)
+                 (type:float type:vec3 type:vec3)
+                 (type:vec4 type:vec4 type:vec4)
+                 (type:vec4 type:float type:vec4)
+                 (type:float type:vec4 type:vec4)
+                 (type:mat3 type:mat3 type:mat3)
+                 (type:mat3 type:vec3 type:vec3)
+                 (type:vec3 type:mat3 type:vec3)
+                 (type:mat4 type:mat4 type:mat4)
+                 (type:mat4 type:vec4 type:vec4)
+                 (type:vec4 type:mat4 type:vec4))
   #:proc *
   #:expand
   (lambda (args stage env)
@@ -603,19 +603,18 @@
   #:emit (make-infix-emitter '*))
 
 (define-seagull-primitive /
-  #:type
-  (a+b->c (type:int type:int type:int)
-          (type:float type:float type:float)
-          (type:float type:int type:float)
-          (type:int type:float type:float)
-          (type:vec2 type:vec2 type:vec2)
-          (type:vec2 type:float type:vec2)
-          (type:vec3 type:vec3 type:vec3)
-          (type:vec3 type:float type:vec3)
-          (type:vec4 type:vec4 type:vec4)
-          (type:vec4 type:float type:vec4)
-          (type:mat3 type:float type:mat3)
-          (type:mat4 type:float type:mat4))
+  #:type (a+b->c (type:int type:int type:int)
+                 (type:float type:float type:float)
+                 (type:float type:int type:float)
+                 (type:int type:float type:float)
+                 (type:vec2 type:vec2 type:vec2)
+                 (type:vec2 type:float type:vec2)
+                 (type:vec3 type:vec3 type:vec3)
+                 (type:vec3 type:float type:vec3)
+                 (type:vec4 type:vec4 type:vec4)
+                 (type:vec4 type:float type:vec4)
+                 (type:mat3 type:float type:mat3)
+                 (type:mat4 type:float type:mat4))
   ;; The division of two integers can result in a rational,
   ;; non-integer, such as 1/2.  This isn't how integer division works
   ;; in GLSL, so we need to round the result to an integer.
@@ -643,38 +642,35 @@
   #:emit (make-infix-emitter '/))
 
 (define-seagull-primitive mod
-  #:type
-  (a+b->c (type:float type:float type:float)
-          (type:int type:int type:float)
-          (type:vec2 type:vec2 type:vec2)
-          (type:vec3 type:vec3 type:vec3)
-          (type:vec4 type:vec4 type:vec4)
-          (type:vec2 type:float type:vec2)
-          (type:vec3 type:float type:vec3)
-          (type:vec4 type:float type:vec4))
+  #:type (a+b->c (type:float type:float type:float)
+                 (type:int type:int type:float)
+                 (type:vec2 type:vec2 type:vec2)
+                 (type:vec3 type:vec3 type:vec3)
+                 (type:vec4 type:vec4 type:vec4)
+                 (type:vec2 type:float type:vec2)
+                 (type:vec3 type:float type:vec3)
+                 (type:vec4 type:float type:vec4))
   #:proc mod)
 
 (define-seagull-primitive floor
-  #:type
-  (overload ((a type:float type:vec2 type:vec3 type:vec4))
-            (-> (a) (a)))
+  #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+                   (-> (a) (a)))
   #:proc floor)
 
 (define-seagull-primitive ceiling
   #:glsl-name 'ceil
-  #:type
-  (overload ((a type:float type:vec2 type:vec3 type:vec4))
-            (-> (a) (a)))
+  #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+                   (-> (a) (a)))
   #:proc ceiling)
 
 (define-seagull-primitive int->float
   #:glsl-name 'float
-  #:type (function-type (list type:int) (list type:float))
+  #:type (-> (type:int) (type:float))
   #:proc exact->inexact)
 
 (define-seagull-primitive float->int
   #:glsl-name 'int
-  #:type (function-type (list type:float) (list type:int))
+  #:type (-> (type:float) (type:int))
   #:proc (compose inexact->exact floor))
 
 (define-syntax define-comparison-primitive
@@ -698,7 +694,7 @@
 
 (define-seagull-primitive not
   #:glsl-name '!
-  #:type (function-type (list type:bool) (list type:bool))
+  #:type (-> (type:bool) (type:bool))
   #:emit
   (lambda (args port)
     (match args
@@ -706,40 +702,31 @@
        (format port "!(~a)" a)))))
 
 (define-seagull-primitive vec2
-  #:type
-  (function-type (list type:float type:float)
-                 (list type:vec2)))
+  #:type (-> (type:float type:float) (type:vec2)))
 
 (define-seagull-primitive vec3
-  #:type
-  (function-type (list type:float type:float type:float)
-                 (list type:vec3)))
+  #:type (-> (type:float type:float type:float) (type:vec3)))
 
 (define-seagull-primitive vec4
-  #:type
-  (function-type (list type:float type:float type:float type:float)
-                 (list type:vec4)))
+  #:type (-> (type:float type:float type:float type:float) (type:vec4)))
 
 (define-seagull-primitive length
-  #:type
-  (overload ((a type:float type:vec2 type:vec3 type:vec4))
-            (-> (a) (type:float))))
+  #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+                   (-> (a) (type:float))))
 
 (define-seagull-primitive abs
-  #:type
-  (overload ((a type:int type:float))
-            (-> (a) (a)))
+  #:type (overload ((a type:int type:float))
+                   (-> (a) (a)))
   #:proc abs)
 
 (define-seagull-primitive sqrt
-  #:type (function-type (list type:float) (list type:float))
+  #:type (-> (type:float) (type:float))
   #:proc sqrt)
 
 (define-seagull-primitive expt
   #:glsl-name 'pow
-  #:type
-  (overload ((a type:float type:vec2 type:vec3 type:vec4))
-            (-> (a a) (a)))
+  #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+                   (-> (a a) (a)))
   #:proc expt)
 
 (define-seagull-primitive min
@@ -751,49 +738,45 @@
   #:proc min)
 
 (define-seagull-primitive sin
-  #:type (function-type (list type:float) (list type:float))
+  #:type (-> (type:float) (type:float))
   #:proc sin)
 
 (define-seagull-primitive cos
-  #:type (function-type (list type:float) (list type:float))
+  #:type (-> (type:float) (type:float))
   #:proc cos)
 
 (define-seagull-primitive tan
-  #:type (function-type (list type:float) (list type:float))
+  #:type (-> (type:float) (type:float))
   #:proc tan)
 
 (define-seagull-primitive clamp
   #:type (overload ((a type:int type:float)) (-> (a a a) (a))))
 
 (define-seagull-primitive mix
-  #:type
-  (overload ((a type:int type:float type:vec2 type:vec3 type:vec4))
-            (-> (a a type:float) (a))))
+  #:type (overload ((a type:int type:float type:vec2 type:vec3 type:vec4))
+                   (-> (a a type:float) (a))))
 
 (define-seagull-primitive step
-  #:type
-  (a+b->c (type:float type:float type:float)
-          (type:vec2 type:vec2 type:vec2)
-          (type:vec3 type:vec3 type:vec3)
-          (type:vec4 type:vec4 type:vec4)
-          (type:float type:vec2 type:vec2)
-          (type:float type:vec3 type:vec3)
-          (type:float type:vec4 type:vec4)))
+  #:type (a+b->c (type:float type:float type:float)
+                 (type:vec2 type:vec2 type:vec2)
+                 (type:vec3 type:vec3 type:vec3)
+                 (type:vec4 type:vec4 type:vec4)
+                 (type:float type:vec2 type:vec2)
+                 (type:float type:vec3 type:vec3)
+                 (type:float type:vec4 type:vec4)))
 
 (define-seagull-primitive smoothstep
-  #:type
-  (a+b+c->d (type:float type:float type:float type:float)
-            (type:vec2 type:vec2 type:vec2 type:vec2)
-            (type:vec3 type:vec3 type:vec3 type:vec3)
-            (type:vec4 type:vec4 type:vec4 type:vec4)
-            (type:float type:float type:vec2 type:vec2)
-            (type:float type:float type:vec3 type:vec3)
-            (type:float type:float type:vec4 type:vec4)))
+  #:type (a+b+c->d (type:float type:float type:float type:float)
+                   (type:vec2 type:vec2 type:vec2 type:vec2)
+                   (type:vec3 type:vec3 type:vec3 type:vec3)
+                   (type:vec4 type:vec4 type:vec4 type:vec4)
+                   (type:float type:float type:vec2 type:vec2)
+                   (type:float type:float type:vec3 type:vec3)
+                   (type:float type:float type:vec4 type:vec4)))
 
 (define-seagull-primitive texture
   #:stages '(fragment)
-  #:type (function-type (list type:sampler-2d type:vec2)
-                        (list type:vec4)))
+  #:type (-> (type:sampler-2d type:vec2) (type:vec4)))
 
 
 ;;;
-- 
cgit v1.2.3