summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-01-22 19:42:36 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commit361e58647b287f7898d750b9c3113acb4cb9e329 (patch)
treec0049ab392df6ee9887d34f615c34423e8f9445c
parentf8b136c3bd01898e220bfdd121388392870e18d9 (diff)
Add support for more primitives.
-rw-r--r--chickadee/graphics/seagull.scm175
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)))