summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm44
1 files changed, 41 insertions, 3 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 0df9b89..8a61367 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)
-;; - n-ary comparison operators
;; - Overloaded functions with multiple arities
;; - Helper function modules
;; - Shader composition
@@ -753,20 +752,59 @@
#:type (-> (type:float) (type:int))
#:proc (compose inexact->exact floor))
+(define (make-comparison-expander name)
+ (lambda (args stage env)
+ (match args
+ (() #t)
+ ((x)
+ (expand `(let ((x* ,x)) (,name x* x*)) stage env))
+ ((x y)
+ `(primcall ,name ,(expand x stage env) ,(expand y stage env)))
+ ((x y . rest)
+ (expand `(let ((y* ,y))
+ (and (,name ,x y*)
+ ,(let loop ((rest rest)
+ (prev 'y*))
+ (match rest
+ ((z)
+ (list name prev z))
+ ((z . rest)
+ `(let ((z* ,z))
+ (and (,name ,prev z*)
+ ,(loop rest 'z*))))))))
+ stage env)))))
+
(define-syntax define-comparison-primitive
(syntax-rules ()
((_ name)
- (define-comparison-primitive name name))
+ (define-comparison-primitive name name
+ (make-comparison-expander 'name)))
((_ name glsl-name)
+ (define-comparison-primitive name glsl-name
+ (make-comparison-expander 'name)))
+ ((_ name glsl-name expand)
(define-seagull-primitive name
#:glsl-name 'glsl-name
#:type
(overload ((a type:int type:float))
(-> (a a) (type:bool)))
#:proc name
+ #:expand expand
#:emit (make-infix-emitter 'glsl-name)))))
-(define-comparison-primitive = ==)
+(define-comparison-primitive = ==
+ (lambda (args stage env)
+ (match args
+ (() #t)
+ ((x)
+ (expand `(let ((x* ,x)) (= x* x*)) stage env))
+ ((x y)
+ `(primcall = ,(expand x stage env) ,(expand y stage env)))
+ ((x . rest)
+ (expand `(let ((x* ,x))
+ (and ,@(map (lambda (y) `(= x* ,y)) rest)))
+ stage env)))))
+
(define-comparison-primitive <)
(define-comparison-primitive <=)
(define-comparison-primitive >)