;;; 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
          prefix->infix
          infix
          current-infix-rules)
  (import (scheme base)
          (scheme case-lambda)
          (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? mapping-unfold mapping-adjoin mapping-ref/default))
  (begin
    (define-record-type <infix-rule>
      (%make-operator symbol precedence left? unit inv?)
      operator?
      (symbol operator-symbol)
      (precedence operator-precedence)
      (left? operator-left?)
      (unit operator-unit)
      (inv? operator-inv?))

    (define-record-type <unit>
      (make-unit value)
      unit?
      (value unit-value))

    (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 (infix-rule-list->infix-rule-mapping ops)
      (mapping-unfold null?
                      (lambda (ops)
                        (values (operator-symbol (car ops))
                                (car ops)))
                      cdr
                      ops
                      (make-default-comparator)))

    (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-infix-rules
      (make-parameter (make-default-infix-rules)
                      (lambda (x)
                        (if (mapping? x)
                            x
                            (infix-rule-list->infix-rule-mapping x)))))

    (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)))

    (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)
      (if (not (pair? expr))
          expr
          (let ->prefix ((expr (cons (car expr) (replace-operators (cdr expr) ops)))) ;; all new conses
            (define op (minimum-precedence (cdr 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 (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 (pair? 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))))
    ))