;;; 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) 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 ((op (car op+rev-rest))
                             (rev-rest (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 ((op (car op+rest))
                           (rest (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))))
    ))