From fec4fc36028ae1aa24f3720720820ea7a9283051 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sat, 7 Sep 2024 19:47:18 +0900
Subject: Refactor infix->prefix and prefix-infix procedures

---
 qklib/infix.scm | 245 +++++++++++++++++++++++---------------------------------
 1 file changed, 101 insertions(+), 144 deletions(-)

diff --git a/qklib/infix.scm b/qklib/infix.scm
index 7a897fd..553fb47 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -18,76 +18,48 @@
           current-operator-rule-set)
   (import (scheme base)
           (scheme case-lambda)
-          (only (srfi 1) car+cdr fold fold-right break! reverse! append-map append! append-map!)
+          (only (srfi 1) car+cdr fold break! reverse! append! append-map! append-reverse!)
           (only (srfi 26) cut cute)
-          (srfi 35)
           (qklib infix rule-set))
   (begin
     (define (make-default-operator-rule-set)
       (rule-set
        (list
+        (operator '= 0 'both)
         (operator '+ 1 'both (unit 0 #f #t))
         (operator '- 1 'left (unit 0 #t #t))
         (operator '* 2 'both (unit 1))
         (operator '/ 2 'left (unit 1 #t) (prefix '/))
-        (operator '^ 3 'right #f (prefix 'expt #f)))))
+        (operator '^ 3 'right #f (prefix 'expt #t)))))
 
     (define current-operator-rule-set
       (make-parameter (make-default-operator-rule-set)))
 
-    (define-condition-type &infix-error &error
-      infix-error?
-      (expr infix-error-expr))
-
     (define infix->prefix
       (case-lambda
         ((expr failure)
          (call/cc
           (lambda (return)
             (let ((rs (current-operator-rule-set)))
-              (map-all-list (cut infix->prefix-1 <> rs (lambda (e) (return (failure e))))
+              (map-all-list (cute infix->prefix-1 <> rs (lambda (e) (return (failure e))))
                             expr)))))
         ((expr)
          (infix->prefix expr (lambda (e) #f)))))
 
-    (define (map-all-list f expr)
-      (f (map-cars f expr)))
-
-    (define (map-cars f expr)
-      (if (pair? expr)
-          (if (pair? (car expr))
-              (cons (f (map-cars f (car expr)))
-                    (map-cars f (cdr expr)))
-              (cons (car expr)
-                    (map-cars f (cdr expr))))
-          expr))
-
-    (define (operator-unit-unary? op)
-      (cond ((operator-unit op) => unit-unary?)
-            (else #f)))
-
-    (define (operator-prefix-binary-only? op)
-      (cond ((operator-prefix op) => prefix-binary-only?)
-            (else #f)))
-
     (define (infix->prefix-1 expr rs fail)
-      (cond ((and (pair? expr)
-                  (single? expr))
-             (car expr))
-            ((and (pair? expr)
-                  (single? (cdr expr))
-                  (let ((op (rule-set-infix-ref rs (car expr))))
-                    (if (and op (operator-unit-unary? op))
-                        op
-                        #f)))
+      (cond ((and (pair? expr) (null? (cdr expr))) (car expr))
+            ((and (pair? expr) (null? (cdr (cdr expr)))
+                  (rule-set-infix-ref rs (car expr)))
              => (lambda (op)
-                  (let ((arg (car (cdr expr)))
-                        (unit (operator-unit op)))
-                    (if (rule-set-infix-ref rs arg)
-                        (fail expr)
-                        (if (unit-inv? unit)
-                            expr
-                            arg)))))
+                  (if (operator-unit-unary? op)
+                      (let ((arg (car (cdr expr)))
+                            (unit (operator-unit op)))
+                        (if (rule-set-infix-ref rs arg)
+                            (fail expr)
+                            (if (unit-inv? unit)
+                                expr
+                                arg)))
+                      (fail expr))))
             ((minimum-precedence expr rs)
              => (lambda (op)
                   (let ->prefix ((expr (list-copy expr))
@@ -98,64 +70,27 @@
                       (let ((left-op (minimum-precedence left rs))
                             (right-op (minimum-precedence right rs))
                             (not-binary-only? (not (operator-prefix-binary-only? op))))
-                        (cond ((and (operator? left-op) (operator? right-op))
-                               `(,(operator-prefix-symbol op)
-                                 ,@(if (and not-binary-only?
-                                            (operator-left? op)
-                                            (eqv? (operator-symbol op) (operator-symbol left-op)))
-                                       (cdr (->prefix left left-op))
-                                       (list (->prefix left left-op)))
-                                 ,@(if (and not-binary-only?
-                                            (operator-right? op)
-                                            (eqv? (operator-symbol op) (operator-symbol right-op)))
-                                       (cdr (->prefix right right-op))
-                                       (list (->prefix right right-op)))))
-                              ((operator? left-op)
-                               (if (single? right)
-                                   `(,(operator-prefix-symbol op)
-                                     ,@(if (and not-binary-only?
-                                                (operator-left? op)
-                                                (eqv? (operator-symbol op) (operator-symbol left-op)))
-                                           (cdr (->prefix left left-op))
-                                           (list (->prefix left left-op)))
-                                     ,@(if (and not-binary-only?
-                                                (operator-right? op)
-                                                (pair? (car right))
-                                                (eqv? (operator-symbol op) (car (car right))))
-                                           (cdr (car right))
-                                           (list (car right))))
-                                   (fail (->infix left op-sym right))))
-                              ((operator? right-op)
-                               (if (single? left)
-                                   `(,(operator-prefix-symbol op)
-                                     ,@(if (and not-binary-only?
-                                                (operator-left? op)
-                                                (pair? (car left))
-                                                (eqv? (operator-symbol op) (car (car left))))
-                                           (cdr (car left))
-                                           (list (car left)))
-                                     ,@(if (and not-binary-only?
-                                                (operator-right? op)
-                                                (eqv? (operator-symbol op) (operator-symbol right-op)))
-                                           (cdr (->prefix right right-op))
-                                           (list (->prefix right right-op))))
-                                   (fail (->infix left op-sym right))))
-                              (else
-                               (if (and (single? left) (single? right))
-                                   `(,(operator-prefix-symbol op)
-                                     ,@(if (and not-binary-only?
-                                                (operator-left? op)
-                                                (pair? (car left))
-                                                (eqv? (operator-symbol op) (car (car left))))
-                                           (cdr (car left))
-                                           (list (car left)))
-                                     ,@(if (and not-binary-only?
-                                                (operator-right? op)
-                                                (pair? (car right))
-                                                (eqv? (operator-symbol op) (car (car right))))
-                                           (cdr (car right))
-                                           (list (car right))))
-                                   (fail (->infix left op-sym right)))))))
+                        `(,(operator-prefix-symbol op)
+                          ,@(if (operator? left-op)
+                                (if (and not-binary-only?
+                                         (operator-left? op)
+                                         (eqv? (operator-symbol op) (operator-symbol left-op)))
+                                    (cdr (->prefix left left-op))
+                                    (list (->prefix left left-op)))
+                                (if (and (pair? left)
+                                         (null? (cdr left)))
+                                    (list (car left))
+                                    (fail (->infix left op-sym right))))
+                          ,@(if (operator? right-op)
+                                (if (and not-binary-only?
+                                         (operator-right? op)
+                                         (eqv? (operator-symbol op) (operator-symbol right-op)))
+                                    (cdr (->prefix right right-op))
+                                    (list (->prefix right right-op)))
+                                (if (and (pair? right)
+                                         (null? (cdr right)))
+                                    (list (car right))
+                                    (fail (->infix left op-sym right)))))))
                     (if (operator-right? op)
                         (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr)))
                           (let-values (((op rest) (car+cdr op+rest)))
@@ -177,10 +112,6 @@
         ((expr)
          (prefix->infix expr (lambda (e) #f)))))
 
-    (define (operator-unit-inv? x)
-      (cond ((operator-unit x) => (cut unit-inv? <>))
-            (else #f)))
-
     (define (%prefix->infix expr rs failure)
       (let ->infix ((expr expr))
         (define (->infix-fst expr)
@@ -193,68 +124,67 @@
                      => (lambda (op)
                           (let ((p (operator-precedence op))
                                 (op-sym (operator-symbol op)))
-                            (define (left-select op x xp)
-                              (if (operator-left? op)
-                                  (if (<= p xp) x (list x))
-                                  (if (< p xp) x (list x))))
-                            (define (right-select op x xp)
-                              (if (operator-right? op)
-                                  (if (<= p xp) x (list x))
-                                  (if (< p xp) x (list x))))
                             (cond ((null? args)
                                    (cond ((and (not (operator-unit-inv? op))
                                                (operator-unit op))
                                           => (lambda (u) (values (unit-value u) -inf.0)))
                                          (else (failure expr))))
                                   ((null? (cdr args))
-                                   (let-values (((x xp) (->infix (car args))))
+                                   (let-values (((r-expr r-p) (->infix (car args))))
                                      (cond ((operator-unit op)
                                             => (lambda (u)
                                                  (if (unit-inv? u)
                                                      (if (unit-unary? u)
-                                                         (values `(,op-sym ,x) -inf.0)
+                                                         (values `(,op-sym ,r-expr) -inf.0)
                                                          (values `(,(unit-value (operator-unit op))
                                                                    ,op-sym
-                                                                   ,@(right-select op x xp))
+                                                                   ,@(if (operator-right? op)
+                                                                         (wrap-when (< r-p p) r-expr)
+                                                                         (wrap-when (<= r-p p) r-expr)))
                                                                  p))
-                                                     (values x xp))))
+                                                     (values r-expr r-p))))
                                            (else (failure expr)))))
                                   ((null? (cdr (cdr args)))
-                                   (let-values (((x xp) (->infix (car args)))
-                                                ((y yp) (->infix (cadr args))))
-                                     (values `(,@(left-select op x xp) ,op-sym ,@(right-select op y yp)) p)))
+                                   (let-values (((l-expr l-p) (->infix (car args)))
+                                                ((r-expr r-p) (->infix (cadr args))))
+                                     (values `(,@(if (operator-left? op)
+                                                     (wrap-when (< l-p p) l-expr)
+                                                     (wrap-when (<= l-p p) l-expr))
+                                               ,op-sym
+                                               ,@(if (operator-right? op)
+                                                     (wrap-when (< r-p p) r-expr)
+                                                     (wrap-when (<= r-p p) r-expr)))
+                                             p)))
                                   (else
                                    (cond ((and (operator-left? op)
                                                (operator-right? op))
-                                          (values (cdr (append-map (lambda (arg)
-                                                                     (let-values (((x xp) (->infix arg)))
-                                                                       (cons op-sym (if (<= p xp) x (list x)))))
-                                                                   args))
+                                          (values (cdr (append-map! (lambda (arg)
+                                                                      (let-values (((x-expr x-p) (->infix arg)))
+                                                                        (cons op-sym (wrap-when (< x-p p) x-expr))))
+                                                                    args))
                                                   p))
                                          ((operator-left? op)
-                                          (let-values (((x xp) (->infix (car args))))
-                                            (values (append (if (<= p xp) x (list x))
-                                                            (append-map (lambda (arg)
-                                                                          (let-values (((x xp) (->infix arg)))
-                                                                            (cons op-sym (if (< p xp) x (list x)))))
-                                                                        (cdr args)))
+                                          (let-values (((l-expr l-p) (->infix (car args))))
+                                            (values (append! (wrap-when (< l-p p) l-expr)
+                                                             (append-map! (lambda (arg)
+                                                                            (let-values (((l-expr l-p) (->infix arg)))
+                                                                              (cons op-sym (wrap-when (<= l-p p) l-expr))))
+                                                                          (cdr args)))
                                                     p)))
-                                         (else
+                                         ((operator-right? op)
                                           (let ((rev-args (reverse args)))
-                                            (let-values (((x xp) (->infix (car rev-args))))
-                                              (values (reverse
-                                                       (append (if (<= p xp) (reverse x) (list x))
-                                                               (append-map (lambda (arg)
-                                                                             (let-values (((x xp) (->infix arg)))
-                                                                               (cons op-sym (if (< p xp) x (list x)))))
-                                                                           (cdr rev-args))))
-                                                      p))))))))))
+                                            (let-values (((r-expr r-p) (->infix (car rev-args))))
+                                              (values (reverse!
+                                                       (append-reverse! (wrap-when (< r-p p) r-expr)
+                                                                        (append-map!
+                                                                         (lambda (arg)
+                                                                           (let-values (((r-expr r-p) (->infix arg)))
+                                                                             (cons op-sym (wrap-when (<= r-p p) r-expr))))
+                                                                         (cdr rev-args))))
+                                                      p))))
+                                         (else (failure expr))))))))
                     (else (values (map ->infix-fst expr) -inf.0)))))))
 
-    (define (single? x)
-      (and (pair? x)
-           (null? (cdr x))))
-
     (define (minimum-precedence expr rs)
       (let ((dummy (operator 'dummy +inf.0 'both)))
         (let ((result
@@ -269,4 +199,31 @@
           (if (eq? dummy result)
               #f
               result))))
+
+    (define (operator-unit-inv? x)
+      (cond ((operator-unit x) => (cut unit-inv? <>))
+            (else #f)))
+
+    (define (operator-unit-unary? op)
+      (cond ((operator-unit op) => unit-unary?)
+            (else #f)))
+
+    (define (operator-prefix-binary-only? op)
+      (cond ((operator-prefix op) => prefix-binary-only?)
+            (else #f)))
+
+    (define (wrap-when b? x)
+      (if b? (list x) x))
+
+    (define (map-all-list f expr)
+      (f (map-cars f expr)))
+
+    (define (map-cars f expr)
+      (if (pair? expr)
+          (if (pair? (car expr))
+              (cons (f (map-cars f (car expr)))
+                    (map-cars f (cdr expr)))
+              (cons (car expr)
+                    (map-cars f (cdr expr))))
+          expr))
     ))
-- 
cgit v1.2.3