diff options
Diffstat (limited to 'infix-to-prefix')
| -rw-r--r-- | infix-to-prefix/rule-set.scm | 184 |
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)))))) |