From 6f443590d345b82a40dc0c8cfd824ec3166f82e1 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Fri, 6 Sep 2024 16:12:23 +0900 Subject: Update infix->prefix and prefix->infix --- qklib/infix.scm | 133 ++++++++++++++++++++++++++++++++++++----------- qklib/infix/rule-set.scm | 48 ++++++++++------- 2 files changed, 131 insertions(+), 50 deletions(-) diff --git a/qklib/infix.scm b/qklib/infix.scm index 88ebb18..7a897fd 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -18,7 +18,7 @@ current-operator-rule-set) (import (scheme base) (scheme case-lambda) - (only (srfi 1) car+cdr fold break! reverse! append-map) + (only (srfi 1) car+cdr fold fold-right break! reverse! append-map append! append-map!) (only (srfi 26) cut cute) (srfi 35) (qklib infix rule-set)) @@ -26,11 +26,11 @@ (define (make-default-operator-rule-set) (rule-set (list - (operator '+ 1 'left (unit 0 #f #t)) + (operator '+ 1 'both (unit 0 #f #t)) (operator '- 1 'left (unit 0 #t #t)) - (operator '* 2 'left (unit 1)) - (operator '/ 2 'left (unit 1 #t)) - (operator '^ 3 'right #f (prefix 'expt #t))))) + (operator '* 2 'both (unit 1)) + (operator '/ 2 'left (unit 1 #t) (prefix '/)) + (operator '^ 3 'right #f (prefix 'expt #f))))) (define current-operator-rule-set (make-parameter (make-default-operator-rule-set))) @@ -66,8 +66,15 @@ (cond ((operator-unit op) => unit-unary?) (else #f))) + (define (operator-prefix-binary-only? op) + (cond ((operator-prefix op) => prefix-binary-only?) + (else #f))) + (define (infix->prefix-1 expr rs fail) (cond ((and (pair? expr) + (single? expr)) + (car expr)) + ((and (pair? expr) (single? (cdr expr)) (let ((op (rule-set-infix-ref rs (car expr)))) (if (and op (operator-unit-unary? op)) @@ -89,31 +96,74 @@ (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))) + (right-op (minimum-precedence right rs)) + (not-binary-only? (not (operator-prefix-binary-only? op)))) (cond ((and (operator? left-op) (operator? right-op)) - (list op-sym - (->prefix left left-op) - (->prefix right right-op))) + `(,(operator-prefix-symbol op) + ,@(if (and not-binary-only? + (operator-left? op) + (eqv? (operator-symbol op) (operator-symbol left-op))) + (cdr (->prefix left left-op)) + (list (->prefix left left-op))) + ,@(if (and not-binary-only? + (operator-right? op) + (eqv? (operator-symbol op) (operator-symbol right-op))) + (cdr (->prefix right right-op)) + (list (->prefix right right-op))))) ((operator? left-op) (if (single? right) - (list op-sym (->prefix left left-op) (car right)) + `(,(operator-prefix-symbol op) + ,@(if (and not-binary-only? + (operator-left? op) + (eqv? (operator-symbol op) (operator-symbol left-op))) + (cdr (->prefix left left-op)) + (list (->prefix left left-op))) + ,@(if (and not-binary-only? + (operator-right? op) + (pair? (car right)) + (eqv? (operator-symbol op) (car (car right)))) + (cdr (car right)) + (list (car right)))) (fail (->infix left op-sym right)))) ((operator? right-op) (if (single? left) - (list op-sym (car left) (->prefix right right-op)) + `(,(operator-prefix-symbol op) + ,@(if (and not-binary-only? + (operator-left? op) + (pair? (car left)) + (eqv? (operator-symbol op) (car (car left)))) + (cdr (car left)) + (list (car left))) + ,@(if (and not-binary-only? + (operator-right? op) + (eqv? (operator-symbol op) (operator-symbol right-op))) + (cdr (->prefix right right-op)) + (list (->prefix right right-op)))) (fail (->infix left op-sym right)))) (else (if (and (single? left) (single? right)) - (list op-sym (car left) (car right)) + `(,(operator-prefix-symbol op) + ,@(if (and not-binary-only? + (operator-left? op) + (pair? (car left)) + (eqv? (operator-symbol op) (car (car left)))) + (cdr (car left)) + (list (car left))) + ,@(if (and not-binary-only? + (operator-right? op) + (pair? (car right)) + (eqv? (operator-symbol op) (car (car right)))) + (cdr (car right)) + (list (car right)))) (fail (->infix left op-sym right))))))) - (if (operator-left? op) + (if (operator-right? op) + (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))) (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))) - (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst))))) - (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))))))) + (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst))))))))) (else expr))) (define prefix->infix @@ -143,8 +193,14 @@ => (lambda (op) (let ((p (operator-precedence op)) (op-sym (operator-symbol op))) - (define (select x xp) - (if (< p xp) x (list x))) + (define (left-select op x xp) + (if (operator-left? op) + (if (<= p xp) x (list x)) + (if (< p xp) x (list x)))) + (define (right-select op x xp) + (if (operator-right? op) + (if (<= p xp) x (list x)) + (if (< p xp) x (list x)))) (cond ((null? args) (cond ((and (not (operator-unit-inv? op)) (operator-unit op)) @@ -159,23 +215,40 @@ (values `(,op-sym ,x) -inf.0) (values `(,(unit-value (operator-unit op)) ,op-sym - ,@(select x xp)) + ,@(right-select op x xp)) p)) (values x xp)))) (else (failure expr))))) ((null? (cdr (cdr args))) (let-values (((x xp) (->infix (car args))) ((y yp) (->infix (cadr args)))) - (values `(,@(select x xp) ,op-sym ,@(select y yp)) p))) + (values `(,@(left-select op x xp) ,op-sym ,@(right-select op y yp)) p))) (else - (if (and (operator-prefix op) - (prefix-fix? (operator-prefix op))) - (failure expr) - (values (cdr (append-map (lambda (arg) - (let-values (((x xp) (->infix arg))) - (cons op-sym (select x xp)))) - args)) - p))))))) + (cond ((and (operator-left? op) + (operator-right? op)) + (values (cdr (append-map (lambda (arg) + (let-values (((x xp) (->infix arg))) + (cons op-sym (if (<= p xp) x (list x))))) + args)) + p)) + ((operator-left? op) + (let-values (((x xp) (->infix (car args)))) + (values (append (if (<= p xp) x (list x)) + (append-map (lambda (arg) + (let-values (((x xp) (->infix arg))) + (cons op-sym (if (< p xp) x (list x))))) + (cdr args))) + p))) + (else + (let ((rev-args (reverse args))) + (let-values (((x xp) (->infix (car rev-args)))) + (values (reverse + (append (if (<= p xp) (reverse x) (list x)) + (append-map (lambda (arg) + (let-values (((x xp) (->infix arg))) + (cons op-sym (if (< p xp) x (list x))))) + (cdr rev-args)))) + p)))))))))) (else (values (map ->infix-fst expr) -inf.0))))))) (define (single? x) @@ -183,7 +256,7 @@ (null? (cdr x)))) (define (minimum-precedence expr rs) - (let ((dummy (operator 'dummy +inf.0))) + (let ((dummy (operator 'dummy +inf.0 'both))) (let ((result (fold (lambda (x y-op) (cond ((rule-set-infix-ref rs x) diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm index 5d8908a..f867786 100644 --- a/qklib/infix/rule-set.scm +++ b/qklib/infix/rule-set.scm @@ -24,6 +24,7 @@ operator-prefix-symbol operator-precedence operator-left? + operator-right? operator-prefix operator-unit @@ -36,7 +37,7 @@ prefix prefix? prefix-symbol - prefix-fix?) + prefix-binary-only?) (import (scheme base) (scheme case-lambda) (only (srfi 128) make-eqv-comparator)) @@ -82,46 +83,53 @@ (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f)) (define-record-type - (make-operator symbol precedence left? unit prefix) + (make-operator symbol precedence assoc unit prefix) operator? (symbol operator-symbol) (precedence operator-precedence) - (left? operator-left?) + (assoc operator-assoc) (unit operator-unit) (prefix operator-prefix)) (define operator (case-lambda - ((symbol) - (operator symbol 0)) - ((symbol precedence) - (operator symbol precedence 'left)) - ((symbol precedence left-or-right) - (operator symbol precedence left-or-right #f)) - ((symbol precedence left-or-right unit) - (operator symbol precedence left-or-right unit #f)) - ((symbol precedence left-or-right unit prefix) - (unless (or (eq? 'left left-or-right) - (eq? 'right left-or-right)) - (error "operator: The 3rd argument must be 'left or 'right" left-or-right)) - (make-operator symbol precedence (eq? 'left left-or-right) unit prefix)))) + ((symbol precedence assoc) + (operator symbol precedence assoc #f)) + ((symbol precedence assoc unit) + (operator symbol precedence assoc unit #f)) + ((symbol precedence assoc unit prefix) + (unless (or (eq? 'left assoc) + (eq? 'right assoc) + (eq? 'both assoc)) + (error "operator: The 3rd argument must be 'left or 'right or 'both" assoc)) + (make-operator symbol precedence assoc unit prefix)))) + + (define (operator-left? x) + (let ((a (operator-assoc x))) + (or (eq? a 'left) + (eq? a 'both)))) + + (define (operator-right? x) + (let ((a (operator-assoc x))) + (or (eq? a 'right) + (eq? a 'both)))) (define (operator-prefix-symbol op) (cond ((operator-prefix op) => prefix-symbol) (else (operator-symbol op)))) (define-record-type - (make-prefix symbol fix?) + (make-prefix symbol binary-only?) prefix? (symbol prefix-symbol) - (fix? prefix-fix?)) + (binary-only? prefix-binary-only?)) (define prefix (case-lambda ((symbol) (prefix symbol #f)) - ((symbol fix?) - (make-prefix symbol fix?)))) + ((symbol binary-only?) + (make-prefix symbol binary-only?)))) (define-record-type (make-unit value inv? unary?) -- cgit v1.2.3