;; NOTES: a token is a (list symbol symbol) e.g. (list 'NUMBER 3.14)
;;        a transition is a (list symbol (char -> boolean) symbol) e.g. (list 'START char-numeric? 'NUMBER)
;;        a s-expr is a quoted scheme expression

;; CONTRACT: parse: string -> (listof s-expr)
;; PURPOSE: Transform a string into a list of sexpr
;; EFFECTS: External: None
;;          Internal: None
(define parse
  (lambda (str)
    (local
      [;; CONTRACT: tokenize: string -> (listof token)
       ;; PURPOSE: Consume a string and transform it into a list of tokens 
       (define tokenize 
         (lambda (str)
           (local
             [(define next-token ; next-token: (listof char)
                (lambda (charlst)
                  (local
                    [;;;;;; char test functions ;;;;;;
                     (define char-cmp ; char-cmp: char -> (char -> boolean)
                       (lambda (tst)
                         (lambda (ch) (char=? tst ch))))
                     (define char-cmp-or ; char-cmp-or: (char -> boolean) (char -> boolean) -> (char->boolean)
                       (lambda (cmp1 cmp2)
                         (lambda (ch) (or (cmp1 ch) (cmp2 ch)))))
                     (define char-paren? ; char-paren?: char -> boolean
                       (lambda (ch)
                         (ormap (lambda (cmp) (char=? cmp ch)) (list #\( #\) #\[ #\]))))
                     (define char-name? ; char-name?: char -> boolean
                       (lambda (ch)
                         (not (or (ormap (lambda (cmp) (char=? cmp ch)) 
                                         (list #\" #\, #\' #\` #\| #\; #\#)) 
                                  (char-whitespace? ch) 
                                  (char-paren? ch)))))
                     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                     (define translist (list
                                        ; ambiguous
                                        (list 'START (char-cmp #\-) 'MINUS)
                                        (list 'START (char-cmp #\.) 'PERIOD)
                                        
                                        ; symbols
                                        (list 'START (char-cmp #\') 'SYMBOL)
                                        (list 'SYMBOL char? 'FINISHED)
           
                                        ; identifiers
                                        (list 'START (lambda (ch) (and (char-name? ch) (not (char-numeric? ch)))) 'IDENTIFIER)
                                        (list 'IDENTIFIER char-name? 'IDENTIFIER)
                                        (list 'IDENTIFIER (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
                                        (list 'MINUS (lambda (ch) (and (char-name? ch) (not (char-numeric? ch)))) 'IDENTIFIER)
                                        
                                        ; numbers
                                        (list 'START char-numeric? 'INTEGER)
                                        (list 'INTEGER char-numeric? 'INTEGER)
                                        (list 'INTEGER (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
                                        (list 'INTEGER (char-cmp #\.) 'DECIMAL)
                                        (list 'DECIMAL char-numeric? ' DECIMAL)
                                        (list 'DECIMAL (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
                                        (list 'MINUS char-numeric? 'INTEGER)
                                        (list 'INTEGER (char-cmp #\/) 'FRACTION)
                                        (list 'FRACTION char-numeric? 'FRACTION)
                                        (list 'FRACTION (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
                                        ; complex numbers go here
                                 
                                        ; parents
                                        (list 'START char-paren? 'PAREN)
                                        (list 'PAREN char? 'FINISHED)
                                        
                                        ; whitespace
                                        (list 'START char-whitespace? 'WHITESPACE)
                                        (list 'WHITESPACE char-whitespace? 'WHITESPACE)
                                        (list 'WHITESPACE (lambda (ch) (not (char-whitespace? ch))) 'FINISHED)
                                        ))
                     (define getnextstate ; getnextstate: character symbol (listof transition) -> symbol
                       (lambda (ch state tlst)
                         (cond
                           [(empty? tlst) false]
                           [(and (symbol=? (caar tlst) state) ((cadr (car tlst)) ch)) (caddr (car tlst))]
                           [else 
                            (getnextstate ch state (cdr tlst))])))
                     (define next-token ; next-token: (listof char) symbol (listof char) -> (list symbol (list symbol symbol))
                       (lambda (charlst state acc)
                         (local
                           [(define next-state 
                              (cond
                                [(empty? charlst) 'FINISHED]
                                [else (getnextstate (car charlst) state translist)]))]
                           (cond
                             [(boolean? next-state)
                              (error 'next-token 
                                     (string-append "parse error, no state transition for state " (symbol->string state) 
                                                    " with character " (list->string (list (car charlst))) 
                                                    ". Accumulator = \"" (list->string (reverse acc)) "\""))]
                             [(symbol=? next-state 'FINISHED) (list charlst state (string->symbol (list->string (reverse acc))))]
                             [else (next-token (cdr charlst) next-state (cons (car charlst) acc))]))))]
                    (next-token charlst 'START empty))))
              (define clean-token ; clean-token (list symbol symbol) -> (list symbol symbol)
                (lambda (token)
                  (cond
                 ;
                    [(or (symbol=? 'INTEGER (car token)) (symbol=? 'FRACTION (car token)) (symbol=? 'DECIMAL (car token)))
                         (list (car token) (string->number (symbol->string (cadr token))))]
                    [else token])))
              (define tokenize ; tokenize: (listof char) (listof token) -> (listof token)
                (lambda (chlist acc)
                  (cond 
                    [(empty? chlist) (reverse acc)]
                    [else ((lambda (x) (tokenize (car x) (cons (clean-token (cdr x)) acc))) (next-token chlist))])))] ; excuse the funkiness
             (tokenize (string->list str) empty))))
       
       ;; CONTRACT: build-sexpr: (listof token) s-expr union('|)| '||]|) (continuation-lambda)
       ;; PURPOSE: Consume a list of tokens, keep an accumulator of s-exprs, remember which type of paren is active (circle or
       ;;          square) and keep a continuation lambda
       (define build-sexpr 
         (lambda (tokens acc endparen cont)
           (local
             [(define type (cond [(empty? tokens) 'oops] [else (caar tokens)]))
              (define match-delim 
                (lambda (p) 
                  (cond
                    [(symbol=? p '|(|) '|)|]
                    [(symbol=? p '|[|) '|]|])))]
             (cond
               [(empty? tokens) 
                (cond
                  [(symbol=? endparen 'NONE) (cont (reverse acc))]
                  [else (error 'build-sexpr (string-append "Unmatched " (symbol->string endparen)))])]
               [(symbol=? 'PAREN type) 
                (cond 
                  [(or (symbol=? '|(| (cadar tokens)) (symbol=? '|[| (cadar tokens))) 
                   (build-sexpr (cdr tokens) empty (match-delim (cadar tokens)) 
                                (lambda (tokens subexpr) (build-sexpr tokens (cons subexpr acc) endparen cont)))]
                  [(symbol=? endparen (cadar tokens)) (cont (cdr tokens) (reverse acc))]
                  [else (error 'build-sexpr (string-append "Unexpected " (symbol->string (cadar tokens))))])]
               [(symbol=? 'WHITESPACE type) (build-sexpr (cdr tokens) acc endparen cont)] ; ignore whitespace
               [else (build-sexpr (cdr tokens) (cons (cadar tokens) acc) endparen cont)]
               ))))]
      (build-sexpr (tokenize str) empty 'NONE (lambda (x) x)))))
;; CONTRACT: eval: expr env -> expr
;; PURPOSE: Reduce an expression as far as possible
(define eval
  (lambda (expr env)
    (local
      [(define zip ; list list -> assoclist
         (lambda (L1 L2)
           (local
             [(define zip
                (lambda (L1 L2 acc)
                  (cond
                    [(empty? L2) (reverse acc)]
                    [else (zip (cdr L1) (cdr L2) (cons (list (car L1) (car L2)) acc))])))]
             (zip L1 L2 empty))))
       (define lookup ; lookup: symbol env -> expr
         (lambda (sym env)
           (local 
             [(define ans (assq sym env))]
              (cond
               [(boolean? ans) (error 'lookup (format "symbol undefined: ~a" (symbol->string sym)))]
               [else (cadr ans)]))))
       (define lookup-prm ; lookup-prm: symbol -> prm
         (lambda (sym)
           (local
             [(define prm-ops `((+ ,+) (- ,-) (* ,*) (cons ,cons) (car ,car) (cdr ,cdr) (empty ,empty) (empty? ,empty?)))
              (define ans (assq sym prm-ops))]
             (cond 
               [(boolean? ans) #f]
               [else (cadr ans)]))))
       (define exprsubs
         (lambda (expr env)
           (local
             [(define exprsubs
                (lambda (expr env acc)
                  (cond
                    [(empty? expr) (reverse acc)]
                    [(and (cons? (car expr)) (cons? (car expr))) (exprsubs (cdr expr) env (cons (exprsubs (car expr) env empty) acc))]
                    [else
                     (local
                       [(define subs 
                          (cond 
                            [(boolean? (lookup-prm (car expr))) (lookup (car expr) env)]
                            [else (lookup-prm (car expr))]))]
                       (exprsubs (cdr expr) env (cons subs acc)))])))]
             (exprsubs expr env empty))))
       (define getlocaldefs
         (lambda (defs) ...))]
    (cond
      [(empty? expr) (error 'eval "expected a special form or primative name after an open parenthesis, but nothing's there")]
      [(number? expr) expr]
      [(symbol? expr) 
       (cond
         [(boolean? (lookup-prm expr)) (lookup expr env)]
         [else (lookup-prm expr)])]
      [(and (cons? expr) (cons? (car expr))) (eval (caddr (car expr)) (zip (cadar expr) (map (lambda (x) (eval x env)) (cdr expr))))]
      [(cons? expr)
       (cond 
         ;[(number? (car expr)) (error 'eval (format "expected procedure, given ~a; other arguments were: ~a" (car expr) (cdr expr)))]
         [(symbol=? 'cond (car expr)) ...]
         [(symbol=? 'local (car expr)) (eval (caddr expr) (append (getlocaldefs (cadr expr)) env))] ; a local expr - (local <listof definitions> expr)
         [(symbol=? 'lambda (car expr)) (list 'lambda (cadr expr) (exprsubs (caddr expr) (append (zip (cadr expr) (cadr expr)) env)))] ; a lambda expr
         [(symbol=? 'quote (car expr)) (cadr expr)] ; a symbol 
         
            [else (cond ; (<func> <arg1> ... <argn>) - function application
                 [(boolean? (lookup-prm (car expr))) (eval (caddr expr) (zip (cadr expr) (eval (car expr) env)) (map (lambda (x) (eval x env)) (cdr expr)))]
                 [else (apply (lookup-prm (car expr)) (map (lambda (x) (eval x env)) (cdr expr)))]
                 )])]
      [else (error 'eval "unexpected syntax")]))))