From c751ca4c5a47c02224e2365756fbf66bdc2f62bb Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sat, 14 Nov 2020 13:45:13 +0900
Subject: wip16

---
 vikalpa.scm | 104 ++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 63 insertions(+), 41 deletions(-)

diff --git a/vikalpa.scm b/vikalpa.scm
index 2b68c41..bec7c61 100644
--- a/vikalpa.scm
+++ b/vikalpa.scm
@@ -173,72 +173,94 @@
               (environment (cdr x))))
         (else #f)))
 
+(define (traverse f expr acc context preconds fail)
+  (match-expr (lambda (ex1 ex2 a c ps fail)
+                (f ex1 a c ps fail))
+              expr
+              expr
+              acc
+              context
+              preconds
+              fail))
 
-(define (match-expr f context acc preconds expr1 expr2 fail)
+(define (match-expr f expr1 expr2 acc context preconds fail)
   (cond
    ((and (expr-quoted? expr1)
          (expr-quoted? expr2)
          (equal? expr1 expr2))
-    (f (cons '(quoted) context) acc preconds expr1 expr2 fail))
+    (f expr1 expr2 acc context preconds fail))
+   ((variable? expr1)
+    (f expr1 expr2 acc context preconds fail))
    ((and (expr-if? expr1)
          (expr-if? expr2))
-    (let*-values (((acc/test expr/test)
-                   (match-expr f '(if 1)
-                               acc
-                               preconds
+    (let*-values (((expr/test acc/test)
+                   (match-expr f
                                (expr-if-test expr1)
                                (expr-if-test expr2)
+                               acc
+                               (cons '(if 1) context)
+                               preconds
                                fail))
                   ((expr/then acc/then)
                    (match-expr f
-                               (cons '(if 2) context)
-                               acc/test
-                               (cons (expr-if-test expr2) preconds)
                                (expr-if-then expr1)
                                (expr-if-then expr2)
+                               acc/test
+                               (cons '(if 2) context)
+                               (cons (expr-if-test expr2) preconds)
                                fail))
-                  ((acc/else expr/else)
+                  ((expr/else acc/else)
                    (match-expr f
-                               (cons '(if 3) context)
+                               (expr-if-else expr1)
+                               (expr-if-else expr2)
                                acc/then
+                               (cons '(if 3) context)
                                (cons (expr-not (expr-if-test expr2))
                                      preconds)
-                               (expr-if-else expr1)
-                               (expr-if-else expr2)
                                fail)))
-      (values acc/else (expr-if expr/test expr/then expr/else))))
+      (values (expr-if expr/test expr/then expr/else)
+              acc/else)))
    ((and (form? expr1)
          (form? expr2)
          (eq? (form-name expr1)
               (form-name expr2)))
-    (let fold2 ((expr1-args (form-args expr1))
-                (expr2-args (form-args expr2))
-                (acc acc)
-                (i 1))
-      (cond ((and (null? expr1-args)
-                  (null? expr2-args))
-             (values acc '()))
-            ((and (pair? expr1-args)
-                  (pair? expr2-args))
-             (receive (first-acc first-expr)
-                 (match-expr f
-                             (cons `(,(form-name expr1) ,i) context)
-                             acc
-                             preconds
-                             (car expr1-args)
-                             (car expr2-args)
-                             fail)
-               (receive (rest-acc rest-expr)
-                   (fold2 (cdr expr1-args)
-                          (cdr expr2-args)
-                          first-acc
-                          (+ i 1))
-                 (values (cons first-expr rest-expr)
-                         rest-acc))))
-            (else
-             (fail context acc)))))
+    (receive (args-expr args-acc)
+        (let fold2 ((expr1-args (form-args expr1))
+                    (expr2-args (form-args expr2))
+                    (acc acc)
+                    (i 1))
+          (cond ((and (null? expr1-args)
+                      (null? expr2-args))
+                 (values '() acc))
+                ((and (pair? expr1-args)
+                      (pair? expr2-args))
+                 (receive (first-expr first-acc)
+                     (match-expr f
+                                 (car expr1-args)
+                                 (car expr2-args)
+                                 acc
+                                 (cons `(,(form-name expr1) ,i) context)
+                                 preconds
+                                 fail)
+                   (receive (rest-expr rest-acc)
+                       (fold2 (cdr expr1-args)
+                              (cdr expr2-args)
+                              first-acc
+                              (+ i 1))
+                     (values (cons first-expr rest-expr)
+                             rest-acc))))
+                (else
+                 (fail expr1
+                       expr2
+                       acc
+                       context))))
+      (values (cons (form-name expr1) args-expr)
+              args-acc)))
    (else
-    (fail context acc))))
+    (fail expr1
+          expr2
+          acc
+          context))))
 
 ;; (apply-rule preconds rule? expression?) -> (or (cons rhs environment) #f)
 (define (apply-rule preconds rl expr env)
-- 
cgit v1.2.3