;;; 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
          current-operator-rule-set)
  (import (scheme base)
          (scheme case-lambda)
          (only (srfi 1) car+cdr fold break! reverse! append-map)
          (only (srfi 26) cut cute)
          (srfi 35)
          (qklib infix rule-set))
  (begin
    (define (make-default-operator-rule-set)
      (rule-set
       (list
        (operator '+ 1 'left (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)))))

    (define current-operator-rule-set
      (make-parameter (make-default-operator-rule-set)))

    (define-condition-type &infix-error &error
      infix-error?
      (expr infix-error-expr))

    (define infix->prefix
      (case-lambda
        ((expr failure)
         (call/cc
          (lambda (return)
            (let ((rs (current-operator-rule-set)))
              (map-all-list (cut infix->prefix-1 <> rs (lambda (e) (return (failure e))))
                            expr)))))
        ((expr)
         (infix->prefix expr (lambda (e) #f)))))

    (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 (operator-unit-unary? op)
      (cond ((operator-unit op) => unit-unary?)
            (else #f)))

    (define (infix->prefix-1 expr rs fail)
      (cond ((and (pair? expr)
                  (single? (cdr expr))
                  (let ((op (rule-set-infix-ref rs (car expr))))
                    (if (and op (operator-unit-unary? op))
                        op
                        #f)))
             => (lambda (op)
                  (let ((arg (car (cdr expr)))
                        (unit (operator-unit op)))
                    (if (rule-set-infix-ref rs arg)
                        (fail expr)
                        (if (unit-inv? unit)
                            expr
                            arg)))))
            ((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)))
                        (cond ((and (operator? left-op) (operator? right-op))
                               (list op-sym
                                     (->prefix left left-op)
                                     (->prefix right right-op)))
                              ((operator? left-op)
                               (if (single? right)
                                   (list op-sym (->prefix left left-op) (car right))
                                   (fail (->infix left op-sym right))))
                              ((operator? right-op)
                               (if (single? left)
                                   (list op-sym (car left) (->prefix right right-op))
                                   (fail (->infix left op-sym right))))
                              (else
                               (if (and (single? left) (single? right))
                                   (list op-sym (car left) (car right))
                                   (fail (->infix left op-sym right)))))))
                    (if (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)))
                              (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)))))))
            (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 (operator-unit-inv? x)
      (cond ((operator-unit x) => (cut unit-inv? <>))
            (else #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)))
                            (define (select x xp)
                              (if (<= p xp) x (list x)))
                            (cond ((null? args)
                                   (cond ((and (not (operator-unit-inv? op))
                                               (operator-unit op))
                                          => (lambda (u) (values (unit-value u) -inf.0)))
                                         (else (failure expr))))
                                  ((null? (cdr args))
                                   (let-values (((x xp) (->infix (car args))))
                                     (cond ((operator-unit op)
                                            => (lambda (u)
                                                 (if (unit-inv? u)
                                                     (if (unit-unary? u)
                                                         (values `(,op-sym ,x) -inf.0)
                                                         (values `(,(unit-value (operator-unit op))
                                                                   ,op-sym
                                                                   ,@(select 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)))
                                  (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)))))))
                    (else (values (map ->infix-fst expr) -inf.0)))))))

    (define (single? x)
      (and (pair? x)
           (null? (cdr x))))

    (define (minimum-precedence expr rs)
      (let ((dummy (operator 'dummy +inf.0)))
        (let ((result
               (fold (lambda (x y-op)
                       (cond ((rule-set-infix-ref rs x)
                              => (lambda (x-op) (if (<= (operator-precedence x-op) (operator-precedence y-op))
                                                    x-op
                                                    y-op)))
                             (else y-op)))
                     dummy
                     expr)))
          (if (eq? dummy result)
              #f
              result))))
    ))