Rename from `infix-to-scheme` to `infix-to-prefix`

1 files changed, 272 insertions, 0 deletions

diff --git a/infix-to-prefix.scm b/infix-to-prefix.scm
new file mode 100644
index 0000000..00e8cc9
--- /dev/null
+++ b/infix-to-prefix.scm
@@ -0,0 +1,272 @@
+;;; Infix-to-Prefix --- Library for converting infix formula to Prefix expression
+;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo>
+;;;
+;;; This file is part of Infix-to-Prefix.
+;;;
+;;; Infix-to-Prefix is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Infix-to-Prefix is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Infix-to-Prefix. If not, see
+;;; <https://www.gnu.org/licenses/>.
+
+(define-library (infix-to-prefix)
+  (export infix->prefix
+          prefix->infix
+          current-operator-rule-set)
+  (import (scheme base)
+          (scheme case-lambda)
+          (infix-to-prefix rule-set)
+          (only (srfi 1) car+cdr fold break! reverse! append! append-map! append-reverse!)
+          (only (srfi 26) cut cute))
+  (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))
+    ))