diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 175 |
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))) |