aboutsummaryrefslogtreecommitdiff
path: root/infix-to-scheme.scm
diff options
context:
space:
mode:
Diffstat (limited to 'infix-to-scheme.scm')
-rw-r--r--infix-to-scheme.scm272
1 files changed, 272 insertions, 0 deletions
diff --git a/infix-to-scheme.scm b/infix-to-scheme.scm
new file mode 100644
index 0000000..ae2fc56
--- /dev/null
+++ b/infix-to-scheme.scm
@@ -0,0 +1,272 @@
+;;; Infix-to-Scheme --- Library for converting infix formula to Scheme expression
+;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo>
+;;;
+;;; 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
+;;; <https://www.gnu.org/licenses/>.
+
+(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))
+ ))
generated by cgit v1.2.3 (git 2.46.0) at 2024-11-14 23:22:28 +0000