;;
;;
;; This file contains a scheme program for interpreting
;; pcode for a machine which will contain a mouse and a screen
;; but no other input/output devices. 
;; Currently I've only implemented simple textual input/output
;;
;; THE FUTURE PLANS ARE AS FOLLOWS:
;; The screen is a window of size 256x256 pixels
;; and each pixel has a color specified by three bytes.
;;
;; To draw on the screen you give commands to the graphics processor
;; by storing certain values in memory as follows:
;;   memory location    meaning
;;     1               x1
;;     2               y1
;;     3               x2
;;     4               y2
;;     5               r
;;     6               g
;;     7               b
;;     8               1=draw (processors sets back to 0 when done)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; here is the program that will initially be loaded into the interpreter


(jlib.JLIB.load)

;; define components and actions

(define limitfield (textfield "100" 10))
(define CodeArea (textarea 5 40 (CourierBold 12)))
(define TraceArea (textarea 5 40) (CourierBold 12))
(define OutputArea (textarea 2 40) (CourierBold 12))
(define InputField (textfield "0" 10))

(define state (textarea 5 40))

(define appletg (.getGraphics thisApplet))


(define FileField (textfield "ex1.a" 10)


(define win (window "Assembly Interpreter"))

(define (addactions L)
  (define (addaction comp action)
    (cond 
       ((.isInstance java.awt.Button.class comp)
        (.addActionListener comp action))
       ((.isInstance java.awt.Textfield.class comp)
        (.addActionListener comp action))
       ((.isInstance java.awt.Choice.class comp)
        (.addItemListener comp action))
       (else
        (.addActionListener comp action))))
  (if (null? L) #t
      (begin
        (addaction (first (first L)) (second (first L)))
        (addactions (rest L))))


(.setColor appletg (color 255 0 0))
(.drawLine appletg 0 0 256 256)
(.drawLine appletg 0 256 256 0)

(.add win 
 (tablebyrow 1
  (row 
    (grid 4 2 
      (label "Input") 
       InputField 
      (label "Limit")
       limitfield
      (label "fontsize")
       (textfield "12" 6 (action (lambda(e) (changefontsize e))))
      (label "program file")
       (textfield "ex.a" 12 (action (lambda (e) (loadfile e))))
    )
    (grid 4 2
      (button "start"          (action (lambda(e) (run))))
      (button "clear code"     (action (lambda(e) (writeexpr CodeArea ""))))
      (button "clear trace"    (action (lambda(e) (writeexpr TraceArea ""))))
      (button "clear output"   (action (lambda(e) (writeexpr OutputArea ""))))
      (button "quit"           (action (lambda(e) (hide win))))
      (button "enable tracing" (action (lambda(e) (toggletracing))))
      (button "load"           (action (lambda(e) (loadfile))))
      (button "assemble"       (action (lambda(e) (assemble))))
    )
  )
  CodeArea
  OutputArea
  TraceArea
 )
)

(define L (label "Pcode Interpreter: 10/27/99") (TimesRomanBold 18))
(define fontsize 
   


(addactions (list
  (list start
       (action (lambda (e) (run))))))
  (list fontsize
       (action (lambda(e) (changefontsize))))
  (list clearcode
       (action (lambda (e) (writeexpr CodeArea ""))))
  (list cleartrace (action (lambda (e) (writeexpr TraceArea ""))))
  (list clearoutput (action (lambda (e) (writeexpr OutputArea ""))))
  (list tracebutton 
       (action (lambda (e) (toggletracing))))
  (list FileField (action (lambda (e) (loadfile))))


(define (loadfile e)
  (load (readexpr (.getSource e)))
  (writeexpr CodeArea "")
  (prettyprint CodeArea program))

(define (assemble)
   (let ((code (readexpr CodeArea)))
        (writeexpr CodeArea "")
        (appendlnExpr OutputArea "assembling")
;        (prettyprint CodeArea (assemble code)))))
        (assemble2 CodeArea code)))

(define (run)
   (appendlnexpr TraceArea 
       (runcode (readexpr CodeArea) '((pc 1)) '() (readexpr limitfield))))))

(define (changefontsize e)
   (.setFont TraceArea (java.awt.Font. "Courier" 1 (readexpr (.getSource e))))
   (.setFont OutputArea (java.awt.Font. "Courier" 1 (readexpr (.getSource e))))
   (.setFont CodeArea (java.awt.Font. "Courier" 1 (readexpr (.getSource e)))))

(define (toggletracing)
   (if tracing
       (writeexpr tracebutton "enable tracing")
       (writeexpr tracebutton "disable tracing"))
   (set! tracing (not tracing)))




(setbackground win (color 255 255 0))
(pack win)
(show win)

(define tracing #f)

(define (runcode CODE registers memory limit)
  (if (< limit 0) "TIME LIMIT EXCEEDED"
  (let ((PC (lookup 'pc registers)))
    (let ((instruction (lookup PC CODE)))
       (if (equal? instruction 0)
           (appendlnExpr OutputArea (list "Jump to unknown PC" ))
       (begin
        (writeexpr limitfield limit)
        (if tracing (begin
          (appendlnExpr TraceArea (list registers memory))
          (appendlnExpr TraceArea (list "---------------------------------------------" instruction))))
        (evalinstruction instruction PC CODE registers memory (- limit 1))))))))

(define (lookup X Y)
  (if (null? Y) 0
    (if (equal? X (first (first Y))) (second (first Y))
        (lookup X (rest Y)))))

(define (storemem key val memory)
  (if (and (equal? key 'M8) (> val 0))
      (let ((R (lookup 'M5 memory))
            (G (lookup 'M6 memory))
            (B (lookup 'M7 memory))
            (x1 (lookup 'M1 memory))
            (y1 (lookup 'M2 memory))
            (x2 (lookup 'M3 memory))
            (y2 (lookup 'M4 memory)))
      (begin
        (if tracing
         (begin
          (if (equal? val 1)
             (display (list 'drawing 'line 'from  (list x1 y1) 'to (list x2 y2) 'in 'color (list R G B)))
             (display (list 'filling 'rect 'from  (list x1 y1) 'of 'size (list x2 y2) 
                       'in 'color (list R G B))))
         (newline)))


         (.setColor appletg (color R G B))
         (if (equal? val 1)
             (.drawLine appletg x1 y1 x2 y2)
             (.fillRect appletg x1 y1 x2 y2))
         (store 'M8 0 memory)))
      (store key val memory)))

(define (store key val R)
  (if (null? R) (list (list key val))
      (if (equal? key (first (first R)))
          (cons (list key val) (rest R))
          (cons (first R) (store key val (rest R))))))

(define (evalinstruction I PC CODE registers memory limit)
  (let ((opcode (first I))
        (args (rest I)))
     (cond
       ((equal? opcode 'halt) 
        (display 'DONE))

       ((equal? opcode 'add)
        (runcode CODE
           (store 'pc (+ 1 PC)
               (store (third args)
                   (+ (lookup (first args) registers)
                      (lookup (second args) registers))
                   registers))
           memory limit))

       ((equal? opcode 'sub)
        (runcode CODE
           (store 'pc (+ 1 PC)
               (store (third args)
                   (- (lookup (first args) registers)
                      (lookup (second args) registers))
                   registers))
           memory limit))

       ((equal? opcode 'mul)
        (runcode CODE
           (store 'pc (+ 1 PC)
               (store (third args)
                   (* (lookup (first args) registers)
                      (lookup (second args) registers))
                   registers))
           memory limit))

       ((equal? opcode 'div)
        (runcode CODE
           (store 'pc (+ 1 PC)
               (store (third args)
                   (quotient (lookup (first args) registers)
                      (lookup (second args) registers))
                   registers))
           memory limit))

       ((equal? opcode 'rem)
        (runcode CODE
           (store 'pc (+ 1 PC)
               (store (third args)
                   (remainder (lookup (first args) registers)
                      (lookup (second args) registers))
                   registers))
           memory limit))

       ((equal? opcode 'jump)
        (runcode CODE
           (store 'pc (first args) registers)
           memory limit))

       ((equal? opcode 'jumpEQ)
        (runcode CODE
           (if (equal? 
                  (lookup (first args) registers)
                  (lookup (second args) registers))
               (store 'pc (third args) registers)
               (store 'pc (+ 1 PC) registers))
           memory limit))

       ((equal? opcode 'jumpLT)
        (runcode CODE
           (if (<
                  (lookup (first args) registers)
                  (lookup (second args) registers))
               (store 'pc (third args) registers)
               (store 'pc (+ 1 PC) registers))
           memory limit))

       ((equal? opcode 'jumpLE)
        (runcode CODE
           (if (<=
                  (lookup (first args) registers)
                  (lookup (second args) registers))
               (store 'pc (third args) registers)
               (store 'pc (+ 1 PC) registers))
           memory limit))

       ((equal? opcode 'jumpR)
        (runcode CODE
               (store 'pc (lookup (first args) registers) registers)
           memory limit))

       ((equal? opcode 'loadI)
        (runcode CODE
               (store 'pc (+ 1 PC)
               (store (second args) (first args)
                   registers))
           memory limit))

       ((equal? opcode 'move)
        (runcode CODE
               (store 'pc (+ 1 PC)
               (store (second args) (lookup (first args) registers) 
                   registers))
           memory limit))

       ((equal? opcode 'store)
        (runcode CODE
               (store 'pc (+ 1 PC) registers)
               (storemem (second args) (lookup (first args) registers)
                  memory)
               limit))

       ((equal? opcode 'load)
        (runcode CODE
               (store 'pc (+ 1 PC) 
               (store (second args) (lookup (first args) memory) registers))
               memory
               limit))


       ((equal? opcode 'input)
        (runcode CODE
               (store 'pc (+ 1 PC)
               (store (second args) (readexpr InputField)
                   registers))
           memory limit))

       ((equal? opcode 'output)
        (appendExpr OutputArea (lookup (first args) registers))
        (appendExpr OutputArea "  ")
        (runcode CODE
               (store 'pc (+ 1 PC) registers)
           memory limit))



       (else (display "UNKNOWN OPCODE")))))


;; this procedure adds line numbers to pcode and
;; replace symbolic addresses in jumps with numeric
;; addresses
(define (assemble code)
  (define (getsymaddresses code N D)
     (cond ((null? code) D)
           ((pair? (first code)) (getsymaddresses (rest code) (+ N 1) D))
           (else (store (first code) N (getsymaddresses (rest code)  N D)))))
          
  (define (fourth X) (car (cdddr X)))

  (define (updateinstruction INST D)
     (cond ((or (equal? (first INST) 'jumpEQ)
                (equal? (first INST) 'jumpLE)
                (equal? (first INST) 'jumpLT))
            (list (first INST) (second INST) (third INST) (lookup (fourth INST) D)))
           ((equal? (first INST) 'jump)
            (list (first INST) (lookup (second INST) D)))
           (else  INST)))

  (define (addlinenums code N D)
;     (display (list 'addlinenums code N D)) (newline)
     (cond ((null? code) ())
           ((pair? (first code))
            (cons
              (list N (updateinstruction (first code) D))
              (addlinenums (rest code) (+ N 1) D)))
           (else
            (addlinenums (rest code) N D))))

  (define dict (getsymaddresses code 1 ()))
  (display dict)(newline)
  (addlinenums code 1 dict))

;; this procedure adds line numbers to pcode and
;; replace symbolic addresses in jumps with numeric
;; addresses
(define (assemble2 CodeArea code)
  (display "entering assemble2") (newline)
  (define (getsymaddresses code N D)
     (cond ((null? code) D)
           ((pair? (first code)) (getsymaddresses (rest code) (+ N 1) D))
           (else (store (first code) N (getsymaddresses (rest code)  N D)))))
          
  (define (fourth X) (car (cdddr X)))

  (define (updateinstruction INST D)
     (cond ((or (equal? (first INST) 'jumpEQ)
                (equal? (first INST) 'jumpLE)
                (equal? (first INST) 'jumpLT))
            (list (first INST) (second INST) (third INST) (lookup (fourth INST) D)))
           ((equal? (first INST) 'jump)
            (list (first INST) (lookup (second INST) D)))
           (else  INST)))

  (define (addlinenums code N D)
;     (display (list 'addlinenums code N D)) (newline)
     (cond ((null? code) ())
           ((pair? (first code))
            (appendlnExpr CodeArea (list N (updateinstruction (first code) D)))
            (addlinenums (rest code) (+ N 1) D))
           (else
            (addlinenums (rest code) N D))))

  (define dict (getsymaddresses code 1 ()))
  (display dict)(newline)
  (appendlnExpr CodeArea "(")
  (addlinenums code 1 dict)
  (appendlnExpr CodeArea ")")
)

(define (prettyprint Comp X)
  (define (pp X) 
    (if (null? X) ()
        (begin
          (appendlnExpr Comp (first X))
          (pp (rest X)))))
  (appendlnExpr Comp "(")
  (pp X)
  (appendlnExpr Comp ")"))