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

1 files changed, 184 insertions, 0 deletions

diff --git a/infix-to-prefix/rule-set.scm b/infix-to-prefix/rule-set.scm
new file mode 100644
index 0000000..4f8c123
--- /dev/null
+++ b/infix-to-prefix/rule-set.scm
@@ -0,0 +1,184 @@
+;;; 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 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))))))