summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm191
1 files changed, 87 insertions, 104 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 8409503..b2058d0 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -491,6 +491,9 @@
(and (seagull-primitive? primitive)
(memq stage (seagull-primitive-stages primitive)))))
+(define-syntax-rule (-> (params ...) (returns ...))
+ (function-type (list params ...) (list returns ...)))
+
(define-syntax overload
(syntax-rules (->)
((_ ((var types ...) ...) (-> (args ...) (returns ...)))
@@ -536,11 +539,10 @@
...))))))
(define-seagull-primitive +
- #:type
- (overload ((a type:int type:float
- type:vec2 type:vec3 type:vec4
- type:mat3 type:mat4))
- (-> (a a) (a)))
+ #:type (overload ((a type:int type:float
+ type:vec2 type:vec3 type:vec4
+ type:mat3 type:mat4))
+ (-> (a a) (a)))
#:proc +
#:expand
(lambda (args stage env)
@@ -553,11 +555,10 @@
#:emit (make-infix-emitter '+))
(define-seagull-primitive -
- #:type
- (overload ((a type:int type:float
- type:vec2 type:vec3 type:vec4
- type:mat3 type:mat4))
- (-> (a a) (a)))
+ #:type (overload ((a type:int type:float
+ type:vec2 type:vec3 type:vec4
+ type:mat3 type:mat4))
+ (-> (a a) (a)))
#:proc -
#:expand
(lambda (args stage env)
@@ -571,26 +572,25 @@
#:emit (make-infix-emitter '-))
(define-seagull-primitive *
- #:type
- (a+b->c (type:int type:int type:int)
- (type:float type:float type:float)
- (type:int type:float type:float)
- (type:float type:int 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:vec3 type:vec3)
- (type:vec3 type:mat3 type:vec3)
- (type:mat4 type:mat4 type:mat4)
- (type:mat4 type:vec4 type:vec4)
- (type:vec4 type:mat4 type:vec4))
+ #:type (a+b->c (type:int type:int type:int)
+ (type:float type:float type:float)
+ (type:int type:float type:float)
+ (type:float type:int 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:vec3 type:vec3)
+ (type:vec3 type:mat3 type:vec3)
+ (type:mat4 type:mat4 type:mat4)
+ (type:mat4 type:vec4 type:vec4)
+ (type:vec4 type:mat4 type:vec4))
#:proc *
#:expand
(lambda (args stage env)
@@ -603,19 +603,18 @@
#:emit (make-infix-emitter '*))
(define-seagull-primitive /
- #:type
- (a+b->c (type:int type:int type:int)
- (type:float type:float type:float)
- (type:float type:int type:float)
- (type:int 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 (a+b->c (type:int type:int type:int)
+ (type:float type:float type:float)
+ (type:float type:int type:float)
+ (type:int 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))
;; The division of two integers can result in a rational,
;; non-integer, such as 1/2. This isn't how integer division works
;; in GLSL, so we need to round the result to an integer.
@@ -643,38 +642,35 @@
#:emit (make-infix-emitter '/))
(define-seagull-primitive mod
- #:type
- (a+b->c (type:float type:float type:float)
- (type:int type:int type:float)
- (type:vec2 type:vec2 type:vec2)
- (type:vec3 type:vec3 type:vec3)
- (type:vec4 type:vec4 type:vec4)
- (type:vec2 type:float type:vec2)
- (type:vec3 type:float type:vec3)
- (type:vec4 type:float type:vec4))
+ #:type (a+b->c (type:float type:float type:float)
+ (type:int type:int type:float)
+ (type:vec2 type:vec2 type:vec2)
+ (type:vec3 type:vec3 type:vec3)
+ (type:vec4 type:vec4 type:vec4)
+ (type:vec2 type:float type:vec2)
+ (type:vec3 type:float type:vec3)
+ (type:vec4 type:float type:vec4))
#:proc mod)
(define-seagull-primitive floor
- #:type
- (overload ((a type:float type:vec2 type:vec3 type:vec4))
- (-> (a) (a)))
+ #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+ (-> (a) (a)))
#:proc floor)
(define-seagull-primitive ceiling
#:glsl-name 'ceil
- #:type
- (overload ((a type:float type:vec2 type:vec3 type:vec4))
- (-> (a) (a)))
+ #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+ (-> (a) (a)))
#:proc ceiling)
(define-seagull-primitive int->float
#:glsl-name 'float
- #:type (function-type (list type:int) (list type:float))
+ #:type (-> (type:int) (type:float))
#:proc exact->inexact)
(define-seagull-primitive float->int
#:glsl-name 'int
- #:type (function-type (list type:float) (list type:int))
+ #:type (-> (type:float) (type:int))
#:proc (compose inexact->exact floor))
(define-syntax define-comparison-primitive
@@ -698,7 +694,7 @@
(define-seagull-primitive not
#:glsl-name '!
- #:type (function-type (list type:bool) (list type:bool))
+ #:type (-> (type:bool) (type:bool))
#:emit
(lambda (args port)
(match args
@@ -706,40 +702,31 @@
(format port "!(~a)" a)))))
(define-seagull-primitive vec2
- #:type
- (function-type (list type:float type:float)
- (list type:vec2)))
+ #:type (-> (type:float type:float) (type:vec2)))
(define-seagull-primitive vec3
- #:type
- (function-type (list type:float type:float type:float)
- (list type:vec3)))
+ #:type (-> (type:float type:float type:float) (type:vec3)))
(define-seagull-primitive vec4
- #:type
- (function-type (list type:float type:float type:float type:float)
- (list type:vec4)))
+ #:type (-> (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))
- (-> (a) (type:float))))
+ #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+ (-> (a) (type:float))))
(define-seagull-primitive abs
- #:type
- (overload ((a type:int type:float))
- (-> (a) (a)))
+ #:type (overload ((a type:int type:float))
+ (-> (a) (a)))
#:proc abs)
(define-seagull-primitive sqrt
- #:type (function-type (list type:float) (list type:float))
+ #:type (-> (type:float) (type:float))
#:proc sqrt)
(define-seagull-primitive expt
#:glsl-name 'pow
- #:type
- (overload ((a type:float type:vec2 type:vec3 type:vec4))
- (-> (a a) (a)))
+ #:type (overload ((a type:float type:vec2 type:vec3 type:vec4))
+ (-> (a a) (a)))
#:proc expt)
(define-seagull-primitive min
@@ -751,49 +738,45 @@
#:proc min)
(define-seagull-primitive sin
- #:type (function-type (list type:float) (list type:float))
+ #:type (-> (type:float) (type:float))
#:proc sin)
(define-seagull-primitive cos
- #:type (function-type (list type:float) (list type:float))
+ #:type (-> (type:float) (type:float))
#:proc cos)
(define-seagull-primitive tan
- #:type (function-type (list type:float) (list type:float))
+ #:type (-> (type:float) (type:float))
#:proc tan)
(define-seagull-primitive clamp
#:type (overload ((a type:int type:float)) (-> (a a a) (a))))
(define-seagull-primitive mix
- #:type
- (overload ((a type:int type:float type:vec2 type:vec3 type:vec4))
- (-> (a a type:float) (a))))
+ #:type (overload ((a type:int type:float type:vec2 type:vec3 type:vec4))
+ (-> (a a type:float) (a))))
(define-seagull-primitive step
- #:type
- (a+b->c (type:float type:float type:float)
- (type:vec2 type:vec2 type:vec2)
- (type:vec3 type:vec3 type:vec3)
- (type:vec4 type:vec4 type:vec4)
- (type:float type:vec2 type:vec2)
- (type:float type:vec3 type:vec3)
- (type:float type:vec4 type:vec4)))
+ #:type (a+b->c (type:float type:float type:float)
+ (type:vec2 type:vec2 type:vec2)
+ (type:vec3 type:vec3 type:vec3)
+ (type:vec4 type:vec4 type:vec4)
+ (type:float type:vec2 type:vec2)
+ (type:float type:vec3 type:vec3)
+ (type:float type:vec4 type:vec4)))
(define-seagull-primitive smoothstep
- #:type
- (a+b+c->d (type:float type:float type:float type:float)
- (type:vec2 type:vec2 type:vec2 type:vec2)
- (type:vec3 type:vec3 type:vec3 type:vec3)
- (type:vec4 type:vec4 type:vec4 type:vec4)
- (type:float type:float type:vec2 type:vec2)
- (type:float type:float type:vec3 type:vec3)
- (type:float type:float type:vec4 type:vec4)))
+ #:type (a+b+c->d (type:float type:float type:float type:float)
+ (type:vec2 type:vec2 type:vec2 type:vec2)
+ (type:vec3 type:vec3 type:vec3 type:vec3)
+ (type:vec4 type:vec4 type:vec4 type:vec4)
+ (type:float type:float type:vec2 type:vec2)
+ (type:float type:float type:vec3 type:vec3)
+ (type:float type:float type:vec4 type:vec4)))
(define-seagull-primitive texture
#:stages '(fragment)
- #:type (function-type (list type:sampler-2d type:vec2)
- (list type:vec4)))
+ #:type (-> (type:sampler-2d type:vec2) (type:vec4)))
;;;