blob: 4715a3a66d2f2775d52ee13f44e1cf6a1689dade (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
;;; 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
make-operator
operator?
operator-symbol
operator-left?
operator-precedence
operator-list->operator-mapping
operator-mapping-adjoin
current-operator-mapping)
(import (scheme base)
(scheme case-lambda)
(only (srfi 1) car+cdr fold break! reverse!)
(only (srfi 26) cut)
(only (srfi 128) make-default-comparator)
(only (srfi 146) mapping-unfold mapping-adjoin mapping-ref/default))
(begin
(define-record-type <operator>
(%make-operator symbol left? precedence)
operator?
(symbol operator-symbol)
(left? operator-left?)
(precedence operator-precedence))
(define (make-operator symbol left? precedence)
(%make-operator symbol left? precedence))
(define (operator-mapping-adjoin op op-map)
(mapping-adjoin op op-map))
(define (operator-list->operator-mapping ops)
(mapping-unfold null?
(lambda (ops)
(values (operator-symbol (car ops))
(car ops)))
cdr
ops
(make-default-comparator)))
(define default-operator-mapping
(operator-list->operator-mapping
(list (make-operator '+ #t 1)
(make-operator '- #t 1)
(make-operator '* #t 2)
(make-operator '/ #t 2))))
(define current-operator-mapping
(make-parameter default-operator-mapping))
(define infix->prefix
(case-lambda
((expr ops)
(map-all-list (cut infix->prefix-1 <> ops)
expr))
((expr)
(infix->prefix expr (current-operator-mapping)))))
(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))
(define (infix->prefix-1 expr ops)
(let ->prefix ((expr (replace-operators expr ops))) ;; all new conses
(define op (minimum-precedence expr))
(cond ((operator? op)
(if (operator-left? op)
(let ((rev-expr (reverse! expr)))
(let-values (((rev-lst op+rev-rest) (break! (cut operator=? op <>) rev-expr)))
(let-values (((op rev-rest) (car+cdr op+rev-rest)))
(list (operator-symbol op) (->prefix (reverse! rev-rest)) (->prefix (reverse! rev-lst))))))
(let-values (((lst op+rest) (break! (cut operator=? op <>) expr)))
(let-values (((op rest) (car+cdr op+rest)))
(list (operator-symbol op) (->prefix lst) (->prefix rest))))))
((single? expr) (car expr))
(else expr))))
(define (single? x)
(and (not (null? x))
(null? (cdr x))))
(define (replace-operators expr ops)
(map (lambda (x)
(mapping-ref/default ops x x))
expr))
(define (expr-precedence expr)
(if (operator? expr)
(operator-precedence expr)
+inf.0))
(define (minimum-precedence expr)
(fold (lambda (x y) (if (< (expr-precedence x) (expr-precedence y)) x y)) #f expr))
(define (operator=? x y)
(and (operator? x)
(operator? y)
(eq? (operator-symbol x)
(operator-symbol y))))
))
|
