;eval basic 'byte codes'
; must have an a list (labels (label index)*)
(defglobal ?*memory* = (create$))

;; =======================
(deffunction doBinOp (?op $?stk)
   ;(printout t "BINOP " ?op " stack: " ?stk crlf)
   (bind ?top (nth$ 1 $?stk))
   (bind ?nxt (nth$ 2 $?stk))
   (bind $?old (rest$ (rest$ $?stk)))
   (bind $?rslt (create$))
   (if (eq ?op PLUS)
      then
      (bind ?rslt (create$ (+  ?nxt ?top) $?old)))
   (if (eq ?op MINUS)
      then
      (bind ?rslt (create$ (- ?nxt ?top) $?old)))
   (if (eq ?op DIV)
      then
      (bind ?rslt (create$ (div ?nxt ?top) $?old)))
   (if (eq ?op MULT)
      then
      (bind ?rslt (create$ (* ?nxt ?top) $?old)))
   $?rslt)

(deffunction getMemory
   (?var)
   (bind ?where (member$ ?var ?*memory*))
   (if (not ?where)
      then
      (bind ?*memory* (create$ ?var 0 ?*memory*))
      (bind ?where 1))
   (nth$ (+ 1 ?where) ?*memory*))

(deffunction isBinOp
   (?x)
   (member$ ?x (create$ PLUS MINUS MULT DIV)))

(deffunction iEval ($?expr)
   ;(printout t "EXPR:" $?expr crlf)
   (bind $?stack (create$))
   (progn$ (?x $?expr) 
      ;(printout t "STK:" $?stack crlf)
      (if (integerp ?x)
         then
         (bind $?stack (create$ ?x $?stack))
         else
         (if (isBinOp ?x)
            then
            (bind $?stack (doBinOp ?x $?stack))
           else
            (if (eq ?x NEG)
               then
               (bind $?stack (create$ (- 0 (nth$ 1 $?stack)) (rest$ $?stack)))
               else
               (bind $?stack (create$ (getMemory ?x) $?stack))))))
   (nth$ 1 $?stack))

(deffunction compares (?comp ?expr1 ?expr2)
  (bind ?result false)
  (if (eq ?comp LT) then (bind ?rslt (< (iEval ?expr1)(iEval ?expr2))))
  (if (eq ?comp GT) then (bind ?rslt (> (iEval ?expr1)(iEval ?expr2))))
  (if (eq ?comp EQ) then (bind ?rslt (= (iEval ?expr1)(iEval ?expr2))))
  (if (eq ?comp NE) then (bind ?rslt (!= (iEval ?expr1)(iEval ?expr2))))
  (if (eq ?comp LE) then (bind ?rslt (<= (iEval ?expr1)(iEval ?expr2))))
  (if (eq ?comp GE) then (bind ?rslt (>= (iEval ?expr1)(iEval ?expr2))))
  ?rslt
)

(deffunction mEval (?expr)
   (bind ?rslt -1)
   (if (stringp ?expr) 
    then (bind ?rslt ?expr)
    else (bind ?rslt (iEval ?expr)))
   ?rslt
)

(deffunction printList
   ($?list)
   (bind ?expr (create$))
   (progn$ (?x $?list) 
      (if (or (stringp ?x)(eq ?x COMMA)(eq ?x SEMIC))
         then
         (if (> (length$ ?expr) 0)
            then ;(printout t "eval" ?expr crlf)
                 (printout t (iEval ?expr)) (bind ?expr (create$)))
         (if (stringp ?x) then (printout t ?x))
         (if (eq ?x SEMIC) then (printout t "    "))
         (printout t " ")
         else(bind ?expr (create$ ?expr ?x))))
   (if (> (length$ ?expr) 0)
    then (printout t (iEval ?expr)))
  (printout t crlf)
)

(deffunction setMemory (?var $?expr)
   (bind ?where (member$ ?var ?*memory*))
   (if ?where
    then (bind ?*memory* (replace$ ?*memory* (+ 1 ?where)( + 1 ?where) (iEval $?expr)))
    else (bind ?*memory* (create$ ?var (iEval $?expr) ?*memory*))))


;=====================================================
(defrule fetch-execute
    (declare (salience -10))
?f<-(PC ?i)
    (stmnt ?i $?s)
    (not (IR $?))
=>
 (retract ?f)
 (assert (IR $?s)
         (PC (+ ?i 1))))

;PRINT "This program demonstrates all commands."
(defrule print 
?f<-(IR PRINT $?items)
=>
  (retract ?f)
  (printList $?items)
  (printout t crlf))

;FOR X = 1 TO 100
(defrule forFirstTime
?g<-(IR FOR ?var $?first TO $?last)
?f<-(forStack $?fors)
    (not (forStack ?ir $?))
    (PC ?pc)
=>
   (retract ?g)
   (setMemory ?var ?first)
   ;(printout t mustEvalCondition LT $?first $?last crlf)
   (if (<= (mEval $?first)(mEval $?last))
    then (retract ?f)
         (assert (forStack (- ?pc 1) $?fors))
    else (assert (findBalancedNext (- ?pc 1) 1))))

(defrule forAgain
?g<-(IR FOR ?var $?first TO $?last)
?f<-(forStack ?ir $?fors)
=>
   (retract ?g)
   (setMemory ?var (+ (mEval ?var) 1))
   ;(printout t "only doing 1loop interation" crlf)
   (if (> (mEval ?var) (mEval $?last))
    then (assert (findBalancedNext (+ ?ir 1) 1))))

(defrule findBalancedNextFor
    (declare (salience 100))
?f<-(findBalancedNext ?inx ?count&~0)
    (stmnt ?inx FOR $?)
=>
    (retract ?f)
    (assert (findBalancedNext ?inx (+ ?count 1))))

(defrule findBalancedNextNext
    (declare (salience 100))
?f<-(findBalancedNext ?inx ?count&~0)
    (stmnt ?inx NEXT)
=>
    (retract ?f)
    (assert (findBalancedNext (+ ?inx 1) (- ?count 1))))

(defrule findBalancedNextNothing
    (declare (salience 50))
?f<-(findBalancedNext ?inx ?count&~0)
    (stmnt ?inx $?)
=>
    (retract ?f)
    (assert (findBalancedNext (+ ?inx 1) ?count)))
(defrule foundBalancedNext
    (declare (salience 200))
?f<-(findBalancedNext ?inx 0)
?g<-(PC ?)
?h<-(forStack ? $?outers)
=>
    (retract ?f ?g ?h)
    (assert (PC ?inx)(forStack $?outers)))


;NEXT
(defrule next 
?h<-(IR NEXT)
?p<-(PC ?)
    (forStack ?top $?rest)
=>
    (retract ?p ?h)
    (assert (PC ?top)))

;GOTO 300
(defrule GOTO 
?f<-(IR GOTO ?lbl)
?p<-(PC ?)
    (labels $? ?lbl ?inx $?)
=>
    (retract ?p ?f)
    (assert (PC ?inx)))

;GOSUB 300
(defrule GOSUB 
?f<-(IR GOSUB ?lbl)
?p<-(PC ?pc)
    (labels $? ?lbl ?inx $?)
?s<-(subStack $?rtrnAddrs)
=>
    (retract ?p ?s ?f)
    (assert (PC ?inx)
            (subStack ?pc $?rtrnAddrs)))

;INPUT H
(defrule input
?f<-(IR INPUT ?var)
=>
   (retract ?f)
   (printout t "?")
   (setMemory ?var (read)))

(defrule inputWithPrompt
?f<-(IR INPUT ?prompt ?var)
    (test (stringp ?prompt))
=>
   (retract ?f)
   (printout t ?prompt "?")
   (setMemory ?var (read)))

;IF H<11 THEN GOTO 200
(defrule ifthen
?f<-(IR IF $?expr1 ?comp $?expr2 THEN $?statement)
    (test (member$ ?comp (create$ LT GT LE GE NE EQ)))
=>
  (retract ?f)
  (if (compares ?comp $?expr1 $?expr2)
   then (assert (IR $?statement))))

;200 A = 100/2
(defrule LET
?f<-(IR LET ?var $?expr)
=>
   (retract ?f)
   (setMemory ?var (mEval $?expr)))

;END
(defrule stop
    (IR END)
=>
  (halt))


; return
(defrule returns
?f<-(IR RETURN)
?g<-(subStack ?inx $?rest)
?h<-(PC ?)
=>
   (retract ?f ?g ?h)
   (assert (PC ?inx)
           (subStack $?rest)))

(deffunction loadProgram1 ()
(assert 
(labels 200 11 300 20)
(stmnt 1 PRINT "This program demostrates all commands.")
(stmnt 2 FOR X 1 TO 4)
(stmnt 3 PRINT X COMMA X 2 DIV SEMIC X COMMA X X MULT)
(stmnt 4 NEXT)
(stmnt 5 GOSUB 300)
(stmnt 6 PRINT "hello")
(stmnt 7 INPUT H)
(stmnt 8 IF H LT 11 THEN GOTO 200)
(stmnt 9 PRINT 12 4 2 div minus)
(stmnt 10 PRINT 100)
(stmnt 11 LET A 100 2 DIV)
(stmnt 12 IF A GT 10 THEN PRINT "this is ok")
(stmnt 13 PRINT A)
(stmnt 14 PRINT A 34 PLUS)
(stmnt 15 INPUT H)
(stmnt 16 PRINT H)
(stmnt 17 INPUT "this is as test " Y)
(stmnt 18 PRINT H Y PLUS)
(stmnt 19 END)
(stmnt 20 PRINT "this is a subroutine")
(stmnt 21 RETURN)
))

(deffunction initial ()
  (reset)
  (bind ?*memory (create$))
  (assert (forStack)(subStack)(PC 1)))

(deffunction test()
  (initial)
  (loadProgram1)
;  (run)
)