From ef7b603b3bee3e56478a33aa8519e995e869e492 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Sat, 14 Sep 2024 19:06:22 +0900 Subject: Initial commit --- infix-to-scheme/rule-set.scm | 184 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 184 insertions(+) create mode 100644 infix-to-scheme/rule-set.scm (limited to 'infix-to-scheme/rule-set.scm') diff --git a/infix-to-scheme/rule-set.scm b/infix-to-scheme/rule-set.scm new file mode 100644 index 0000000..22ffcc3 --- /dev/null +++ b/infix-to-scheme/rule-set.scm @@ -0,0 +1,184 @@ +;;; Infix-to-Scheme --- Library for converting infix formula to Scheme expression +;;; Copyright © 2024 Masaya Tojo +;;; +;;; This file is part of Infix-to-Scheme. +;;; +;;; Infix-to-Scheme 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-Scheme 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-Scheme. If not, see +;;; . + +(define-library (infix-to-scheme rule-set) + (export rule-set + rule-set? + rule-set-infix-ref + rule-set-scheme-ref + + operator + operator? + operator-symbol + operator-scheme-symbol + operator-precedence + operator-left? + operator-right? + operator-associative? + operator-scheme + operator-identity + + identity + identity? + identity-value + identity-inv? + identity-unary? + identity-unary-precedence + + direction + direction? + direction-left? + direction-associative? + + scheme + scheme? + scheme-symbol + scheme-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 + (make-rule-set operator-hashmap scheme-hashmap) + rule-set? + (operator-hashmap rule-set-operator-hashmap) + (scheme-hashmap rule-set-scheme-hashmap)) + + (define (rule-set operator-list) + (make-rule-set (list->operator-hashmap operator-list) + (list->scheme-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->scheme-hashmap ops) + (hashmap-unfold null? + (lambda (ops) + (let ((op (car ops))) + (values (operator-scheme-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-scheme-ref rule-set key) + (hashmap-ref/default (rule-set-scheme-hashmap rule-set) key #f)) + + (define-record-type + (make-operator symbol precedence dir identity scheme) + operator? + (symbol operator-symbol) + (precedence operator-precedence) + (dir operator-direction) + (identity operator-identity) + (scheme operator-scheme)) + + (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 scheme) + (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 scheme)))) + + (define-record-type + (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-scheme-symbol op) + (cond ((operator-scheme op) => (lambda (p) + (and (scheme-has-symbol? p) + (scheme-symbol p)))) + (else (operator-symbol op)))) + + (define-record-type + (make-scheme binary-only? has-symbol? symbol) + scheme? + (binary-only? scheme-binary-only?) + (has-symbol? scheme-has-symbol?) + (symbol scheme-symbol)) + + (define scheme + (case-lambda + ((binary-only?) + (make-scheme binary-only? #f #f)) + ((binary-only? symbol) + (make-scheme binary-only? #t symbol)))) + + (define-record-type + (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)))))) -- cgit v1.2.3