From bdcb16aaebafe995b209526ce79e6fc10eb607a4 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Thu, 19 Sep 2024 01:41:21 +0900 Subject: Rename from `infix-to-scheme` to `infix-to-prefix` --- CHANGELOG.md | 4 +- README.md | 20 ++-- infix-to-prefix.scm | 272 +++++++++++++++++++++++++++++++++++++++++++ infix-to-prefix/rule-set.scm | 184 +++++++++++++++++++++++++++++ infix-to-scheme.scm | 272 ------------------------------------------- infix-to-scheme/rule-set.scm | 184 ----------------------------- 6 files changed, 468 insertions(+), 468 deletions(-) create mode 100644 infix-to-prefix.scm create mode 100644 infix-to-prefix/rule-set.scm delete mode 100644 infix-to-scheme.scm delete mode 100644 infix-to-scheme/rule-set.scm diff --git a/CHANGELOG.md b/CHANGELOG.md index 3ed6e1c..145e812 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Add README.md file. - Add COPYING file. -- Add `(infix-to-scheme)` module. -- Add `(infix-to-scheme rule-set)` module. +- Add `(infix-to-prefix)` module. +- Add `(infix-to-prefix rule-set)` module. - Add CHANGELOG.md file. diff --git a/README.md b/README.md index 54b9000..b30ce71 100644 --- a/README.md +++ b/README.md @@ -1,29 +1,29 @@ -# Infix-to-Scheme +# Infix-to-Prefix -Infix-to-Scheme is an R7RS library for converting infix formula to Scheme expression. +Infix-to-Prefix is an R7RS library for converting infix formula to Prefix expression. ## Usage -### Import `(infix-to-scheme)` library +### Import `(infix-to-prefix)` library -```scheme -(import (infix-to-scheme)) +```prefix +(import (infix-to-prefix)) ``` -#### `(infix->scheme expr) → ` +#### `(infix->prefix expr) → ` -Returns converted scheme expression if `expr` is a valid infix formula expression; otherwise, it returns`#f`. +Returns converted prefix expression if `expr` is a valid infix formula expression; otherwise, it returns`#f`. -#### `(scheme->infix expr) → ` +#### `(prefix->infix expr) → ` -Returns converted infix formula expression if `expr` is a valid scheme expression; otherwise, it returns`#f`. +Returns converted infix formula expression if `expr` is a valid prefix expression; otherwise, it returns`#f`. ## Downloading code with git Use git command. ```shell -git clone https://git.tojo.tokyo/infix-to-scheme.git +git clone https://git.tojo.tokyo/infix-to-prefix.git ``` ## License 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 +;;; +;;; 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 +;;; . + +(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)) + )) 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 +;;; +;;; 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 +;;; . + +(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 + (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 + (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 + (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 + (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 + (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)))))) diff --git a/infix-to-scheme.scm b/infix-to-scheme.scm deleted file mode 100644 index ae2fc56..0000000 --- a/infix-to-scheme.scm +++ /dev/null @@ -1,272 +0,0 @@ -;;; 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) - (export infix->scheme - scheme->infix - current-operator-rule-set) - (import (scheme base) - (scheme case-lambda) - (infix-to-scheme 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 (scheme #t 'expt))))) - - (define current-operator-rule-set - (make-parameter (make-default-operator-rule-set))) - - (define infix->scheme - (case-lambda - ((expr failure) - (call/cc - (lambda (return) - (let ((rs (current-operator-rule-set))) - (map-all-list (cute infix->scheme-1 <> rs (lambda (e) (return (failure e)))) - expr))))) - ((expr) - (infix->scheme expr (lambda (e) #f))))) - - (define (infix->scheme-1 expr rs fail) - (cond ((and (pair? expr) (null? (cdr expr))) (car expr)) - ((minimum-precedence expr rs) - => (lambda (op) - (let ->scheme ((expr (list-copy expr)) - (op op)) - (define (make-scheme 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-scheme-binary-only? op)))) - `(,(operator-scheme-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 (->scheme left left-op)) - (cdr (->scheme left left-op))) - (if (operator-left? op) - (list (->scheme left left-op)) - (fail expr))) - (list (->scheme 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 (->scheme right right-op)) - (if (operator-right? op) - (list (->scheme right right-op)) - (fail expr))) - (list (->scheme 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->scheme-1 (append-reverse! rev-rest - (list `(,op-sym ,(car rev-lst)))) - rs - fail) - (make-scheme (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-scheme lst op rest)))))))) - (else expr))) - - (define scheme->infix - (case-lambda - ((expr failure) - (let ((rs (current-operator-rule-set))) - (call-with-current-continuation - (lambda (return) - (let-values (((result _precedence) (%scheme->infix expr rs (lambda (e) (return (failure e)))))) - result))))) - ((expr) - (scheme->infix expr (lambda (e) #f))))) - - (define (%scheme->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-scheme-sym args) (car+cdr expr))) - (cond ((rule-set-scheme-ref rs op-scheme-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-scheme-binary-only? op) - (cond ((operator-scheme op) => scheme-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)) - )) diff --git a/infix-to-scheme/rule-set.scm b/infix-to-scheme/rule-set.scm deleted file mode 100644 index 22ffcc3..0000000 --- a/infix-to-scheme/rule-set.scm +++ /dev/null @@ -1,184 +0,0 @@ -;;; 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