From ec4cc50b43d3e71aa04aafa7ec263441022c3af1 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Fri, 20 Sep 2024 01:57:01 +0900 Subject: Remove infix library Use https://git.tojo.tokyo/infix-to-prefix.git/about/ library. --- qklib/infix.scm | 267 ----------------------------------------------- qklib/infix/rule-set.scm | 179 ------------------------------- 2 files changed, 446 deletions(-) delete mode 100644 qklib/infix.scm delete mode 100644 qklib/infix/rule-set.scm (limited to 'qklib') 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 -;;; -;;; 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)) - )) diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm deleted file mode 100644 index db0c4e5..0000000 --- a/qklib/infix/rule-set.scm +++ /dev/null @@ -1,179 +0,0 @@ -;;; Copyright 2024 Masaya Tojo -;;; -;;; 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 rule-set) - (export rule-set - rule-set? - rule-set-infix-ref - rule-set-prefix-ref - - operator - operator? - operator-symbol - operator-prefix-symbol - operator-precedence - operator-left? - operator-right? - operator-associative? - operator-prefix - operator-identity - - identity - identity? - identity-value - identity-inv? - identity-unary? - identity-unary-precedence - - direction - direction? - direction-left? - direction-associative? - - prefix - prefix? - prefix-symbol - prefix-binary-only?) - (import (scheme base) - (scheme case-lambda) - (only (srfi 128) make-eqv-comparator)) - (cond-expand - ((library (srfi srfi-146 hash)) ;; for guile-srfi-146 - (import (only (srfi srfi-146 hash) hashmap-ref/default hashmap-unfold))) - ((library (srfi 146 hash)) - (import (only (srfi 146 hash) hashmap-ref/default hashmap-unfold)))) - (begin - (define-record-type - (make-rule-set operator-hashmap prefix-hashmap) - rule-set? - (operator-hashmap rule-set-operator-hashmap) - (prefix-hashmap rule-set-prefix-hashmap)) - - (define (rule-set operator-list) - (make-rule-set (list->operator-hashmap operator-list) - (list->prefix-hashmap operator-list))) - - (define (list->operator-hashmap ops) - (hashmap-unfold null? - (lambda (ops) - (values (operator-symbol (car ops)) - (car ops))) - cdr - ops - (make-eqv-comparator))) - - (define (list->prefix-hashmap ops) - (hashmap-unfold null? - (lambda (ops) - (let ((op (car ops))) - (values (operator-prefix-symbol op) - (car ops)))) - cdr - ops - (make-eqv-comparator))) - - (define (rule-set-infix-ref rule-set key) - (hashmap-ref/default (rule-set-operator-hashmap rule-set) key #f)) - - (define (rule-set-prefix-ref rule-set key) - (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f)) - - (define-record-type - (make-operator symbol precedence dir identity prefix) - operator? - (symbol operator-symbol) - (precedence operator-precedence) - (dir operator-direction) - (identity operator-identity) - (prefix operator-prefix)) - - (define operator - (case-lambda - ((symbol precedence) - (operator symbol precedence #f)) - ((symbol precedence direction) - (operator symbol precedence direction #f)) - ((symbol precedence direction identity) - (operator symbol precedence direction identity #f)) - ((symbol precedence direction identity prefix) - (when (and identity (identity-unary? identity) - (not (and direction (direction-left? direction)))) - (error "operator: unary operator must be left direction" symbol)) - (make-operator symbol precedence direction identity prefix)))) - - (define-record-type - (make-direction left? associative?) - direction? - (left? direction-left?) - (associative? direction-associative?)) - - (define (direction-right? assoc) - (not (direction-left? assoc))) - - (define direction - (case-lambda - ((dir) - (direction dir #f)) - ((dir associative?) - (unless (or (eq? 'left dir) - (eq? 'right dir)) - (error "direction: The 1st argument must be 'left or 'right" dir)) - (make-direction (eq? 'left dir) associative?)))) - - (define (operator-left? x) - (cond ((operator-direction x) => direction-left?) - (else #f))) - - (define (operator-right? x) - (cond ((operator-direction x) => (lambda (a) (not (direction-left? a)))) - (else #f))) - - (define (operator-associative? x) - (cond ((operator-direction x) => direction-associative?) - (else #f))) - - (define (operator-prefix-symbol op) - (cond ((operator-prefix op) => (lambda (p) - (and (prefix-has-symbol? p) - (prefix-symbol p)))) - (else (operator-symbol op)))) - - (define-record-type - (make-prefix binary-only? has-symbol? symbol) - prefix? - (binary-only? prefix-binary-only?) - (has-symbol? prefix-has-symbol?) - (symbol prefix-symbol)) - - (define prefix - (case-lambda - ((binary-only?) - (make-prefix binary-only? #f #f)) - ((binary-only? symbol) - (make-prefix binary-only? #t symbol)))) - - (define-record-type - (make-identity value inv? unary? unary-precedence) - identity? - (value identity-value) - (inv? identity-inv?) - (unary? identity-unary?) - (unary-precedence identity-unary-precedence)) - - (define identity - (case-lambda - ((value) (identity value #f)) - ((value inv?) (identity value inv? #f)) - ((value inv? unary?) (identity value inv? unary? #f)) - ((value inv? unary? unary-precedence) (make-identity value inv? unary? unary-precedence)))))) -- cgit v1.2.3