aboutsummaryrefslogtreecommitdiff
path: root/qklib/infix.scm
diff options
context:
space:
mode:
Diffstat (limited to 'qklib/infix.scm')
-rw-r--r--qklib/infix.scm267
1 files changed, 0 insertions, 267 deletions
diff --git a/qklib/infix.scm b/qklib/infix.scm
deleted file mode 100644
index d8748d6..0000000
--- a/qklib/infix.scm
+++ /dev/null
@@ -1,267 +0,0 @@
-;;; Copyright 2024 Masaya Tojo <masaya@tojo.tokyo>
-;;;
-;;; Licensed under the Apache License, Version 2.0 (the "License");
-;;; you may not use this file except in compliance with the License.
-;;; You may obtain a copy of the License at
-;;;
-;;; http://www.apache.org/licenses/LICENSE-2.0
-;;;
-;;; Unless required by applicable law or agreed to in writing, software
-;;; distributed under the License is distributed on an "AS IS" BASIS,
-;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-;;; See the License for the specific language governing permissions and
-;;; limitations under the License.
-
-(define-library (qklib infix)
- (export infix->prefix
- prefix->infix
- current-operator-rule-set)
- (import (scheme base)
- (scheme case-lambda)
- (only (srfi 1) car+cdr fold break! reverse! append! append-map! append-reverse!)
- (only (srfi 26) cut cute)
- (qklib infix rule-set))
- (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))
- ))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-21 17:11:32 +0000