#lang racket

;;; A simple PostFix interpreter without error checking

;; Set this to #t to turn on printing of intermediate stacks; #f to turn it off
(define print-stacks? #t)

(define (postfix-run pgm args)
  (let ((final-stk (postfix-exec-commands (postfix-commands pgm) args)))
    (first final-stk)))

;; Perform the stack transform of each command from left to right,
;; starting with init-stk, to yield the final stack. 
(define (postfix-exec-commands cmds init-stk)
  (foldl (λ (cmd stk)
           (let ((new-stk (postfix-exec-command cmd stk)))
             (begin (if print-stacks? ; Only print intermediate stack if print-stacks? is #t
                        (printf "after executing ~a, stack is ~a\n" cmd new-stk)
                        'do-nothing)
                    new-stk)))   
         init-stk
         cmds))

;; Execute a command on a stack to yield a new stack.
;; So each command can be viewed as a "stack transformer"
(define (postfix-exec-command cmd stk)
  (cond ((integer? cmd) (cons cmd stk))
        ((eq? cmd 'pop) (rest stk))
        ((eq? cmd 'swap) (cons (second stk) (cons (first stk) (rest (rest stk)))))
        #|
        ((eq? cmd 'sub) (cons (- (second stk) (first stk)) (rest (rest stk))))
        ; other arithops similar
        ; This is superseded by more general handling of arithops, below
        |#
        ((postfix-arithop? cmd)
         (cons ((postfix-arithop->racket-binop cmd) (second stk) (first stk))
               (rest (rest stk))))
        #|
        ((eq? cmd 'lt) (cons (if (< (second stk) (first stk)) 1 0)
                             (rest (rest stk))))
        ; other relops similar
        ; This is superseded by more general handling of arithops, below
        |#
        ((postfix-relop? cmd)
         (cons ((postfix-relop->racket-binop cmd) (second stk) (first stk))
               (rest (rest stk))))
        ((eq? cmd 'nget) (cons (list-ref stk (first stk)) (rest stk)))
        ((eq? cmd 'sel) (cons (if (= (third stk) 0) (first stk) (second stk))
                              (rest (rest (rest stk)))))
        ((postfix-command-sequence? cmd) (cons cmd stk))
        ((eq? cmd 'exec)
         ;; Treat executable sequence as a stack transform rather than
         ;; appending the commands in the sequence to commands
         ;; portion of (stack x commands) configuration.
         (postfix-exec-commands (first stk) (rest stk)))
        (else (error "unrecognized command" cmd))))

(define postfix-arithops
  (list (list 'add +)
        (list 'mul *)
        (list 'sub -)
        (list 'div quotient)
        (list 'rem remainder)
        ))

(define (postfix-arithop? cmd)
  (assoc cmd postfix-arithops))

(define (postfix-arithop->racket-binop arithop)
  (second (assoc arithop postfix-arithops)))

(define postfix-relops
  (list (list 'lt <)
        (list 'eq =)
        (list 'gt >)
        ))
        
(define (postfix-relop? cmd)
  (assoc cmd postfix-relops))

(define (postfix-relop->racket-binop relop)
  (let ((boolop (second (assoc relop postfix-relops))))
    (lambda (x y) (if (boolop x y) 1 0))))


;;----------------------------------------------------------------------
;; Postfix Syntax abstractions

(define (postfix-program? sexp)
  (and (list? sexp)
       (>= (length sexp) 2)
       (eq? (first sexp) 'postfix)
       (integer? (second sexp))
       (postfix-command-sequence? (rest (rest sexp)))))

(define (postfix-command-sequence? sexp)
  (and (list? sexp)
       (forall? postfix-command? sexp)))

(define (postfix-command? sexp)
  (or (integer? sexp)
      (member sexp '(pop swap nget sel exec
                     add mul sub div rem
                     lt eq gt))
      (postfix-command-sequence? sexp)))

(define (postfix-numargs pgm) (second pgm))
(define (postfix-commands pgm) (rest (rest pgm)))

(define (postfix-arguments? sexp)
  (and (list? sexp)
       (forall? integer? sexp)))

;;----------------------------------------------------------------------
;;; Helper functions

(define (forall? pred xs)
  (if (null? xs)
      #t
      (and (pred (first xs))
           (forall? pred (rest xs)))))

;;----------------------------------------------------------------------
;;; Examples

;; Sample program from lecture
(define pf1 '(postfix 2 2 nget 0 gt (mul) (swap 1 nget mul add) sel exec))

;> (postfix-run pf1 '(3 5))
;15
;
;> (postfix-run pf1 '(3 -5))
;28
 

;; Sum-of-squares program 
(define sos
  '(postfix 2 ; let's call the arguments a and b, from top down
            1 nget ; duplicate a at top of stack
            mul ; square a
            swap ; stack now has b and a^2 from top down
            1 nget mul ; square b
            add ; add b^2 + a^2 and return
            ))

#|
;; When print-stacks? is #t
> (postfix-run sos '(5 12))
after executing 1, stack is (1 5 12)
after executing nget, stack is (5 5 12)
after executing mul, stack is (25 12)
after executing swap, stack is (12 25)
after executing 1, stack is (1 12 25)
after executing nget, stack is (12 12 25)
after executing mul, stack is (144 25)
after executing add, stack is (169)
169

;; When print-stacks? is #f
> (postfix-run sos '(5 12))
169
|#