Add support for more primitives.

1 files changed, 129 insertions, 46 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index d5b2cc6..9403f37 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -72,8 +72,12 @@
   (or (arithmetic-operator? x)
       (comparison-operator? x)))
 
+(define (vector-constructor? x)
+  (memq x '(vec2 vec3 vec4)))
+
 (define (primitive-call? x)
-  (binary-operator? x))
+  (or (binary-operator? x)
+      (vector-constructor? x)))
 
 (define (difference a b)
   (match a
@@ -413,7 +417,7 @@
      (propagate:let names exps body env))
     (('primcall (and (or '+ '- '* '/) op) x y)
      (propagate:arithmetic op x y env))
-    (('primcall operator args)
+    (('primcall operator args ...)
      (propagate:primcall operator args env))
     (('call operator args ...)
      (propagate:call operator args env))))
@@ -672,20 +676,77 @@
          (function-type (list int-type int-type)
                         (list int-type))
          (function-type (list float-type float-type)
-                        (list float-type)))))
-
-;; a, b -> c
-;; int, int -> int
-;; float, float -> float
-;; vec2, vec2 -> vec2
-;; vec3, vec3 -> vec3
-;; vec4, vec4 -> vec4
-;; mat3, mat3 -> mat3
-;; vec3, mat3 -> mat3
-;; mat3, vec3 -> mat3
-;; mat4, mat4 -> mat4
-;; vec4, mat4 -> mat4
-;; mat4, vec4 -> mat4
+                        (list float-type))
+         (function-type (list vec2-type vec2-type)
+                        (list vec2-type))
+         (function-type (list vec3-type vec3-type)
+                        (list vec3-type))
+         (function-type (list vec4-type vec4-type)
+                        (list vec4-type))
+         (function-type (list mat3-type mat3-type)
+                        (list mat3-type))
+         (function-type (list mat4-type mat4-type)
+                        (list mat4-type)))))
+
+(define mul-type
+  (list (overload-type
+         (function-type (list int-type int-type)
+                        (list int-type))
+         (function-type (list float-type float-type)
+                        (list float-type))
+         (function-type (list vec2-type vec2-type)
+                        (list vec2-type))
+         (function-type (list vec2-type float-type)
+                        (list vec2-type))
+         (function-type (list float-type vec2-type)
+                        (list vec2-type))
+         (function-type (list vec3-type vec3-type)
+                        (list vec3-type))
+         (function-type (list vec3-type float-type)
+                        (list vec3-type))
+         (function-type (list float-type vec3-type)
+                        (list vec3-type))
+         (function-type (list vec4-type vec4-type)
+                        (list vec4-type))
+         (function-type (list vec4-type float-type)
+                        (list vec4-type))
+         (function-type (list float-type vec4-type)
+                        (list vec4-type))
+         (function-type (list mat3-type mat3-type)
+                        (list mat3-type))
+         (function-type (list mat3-type vec3-type)
+                        (list mat3-type))
+         (function-type (list vec3-type mat3-type)
+                        (list mat3-type))
+         (function-type (list mat4-type mat4-type)
+                        (list mat4-type))
+         (function-type (list mat4-type vec4-type)
+                        (list mat4-type))
+         (function-type (list vec4-type mat4-type)
+                        (list mat4-type)))))
+
+(define div-type
+  (list (overload-type
+         (function-type (list int-type int-type)
+                        (list int-type))
+         (function-type (list float-type float-type)
+                        (list float-type))
+         (function-type (list vec2-type vec2-type)
+                        (list vec2-type))
+         (function-type (list vec2-type float-type)
+                        (list vec2-type))
+         (function-type (list vec3-type vec3-type)
+                        (list vec3-type))
+         (function-type (list vec3-type float-type)
+                        (list vec3-type))
+         (function-type (list vec4-type vec4-type)
+                        (list vec4-type))
+         (function-type (list vec4-type float-type)
+                        (list vec4-type))
+         (function-type (list mat3-type float-type)
+                        (list mat3-type))
+         (function-type (list mat4-type float-type)
+                        (list mat4-type)))))
 
 (define comparison-type
   (list (overload-type
@@ -694,24 +755,31 @@
          (function-type (list float-type float-type)
                         (list bool-type)))))
 
-;; (define (top-level-type-env)
-;;   `(;; (+ . ,(list (function-type (list int-type int-type)
-;;     ;;                            (list int-type))))
-;;     (+ . ,arithmetic-type)
-;;     (- . ,arithmetic-type)
-;;     (* . ,arithmetic-type)
-;;     (/ . ,arithmetic-type)
-;;     (= . ,comparison-type)
-;;     (< . ,comparison-type)
-;;     (<= . ,comparison-type)
-;;     (> . ,comparison-type)
-;;     (>= . ,comparison-type)))
+(define make-vec2-type
+  (list (function-type (list float-type float-type)
+                       (list vec2-type))))
+
+(define make-vec3-type
+  (list (function-type (list float-type float-type float-type)
+                       (list vec3-type))))
+
+(define make-vec4-type
+  (list (function-type (list float-type float-type float-type float-type)
+                       (list vec4-type))))
 
 (define (top-level-type-env)
   `((+ . ,add/sub-type)
     (- . ,add/sub-type)
-    (* . (,(function-type (list int-type int-type) (list int-type))))
-    (/ . (,(function-type (list int-type int-type) (list int-type))))))
+    (* . ,mul-type)
+    (/ . ,div-type)
+    (= . ,comparison-type)
+    (< . ,comparison-type)
+    (<= . ,comparison-type)
+    (> . ,comparison-type)
+    (>= . ,comparison-type)
+    (vec2 . ,make-vec2-type)
+    (vec3 . ,make-vec3-type)
+    (vec4 . ,make-vec4-type)))
 
 (define (occurs? a b)
   (cond
@@ -829,14 +897,13 @@
              env)))
 
 (define (generalize type env)
-  (pk 'generalize type
-      (if (function-type? type)
-          (match (difference (free-variables-in-type type)
-                             (free-variables-in-env env))
-            (() type)
-            ((quantifiers ...)
-             (for-all-type quantifiers type)))
-          type)))
+  (if (function-type? type)
+      (match (difference (free-variables-in-type type)
+                         (free-variables-in-env env))
+        (() type)
+        ((quantifiers ...)
+         (for-all-type quantifiers type)))
+      type))
 
 (define (instantiate for-all)
   (define subs
@@ -844,8 +911,7 @@
             (extend-env var (fresh-type-variable) env))
           (empty-env)
           (for-all-type-quantifiers for-all)))
-  (pk 'instantiate for-all
-      (apply-substitutions-to-type (for-all-type-ref for-all) subs)))
+  (apply-substitutions-to-type (for-all-type-ref for-all) subs))
 
 (define (fresh-type-variables-for-list lst)
   (map (lambda (_x) (fresh-type-variable)) lst))
@@ -955,7 +1021,7 @@
                        #f
                        (cons from to))))
                 a))
-  (pk 'compose a b (append a* b*)))
+  (append a* b*))
 
 (define unify-prompt-tag (make-prompt-tag 'unify))
 
@@ -1344,6 +1410,20 @@
   (emit:declarations (texp-types body) let-temps body-temps port level)
   let-temps)
 
+(define (emit:primcall type operator args port level)
+  (define arg-temps
+    (map (lambda (arg)
+           (single-temp (emit-glsl arg port level)))
+         args))
+  (define output-temp (unique-identifier))
+  (indent level port)
+  (format port "~a ~a = ~a(~a);\n"
+          (type-name type)
+          output-temp
+          operator
+          (string-join (map symbol->string arg-temps) ", "))
+  (list output-temp))
+
 (define (emit:call types operator args port level)
   (define operator-name (single-temp (emit-glsl operator port)))
   (define arg-temps
@@ -1384,10 +1464,13 @@
      (emit:let types names exps body port level))
     (('t (type) ('primcall ('t _ (? binary-operator? op)) a b))
      (emit:binary-operator type op a b port level))
+    (('t (type) ('primcall ('t _ op) args ...))
+     (emit:primcall type op args port level))
     (('t types ('call operator args ...))
      (emit:call types operator args port level))
     (('t _ ('top-level (bindings ...) body))
-     (emit:top-level bindings body port level))))
+     (emit:top-level bindings body port level))
+    (_ (error "woopsies"))))
 
 
 ;;;
@@ -1408,8 +1491,8 @@
            (propagated (pk 'propagated (propagate-constants expanded (empty-env))))
            (hoisted (pk 'hoisted (hoist-functions* propagated)))
            (inferred (pk 'inferred (infer-types hoisted))))
-      ;; (display "*** BEGIN GLSL OUTPUT ***\n" port)
-      ;; (emit-glsl resolved port)
-      ;; (newline port)
-      ;; (display "*** END GLSL OUTPUT ***\n" port)
+      (display "*** BEGIN GLSL OUTPUT ***\n" port)
+      (emit-glsl inferred port)
+      (newline port)
+      (display "*** END GLSL OUTPUT ***\n" port)
       inferred)))