From 4461d61bb13fbc9ac2ea3a5ecc09c90434653ec3 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 25 Feb 2023 13:21:17 -0500
Subject: Implement n-ary comparison operators.

---
 chickadee/graphics/seagull.scm | 44 +++++++++++++++++++++++++++++++++++++++---
 1 file 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 >)
-- 
cgit v1.2.3