;;; SAMPLE SOLUTION TO EXERCISES 3.7, 3.11, 3.12

;;; Based on 3-1.scm

;;; The domain is changed:
;;;     ExpressedValue = numbers + lists
;;; The new features are added as primitives.


;;; ADTs used

(load "environment-as-ribcage.scm")

;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
; Test harness and test cases are near the end of 
; this file; search for 'run-tests'.

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

(define run
; (string -> datum)
  (lambda (string)
    (eval-program (scan&parse string))))

;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "_" "-" "?")))
      symbol)
    (number (digit (arbno digit)) number)))

(define the-grammar
  '((program (expression) a-program)

    (expression (number) lit-exp)
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
    (expression
      ("let" (arbno  identifier "=" expression) "in" expression)
      let-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive  ("list") list-prim)
    (primitive  ("car")  car-prim)
    (primitive  ("cdr")  cdr-prim)
    (primitive  ("cons") cons-prim)
    (primitive  ("eq?")  eq?-prim)
    (primitive ("equal?") equal-test-prim) 
    (primitive ("zero?") zero-prim) 
    (primitive ("greater?") greater-test-prim) 
    (primitive ("less?") less-test-prim) 
    (primitive ("null?") null-test-prim)  
    ))

(define show-the-datatypes
; (() -> (list-of datum))
  (lambda ()
    (sllgen:make-define-datatypes the-lexical-spec the-grammar)
    (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

;; The following is generated by calling show-the-datatypes
;; (and then removing the outer lists, indenting, and renaming fields).
(define-datatype
  program
  program?
  (a-program (exp expression?)))

(define-datatype
  expression
  expression?
  (lit-exp (datum number?))
  (var-exp (id symbol?))
  (primapp-exp
   (prim primitive?)
   (rands (list-of expression?)))
  (if-exp (if-exp17 expression?) (if-exp18 expression?) (if-exp19 expression?))
   (let-exp (let-exp20 (list-of symbol?)) (let-exp21 (list-of expression?)) (let-exp22 expression?)))

(define-datatype
  primitive
  primitive?
  (add-prim)
  (subtract-prim)
  (mult-prim)
  (incr-prim)
  (decr-prim)
  (list-prim)
  (car-prim)
  (cdr-prim)
  (cons-prim)
  (eq?-prim)
  (equal-test-prim)  
  (greater-test-prim)
  (null-test-prim)
  (less-test-prim)
  (zero-prim))

;(string -> program)
(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

; (string -> (list-of token))
(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))

(define read-eval-print 
  (sllgen:make-rep-loop  "--> "
    (lambda (pgm) (eval-program pgm))   ; wrapped to avoid load
                                        ; dependency 
    (sllgen:make-stream-parser 
      the-lexical-spec
      the-grammar)))

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

;(program -> datum)
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (init-env))))))

;( expression * environment -> Expressed-Value)
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id)(apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (if-exp (test-exp true-exp false-exp) 
        (if (= 1 (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (let-exp (ids rands body)  
        (let ((args (eval-rands rands env)))
          (eval-expression body (extend-env ids args env))))
      )))

; ((list-of expression) * environment -> (list-of Expressed-Value))
(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

;(expression * environment -> Expressed-Value)
(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

; ( primitive * (list-of Expressed-Value) -> Expressed-Value)
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  ()     (+ (car args) (cadr args)))
      (subtract-prim () (- (car args) (cadr args)))
      (mult-prim  ()    (* (car args) (cadr args)))
      (incr-prim  ()    (+ (car args) 1))
      (decr-prim  ()    (- (car args) 1))
      (list-prim  ()    args)
      (car-prim   ()    (caar args))
      (cdr-prim   ()    (cdar args))
      (cons-prim  ()    (cons (car args) (cadr args)))
      (equal-test-prim () (if (equal? (car args) (cadr args)) 1 0)) 
      (greater-test-prim () (if (apply > args) 1 0)) 
      (less-test-prim () (if (apply < args) 1 0)) 
      (null-test-prim () (if (null? (car args)) 1 0)) 
      (eq?-prim () (if (eq? (car args) (cadr args)) 1 0)) 
      (zero-prim () (if (zero? (car args)) 1 0))
	)))

; (() -> environment)
(define init-env 
  (lambda ()
    (extend-env
      '(i v x emptylist)
      '(1 5 10 ())
      (empty-env))))
(show-the-datatypes)


(define run-tests
   ; Returns a list of whether each test yields expected outcome,
   ; and displays the test case and its value.
   ; Format of test-list is a list of pairs  (<expression> expected-value)
   (lambda (test-list)
     (map (lambda (tst)
				(begin (display (list "testing: " (car tst))) (newline)
						 (let ((result (run (car tst))))
							(begin (display (list "value is: " result)) (newline) (newline)
									 (equal? result (cadr tst))))))
			 test-list))) 

(define test1 '("list (1,2,3)" (1 2 3) ))
(define test2 '("list (1,2, list(3,4),3)" (1 2 (3 4) 3)))
(define test3 '("list (4,5, list(6))" (4 5 (6))))
(define test4 '("list(4,5,emptylist)" (4 5 ())))
(define test5 '("cons(1,2)" (1 . 2)))
(define test6 '("cons(5,emptylist)" (5)))
(define test7 '("cons(1,cons(5,emptylist))" (1 5)))
(define test8 '("cons(9,list(10,emptylist))" (9 10 ())))
(define test9 '("car(list(1,2,3,4))" 1))
(define test10 '("car(list(emptylist,6))" ()))
(define test11 '("car(cons(4,emptylist))" 4))
(define test12 '("car(cons(4,list(5,6)))" 4))
(define test13 '("cdr(list(1, 2, 3, 4))" (2 3 4)))
(define test14 '("cdr (list(4, emptylist))" (())))
(define test15 '("cdr(cons(6,list(7,8)))" (7 8)))
(define test16 '("cdr(car(cons(list(9,10),list(11,12))))" (10)))
(define test17 '("equal? (4,4)" 1))
(define test18 '("equal?(v,v)" 1))
(define test19 '("equal?(-(6,7),11)" 0))
(define test20 '("zero? (sub1 (5))" 0))
(define test21 '("zero? (sub1(v))" 0 ))
(define test22 '("greater?(5,6)" 0))
(define test23 '("less?(5,6)" 1))
(define test24 '("greater?(+(9,10),-(9,8))" 1))
(define test25 '("less?(+(9,10),-(9,8))" 0))
(define test26 '("if greater? (2,3) then 5 else 6" 6))
(define test27 '("null?(cdr(list(8,9)))" 0)) 
(define test28 '("null?(car(list(4,5)))" 0))
(define test29 '("null?(cdr(list(8,emptylist)))" 0))

(define the-tests (list test1 test2 test3 test4 test5 test6 test7 test8 test9 test10 test11 test12 test13 test14 test15 test16 test17 test18 test19 test20 test21 test22 test23 test24 test25 test26 test27 test28 test29 ))

(show-the-datatypes)