Remove infix libraryHEADmain

Use https://git.tojo.tokyo/infix-to-prefix.git/about/ library.

2 files changed, 0 insertions, 446 deletions

diff --git a/qklib/infix.scm b/qklib/infix.scm
deleted file mode 100644
index d8748d6..0000000
--- a/qklib/infix.scm
+++ /dev/null
@@ -1,267 +0,0 @@
-;;; 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
-          prefix->infix
-          current-operator-rule-set)
-  (import (scheme base)
-          (scheme case-lambda)
-          (only (srfi 1) car+cdr fold break! reverse! append! append-map! append-reverse!)
-          (only (srfi 26) cut cute)
-          (qklib infix rule-set))
-  (begin
-    (define (make-default-operator-rule-set)
-      (rule-set
-       (list
-        (operator '= 0)
-        (operator '+ 1 (direction 'left #t) (identity 0))
-        (operator '- 1 (direction 'left) (identity 0 #t #t 3))
-        (operator '* 2 (direction 'left #t) (identity 1))
-        (operator '/ 2 (direction 'left) (identity 1 #t))
-        (operator '^ 4 (direction 'right) #f (prefix #t 'expt)))))
-
-    (define current-operator-rule-set
-      (make-parameter (make-default-operator-rule-set)))
-
-    (define infix->prefix
-      (case-lambda
-        ((expr failure)
-         (call/cc
-          (lambda (return)
-            (let ((rs (current-operator-rule-set)))
-              (map-all-list (cute infix->prefix-1 <> rs (lambda (e) (return (failure e))))
-                            expr)))))
-        ((expr)
-         (infix->prefix expr (lambda (e) #f)))))
-
-    (define (infix->prefix-1 expr rs fail)
-      (cond ((and (pair? expr) (null? (cdr expr))) (car expr))
-            ((minimum-precedence expr rs)
-             => (lambda (op)
-                  (let ->prefix ((expr (list-copy expr))
-                                 (op op))
-                    (define (make-prefix left op-sym right)
-                      (define (->infix left op-sym right)
-                        (append left (cons op-sym right)))
-                      (let ((left-op (minimum-precedence left rs))
-                            (right-op (minimum-precedence right rs))
-                            (not-binary-only? (not (operator-prefix-binary-only? op))))
-                        `(,(operator-prefix-symbol op)
-                          ,@(if (operator? left-op)
-                                (if (eqv? (operator-symbol op) (operator-symbol left-op))
-                                    (if not-binary-only?
-                                        (if (and (eqv? op-sym (car left))
-                                                 (pair? (cdr left))
-                                                 (null? (cdr (cdr left))))
-                                            (list (->prefix left left-op))
-                                            (cdr (->prefix left left-op)))
-                                        (if (operator-left? op)
-                                            (list (->prefix left left-op))
-                                            (fail expr)))
-                                    (list (->prefix left left-op)))
-                                (if (and (pair? left)
-                                         (null? (cdr left)))
-                                    (if (and not-binary-only?
-                                             (or (operator-left? op)
-                                                 (operator-associative? op))
-                                             (pair? (car left))
-                                             (eqv? (operator-symbol op) (car (car left))))
-                                        (cdr (car left))
-                                        (list (car left)))
-                                    (fail (->infix left op-sym right))))
-                          ,@(if (operator? right-op)
-                                (if (eqv? (operator-symbol op) (operator-symbol right-op))
-                                    (if not-binary-only?
-                                        (cdr (->prefix right right-op))
-                                        (if (operator-right? op)
-                                            (list (->prefix right right-op))
-                                            (fail expr)))
-                                    (list (->prefix right right-op)))
-                                (if (and (pair? right)
-                                         (null? (cdr right)))
-                                    (if (and not-binary-only?
-                                             (or (operator-right? op)
-                                                 (operator-associative? op))
-                                             (pair? (car right))
-                                             (eqv? (operator-symbol op) (car (car right))))
-                                        (cdr (car right))
-                                        (list (car right)))
-                                    (fail (->infix left op-sym right)))))))
-                    (cond ((operator-left? op)
-                           (let ((rev-expr (reverse! expr)))
-                             (let-values (((rev-lst op+rev-rest) (break! (cute eqv? (operator-symbol op) <>) rev-expr)))
-                               (let-values (((op-sym rev-rest) (car+cdr op+rev-rest)))
-                                 (if (and (or (null? rev-rest)
-                                              (rule-set-infix-ref rs (car rev-rest)))
-                                          (and (pair? rev-lst)
-                                               (null? (cdr rev-lst))))
-                                     (infix->prefix-1 (append-reverse! rev-rest
-                                                                       (list `(,op-sym ,(car rev-lst))))
-                                                      rs
-                                                      fail)
-                                     (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst)))))))
-                          (else
-                           (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr)))
-                             (let-values (((op rest) (car+cdr op+rest)))
-                               (make-prefix lst op rest))))))))
-            (else expr)))
-
-    (define prefix->infix
-      (case-lambda
-        ((expr failure)
-         (let ((rs (current-operator-rule-set)))
-           (call-with-current-continuation
-            (lambda (return)
-              (let-values (((result _precedence) (%prefix->infix expr rs (lambda (e) (return (failure e))))))
-                result)))))
-        ((expr)
-         (prefix->infix expr (lambda (e) #f)))))
-
-    (define (%prefix->infix expr rs failure)
-      (let ->infix ((expr expr))
-        (define (->infix-fst expr)
-          (let-values (((x _) (->infix expr)))
-            x))
-        (if (not (pair? expr))
-            (values expr -inf.0)
-            (let-values (((op-prefix-sym args) (car+cdr expr)))
-              (cond ((rule-set-prefix-ref rs op-prefix-sym)
-                     => (lambda (op)
-                          (let ((p (operator-precedence op))
-                                (op-sym (operator-symbol op)))
-                            (cond ((null? args)
-                                   (cond ((and (not (operator-identity-inv? op))
-                                               (operator-identity op))
-                                          => (lambda (u) (values (identity-value u) -inf.0)))
-                                         (else (failure expr))))
-                                  ((null? (cdr args))
-                                   (let-values (((r-expr r-p) (->infix (car args))))
-                                     (cond ((operator-identity op)
-                                            => (lambda (u)
-                                                 (if (identity-inv? u)
-                                                     (if (identity-unary? u)
-                                                         (values `(,op-sym ,r-expr)
-                                                                 (or (operator-identity-unary-precedence op)
-                                                                     +inf.0))
-                                                         (values `(,(identity-value (operator-identity op))
-                                                                   ,op-sym
-                                                                   ,@(if (or (operator-right? op)
-                                                                             (operator-associative? op))
-                                                                         (wrap-when (< r-p p) r-expr)
-                                                                         (wrap-when (<= r-p p) r-expr)))
-                                                                 p))
-                                                     (values r-expr r-p))))
-                                           (else (failure expr)))))
-                                  ((null? (cdr (cdr args)))
-                                   (let-values (((l-expr l-p) (->infix (car args)))
-                                                ((r-expr r-p) (->infix (cadr args))))
-                                     (values `(,@(if (or (operator-left? op)
-                                                         (operator-associative? op))
-                                                     (wrap-when (< l-p p) l-expr)
-                                                     (wrap-when (<= l-p p) l-expr))
-                                               ,op-sym
-                                               ,@(if (or (operator-right? op)
-                                                         (operator-associative? op))
-                                                     (wrap-when (< r-p p) r-expr)
-                                                     (wrap-when (<= r-p p) r-expr)))
-                                             p)))
-                                  (else
-                                   (cond ((operator-associative? op)
-                                          (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 (((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)))
-                                         ((operator-right? op)
-                                          (let ((rev-args (reverse args)))
-                                            (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
-                                          (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))))))))
-                    (else (values (map ->infix-fst expr) -inf.0)))))))
-
-    (define (minimum-precedence expr rs)
-      (let loop ((expr expr)
-                 (min #f)
-                 (min-precedence +inf.0)
-                 (prev #t))
-        (if (null? expr)
-            min
-            (cond ((rule-set-infix-ref rs (car expr))
-                   => (lambda (current)
-                        (let ((precedence
-                               (if (and (operator-identity-unary? current)
-                                        prev)
-                                   (operator-identity-unary-precedence current)
-                                   (operator-precedence current))))
-                          (if (<= precedence min-precedence)
-                              (loop (cdr expr) current precedence current)
-                              (loop (cdr expr) min min-precedence current)))))
-                  (else (loop (cdr expr) min min-precedence #f))))))
-
-    (define (operator-identity-inv? x)
-      (cond ((operator-identity x) => (cut identity-inv? <>))
-            (else #f)))
-
-    (define (operator-identity-unary? op)
-      (cond ((operator-identity op) => identity-unary?)
-            (else #f)))
-
-    (define (operator-identity-unary-precedence op)
-      (cond ((operator-identity op) =>
-             (lambda (id)
-               (cond ((identity-unary-precedence id)
-                      => (lambda (p) p))
-                     (else (operator-precedence op)))))
-            (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))
-    ))
diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm
deleted file mode 100644
index db0c4e5..0000000
--- a/qklib/infix/rule-set.scm
+++ /dev/null
@@ -1,179 +0,0 @@
-;;; 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 rule-set)
-  (export rule-set
-          rule-set?
-          rule-set-infix-ref
-          rule-set-prefix-ref
-
-          operator
-          operator?
-          operator-symbol
-          operator-prefix-symbol
-          operator-precedence
-          operator-left?
-          operator-right?
-          operator-associative?
-          operator-prefix
-          operator-identity
-
-          identity
-          identity?
-          identity-value
-          identity-inv?
-          identity-unary?
-          identity-unary-precedence
-
-          direction
-          direction?
-          direction-left?
-          direction-associative?
-
-          prefix
-          prefix?
-          prefix-symbol
-          prefix-binary-only?)
-  (import (scheme base)
-          (scheme case-lambda)
-          (only (srfi 128) make-eqv-comparator))
-  (cond-expand
-    ((library (srfi srfi-146 hash)) ;; for guile-srfi-146
-     (import (only (srfi srfi-146 hash) hashmap-ref/default hashmap-unfold)))
-    ((library (srfi 146 hash))
-     (import (only (srfi 146 hash) hashmap-ref/default hashmap-unfold))))
-  (begin
-    (define-record-type <rule-set>
-      (make-rule-set operator-hashmap prefix-hashmap)
-      rule-set?
-      (operator-hashmap rule-set-operator-hashmap)
-      (prefix-hashmap rule-set-prefix-hashmap))
-
-    (define (rule-set operator-list)
-      (make-rule-set (list->operator-hashmap operator-list)
-                     (list->prefix-hashmap operator-list)))
-
-    (define (list->operator-hashmap ops)
-      (hashmap-unfold null?
-                      (lambda (ops)
-                        (values (operator-symbol (car ops))
-                                (car ops)))
-                      cdr
-                      ops
-                      (make-eqv-comparator)))
-
-    (define (list->prefix-hashmap ops)
-      (hashmap-unfold null?
-                      (lambda (ops)
-                        (let ((op (car ops)))
-                          (values (operator-prefix-symbol op)
-                                  (car ops))))
-                      cdr
-                      ops
-                      (make-eqv-comparator)))
-
-    (define (rule-set-infix-ref rule-set key)
-      (hashmap-ref/default (rule-set-operator-hashmap rule-set) key #f))
-
-    (define (rule-set-prefix-ref rule-set key)
-      (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f))
-
-    (define-record-type <operator>
-      (make-operator symbol precedence dir identity prefix)
-      operator?
-      (symbol operator-symbol)
-      (precedence operator-precedence)
-      (dir operator-direction)
-      (identity operator-identity)
-      (prefix operator-prefix))
-
-    (define operator
-      (case-lambda
-        ((symbol precedence)
-         (operator symbol precedence #f))
-        ((symbol precedence direction)
-         (operator symbol precedence direction #f))
-        ((symbol precedence direction identity)
-         (operator symbol precedence direction identity #f))
-        ((symbol precedence direction identity prefix)
-         (when (and identity (identity-unary? identity)
-                    (not (and direction (direction-left? direction))))
-           (error "operator: unary operator must be left direction" symbol))
-         (make-operator symbol precedence direction identity prefix))))
-
-    (define-record-type <direction>
-      (make-direction left? associative?)
-      direction?
-      (left? direction-left?)
-      (associative? direction-associative?))
-
-    (define (direction-right? assoc)
-      (not (direction-left? assoc)))
-
-    (define direction
-      (case-lambda
-        ((dir)
-         (direction dir #f))
-        ((dir associative?)
-         (unless (or (eq? 'left dir)
-                     (eq? 'right dir))
-           (error "direction: The 1st argument must be 'left or 'right" dir))
-         (make-direction (eq? 'left dir) associative?))))
-
-    (define (operator-left? x)
-      (cond ((operator-direction x) => direction-left?)
-            (else #f)))
-
-    (define (operator-right? x)
-      (cond ((operator-direction x) => (lambda (a) (not (direction-left? a))))
-            (else #f)))
-
-    (define (operator-associative? x)
-      (cond ((operator-direction x) => direction-associative?)
-            (else #f)))
-
-    (define (operator-prefix-symbol op)
-      (cond ((operator-prefix op) => (lambda (p)
-                                       (and (prefix-has-symbol? p)
-                                            (prefix-symbol p))))
-            (else (operator-symbol op))))
-
-    (define-record-type <prefix>
-      (make-prefix binary-only? has-symbol? symbol)
-      prefix?
-      (binary-only? prefix-binary-only?)
-      (has-symbol? prefix-has-symbol?)
-      (symbol prefix-symbol))
-
-    (define prefix
-      (case-lambda
-        ((binary-only?)
-         (make-prefix binary-only? #f #f))
-        ((binary-only? symbol)
-         (make-prefix binary-only?  #t symbol))))
-
-    (define-record-type <identity>
-      (make-identity value inv? unary? unary-precedence)
-      identity?
-      (value identity-value)
-      (inv? identity-inv?)
-      (unary? identity-unary?)
-      (unary-precedence identity-unary-precedence))
-
-    (define identity
-      (case-lambda
-        ((value) (identity value #f))
-        ((value inv?) (identity value inv? #f))
-        ((value inv? unary?) (identity value inv? unary? #f))
-        ((value inv? unary? unary-precedence) (make-identity value inv? unary? unary-precedence))))))