;;;; A lisp version of the Crenshaw tutorials - Jeremy English
;;;; 10-October-2006
;;;; http://compilers.iecc.com/crenshaw/tutor4.txt
;;;;
;;;; This one similar to the interperter out of "Compiler Construction"
;;;; By Niklaus Wirth
;;;;
;;;; <factor> ::= number | (<expression>) | <variable>
;;;; <term> ::= <factor>  [ <mulop> <factor> ]*
;;;; <expression> ::= <term> [<addop> <term>]*

(defpackage crenshaw-interpreter
  (:use :cl :closure-reader))

(in-package :crenshaw-interpreter)

(defun expected (s)
  (error (format nil "~a expected" s)))

(defun get-name (reader)
  (if (alpha-char-p (sym reader))
      (let ((token
             (loop while (and (not (null (sym reader)))
                              (alphanumericp (sym reader)))
                   collecting (char-upcase (sym reader))
                   do (next reader))))
        (skip-white reader)
        (coerce token 'string))
      (expected "name")))

(defun get-num (reader)
  (if (digit-char-p (sym reader))
      (let ((token
             (loop while (and (not (null (sym reader)))
                              (digit-char-p (sym reader)))
                   collecting (sym reader)
                   do (next reader))))
        (skip-white reader)
        (read-from-string (coerce token 'string)))
      (expected "integer")))


;;I don't care for the way that Crenshaw treats newlines and space
;;seperatly. I prefer the way Wirth handles it by skiping everything
;;less then space.
(defun is-white (char)
  (if (characterp char)
      (char<= char #\space)
      nil))

(defun skip-white (reader)
  (loop while (is-white (sym reader))
        do (next reader)))

(defun is-add-op (char)
  (member char '(#\+ #\-)))

(defun is-mul-op (char)
  (member char '(#\* #\/)))

(defun factor (reader memory)
  (if (equal (sym reader) #\()
      (progn
        (match reader #\()
        (let ((value
               (expression reader memory)))
          (match reader #\))
          value))
      (if (alpha-char-p (sym reader))
          (gethash (get-name reader) memory)
          (get-num reader))))

(defun expression (reader memory)
  (let ((value
         (if (is-add-op (sym reader)) ;Deal with unary minus by prefixing zero
             0
             (term reader memory))))
    (loop while (is-add-op (sym reader)) do
          (cond
            ((equal (sym reader) #\+)
             (match reader #\+)
             (setf value (+ value (term reader memory))))
            ((equal (sym reader) #\-)
             (match reader #\-)
             (setf value (- value (term reader memory))))))
    value))

(defun term (reader memory)
  (let ((value (factor reader memory)))
    (loop while (is-mul-op (sym reader)) do
          (cond
            ((equal (sym reader) #\*)
             (match reader #\*)
             (setf value (* value (factor reader memory))))
            ((equal (sym reader) #\/)
             (match reader #\/)
             (setf value (/ value (factor reader memory))))))
    value))

(defun assignment (reader memory)
  (let ((name (get-name reader)))
    (match reader #\=)
    (setf (gethash name memory)
          (expression reader memory))))

(defun match (reader x)
  (if (equal x (sym reader))
      (progn
        (next reader)
        (skip-white reader))
      (expected (format nil "~a" x))))

(defun init-memory (init-value-pairs)
  "Pass a list of key value pairs to the function to define
constants. For example:

   (init-memory '((\"pi2\" 6.28318531) (\"width\" 500)))

All of the keys should be strings and the values should be numbers."
  (let ((memory (make-hash-table :test 'string-equal))) ;case insensitive
    (setf (gethash "pi" memory) 3.14159265)
    (setf (gethash "e" memory) 2.71828183)
    (setf (gethash "phi" memory) 1.61803399)
    (loop for key-value-pair in init-value-pairs do
          (setf (gethash (first key-value-pair) memory)
                (second key-value-pair)))
    memory))

(defun infix-calc (exp &key (constants nil))
  (let ((reader (closure-reader:define-string-reader exp)))
    (expression reader (init-memory constants))))

(defun infix-eval-loop ()
  (let ((memory (init-memory nil)))
    (format t "> ")
    (loop for reader = (closure-reader:define-string-reader (read-line))
          until (equal (sym reader) #\.) do
          (format t "~a~%> " (assignment reader memory)))))