;;; 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)
(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)
(if (and (pair? expr) (null? (cdr expr)))
(car expr)
(let-values (((op unary?) (minimum-precedence expr rs)))
(if op
(let ->prefix ((expr (list-copy expr))
(op op)
(unary? unary?))
(define (make-prefix left op-sym right)
(define (->infix left op-sym right)
(append left (cons op-sym right)))
(let-values (((left-op left-unary?) (minimum-precedence left rs))
((right-op right-unary?) (minimum-precedence right rs)))
(let ((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 left-unary?))
(cdr (->prefix left left-op left-unary?)))
(if (operator-left? op)
(list (->prefix left left-op left-unary?))
(fail expr)))
(list (->prefix left left-op left-unary?)))
(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 right-unary?))
(if (operator-right? op)
(list (->prefix right right-op right-unary?))
(fail expr)))
(list (->prefix right right-op right-unary?)))
(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 (unary?
(let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr)))
(let-values (((op-sym rest) (car+cdr op+rest)))
(infix->prefix-1 (append lst (list (list op-sym (infix->prefix-1 rest rs fail))))
rs
fail))))
((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)))
(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))))))
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)
(min-unary? #f)
(prev #t))
(if (null? expr)
(values min min-unary?)
(cond ((rule-set-infix-ref rs (car expr))
=> (lambda (current)
(let-values (((precedence current-unary?)
(if (and (operator-identity-unary? current)
prev)
(values (operator-identity-unary-precedence current) #t)
(values (operator-precedence current) #f))))
(if (<= precedence min-precedence)
(loop (cdr expr) current precedence current-unary? current)
(loop (cdr expr) min min-precedence min-unary? current)))))
(else (loop (cdr expr) min min-precedence min-unary? #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))
))
