From d24785d557acbc201876970f30095328af8e7b08 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Fri, 30 Aug 2024 03:44:38 +0900 Subject: Add `prefix->infix` and modify `(qklib infix)` interfaces --- qklib/infix.scm | 123 ++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 89 insertions(+), 34 deletions(-) diff --git a/qklib/infix.scm b/qklib/infix.scm index 473aed5..1c8502f 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -14,35 +14,49 @@ (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) + prefix->infix + infix + make-default-infix-rules + current-infix-rules) (import (scheme base) (scheme case-lambda) - (only (srfi 1) car+cdr fold break! reverse!) + (ice-9 pretty-print) + (only (srfi 1) car+cdr fold break! reverse! append-map) (only (srfi 26) cut) (only (srfi 128) make-default-comparator) - (only (srfi 146) mapping-unfold mapping-adjoin mapping-ref/default)) + (only (srfi 146) mapping? mapping-unfold mapping-adjoin mapping-ref/default)) (begin - (define-record-type - (%make-operator symbol left? precedence) + (define-record-type + (%make-operator symbol precedence left? unit inv?) operator? (symbol operator-symbol) + (precedence operator-precedence) (left? operator-left?) - (precedence operator-precedence)) + (unit operator-unit) + (inv? operator-inv?)) - (define (make-operator symbol left? precedence) - (%make-operator symbol left? precedence)) + (define-record-type + (make-unit value) + unit? + (value unit-value)) - (define (operator-mapping-adjoin op op-map) - (mapping-adjoin op op-map)) + (define infix + (case-lambda + ((sym) + (infix sym 0)) + ((sym precedence) + (infix sym precedence 'right)) + ((sym precedence left-or-right) + (%make-operator sym precedence (eq? 'left left-or-right) #f #f)) + ((sym precedence left-or-right unit) + (infix sym precedence left-or-right unit #f)) + ((sym precedence left-or-right unit inv?) + (unless (or (eq? 'left left-or-right) + (eq? 'right left-or-right)) + (error "infix: The 3rd argument must be 'left or 'right" left-or-right)) + (%make-operator sym precedence (eq? 'left left-or-right) (make-unit unit) inv?)))) - (define (operator-list->operator-mapping ops) + (define (infix-rule-list->infix-rule-mapping ops) (mapping-unfold null? (lambda (ops) (values (operator-symbol (car ops)) @@ -51,23 +65,23 @@ 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 (make-default-infix-rules) + (list (infix '+ 1 'left 0) + (infix '- 1 'left 0 #t) + (infix '* 2 'left 1) + (infix '/ 2 'left 1 #t))) - (define current-operator-mapping - (make-parameter default-operator-mapping)) + (define current-infix-rules + (make-parameter (make-default-infix-rules) + (lambda (x) + (if (mapping? x) + x + (infix-rule-list->infix-rule-mapping x))))) - (define infix->prefix - (case-lambda - ((expr ops) - (map-all-list (cut infix->prefix-1 <> ops) - expr)) - ((expr) - (infix->prefix expr (current-operator-mapping))))) + (define (infix->prefix expr) + (let ((infix-rules (current-infix-rules))) + (map-all-list (cut infix->prefix-1 <> infix-rules) + expr))) (define (map-all-list f expr) (f (map-cars f expr))) @@ -98,8 +112,49 @@ ((single? expr) (car expr)) (else expr))))) + (define (prefix->infix expr) + (let ((infix-rules (current-infix-rules))) + (let-values (((result _precedence) (%prefix->infix expr infix-rules))) + result))) + + (define (%prefix->infix expr ops) + (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 args) (car+cdr expr))) + (cond ((mapping-ref/default ops op #f) + => (lambda (op) + (let ((p (operator-precedence op)) + (sym (operator-symbol op))) + (cond ((and (null? args) + (not (operator-inv? op)) + (operator-unit op)) + => (lambda (u) (values (unit-value u) -inf.0))) + ((single? args) + (let-values (((x xp) (->infix (car args)))) + (cond ((operator-inv? op) + (values `(,(unit-value (operator-unit op)) + ,sym + ,@(if (<= p xp) x (list x))) + p)) + ((operator-unit op) + (values x xp)) + (else (values (list sym x) -inf.0))))) + ((pair? args) + (values (cdr + (append-map (lambda (arg) + (let-values (((x xp) (->infix arg))) + (cons sym (if (<= p xp) x (list x))))) + args)) + p)) + (else (values (map ->infix-fst expr) -inf.0)))))) + (else (values (map ->infix-fst expr) -inf.0))))))) + (define (single? x) - (and (not (null? x)) + (and (pair? x) (null? (cdr x)))) (define (replace-operators expr ops) -- cgit v1.2.3