(in-package "MEVAL")

(defvar *rl* nil)

(defun read-main (read-ch)
  (let ((ini-ch nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (consume-whitespace read-ch)
    (setf ini-ch (funcall same-ch))
    (cond ((is-symbol-start ini-ch) (read-symbol read-ch))
          ((is-quote-start ini-ch) 
           (funcall next-ch)
           (list 'quote (read-main read-ch)))
          ((is-macro-start ini-ch) (read-macro read-ch))
          ((is-lparen ini-ch) 
           (let ((lv nil)
                 (rv nil))
             (funcall next-ch)
             (consume-whitespace read-ch)
             (cond ((is-rparen (funcall same-ch))
                    (let ()
                      (funcall next-ch)
                      nil))
                   (t (let ()
                        (setf lv (read-main read-ch))
                        (setf rv (read-rest-list read-ch))
                        (cons lv rv))))))
          (t (throw 'read-error "read:err:unknown form"))))) 
                      
(defun read-rest-list (read-ch)
  (let ((lv nil)
        (rv nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same))
        (peek-ch (funcall read-ch 'peek)))
    (consume-whitespace read-ch)
    (cond ((is-dot (funcall same-ch))
           (let ()
             (cond ((is-whitespace (funcall peek-ch))
                    (funcall next-ch)
                    (setf rv (read-main read-ch))
                    (consume-whitespace read-ch)
                    (cond ((is-rparen (funcall same-ch))
                           (funcall next-ch)
                           rv)
                          (t (throw 'read-error "read:err:missing rparen:1"))))
                   (t 
                    (setf lv (read-main read-ch))
                    (setf rv (read-rest-list read-ch))
                    (cons lv rv)))))
          (t (cond ((is-rparen (funcall same-ch))
                    (funcall next-ch)
                    nil)
                   (t 
                    (setf lv (read-main read-ch))
                    (setf rv (read-rest-list read-ch))
                    (cons lv rv)))))))
                   

(defun is-quote-start (ch)
  (eq ch #\'))

(defun is-macro-start (ch)
  (eq ch #\#))

(defun is-atom-start (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\% #\&))))

(defun is-fixnum-start (ch)
  (or (is-digit ch) (member ch '(#\- #\+))))

(defun is-float-start (ch)
  (or (is-fixnum-start ch) (eq ch #\.)))

(defun is-symbol-start (ch)
  (or (is-fixnum-start ch) (is-float-start ch) (is-atom-start ch)))

(defun is-symbol-ch (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '( #\* #\\ #\+ #\- #\. #\< #\> #\= #\? #\_ #\% #\:))))

(defun is-lparen (ch)
  (eq ch #\())

(defun is-rparen (ch)
  (eq ch #\)))

(defun is-dot (ch)
  (eq ch #\.))

(defun is-sign (ch)
  (or (eq ch #\+) (eq ch #\-)))

(defun is-whitespace (ch)
  (member ch '(#\Space)))

(defun is-atom-char (ch)
  (or (is-alpha ch) (is-digit ch) (member ch '(#\- #\+))))

(defun is-digit (ch)
  (and (>= (char-code ch) (char-code #\0)) (<= (char-code ch) (char-code #\9))))

(defun is-hex-digit (ch)
  (or (is-digit ch) (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\f))))) 

(defun is-alpha (ch)
  (and (>= (char-code ch) (char-code #\a)) (<= (char-code ch) (char-code #\z))))

(defun is-expo-init (ch)
  (member ch '( #\e #\E )))


(defun consume-whitespace (read-ch)
  (let ((next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (do ((akt-ch (funcall same-ch) (funcall next-ch)))
        ((not (is-whitespace akt-ch))))))


(defun read-symbol (read-ch)
  (let ((sym-cl nil)
        (num nil)
        (next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same)))
    (do ((akt-ch (funcall same-ch) (funcall next-ch)))
        ((not (is-symbol-ch akt-ch)))
      (setf sym-cl (cons akt-ch sym-cl)))
    (setf sym-cl (reverse sym-cl))
    (setf num (read-cl-as-number sym-cl))
    (if num
        num
      (make-atom-str (make-string-cl sym-cl)))))
      



(defun make-string-cl (cl)
  (let ((s (make-string (length cl))))
    (do ((i 0 (1+ i))
         (clx cl (cdr clx)))
        ((null clx) s)
      (setf (char s i) (car clx)))))

(defun make-atom-str (str)
  (list 'atom str))

(defun read-macro (read-ch)
  (let ((next-ch (funcall read-ch 'next))
        (same-ch (funcall read-ch 'same))
        (akt-ch nil)
        (res nil))
    (setf akt-ch (funcall next-ch))
    (cond ((eq akt-ch #\')
           (let ()
             (funcall next-ch)
             (list 'function (read-main read-ch))))
          ((eq akt-ch #\Q)
           (let ()
             (setf res nil)
             (do ((i 0 (+ 1 i)))
                 ((> i 7))
               (setf akt-ch (funcall next-ch))
               (if (not (is-hex-digit akt-ch))
                   (throw 'read-error "read:err:Q malformed:001"))
               (setf res (cons akt-ch res)))
             (funcall next-ch)
             (setf res (reverse res))
             (make-q res)))
          ((eq akt-ch #\\)
           (setf akt-ch (funcall next-ch))
           (funcall next-ch)
           akt-ch)
          (t (throw 'read-error "read:err:undefined macro:001")))))

(defun make-q (hexl)
  (list 'Q hexl))


(defun digit-to-num (ch)
  (- (char-code ch) (char-code #\0)))

(defun read-cl-as-number (cl)
  (let ((sign +1)
        (sign-exp +1)
        (cll cl)
        (pre-dot 0)
        (post-dot 0)
        (exp-val 0)
        (dig-cnt 0)
        (akt-ch nil))
    (cond ((eq (car cll) #\+)
           (let ()
             (setf cll (cdr cll))))
          ((eq (car cll) #\-)
           (let ()
             (setf cll (cdr cll))
             (setf sign -1))))
    (setf dig-cnt 
          (do ((pre-digs 0 (+ pre-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))) pre-digs)
            (setf akt-ch (car cll))
            (setf pre-dot (+ (* pre-dot 10) (digit-to-num akt-ch)))
            (setf cll (cdr cll))))
    (if (and (null cll) (> dig-cnt 0))
        (return-from read-cl-as-number (* sign pre-dot)))
    (if (eq (car cll) #\.)
        (let ()
          (setf cll (cdr cll))
          (do ((dez-fact 0.1 (* 0.1 dez-fact))
               (post-digs 0 (+ post-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))))
            (setf akt-ch (car cll))
            (setf cll (cdr cll))
            (if (< post-digs 6)
                (setf post-dot (+ post-dot (* dez-fact (digit-to-num akt-ch))))))))
    (if (null cll)
        (return-from read-cl-as-number (* sign (+ pre-dot post-dot))))
    (if (is-expo-init (car cll))
        (let ()
          (setf cll (cdr cll))
          (if (is-sign (car cll))
              (let ()
                (if (eq (car cll) #\-)
                    (setf sign-exp -1))
                (setf cll (cdr cll))))
          (do ((exp-digs 0 (+ exp-digs 1)))
              ((or (not cll) (not (is-digit (car cll)))))
            (setf akt-ch (car cll))
            (setf exp-val (+ (* exp-val 10) (digit-to-num akt-ch)))
            (setf cll (cdr cll)))
          (setf exp-val (expt 10.0 (* sign-exp exp-val)))))
    (if (null cll)
        (return-from read-cl-as-number (* sign (+ pre-dot post-dot) exp-val)))
    nil))
         






  


(defun eval (expr env)
  (let ((res nil))
;    (format t "eval:expr = ~S~%" (funarg-chop expr))
    (setf res
          (cond ((numberp expr) expr)
                ((atom expr) (eval-atom expr env))
                (t (eval-list expr env))))
;    (format t "eval:result = ~S~%" (funarg-chop res))
    res))

(defun eval-atom (expr env)

  (let ((erg (env-assoc expr env)))
    (if (eq (car erg) '&empty)
        (get-symbol-value expr)
      (cdr erg))))

(defun env-assoc (atm env)
  (do
      ((p env (cdr p))
       (pold nil p))
      ((or (null p) (eq (caar p) atm))
       (cond ((null p) (cons '&empty pold))
             (t (car p))))))

; set-symbol-value und get-symbol-value hier ist provisorisch. muss in cons-pack.lisp umdefiniert werden

(defun set-symbol-value (atm val)
  (setf (symbol-value atm) val))

(defun get-symbol-value (atm)
  (symbol-value atm))


(defun set-symbol-function (atm fun)
  (setf (get atm '&my-symbol-function atm) fun))

(defun get-symbol-function (atm)
  (get atm '&my-symbol-function atm))

;
;

(defun eval-list (expr env)

  (let ((head (car expr))
        (rest (cdr expr)))
    (cond ((eq head 'cond) (eval-cond rest env))
          ((eq head 'quote) (car rest))

          ((eq head 'function) (make-funarg (car rest) env))

          ((eq head 'lambda) (eval-lambda expr env))

          ((eq head 'labels) (eval-labels rest env))

          ((eq head 'let) (eval-let rest env))

          ((eq head 'setq) (eval-setq rest env))

          ((eq head 'defun) (eval-defun rest env))
          
          ((eq head 'defmacro) (eval-defmacro rest env))

          ((eq head 'progn) (eval-progn rest env))

          ((eq head 'do) (eval-do rest env))
          
          ((eq head 'do-until) (eval-do-until rest env))

          ((eq head 'funcall) (eval-funcall rest env))

          ((eq head 'and) (eval-and rest env))

          ((eq head 'or) (eval-or rest env))
          
          ((is-expr-fun head) (eval-expr-fun head rest env))
          ((is-list-fun head) (eval-list-fun head rest env))
          
          ((atom head) (eval-atom-head head rest env))
          (t (error "eval-list: wrong list header")))))



(defun make-funarg (fun env)
  (list 'funarg fun env))


(defun eval-atom-head (head rest env)
;  (format t "~%~S : ~S ~%" head rest)
;  (format t "~%~S~%" (funarg-chop env))
;  (format t "eval-atom-head:~S~%" (funarg-chop (eval head env)))
  (let ((fn (env-assoc head env))
        (fn-expr))
    (setf fn-expr
          (cond ((eq (car fn) '&empty)
                 (get-symbol-function head))
                (t (cdr fn))))
    (if (is-macro fn-expr)
        (eval (apply (macro-fun fn-expr) rest env) env)
      (eval (cons fn-expr rest) env))))

(defun protect-quote (args)
  (do ((args1 args (cdr args1))
       (res nil (cons (list 'quote (car args1)) res)))
      ((null args1) (reverse res))))

(defun is-macro (fn-expr)
  (and (listp fn-expr) (eq (car fn-expr) '&&macro)))

(defun macro-fun (fn-expr)
  (cdr fn-expr))



(defun eval-labels (rest env)
  (let ((env-new env)
        (res nil)
        (result nil)
        (env-end nil))
    (dolist (def (car rest))
      (setf env-new (cons (cons (car def)  nil) env-new)))
    (dolist (def (car rest))
;    (format t "~%~S~%" def)
      (setf res (cons (make-funarg (list 'lambda (car (cdr def)) (car (cdr (cdr def)))) env-new) res)))
;   (format t "~%~S~%" env-new)
    (setf env-end env-new)
    (dolist (defval res)
      (rplacd (car env-end) defval)
      (setf env-end (cdr env-end)))
;   (format t "~%~S~%" (funarg-chop env-new))
    (dolist (form (cdr rest))
      (setf result (eval form env-new)))
    result))

(defun eval-let (rest env)
  (let ((var-term nil)
        (vars nil)
        (vals nil))
;    (format t "rest = ~S ~%" rest)
    (setf var-term (car rest))
    (dolist (x var-term)
      (cond ((null (cdr x))
             (setf vars (cons (car x) vars))
             (setf vals (cons nil vals)))
            (t 
             (setf vars (cons (car x) vars))
             (setf vals (cons (cadr x) vals)))))
;    (format t "vars = ~S vals = ~S ~%" vars vals)
    (eval (append (list (list 'lambda vars (cons 'progn (cdr rest)))) vals) env)))


(defun eval-setq (rest env)
  (let ((val (eval (cadr rest) env))
        (pair (env-assoc (car rest) env)))
    (if (not (eq (car pair) '&empty))
        (progn (rplacd pair val)
          val)
      (set-symbol-value (car rest) val))))

(defun eval-defun (rest env)
  (set-symbol-function (car rest)
                       (make-funarg (list 'lambda (cadr rest) (caddr rest)) env)))

(defun eval-defmacro (rest env)
  (set-symbol-function (car rest) 
                       (cons '&&macro
                             (make-funarg (list 'lambda (cadr rest) (caddr rest)) env))))

(defun eval-progn (rest env)
  (let ((res nil))
    (dolist (x rest)
      (setf res (eval x env)))
    res))


(defun eval-do (rest env)
  (let ((pre (car rest))
        (tst-res (cadr rest))
        (body (cddr rest))
        (new-expr nil)
        (assign nil)
        (update nil))
    (dolist (x pre)
      (setf assign (cons (list (car x) (cadr x)) assign)))
    (dolist (x pre)
      (setf update (cons (list 'setq (car x) (caddr x)) update)))
    (setf body (append body update))
    (setf new-expr (append (list 'do-until tst-res) body))
    (setf new-expr (list 'let assign new-expr))
    (eval new-expr env)))

(defun eval-do-until (rest env)
  (let ((tst (caar rest))
        (res (cadar rest))
        (body (cons 'progn (cdr rest))))
    (do ()
        ((eval tst env) (eval res env))
      (eval body env))))


(defun eval-funcall (rest env)
  (let ((fval (eval (car rest) env))
        (argl (list-eval (cdr rest) env)))
    (eval (cons fval argl) env)))


(defun eval-and (rest env)
  (labels ((eval-and-1 (rest env acc)
             (if (null rest)
                 acc
               (let ((v1 (eval (car rest) env)))
                 (if v1
                     (eval-and-1 (cdr rest) env v1)
                   nil))))) (eval-and-1 rest env nil)))

(defun eval-or (rest env)
  (if (null rest)
      nil
    (let ((v1 (eval (car rest) env)))
      (if v1
          v1
        (eval-or (cdr rest) env)))))


(defun eval-cond (rest env)
  (let ((res nil))
    (dolist (cond-line rest)
      (if (not (null (eval (car cond-line) env)))
          (do ((cond-expr (cdr cond-line) (cdr cond-expr)))
              ((null cond-expr) (return-from eval-cond res))
            (setf res (eval (car cond-expr) env)))))
    (error "eval-cond:run out of conditions")))


(defun eval-lambda (expr env)

  (list 'funarg expr env))

(defun is-expr-fun (head)

  (member head '(+ - * / = <= >= < > null cons car cdr atom numberp not listp list eq equal)))

(defun is-list-fun (head)

  (listp head))


(defun eval-expr-fun (head rest env)
  
  (let ((args (list-eval rest env)))
    (cond ((eq head 'cons)
           (cl:apply 'cons args))
          ((eq head 'list)
           (cl:apply 'list args))
          (t (cl:apply head args)))))


(defun eval-list-fun (head rest env)
  (progn
;    (format t "head = ~S rest = ~S ~%" head rest)
    (cond ((eq (car head) 'lambda) (eval-lambda-list (cdr head) rest env))
          ((eq (car head) 'funarg) (eval-funarg (cdr head) rest env))
          (t (error "eval-list-fun: case not implemented")))))


(defun apply (fn args env)
  (cond ((listp fn)
         (cond ((eq (car fn) 'lambda) (apply-lambda (cdr fn) args env))
               ((eq (car fn) 'funarg) (apply-funarg (cdr fn) args env))
                (t (apply (eval fn env) args env))))
         ((atom fn)
          (let ((fn1 (env-assoc fn env))
                (fn-expr))
            (setf fn-expr
                  (cond ((eq (car fn1) '&empty)
                         (get-symbol-function fn))
                        (t (cdr fn1))))
            (if (not (is-macro fn-expr))
                (apply fn-expr args env)
              (error "apply: try to apply macro"))))
         (t (error "apply: case not implemented"))))


(defun apply-lambda (lambda-rest args env)
  (let ((new-env (env-bind (car lambda-rest) args env)))
    (eval (car (cdr lambda-rest)) new-env)))



(defun eval-lambda-list (lambda-rest args env)

  (let ((new-env (env-bind (car lambda-rest) (list-eval args env) env)))
;    (format t "~S / " (funarg-chop new-env))
    (eval (car (cdr lambda-rest)) new-env)))

(defun list-eval (args env)
  (let ((acc nil))   
    (dolist (x args) (setf acc (cons (eval x env) acc)))
    (reverse acc)))

(defun env-bind (vars vals old-env)
  (do
      ((vars-akt vars (cdr vars-akt))
       (vals-akt vals (cdr vals-akt))
       (res old-env old-env))
      ((or (null vars-akt)
           (eq (car vars-akt) '&rest))
       (if (not (null vars-akt))
         (push (cons (cadr vars-akt)
                     vals-akt) old-env)
         old-env))
    (push (cons (car vars-akt) (car vals-akt)) old-env)))


(defun eval-funarg (funarg-rest args env)
  (apply-funarg funarg-rest (list-eval args env) env))


(defun apply-funarg (funarg-rest args env)
  (apply (car funarg-rest) args (car (cdr funarg-rest))))





(defun funarg-chop (e)
  (cond ((atom e) e)
        ((eq (car e) 'FUNARG) (list (car e) (car (cdr e))))
        (t (cons (funarg-chop (car e)) (funarg-chop (cdr e))))))




(defun main ()

  (let ((global-env (list (cons t t) (cons nil nil))))
    (loop
     (format t ">")
     (let ((r (read-from-string (read-line)))
           (e nil))
       (if (equal r '(quit))
           (return-from main nil))
;       (setf *rl* nil)
       (setf e (eval r global-env))
;       (format t "rl = ~S~%" *rl*)
       (format t "~%~%res = ~S~%~%" (funarg-chop e))))))


(defun make-reader (str)
  (let ((i 0))
    #'(lambda (choose) 
        (cond ((eq choose 'next)
               #'(lambda () (progn (setf i (1+ i))(format t "~S" (elt str i)) (elt str i))))
              ((eq choose 'same)
               #'(lambda ()(elt str i)))
              ((eq choose 'peek)
               #'(lambda () (elt str (+ i 1))))))))

(defun test-read (str)

  (let ((res nil))
    (setf res (make-reader str))
    (read-main res)))