From 24baf3f3b6e14fac2b3f376106184e1214b0dd6e Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 26 Feb 2023 11:34:11 -0500
Subject: Support primitives with multiple arities.

---
 chickadee/graphics/9-patch.scm   |  2 +-
 chickadee/graphics/particles.scm |  2 +-
 chickadee/graphics/path.scm      | 10 +++----
 chickadee/graphics/seagull.scm   | 65 ++++++++++++++++++++++++++++++++++++----
 chickadee/graphics/sprite.scm    |  4 +--
 5 files changed, 67 insertions(+), 16 deletions(-)

diff --git a/chickadee/graphics/9-patch.scm b/chickadee/graphics/9-patch.scm
index 21a5c18..7bd63ac 100644
--- a/chickadee/graphics/9-patch.scm
+++ b/chickadee/graphics/9-patch.scm
@@ -47,7 +47,7 @@
   (out vec2 frag-distance)
   (uniform mat4 mvp)
   (outputs
-   (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+   (vertex:position (* mvp (vec4 position 0.0 1.0)))
    (frag-distance distance)))
 
 (define-fragment-shader 9-patch-fragment
diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm
index cd627bd..cef76fa 100644
--- a/chickadee/graphics/particles.scm
+++ b/chickadee/graphics/particles.scm
@@ -114,7 +114,7 @@ indefinitely."
          (tw (/ 1.0 animation-columns))
          (th (/ 1.0 animation-rows)))
     (outputs
-     (vertex:position (* mvp (vec4 (-> p x) (-> p y) 0.0 1.0)))
+     (vertex:position (* mvp (vec4 p 0.0 1.0)))
      (frag-tex (+ (vec2 tx ty) (* tex (vec2 tw th))))
      (frag-t t))))
 
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 9fb859d..11f6343 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -1235,7 +1235,7 @@
       (outputs
        (vertex:position (vec4 0.0 0.0 0.0 1.0)))
       (outputs
-       (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+       (vertex:position (* mvp (vec4 position 0.0 1.0)))
        (frag-tex tex)
        (frag-stroke-length stroke-length))))
 
@@ -1301,11 +1301,9 @@
   (if (<= (-> color w) 0.0)
       (outputs
        (vertex:position (vec4 0.0 0.0 0.0 1.0)))
-      (let* ((x (-> position x))
-             (y (-> position y))
-             (fp (* gradient-matrix (vec3 x y 1.0))))
+      (let ((fp (* gradient-matrix (vec3 position 1.0))))
         (outputs
-         (vertex:position (* mvp (vec4 x y 0.0 1.0)))
+         (vertex:position (* mvp (vec4 position 0.0 1.0)))
          (frag-position (vec2 (-> fp x) (-> fp y)))))))
 
 (define-fragment-shader fill-fragment
@@ -1336,7 +1334,7 @@
                        (vec2 1.0 radial-gradient-ratio))))
              (gradient-mix (length p))))
           (else
-           (vec4 0.0 0.0 0.0 0.0)))))))
+           (vec4 0.0)))))))
 
 (define-graphics-variable fill-shader
   (compile-shader fill-vertex fill-fragment))
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index fd5be5b..9dc6cb1 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -41,7 +41,6 @@
 ;; - Loops
 ;; - User defined structs
 ;; - Better error messages (especially around type predicate failure)
-;; - Overloaded functions with multiple arities
 ;; - Helper function modules
 ;; - Shader composition
 ;; - Interpreter
@@ -300,6 +299,22 @@
   (match type
     (('-> _ returns) returns)))
 
+;; Function case types:
+;;
+;; For GLSL primitives that support multiple arities.
+(define (function-case-type cases)
+  `(case-> ,cases))
+
+(define (function-case-type? obj)
+  (match obj
+    (('case-> _) #t)
+    (_ #f)))
+
+(define (function-case-type-ref type arity)
+  (match type
+    (('case-> cases)
+     (assv-ref cases arity))))
+
 ;; Type schemes:
 (define (type-scheme quantifiers type)
   `(type-scheme ,quantifiers ,type))
@@ -338,6 +353,7 @@
   (or (primitive-type? obj)
       (variable-type? obj)
       (function-type? obj)
+      (function-case-type? obj)
       (struct-type? obj)
       (outputs-type? obj)))
 
@@ -788,6 +804,9 @@
 (define-syntax-rule (-> (params ...) (returns ...))
   (function-type (list params ...) (list returns ...)))
 
+(define-syntax-rule (->case (arity type) ...)
+  (function-case-type `((arity . ,type) ...)))
+
 (define-syntax overload
   (syntax-rules (->)
     ((_ ((var types ...) ...) (-> (args ...) (returns ...)))
@@ -1035,13 +1054,27 @@
        (format port "!(~a)" a)))))
 
 (define-seagull-primitive vec2
-  #:type (-> (type:float type:float) (type:vec2)))
+  #:type (->case
+          (1 (-> (type:float) (type:vec2)))
+          (2 (-> (type:float type:float) (type:vec2)))))
 
 (define-seagull-primitive vec3
-  #:type (-> (type:float type:float type:float) (type:vec3)))
+  #:type (->case
+          (1 (-> (type:float) (type:vec3)))
+          (2 (a+b->c (type:float type:vec2 type:vec3)
+                     (type:vec2 type:float type:vec3)))
+          (3 (-> (type:float type:float type:float) (type:vec3)))))
 
 (define-seagull-primitive vec4
-  #:type (-> (type:float type:float type:float type:float) (type:vec4)))
+  #:type (->case
+          (1 (-> (type:float) (type:vec4)))
+          (2 (a+b->c (type:vec2 type:vec2 type:vec4)
+                     (type:vec3 type:float type:vec4)
+                     (type:float type:vec3 type:vec4)))
+          (3 (a+b+c->d (type:vec2 type:float type:float type:vec4)
+                       (type:float type:vec2 type:float type:vec4)
+                       (type:float type:float type:vec2 type:vec4)))
+          (4 (-> (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))
@@ -2403,12 +2436,32 @@
                 `(lambda ,params ,body*))
           subs predicate:succeed))
 
+(define (check-arity type arity)
+  (define (arity-error)
+    (seagull-type-error "wrong number of arguments"
+                        (list type arity) check-arity))
+  (cond
+   ((function-type? type)
+    (if (= (length (function-type-parameters type)) arity)
+        type
+        (arity-error)))
+   ((function-case-type? type)
+    (let ((function (function-case-type-ref type arity)))
+      (or function (arity-error))))
+   ;; TODO: We aren't actually checking arity here.
+   ((type-scheme? type)
+    type)
+   ((type? type)
+    (seagull-type-error "expected a function" (list type) check-arity))))
+
 (define (infer:primitive-call operator args env)
   (define primitive (lookup-seagull-primitive operator))
   ;; Primitive functions may be overloaded and need to be instantiated
   ;; with fresh type variables.
- (define-values (operator-type operator-pred)
-    (maybe-instantiate (seagull-primitive-type primitive)))
+  (define-values (operator-type operator-pred)
+    (maybe-instantiate
+     (check-arity (seagull-primitive-type primitive)
+                  (length args))))
   ;; Infer the arguments.
   (define-values (args* arg-subs arg-pred)
     (infer:list args env))
diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm
index 414738d..85033d7 100644
--- a/chickadee/graphics/sprite.scm
+++ b/chickadee/graphics/sprite.scm
@@ -63,7 +63,7 @@
   (out vec2 frag-tex)
   (uniform mat4 mvp)
   (outputs
-   (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+   (vertex:position (* mvp (vec4 position 0.0 1.0)))
    (frag-tex tex)))
 
 (define-fragment-shader sprite-fragment
@@ -172,7 +172,7 @@ BLEND-MODE."
   (out vec4 frag-tint)
   (uniform mat4 mvp)
   (outputs
-   (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+   (vertex:position (* mvp (vec4 position 0.0 1.0)))
    (frag-tex tex)
    (frag-tint tint)))
 
-- 
cgit v1.2.3