Define lots of built-in types and fix outputs form.

1 files changed, 190 insertions, 207 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index dcddfb9..2f7cf69 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -123,9 +123,9 @@
     ((vertex)
      ;; GL 4+ has more built-ins, but we are supporting GL 2+ so we
      ;; can't use them easily.
-     (memq name '(gl-position gl-point-size gl-clip-distance)))
+     (memq name '(vertex:position vertex:point-size vertex:clip-distance)))
     ((fragment)
-     (memq name '(gl-frag-depth gl-sample-mask)))))
+     (memq name '(vertex:frag-depth)))))
 
 
 ;;;
@@ -1069,177 +1069,6 @@
                 a))
   (append a* b*))
 
-;; (define add/sub-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 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 vec4-type))
-;;          (function-type (list vec4-type mat4-type)
-;;                         (list vec4-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
-;;          (function-type (list int-type int-type)
-;;                         (list bool-type))
-;;          (function-type (list float-type float-type)
-;;                         (list bool-type)))))
-
-;; (define make-vec2-type
-;;   (list (function-type (list float-type float-type)
-;;                        (list vec2-type))))
-
-;; (define make-vec3-type
-;;   (list (overload-type
-;;          (function-type (list float-type float-type float-type)
-;;                         (list vec3-type))
-;;          (function-type (list vec2-type float-type)
-;;                         (list vec3-type))
-;;          (function-type (list float-type vec2-type)
-;;                         (list vec3-type)))))
-
-;; (define make-vec4-type
-;;   (list (overload-type
-;;          (function-type (list float-type float-type float-type float-type)
-;;                         (list vec4-type))
-;;          (function-type (list vec2-type float-type float-type)
-;;                         (list vec4-type))
-;;          (function-type (list float-type vec2-type float-type)
-;;                         (list vec4-type))
-;;          (function-type (list float-type float-type vec2-type)
-;;                         (list vec4-type))
-;;          (function-type (list vec3-type float-type)
-;;                         (list vec4-type))
-;;          (function-type (list float-type vec3-type)
-;;                         (list vec4-type)))))
-
-;; (define abs-type
-;;   (list (overload-type
-;;          (function-type (list int-type) (list int-type))
-;;          (function-type (list float-type) (list float-type)))))
-
-;; (define sqrt-type
-;;   (list (overload-type
-;;          (function-type (list int-type) (list int-type))
-;;          (function-type (list float-type) (list float-type)))))
-
-;; (define min/max-type
-;;   (list (overload-type
-;;          (function-type (list int-type int-type) (list int-type))
-;;          (function-type (list float-type float-type) (list float-type)))))
-
-;; (define trigonometry-type
-;;   (list (function-type (list float-type) (list float-type))))
-
-;; (define clamp/mix-type
-;;   (list (overload-type
-;;          (function-type (list int-type int-type int-type)
-;;                         (list int-type))
-;;          (function-type (list float-type float-type float-type)
-;;                         (list float-type)))))
-
-(define (top-level-type-env stage)
-  '()
-  ;; `((+ . ,add/sub-type)
-  ;;   (- . ,add/sub-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)
-  ;;   (not ,(function-type (list bool-type) (list bool-type)))
-  ;;   (int->float ,(function-type (list int-type) (list float-type)))
-  ;;   (float->int ,(function-type (list float-type) (list int-type)))
-  ;;   (abs . ,abs-type)
-  ;;   (sqrt . ,sqrt-type)
-  ;;   (min . ,min/max-type)
-  ;;   (max . ,min/max-type)
-  ;;   (sin . ,trigonometry-type)
-  ;;   (cos . ,trigonometry-type)
-  ;;   (tan . ,trigonometry-type)
-  ;;   (clamp . ,clamp/mix-type)
-  ;;   (mix . ,clamp/mix-type)
-  ;;   ,@(case stage
-  ;;       ((vertex)
-  ;;        `((gl-position ,vec4-type)))
-  ;;       ((fragment)
-  ;;        `((texture-2d ,(function-type (list sampler-2d-type vec2-type)
-  ;;                                      (list vec4-type)))))))
-  )
-
 (define (lookup-type name env)
   (let ((type (lookup name env)))
     (if (for-all-type? type)
@@ -1282,6 +1111,9 @@
          (cons pred (loop rest))))))
   `(list ,@preds*))
 
+(define (predicate:= a b)
+  `(= ,a ,b))
+
 (define (predicate:substitute from to)
   `(substitute ,from ,to))
 
@@ -1309,9 +1141,6 @@
           #t
           preds))
 
-(define (compose-predicates-for-types types)
-  (compose-predicates* (map predicate-for-type types)))
-
 ;; Produces a simplified predicate and a new set of substitutions for
 ;; predicates that have been satisfied and simplified to #t.  It's a
 ;; bit of a weird process since we're dealing with partial evaluation,
@@ -1828,10 +1657,19 @@
 (define (infer:outputs names exps env)
   (define-values (exps* exp-subs exp-pred)
     (infer:list exps env))
+  (define exp-types (map texp-types exps*))
+  (define unify-subs
+    (unify (map texp-types exps*)
+           (map (lambda (name)
+                  (lookup name env))
+                names)))
+  ;; Eval predicate.
+  (define-values (pred combined-subs)
+    (eval-predicate* exp-pred (compose-substitutions exp-subs unify-subs)))
   (values (texp (map single-type exps*)
                 `(outputs ,@(map list names exps*)))
-          exp-subs
-          exp-pred))
+          combined-subs
+          pred))
 
 (define (infer:top-level bindings body env)
   (define (infer-bindings bindings texps subs pred)
@@ -1861,7 +1699,7 @@
          bindings))
   (define type-names
     (map (match-lambda
-           (((or 'in 'out) type-name _) type-name)
+           (((? top-level-qualifier?) type-name _) type-name)
            (_ #f))
          bindings))
   (define-values (exps exp-subs exp-pred)
@@ -1884,7 +1722,7 @@
                      (compose-substitutions exp-subs body-subs)))
   (define bindings*
     (map (match-lambda*
-           (((and (or 'in 'out) qualifier) type-name name _)
+           (((? top-level-qualifier? qualifier) type-name name _)
             (list qualifier type-name name))
            (('function _ name exp)
             `(function ,name ,exp)))
@@ -1922,30 +1760,176 @@
      (infer:top-level bindings body env))
     (_ (error "unknown form" exp))))
 
-(define (make-test-env)
-  (extend-env
-   '+
-   (list (let ((a (fresh-type-variable))
-               (b (fresh-type-variable))
-               (c (fresh-type-variable)))
-           (for-all-type
-            (list a b c)
-            (function-type (list a b) (list c))
-            `(or (and (= ,a ,int-type)
-                      (= ,b ,int-type)
-                      (substitute ,c ,a))
-
-                 (and (= ,a ,float-type)
-                      (= ,b ,float-type)
-                      (substitute ,c ,a))
-                 ))))
-   (empty-env)))
+(define add/sub-type
+  (let ((a (fresh-type-variable)))
+    (list (for-all-type
+           (list a)
+           (function-type (list a a) (list a))
+           (predicate:or
+            (predicate:= a int-type)
+            (predicate:= a float-type)
+            (predicate:= a vec2-type)
+            (predicate:= a vec3-type)
+            (predicate:= a vec4-type)
+            (predicate:= a mat3-type)
+            (predicate:= a mat4-type))))))
+
+(define-syntax-rule (a+b->c (ta tb tc) ...)
+  (let ((a (fresh-type-variable))
+        (b (fresh-type-variable))
+        (c (fresh-type-variable)))
+    (list (for-all-type
+           (list a b c)
+           (function-type (list a b) (list c))
+           (predicate:or
+            (predicate:and (predicate:= a ta)
+                           (predicate:= b tb)
+                           (predicate:substitute c tc))
+            ...)))))
+
+(define mul-type
+  (a+b->c (int-type int-type int-type)
+          (float-type float-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 float-type mat3-type)
+          (float-type mat3-type mat3-type)
+          (mat4-type mat4-type mat4-type)
+          (mat4-type float-type mat4-type)
+          (float-type mat4-type mat4-type)))
+
+(define div-type
+  (a+b->c (int-type int-type int-type)
+          (float-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)))
+
+(define int->float-type
+  (list (function-type (list int-type) (list float-type))))
+
+(define float->int-type
+  (list (function-type (list float-type) (list int-type))))
+
+(define comparison-type
+  (let ((a (fresh-type-variable)))
+    (list (for-all-type
+           (list a)
+           (function-type (list a a) (list bool-type))
+           (predicate:or
+            (predicate:= a int-type)
+            (predicate:= a float-type))))))
+
+(define not-type
+  (list (function-type (list bool-type) (list bool-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 abs-type
+  (let ((a (fresh-type-variable)))
+    (list (for-all-type
+           (list a)
+           (function-type (list a) (list a))
+           (predicate:or
+            (predicate:= a int-type)
+            (predicate:= a float-type))))))
+
+(define sqrt-type
+  (let ((a (fresh-type-variable)))
+    (list (for-all-type
+           (list a)
+           (function-type (list a) (list a))
+           (predicate:or
+            (predicate:= a int-type)
+            (predicate:= a float-type))))))
+
+(define min/max-type
+  (let ((a (fresh-type-variable)))
+    (list (for-all-type
+           (list a)
+           (function-type (list a a) (list a))
+           (predicate:or
+            (predicate:= a int-type)
+            (predicate:= a float-type))))))
+
+(define trigonometry-type
+  (list (function-type (list float-type) (list float-type))))
+
+(define clamp/mix-type
+  (let ((a (fresh-type-variable)))
+    (list (for-all-type
+           (list a)
+           (function-type (list a a) (list a))
+           (predicate:or
+            (predicate:= a int-type)
+            (predicate:= a float-type))))))
+
+(define texture-2d-ref-type
+  (list (function-type (list sampler-2d-type vec2-type)
+                       (list vec4-type))))
+
+(define (top-level-type-env stage)
+  `((+ . ,add/sub-type)
+    (- . ,add/sub-type)
+    (* . ,mul-type)
+    (/ . ,div-type)
+    (int->float . ,int->float-type)
+    (float->int . ,float->int-type)
+    (= . ,comparison-type)
+    (< . ,comparison-type)
+    (<= . ,comparison-type)
+    (> . ,comparison-type)
+    (>= . ,comparison-type)
+    (not . ,not-type)
+    (vec2 . ,make-vec2-type)
+    (vec3 . ,make-vec3-type)
+    (vec4 . ,make-vec4-type)
+    (abs . ,abs-type)
+    (sqrt . ,sqrt-type)
+    (min . ,min/max-type)
+    (max . ,min/max-type)
+    (sin . ,trigonometry-type)
+    (cos . ,trigonometry-type)
+    (tan . ,trigonometry-type)
+    (clamp . ,clamp/mix-type)
+    (mix . ,clamp/mix-type)
+    ,@(case stage
+        ((vertex)
+         `((vertex:position ,vec4-type)
+           (vertex:point-size ,float-type)
+           (vertex:clip-distance ,float-type)))
+        ((fragment)
+         `((fragment:depth ,float-type)
+           (texture-2d . ,texture-2d-ref-type))))))
 
 ;; TODO: Add some kind of context object that is threaded through the
 ;; inference process so that when a type error occurs we can show the
 ;; expression that caused it.
 (define (infer-types exp stage)
-  (infer-exp exp (make-test-env)))
+  (infer-exp exp (top-level-type-env stage)))
 
 
 ;;;
@@ -2006,7 +1990,8 @@
                            (define func*
                              (apply-substitutions-to-exp func subs))
                            `(function ,name (t (,type*) ,func*)))
-                         (possible-substitutions (for-all-type-predicate type)))
+                         (delete-duplicates
+                          (possible-substitutions (for-all-type-predicate type))))
                     (loop rest)))
            ((binding . rest)
             (cons binding (loop rest))))))
@@ -2212,11 +2197,10 @@
   (display "}\n" port))
 
 (define %built-in-output-map
-  '((gl-position . gl_Position)
-    (gl-point-size . gl_PointSize)
-    (gl-clip-distance . gl_ClipDistance)
-    (gl-frag-depth . gl_FragDepth)
-    (gl-sample-mask . gl_SampleMask)))
+  '((vertex:position . gl_Position)
+    (vertex:point-size . gl_PointSize)
+    (vertex:clip-distance . gl_ClipDistance)
+    (fragment:depth . gl_FragDepth)))
 
 (define (emit:outputs names exps version port level)
   (define (output-name name)
@@ -2226,7 +2210,7 @@
                 ((temp)
                  (indent level port)
                  (format port "~a = ~a;\n"
-                         (output-name (texp-exp name))
+                         (output-name name)
                          temp))))
             names exps))
 
@@ -2279,6 +2263,5 @@
            (hoisted (hoist-functions* propagated))
            (inferred (infer-types hoisted stage))
            (resolved (resolve-overloads inferred)))
-      (pretty-print inferred)
       (pretty-print resolved)
       (emit-glsl resolved version port))))