#lang racket

;;; This file (ps7-postloop-config-tail-fancy-starter.rkt) is a version of
;;; postfix-transform-fancy with some extra features relevant to
;;; CS251 Fall '18 PS7 Problem 1 (a solo problem). 
;;; Make a copy of this file for that problem and flesh out the missing parts. 

;;; PostLoop interpreter that uses tail recursion to iterate over a configuration
;;; consisting of (1) list of commands and (2) list of stack values

;;; This "fancy" version includes the following features:
;;; 1. appropriate handling of all error cases, 
;;; 2. the ability to display step-by-step execution,
;;; 3. a general, extensible way to handle arithops and relops

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

;; Run the given PostLoop program on argument values, which form the initial stack
(define (postloop-run pgm args)
  (cond ((not (postloop-program? pgm))
         (error "Invalid PostLoop program" pgm))
        ((not (postloop-arguments? args))
         (error "Invalid PostLoop arguments" args))
        ((not (= (postloop-numargs pgm) (length args)))
         (error "Expected number of arguments does not
                 match actual number of arguments"
                (list (postloop-numargs pgm) (length args))))
        (else (postloop-exec-config-tail (postloop-commands pgm) args))))

;; Use tail recursion to loop over a configuration state consiting of
;; (1) list of commands and (2) list of stack values
(define (postloop-exec-config-tail cmds stk)
  (begin (if display-steps? ; Only print intermediate stack if display-steps? is #t
             (printf "Commands: ~a\n   Stack: ~a\n" cmds stk)
             'do-nothing)
         (cond ((null? cmds)
                (cond ((null? stk)
                       (error "Stack empty at end of program"))
                      ((not (non-sequence-value? (first stk)))
                       (error "Top of final stack is not an integer or pair value"))
                      (else (first stk))))
               ((eq? (first cmds) 'exec)
                (cond ((< (length stk) 1)
                       (error "exec requires nonempty stack" (list cmds stk)))
                      ((not (postloop-command-sequence? (first stk)))
                       (error "exec requires executable sequence on top of stack" (list cmds stk)))
                      (else
                       ; Continue iteration with next configuration
                       (postloop-exec-config-tail (append (first stk) (rest cmds))
                                                  (rest stk)))))
               
               ;; --------------------------------------------------
               ;; Put your code for handling the FOR command here:
               ((eq? (first cmds) 'for)

                ;; REPLACE THIS STUB:
                (postloop-exec-config-tail (rest cmds) (rest (rest stk)))
                )

               ;; --------------------------------------------------
               ;; Continue iteration with next configuration
               (else (postloop-exec-config-tail (rest cmds)
                                                (postloop-exec-command (first cmds) stk))))))
         

;; Execute a non-exec command on a stack to yield a new stack.
;; So each command can be viewed as a "stack transformer"
(define (postloop-exec-command cmd stk)
  (cond ((integer? cmd) (cons cmd stk))
        ((eq? cmd 'pop)
         (if (< (length stk) 1)
             (error "pop requires nonempty stack"
                    (list cmd stk))
             (rest stk)))
        ((eq? cmd 'swap)
         (if (< (length stk) 2)
             (error "swap requires stack with at least two values" (list cmd stk))
             (cons (second stk) (cons (first stk) (rest (rest stk))))))
        ((postloop-arithop? cmd)
         (cond ((< (length stk) 2)
                (error "arithop requires two arguments" (list cmd stk)))
               ((or (not (integer? (first stk)))
                    (not (integer? (second stk))))
                (error "arithop requires two integers" (list cmd stk)))
               (else (cons ((postloop-arithop->racket-binop cmd) (second stk) (first stk))
                           (rest (rest stk))))))
        ((postloop-relop? cmd)
         (cond ((< (length stk) 2)
                (error "relop requires two arguments" (list cmd stk)))
               ((or (not (integer? (first stk)))
                    (not (integer? (second stk))))
                (error "relop requires two integers" (list cmd stk)))
               (else (cons ((postloop-relop->racket-binop cmd) (second stk) (first stk))
                           (rest (rest stk))))))
        ((eq? cmd 'nget)
         (if (< (length stk) 1)
             (error "nget requires one argument" stk)
             (let {[index (first stk)]}
               (cond ((not (integer? index))
                      (error "nget requires integer index" (list cmd stk)))
                     ((or (<= index 0)
                          (> index (length (rest stk))))
                      (error "nget index out of range" (list index (rest stk))))
                     (else 
                      (let {[valAtIndex (list-ref stk index)]}
                           ;; list-ref uses 0-based index, but haven't removed index from
                           ;; top of stack, so this works.
                        (if (non-sequence-value? valAtIndex)
                            (cons valAtIndex (rest stk))
                            (error "nget can't return a command sequence" valAtIndex)
                            )))))))
        ((eq? cmd 'sel)
         (cond ((< (length stk) 3)
                (error "sel requires three arguments" (list cmd stk)))
               ((not (integer? (third stk)))
                (error "sel test value must be an integer" (list cmd stk)))
               (else (cons (if (= (third stk) 0) (first stk) (second stk))
                           (rest (rest (rest stk)))))))
        ((postloop-command-sequence? cmd) (cons cmd stk))
        ;; Can add clauses for new commands here

        ;;----------------------------------------------------------------------
        ;; Extensions to PostFix for PS7 Problem 1 on PostLoop

        ((eq? cmd 'pair)
         (if (< (length stk) 2)
             (error "pair requires two arguments" stk)
             (let {[snd-val (first stk)]
                   [fst-val (second stk)]}
               (cond ((postloop-command-sequence? fst-val)
                      (error "first value of pair cannot be a command sequence" fst-val))
                     ((postloop-command-sequence? snd-val)
                      (error "second value of pair cannot be a command sequence" snd-val))
                     (else (cons (cons fst-val snd-val) (rest (rest stk))))))))

        ((eq? cmd 'fst)
         (if (< (length stk) 1)
             (error "fst requires one argument" stk)
             (let {[pair-val (first stk)]}
               (cond ((not (pair-value? pair-val))
                      (error "fst can only be applied to a pair value"))
                     (else (cons (car pair-val) (rest stk)))))))

        ((eq? cmd 'snd)
         (if (< (length stk) 1)
             (error "snd requires one argument" stk)
             (let {[pair-val (first stk)]}
               (cond ((not (pair-value? pair-val))
                      (error "snd can only be applied to a pair value"))
                     (else (cons (cdr pair-val) (rest stk)))))))

        ;; --------------------------------------------------
        ;; Handle case where no command matches
        
        (else (error "unrecognized command" cmd))
        ))

;;----------------------------------------------------------------------
;; General handling of arithops and relops

;; Begin with PostFix abstractions.
;; These are followed by PostLoop abstractions 
(define postfix-arithops
  (list (list 'add +)
        (list 'mul *)
        (list 'sub -)
        (list 'div (λ (a b)
                     (if (= b 0)
                         (error "division by 0 on" a)
                         (quotient a b))))
        (list 'rem (λ (a b)
                     (if (= b 0)
                         (error "remainder by 0 on" a)
                         (remainder a b))))
        ;; Could add more arithops here
        (list 'avg (λ (a b) (quotient (+ a b) 2)))
        
        ))

(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 >)
        ;; Could add more relops here
        ))
        
(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/Postloop 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)
      (postfix-command-sequence? sexp)
      (postfix-arithop? sexp) ; defaults are: add mul sub div rem (but could add more)
      (postfix-relop? sexp) ; defaults are: lt eq gt (but could add more)
      (member sexp  '(pop swap nget sel exec)) ; handle all other commands here
      ))

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

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

;; Postloop abstractions
(define (postloop-command-sequence? sexp)
  (and (list? sexp)
       (forall? postloop-command? sexp)))

(define (postloop-command? sexp)
  (or (integer? sexp)
      (postloop-command-sequence? sexp)
      (postfix-arithop? sexp) ; defaults are: add mul sub div rem (but could add more)
      (postfix-relop? sexp) ; defaults are: lt eq gt (but could add more)
      (member sexp '(pop swap nget sel exec
                     pair fst snd for ;; Added for postloop
                     ))
      ))

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

(define (postloop-arguments? sexp)
  (and (list? sexp)
       (forall? non-sequence-value? sexp)))

;;; All of the following postloop helper functions/variables are synonyms
;;; for their postfix counterparts. 
(define postloop-numargs postfix-numargs)
(define postloop-commands postfix-commands)
(define postloop-arithops postfix-arithops)
(define postloop-arithop? postfix-arithop?)
(define postloop-arithop->racket-binop postfix-arithop->racket-binop) 
(define postloop-relops postfix-relops)
(define postloop-relop? postfix-relop?)
(define postloop-relop->racket-binop postfix-relop->racket-binop)

;;----------------------------------------------------------------------
;; Postloop value abstractions

(define (pair-value? val)
  (and (pair? val)
       (non-sequence-value? (car val))
       (non-sequence-value? (cdr val))))

(define (non-sequence-value? val)
  (or (integer? val) (pair-value? val)))

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

;; Higher-order helper function from PS4
(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 (sub) (swap 1 nget mul add) sel exec))

#|
> (postfix-run pf1 '(3 5))
Commands: (2 nget 0 gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (3 5)
Commands: (nget 0 gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (2 3 5)
Commands: (0 gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (5 3 5)
Commands: (gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (0 5 3 5)
Commands: ((sub) (swap 1 nget mul add) sel exec)
   Stack: (1 3 5)
Commands: ((swap 1 nget mul add) sel exec)
   Stack: ((sub) 1 3 5)
Commands: (sel exec)
   Stack: ((swap 1 nget mul add) (sub) 1 3 5)
Commands: (exec)
   Stack: ((sub) 3 5)
Commands: (sub)
   Stack: (3 5)
Commands: ()
   Stack: (2)
2
|#

#|
> (postfix-run pf1 '(3 -5))
Commands: (2 nget 0 gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (3 -5)
Commands: (nget 0 gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (2 3 -5)
Commands: (0 gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (-5 3 -5)
Commands: (gt (sub) (swap 1 nget mul add) sel exec)
   Stack: (0 -5 3 -5)
Commands: ((sub) (swap 1 nget mul add) sel exec)
   Stack: (0 3 -5)
Commands: ((swap 1 nget mul add) sel exec)
   Stack: ((sub) 0 3 -5)
Commands: (sel exec)
   Stack: ((swap 1 nget mul add) (sub) 0 3 -5)
Commands: (exec)
   Stack: ((swap 1 nget mul add) 3 -5)
Commands: (swap 1 nget mul add)
   Stack: (3 -5)
Commands: (1 nget mul add)
   Stack: (-5 3)
Commands: (nget mul add)
   Stack: (1 -5 3)
Commands: (mul add)
   Stack: (-5 -5 3)
Commands: (add)
   Stack: (25 3)
Commands: ()
   Stack: (28)
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
            ))
#|
> (postfix-run sos '(3 4))
Commands: (1 nget mul swap 1 nget mul add)
   Stack: (3 4)
Commands: (nget mul swap 1 nget mul add)
   Stack: (1 3 4)
Commands: (mul swap 1 nget mul add)
   Stack: (3 3 4)
Commands: (swap 1 nget mul add)
   Stack: (9 4)
Commands: (1 nget mul add)
   Stack: (4 9)
Commands: (nget mul add)
   Stack: (1 4 9)
Commands: (mul add)
   Stack: (4 4 9)
Commands: (add)
   Stack: (16 9)
Commands: ()
   Stack: (25)
25
|#

;;----------------------------------------------------------------------
;;; PostLoop Examples

;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; PostLoop programs from Problem 1b:
(define postloop-pgm1 '(postloop 1 0 2 nget (pair) for))
(define postloop-pgm2 '(postloop 1 0 2 nget (swap 10 mul add) for))

;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; PostLoop programs from Problem 1c:

;; You are given postloop-sum
(define postloop-sum '(postloop 1 ; this program takes 1 argument,
                                  ; a nonnegative integer N, and returns
                                  ; the sum of integers from N down to 1. 
                                0 ; initial value of summation accumulator
                                2 nget ; get current integer of loop
                                (add) ; add current integer into accumulator
                                for) ; perform the for loop 
                                 )

;; Replace these stubs with commented, working PostLoop programs
(define postloop-fact '(postloop 1))
(define postloop-expt '(postloop 2))
(define postloop-pairs-up '(postloop 1))
(define postloop-fib '(postloop 1))

;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;; Replace this stub for PS7 Extra Credit Problem 2:
(define postloop-sum-between '(postloop 2))

;;----------------------------------------------------------------------
;;; PostLoop Testing

(define loop-tests
  (list

        ;; -------------------------------------------------------
        ;; PS7 Problem 1b

        (list 'postloop-pgm1
              postloop-pgm1
              '(((0) 0)
                ((1) (0 . 1))
                ((2) ((0 . 2) . 1))
                ((3) (((0 . 3) . 2) . 1))
                ((4) ((((0 . 4) . 3) . 2) . 1))
                ((5) (((((0 . 5) . 4) . 3) . 2) . 1))
                ))

        (list 'postloop-pgm2
              postloop-pgm2
              '(((0) 0) ((1) 1) ((2) 21) ((3) 321) ((4) 4321) ((5) 54321)))

        ;; -------------------------------------------------------
        ;; PS7 Problem 1c
        (list 'postloop-fact
              postloop-fact
              '(((0) 1) ((1) 1) ((2) 2) ((3) 6) ((4) 24) ((5) 120)))

        (list 'postloop-expt
              postloop-expt
              '(((2 0) 1) ((2 1) 2) ((2 2) 4) ((2 3) 8) ((2 4) 16) ((2 5) 32)
                ((3 0) 1) ((3 1) 3) ((3 2) 9) ((3 3) 27) ((3 4) 81) ((3 5) 243)
                ((4 2) 16)
                ((5 2) 25) ((5 3) 125)
                ((-3 0) 1) ((-3 1) -3) ((-3 2) 9) ((-3 3) -27) ((-3 4) 81) ((-3 5) -243)
                ((-5 2) 25) ((-5 3) -125)))

        (list 'postloop-pairs-up
              postloop-pairs-up
              '(((0) 0)
                ((1) (0 . 1))
                ((2) ((0 . 1) . 2))
                ((3) (((0 . 1) . 2) . 3))
                ((4) ((((0 . 1) . 2) . 3) . 4))
                ((5) (((((0 . 1) . 2) . 3) . 4) . 5))
                ))

        (list 'postloop-fib
              postloop-fib
              '(((0) 0) ((1) 1) ((2) 1) ((3) 2) ((4) 3) ((5) 5)
                ((6) 8) ((7) 13) ((8) 21) ((9) 34) ((10) 55)))

        ;; -------------------------------------------------------
        ;; PS7 Extra Credit Problem 1
;        (list 'postloop-sum-between
;              postloop-sum-between
;              '(((0 5) 15) ((0 100) 5050) ((17 17) 17)
;                ((3 7) 25) ((-7 -3) -25) ((-3 4) 4) ((-4 3) -4) ((-3 3) 0)
;                ((7 3) 0) ((-3 -7) 0)))
 
        ))

(define (test-loop name pgm test-cases)
  (display "\n--------------------------------------------------\n")
  (printf "Testing ~a\n" name)
  (for-each (λ (test-case)
              (let* {[args (first test-case)]
                     [expected (second test-case)]
                     [actual (postloop-run pgm args)]}
                (if (equal? actual expected)
                    (printf "Passed! Args: ~a; Expected/Actual Result: ~a\n"
                            args
                            actual)
                    (printf "***FAILED! Args: ~a;\n  Expected Result: ~a;\n  Actual Result ~a\n"
                            args
                            expected
                            actual))))
            test-cases))

(define (test-loops test-cases)
  (for-each (λ (test-case) (apply test-loop test-case))
            test-cases))

;; Uncomment this for PS7 Problem 1d
; (test-loops loop-tests)