summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--chickadee/graphics/9-patch.scm2
-rw-r--r--chickadee/graphics/particles.scm2
-rw-r--r--chickadee/graphics/path.scm10
-rw-r--r--chickadee/graphics/seagull.scm65
-rw-r--r--chickadee/graphics/sprite.scm4
5 files changed, 67 insertions, 16 deletions
diff --git a/chickadee/graphics/9-patch.scm b/chickadee/graphics/9-patch.scm
index 21a5c18..7bd63ac 100644
--- a/chickadee/graphics/9-patch.scm
+++ b/chickadee/graphics/9-patch.scm
@@ -47,7 +47,7 @@
(out vec2 frag-distance)
(uniform mat4 mvp)
(outputs
- (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+ (vertex:position (* mvp (vec4 position 0.0 1.0)))
(frag-distance distance)))
(define-fragment-shader 9-patch-fragment
diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm
index cd627bd..cef76fa 100644
--- a/chickadee/graphics/particles.scm
+++ b/chickadee/graphics/particles.scm
@@ -114,7 +114,7 @@ indefinitely."
(tw (/ 1.0 animation-columns))
(th (/ 1.0 animation-rows)))
(outputs
- (vertex:position (* mvp (vec4 (-> p x) (-> p y) 0.0 1.0)))
+ (vertex:position (* mvp (vec4 p 0.0 1.0)))
(frag-tex (+ (vec2 tx ty) (* tex (vec2 tw th))))
(frag-t t))))
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 9fb859d..11f6343 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -1235,7 +1235,7 @@
(outputs
(vertex:position (vec4 0.0 0.0 0.0 1.0)))
(outputs
- (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+ (vertex:position (* mvp (vec4 position 0.0 1.0)))
(frag-tex tex)
(frag-stroke-length stroke-length))))
@@ -1301,11 +1301,9 @@
(if (<= (-> color w) 0.0)
(outputs
(vertex:position (vec4 0.0 0.0 0.0 1.0)))
- (let* ((x (-> position x))
- (y (-> position y))
- (fp (* gradient-matrix (vec3 x y 1.0))))
+ (let ((fp (* gradient-matrix (vec3 position 1.0))))
(outputs
- (vertex:position (* mvp (vec4 x y 0.0 1.0)))
+ (vertex:position (* mvp (vec4 position 0.0 1.0)))
(frag-position (vec2 (-> fp x) (-> fp y)))))))
(define-fragment-shader fill-fragment
@@ -1336,7 +1334,7 @@
(vec2 1.0 radial-gradient-ratio))))
(gradient-mix (length p))))
(else
- (vec4 0.0 0.0 0.0 0.0)))))))
+ (vec4 0.0)))))))
(define-graphics-variable fill-shader
(compile-shader fill-vertex fill-fragment))
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index fd5be5b..9dc6cb1 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -41,7 +41,6 @@
;; - Loops
;; - User defined structs
;; - Better error messages (especially around type predicate failure)
-;; - Overloaded functions with multiple arities
;; - Helper function modules
;; - Shader composition
;; - Interpreter
@@ -300,6 +299,22 @@
(match type
(('-> _ returns) returns)))
+;; Function case types:
+;;
+;; For GLSL primitives that support multiple arities.
+(define (function-case-type cases)
+ `(case-> ,cases))
+
+(define (function-case-type? obj)
+ (match obj
+ (('case-> _) #t)
+ (_ #f)))
+
+(define (function-case-type-ref type arity)
+ (match type
+ (('case-> cases)
+ (assv-ref cases arity))))
+
;; Type schemes:
(define (type-scheme quantifiers type)
`(type-scheme ,quantifiers ,type))
@@ -338,6 +353,7 @@
(or (primitive-type? obj)
(variable-type? obj)
(function-type? obj)
+ (function-case-type? obj)
(struct-type? obj)
(outputs-type? obj)))
@@ -788,6 +804,9 @@
(define-syntax-rule (-> (params ...) (returns ...))
(function-type (list params ...) (list returns ...)))
+(define-syntax-rule (->case (arity type) ...)
+ (function-case-type `((arity . ,type) ...)))
+
(define-syntax overload
(syntax-rules (->)
((_ ((var types ...) ...) (-> (args ...) (returns ...)))
@@ -1035,13 +1054,27 @@
(format port "!(~a)" a)))))
(define-seagull-primitive vec2
- #:type (-> (type:float type:float) (type:vec2)))
+ #:type (->case
+ (1 (-> (type:float) (type:vec2)))
+ (2 (-> (type:float type:float) (type:vec2)))))
(define-seagull-primitive vec3
- #:type (-> (type:float type:float type:float) (type:vec3)))
+ #:type (->case
+ (1 (-> (type:float) (type:vec3)))
+ (2 (a+b->c (type:float type:vec2 type:vec3)
+ (type:vec2 type:float type:vec3)))
+ (3 (-> (type:float type:float type:float) (type:vec3)))))
(define-seagull-primitive vec4
- #:type (-> (type:float type:float type:float type:float) (type:vec4)))
+ #:type (->case
+ (1 (-> (type:float) (type:vec4)))
+ (2 (a+b->c (type:vec2 type:vec2 type:vec4)
+ (type:vec3 type:float type:vec4)
+ (type:float type:vec3 type:vec4)))
+ (3 (a+b+c->d (type:vec2 type:float type:float type:vec4)
+ (type:float type:vec2 type:float type:vec4)
+ (type:float type:float type:vec2 type:vec4)))
+ (4 (-> (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))
@@ -2403,12 +2436,32 @@
`(lambda ,params ,body*))
subs predicate:succeed))
+(define (check-arity type arity)
+ (define (arity-error)
+ (seagull-type-error "wrong number of arguments"
+ (list type arity) check-arity))
+ (cond
+ ((function-type? type)
+ (if (= (length (function-type-parameters type)) arity)
+ type
+ (arity-error)))
+ ((function-case-type? type)
+ (let ((function (function-case-type-ref type arity)))
+ (or function (arity-error))))
+ ;; TODO: We aren't actually checking arity here.
+ ((type-scheme? type)
+ type)
+ ((type? type)
+ (seagull-type-error "expected a function" (list type) check-arity))))
+
(define (infer:primitive-call operator args env)
(define primitive (lookup-seagull-primitive operator))
;; Primitive functions may be overloaded and need to be instantiated
;; with fresh type variables.
- (define-values (operator-type operator-pred)
- (maybe-instantiate (seagull-primitive-type primitive)))
+ (define-values (operator-type operator-pred)
+ (maybe-instantiate
+ (check-arity (seagull-primitive-type primitive)
+ (length args))))
;; Infer the arguments.
(define-values (args* arg-subs arg-pred)
(infer:list args env))
diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm
index 414738d..85033d7 100644
--- a/chickadee/graphics/sprite.scm
+++ b/chickadee/graphics/sprite.scm
@@ -63,7 +63,7 @@
(out vec2 frag-tex)
(uniform mat4 mvp)
(outputs
- (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+ (vertex:position (* mvp (vec4 position 0.0 1.0)))
(frag-tex tex)))
(define-fragment-shader sprite-fragment
@@ -172,7 +172,7 @@ BLEND-MODE."
(out vec4 frag-tint)
(uniform mat4 mvp)
(outputs
- (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
+ (vertex:position (* mvp (vec4 position 0.0 1.0)))
(frag-tex tex)
(frag-tint tint)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-12-22 20:49:05 +0000