;; From shell>> mzscheme -G -f prec.scm -e '(exit)'
;;
;; Scheme version of Precedence Climbing Parser
;;   Pythonic cousin is prec.py
;;
;;  3RD DRAFT   CURRENT
;;

;;Match a NUMBER, IDENTIFIER, or OPERATOR
(define re (regexp "[0-9]+|[A-Za-z_][A-Za-z_0-9]*|[-+*/^()=,]"))

;;
;;Lexical Scanner for basic infix expressions
;;TEST version - PRINTS ITS OUTPUT
;;
(define (scan s)
  (let ( [ip (open-input-string s)] )
    (do ([m (regexp-match re ip) (regexp-match re ip)])
      ((not m) (newline))
      (printf " ~a" (car m))
      )))
;(scan "x=2*3+4")


;;
;;Precedence Climbing Parser
;;

;Operator precedence, arity & associativity

;Initialize
(define binary-table (make-hash-table 'equal))
(define unary-table (make-hash-table 'equal))

(define (init-prec table ops)
  (for-each (lambda (x)
              (let ([level (car x)])
                ; Add operators to hash table
                (for-each (lambda (op)
                            (hash-table-put! table op level)
                            ;(printf "~a ~a~n" op level)
                            )
                          (cdr x)))
              )
            ops))

;;OPERATOR PRECEDENCE IS DEFINED HERE:
(init-prec binary-table
           '[(2 "=")
             (3 "+" "-")
             (5 "*" "/")
             (6 "^")]
           )
(init-prec unary-table
           '[(4 "+" "-")]
           )

;Lookup functions
(define (PREC op)       (hash-table-get binary-table op #f))

(define (UNARY-PREC op) (hash-table-get unary-table op #f))

(define (LEFT-ASSOC? op)
  (NOT (OR (equal? op "=") (equal? op "^"))))

(define (BINARY? op) (prec op)) ;;;OK as long as every operator can be BINARY

(define (UNARY? op) (equal? op "-")) ;;;Bare minimum..


;Input-stream handling
(define IP ())
(define NEXT ())

(define (CONSUME)
  (let ([cur next]
        [t (regexp-match re ip)])
    (set! next
          (if t [bytes->string/utf-8 (car t)] t))
    cur))

(define (BRACKETS)
  (consume)  ;"("
  (do ([tree ()])
    {[equal? next ")"]  (consume)  tree}     ;End loop, consume ")", return TREE
    (let ([E (expr 0)])
      ;      (set! tree (append tree [if (list? E)  E  (list E)]))
      (set! tree (append tree (list E)))
      (if (equal? next ",") (consume)) )))

(define (P)
  (cond [(unary? next)
         (let* ([op (consume)]
                [tree (expr (unary-prec op))])
           (list op tree))]
        
        [(equal? next "(")                  ;SUBEXPRESSION/LIST IN PARENS
         (let ([tree (brackets)])
           (if [AND (= 1 (length tree)) (list? (car tree))]
               (car tree)
               tree))]
        
        [(regexp-match "^[0-9]" next)       ;NUMBER
         (consume)]
        
        [(regexp-match "^[a-zA-Z_]" next)   ;VARIABLE
         (let ([var (consume)])
           (if (equal? next "(")               ;FUNCTION CALL
               (cons var (brackets))
               ;               (list var (brackets))
               var))]
        
        [else (printf "ERROR: (P) Unexpected: ~v~n" next)]))

(define (EXPR n)
  (do ([tree (P)])
    ;While
    ([NOT [AND ;next
           (binary? next)
           (>= (prec next) n)]]
     ;Return when done
     tree)
    ;Loop body
    (let* ([op (consume)]
           [q (+ (prec op) (if (left-assoc? op) 1 0))])
      (set! tree (list op tree (expr q))))))

(define (PARSE src)
  ;Prime the pump
  (set! ip (open-input-string src))
  (consume)
  
  ;Parse
  (let ([E (expr 0)])
    (if next
        (printf "ERROR: Expected EOF, got ~v~n" next))
    (format "~a" E)))


;;
;;TESTS
;;

(define (TEST src)
  ;(scan src)    ;Test the Lexer
  (printf "~a ==> ~a~n~n" src (parse src)))

(require (lib "string.ss"))

(define (RUN src)
  (let ([E (parse src)])
    ;(scan src)    ;Test the Lexer
    (printf "~a ==> ~a~n" src E)
    (printf "  ==> ~v~n~n" (eval-string E))
    ))

(define (^ a b) (expt a b))    ;Alias



(let ([f (open-input-file "tests.txt")])
  (do ([x (read-line f) (read-line f)])
    {[eof-object? x] ()}
    (if (< 0 (string-length x))
        (test x))
    ))