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` --- infix-to-prefix.scm | 272 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 272 insertions(+) create mode 100644 infix-to-prefix.scm (limited to 'infix-to-prefix.scm') 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)) + )) -- cgit v1.2.3