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-scheme.scm | 272 ---------------------------------------------------- 1 file changed, 272 deletions(-) delete mode 100644 infix-to-scheme.scm (limited to 'infix-to-scheme.scm') 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)) - )) -- cgit v1.2.3