Add (qklib infix) library

1 files changed, 123 insertions, 0 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
new file mode 100644
index 0000000..cdeb8e5
--- /dev/null
+++ b/qklib/infix.scm
@@ -0,0 +1,123 @@
+;;; Copyright 2024 Masaya Tojo <masaya@tojo.tokyo>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;     http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-library (qklib infix)
+  (export infix->prefix
+          make-operator
+          operator?
+          operator-symbol
+          operator-left?
+          operator-precedence
+          operator-list->operator-mapping
+          operator-mapping-adjoin
+          current-operator-mapping)
+  (import (scheme base)
+          (scheme case-lambda)
+          (only (srfi 1) fold break! reverse!)
+          (only (srfi 26) cut)
+          (only (srfi 128) make-default-comparator)
+          (only (srfi 146) mapping-unfold mapping-adjoin mapping-ref/default))
+  (begin
+    (define-record-type <operator>
+      (%make-operator symbol left? precedence)
+      operator?
+      (symbol operator-symbol)
+      (left? operator-left?)
+      (precedence operator-precedence))
+
+    (define (make-operator symbol left? precedence)
+      (%make-operator symbol left? precedence))
+
+    (define (operator-mapping-adjoin op op-map)
+      (mapping-adjoin op op-map))
+
+    (define (operator-list->operator-mapping ops)
+      (mapping-unfold null?
+                      (lambda (ops)
+                        (values (operator-symbol (car ops))
+                                (car ops)))
+                      cdr
+                      ops
+                      (make-default-comparator)))
+
+    (define default-operator-mapping
+      (operator-list->operator-mapping
+       (list (make-operator '+ #t 1)
+             (make-operator '- #t 1)
+             (make-operator '* #t 2)
+             (make-operator '/ #t 2))))
+
+    (define current-operator-mapping
+      (make-parameter default-operator-mapping))
+
+    (define infix->prefix
+      (case-lambda
+        ((expr ops)
+         (map-all-list (cut infix->prefix-1 <> ops)
+                       expr))
+        ((expr)
+         (infix->prefix expr (current-operator-mapping)))))
+
+    (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 (infix->prefix-1 expr ops)
+      (let ->prefix ((expr (replace-operators expr ops))) ;; all new conses
+        (define op (minimum-precedence expr))
+        (cond ((operator? op)
+               (if (operator-left? op)
+                   (let ((rev-expr (reverse! expr)))
+                     (let-values (((rev-lst op+rev-rest) (break! (cut operator=? op <>) rev-expr)))
+                       (let ((op (car op+rev-rest))
+                             (rev-rest (cdr op+rev-rest)))
+                         (list (operator-symbol op) (->prefix (reverse! rev-rest)) (->prefix (reverse! rev-lst))))))
+                   (let-values (((lst op+rest) (break! (cut operator=? op <>) expr)))
+                     (let ((op (car op+rest))
+                           (rest (cdr op+rest)))
+                       (list (operator-symbol op) (->prefix lst) (->prefix rest))))))
+              ((single? expr) (car expr))
+              (else expr))))
+
+    (define (single? x)
+      (and (not (null? x))
+           (null? (cdr x))))
+
+    (define (replace-operators expr ops)
+      (map (lambda (x)
+             (mapping-ref/default ops x x))
+           expr))
+
+    (define (expr-precedence expr)
+      (if (operator? expr)
+          (operator-precedence expr)
+          +inf.0))
+
+    (define (minimum-precedence expr)
+      (fold (lambda (x y) (if (< (expr-precedence x) (expr-precedence y)) x y)) #f expr))
+
+    (define (operator=? x y)
+      (and (operator? x)
+           (operator? y)
+           (eq? (operator-symbol x)
+                (operator-symbol y))))
+    ))