aboutsummaryrefslogtreecommitdiff
path: root/infix-to-prefix/rule-set.scm
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2024-09-19 01:41:21 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2024-09-19 01:41:42 +0900
commitbdcb16aaebafe995b209526ce79e6fc10eb607a4 (patch)
tree5e3205d2af2dda924e49f0ebc0069ab605a12e06 /infix-to-prefix/rule-set.scm
parentef7b603b3bee3e56478a33aa8519e995e869e492 (diff)
Rename from `infix-to-scheme` to `infix-to-prefix`
Diffstat (limited to 'infix-to-prefix/rule-set.scm')
-rw-r--r--infix-to-prefix/rule-set.scm184
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))))))