;#lang r5rs
;; (#%require (only racket/base
;;                  make-hasheq
;;                  hash-ref
;;                  hash-set!
;;                  raise-user-error))
; chicken
(require-extension (srfi 69))
; racket
;; (#%require srfi/69
;;            srfi/23)
(define raise-user-error error)

(define (apply. procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           arguments
           (procedure-environment procedure))))
        (else (raise-user-error 'apply. "Unknown procedure type ~a" procedure))))

(define (eval. exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((get-stx (car exp)) => (lambda (f) (f exp env)))
        ((application? exp)
         (apply. (eval. (operator exp) env)
                (list-of-values (operands exp) env)))
        (else (raise-user-error 'eval. "Unknown expression type ~a" exp))))




;; booleans
;; false is false, everything else is truthy.
(define (sc-boolean? exp)
  (or (eq? exp 'true)
      (eq? exp 'false)))
(define (true? exp)
  (not (false? exp)))
(define (false? exp)
  (eq? exp 'false))

;; undefined is used in the expansion of some macros
(define (*undefined*)
  '*undefined*)
;; void is used when a value should not be returned
(define (*void*)
  '*void*)
(define (void? exp)
  (or (eq? exp (*void*))
      (tagged-list? exp (*void*))))


(define (undefined? exp)
  (eq? exp (*undefined*)))
(define syntaxes (make-hash-table))
(define (get-stx id) (hash-table-ref syntaxes id (lambda () #f)))
(define (put-stx! id exp) (hash-table-set! syntaxes id exp))

(define (initialize-stx)
  (begin
    (put-stx! 'void   (*void*))
    (put-stx! 'quote  eval-quoted)
    (put-stx! 'lambda eval-lambda)
    (put-stx! 'cond   eval-cond)
    (put-stx! 'begin  eval-begin)
    (put-stx! 'set!   eval-assignment)
    (put-stx! 'define eval-definition)
    (put-stx! 'if     eval-if)
    (put-stx! 'and    eval-and)
    (put-stx! 'or     eval-or)
    (put-stx! 'let    eval-let)
    (put-stx! 'let*   eval-let*)
    (put-stx! 'letrec eval-letrec)))

(define (eval-quoted exp env) (text-of-quotation exp))

(define (eval-cond exp env) (eval. (cond->if exp) env))

(define (eval-begin exp env)
  (eval-sequence (begin-actions exp) env))

(define (eval-lambda exp env)
  (make-procedure (lambda-parameters exp)
                  (lambda-body exp)
                  env))


(define (eval-let* exp env)
  (eval. (let*->let exp) env))

(define (list-of-values exps env)
    (if (no-operands? exps) '()
        (cons (eval. (first-operand exps) env)
              (list-of-values (rest-operands exps) env))))

(define (eval-if exp env)
  (if (true? (eval. (if-predicate exp) env))
      (eval. (if-consequent exp) env)
      (eval. (if-alternative exp) env)))


(define (eval-sequence exps env)
  (cond ((last-exp? exps) (eval. (first-exp exps) env))
        (else (eval. (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (eval. (assignment-value exp) env)
                       env)
  (*void*))
(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (eval. (definition-value exp) env)
                    env)
   (*void*))
(define (self-evaluating? exp)
  (cond ((void? exp)    #t)
        ((number? exp)  #t)
        ((string? exp)  #t)
        ((sc-boolean? exp) #t)
        (else #f)))
(define (variable? exp) (symbol? exp))
(define (quoted? exp)
  (tagged-list? exp 'quote))

(define (text-of-quotation exp) (cadr exp))
(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))
(define (assignment? exp)
  (tagged-list? exp 'set!))
(define (make-assignment var binding) `(set! ,var ,binding))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

(define (definition? exp)
  (tagged-list? exp 'define))
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (make-definition var binding)
  `(define ,var ,binding))

(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)   ; formal parameters
                   (cddr exp)))) ; body

(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      (*void*)))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))


(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))

(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))

(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))

(define (make-begin seq) (cons 'begin seq))



(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
;;  Macros
;;
;;  Cond

;; These functions perform the tranformation of
;;
;; (cond (<test1> <actions1>)
;;       (<test2> <actions2>)
;;       ...
;;       (<testn> <actionsn>))
;;
;; into
;;
;; (if <test1> (begin <actions1>)
;;     (if <test2> (begin <actions2>) ...
;;         (if <testn> (begin <actionsn>))))
;;
;; where the last test, <testn>, may optionally
;; be replaced by the symbol 'else.  This implementation
;; of cond supports the SFRI-34 style cond arrow syntax,
;; (<test> => <recipient>), which is transformed into
;; (if (<test>) (<recipient> <test>))

;; cond is a list of
;; (cond <clauses>)

(define (cond? exp)
  (tagged-list? exp 'cond))
(define (cond-clauses exp)
  (cdr exp))
;; each clause is a list of (<predicate> <actions>)

(define (cond-predicate clause)
  (car clause))
(define (cond-actions clause)
  (cdr clause))

(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))

(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

(define (cond-arrow-clause? exp)
  (and (list? exp)
       (not (null? (cdr exp)))
       (eq? (cadr exp) '=>)))

(define (cond-arrow-test exp) (car exp))

(define (cond-arrow-recipient exp) (caddr exp))

(define (expand-clauses clauses)
  (if (null? clauses) 'false
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-arrow-clause? first)
            (make-if (cond-predicate first)
                     (list (cond-arrow-recipient first)
                           (cond-arrow-test first))
                     (expand-clauses rest))
            (if (cond-else-clause? first)
                (if (null? rest)
                    (sequence->exp (cond-actions first))
                    (raise-user-error 'cond "ELSE clause isn't last ~a" clauses))
                (make-if (cond-predicate first)
                         (sequence->exp (cond-actions first))
                         (expand-clauses rest)))))))
; and
(define (and? exp) (tagged-list? exp 'and))
(define (eval-and exp env)
  (let and-loop ((exp (cdr exp))
                 (last 'true))
    (cond ((null? exp) last)
          ((false? last) 'false)
          (else (and-loop (cdr exp)
                          (eval. (car exp) env))))))

; or
(define (or? exp) (tagged-list? exp 'or))
(define (eval-or exp env)
  (let or-loop ((exp (cdr exp)))
    (if (null? exp) 'false
        (let ((evaled (eval. (car exp) env)))
          (if (true? evaled) evaled
              (or-loop (cdr exp)))))))



; let

(define (let? exp) (tagged-list? exp 'let))

(define (let-bindings exp)
  (cadr exp))

(define (let-body exp)
  (caddr exp))

;; todo: make more of the code use the function below.
(define (make-let bindings body)
  `(let ,bindings ,body))


(define (let-get-vars/exprs f)
  (lambda (exp)
    (define (rec-let-get-vars/exprs binding-list acc-list)
      (cond ((null? binding-list) (reverse acc-list))
            ((not (pair? (car binding-list)))
             (raise-user-error 'let "Not a variable-expression pair in let-clause ~a" exp))
            (else (rec-let-get-vars/exprs (cdr binding-list) (cons (f (car binding-list)) acc-list)))))
    (rec-let-get-vars/exprs (let-bindings exp) '())))

(define let-exprs (let-get-vars/exprs cadr))

(define let-vars (let-get-vars/exprs car))

(define (eval-let exp env)
  (eval. (let->combination exp) env))

; let*
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*->let exp)
  (if (<= (length (let-bindings exp)) 1)
      `(let ,(let-bindings exp) ,(let-body exp))
      `(let (,(car (let-bindings exp)))
         ,(let*->let `(let* ,(cdr (let-bindings exp)) ,(let-body exp))))))

(define (named-let? exp)
  (and (eq? (car exp) 'let)
       (symbol? (cadr exp))))

; named-let
(define (named-let-body exp) (cadddr exp))

(define (named-let-bindings exp) (caddr exp))

(define (named-let-name exp) (cadr exp))

(define (named-let-vars exp)
  (map car (named-let-bindings exp)))

(define (named-let-inits exp)
  (map cadr (named-let-bindings exp)))

(define (expand-named-let exp)
  (sequence->exp
   `((define (,(named-let-name exp) ,@(named-let-vars exp)) ,(named-let-body exp))
     (,(named-let-name exp) ,@(named-let-inits exp)))))


(define (let->combination exp)
  (if (named-let? exp)
      (expand-named-let exp)
      (if (null? (let-body exp))
          (raise-user-error 'let "Body of let clause must not be empty ~a" exp)
          (cons (make-lambda (let-vars exp) (list (let-body exp)))
                (let-exprs exp)))))


;; letrec implements the transformation of
;; (letrec
;;     ((<var> <expr>) ...)
;;   body)
;; into
;; (let ((<var> '*undefined*)...)
;;   (set! var <expr>)
;;   ...)
(define (letrec? exp)
  (tagged-list? exp 'letrec))
(define (letrec-bindings expr)
  (cadr expr))
(define (letrec-body expr)
  (cddr expr))

(define (transform-letrec exp)
  (make-let
   (map (lambda (binding)
          (list (car binding) `(quote ,(*undefined*))))
        (letrec-bindings exp))
   (make-begin
    (append
     (map (lambda (binding)
            (make-assignment
             (car binding)
             (cadr binding)))
          (letrec-bindings exp))
     (letrec-body exp)))))
(define (eval-letrec exp env)
  (eval. (transform-letrec exp) env))
;; test:
;; (transform-letrec '(letrec ((even?
;;                              (lambda (n)
;;                                (if (= n 0) true
;;                                    (odd? (- n 1)))))
;;                             (odd?
;;                              (lambda (n)
;;                                (if (= n 0) false
;;                                    (odd? (- n 1))))))
;;                      (even? x)))

;; scan-out-defines: basically implements letrec-like transformation
;; for inner defines.  this is necessary, in order for things like
 ;; '(define (f x)
 ;;   (define (even? n)
 ;;     (if (= n 0) true
 ;;         (odd? (- n 1))))
 ;;   (define (odd? n)
 ;;     (if (= n 0) false
 ;;         (even? (- n 1))))
 ;;   (even? x))
;; to be guaranteed to have both even? and odd? defined at the right time.

(define (scan-out-defines exp-body)
  (let* ((defs+other
           (let scan
             ((exp exp-body) (defs '()) (other '()))
             (if (null? exp) (cons (reverse defs) (reverse other))
                 (if (definition? (car exp))
                     (scan (cdr exp)
                           (cons (car exp) defs)
                           other)
                     (scan (cdr exp)
                           defs
                           (cons (car exp) other))))))
         (defs (car defs+other))
         (other (cdr defs+other)))
    (if (null? defs) exp-body
        (begin (display defs) (newline)
         (list
          (make-let (map (lambda (def)
                           `(,(definition-variable def)
                             (quote ,(*undefined*))))
                         defs)
                    (make-begin
                     (append
                      (map (lambda (def)
                             (make-assignment
                              (definition-variable def)
                              (definition-value def)))
                           defs)
                      other))))))))


; procedures

(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-out-defines body) env))

(define (compound-procedure? p) (tagged-list? p 'procedure))

(define (procedure-parameters p) (cadr p))

(define (procedure-body p) (caddr p))

(define (procedure-environment p) (cadddr p))

;; environment and env. frames

(define (enclosing-environment env) (cdr env))

(define (first-frame env) (car env))

(define the-empty-environment '())

(define (make-frame variables values)
  (cons variables values))

(define (frame-variables frame)
  (car frame))

(define (frame-values frame)
  (cdr frame))

(define (find-binding-in-frame frame var)
  (let scan ((vars (frame-variables frame))
             (vals (frame-values frame)))
    (cond ((null? vars)
           (cons #f '()))
          ((eq? var (car vars))
           (cons #t (car vals)))
          (else (scan (cdr vars) (cdr vals))))))

(define (set-binding-in-frame! frame var val)
  (let scan ((vars (frame-variables frame))
             (vals (frame-values frame)))
    (cond ((null? vars) #f)
          ((eq? var (car vars))
           (set-car! vals val) #t)
          (else (scan (cdr vars) (cdr vals))))))

(define (add-binding-to-frame! frame var val)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (lookup-variable-value var env)
      (let env-loop ((cenv env))
        (if (eq? cenv the-empty-environment)
            (raise-user-error "Unbound variable!" var)
            (let ((result (find-binding-in-frame (first-frame cenv) var)))
              (if (car result)
                  (if (eq? (cdr result) (*undefined*))
                      (raise-user-error "Variable is not yet defined: " var)
                      (cdr result))
                  (env-loop (enclosing-environment cenv)))))))

(define (set-variable-value! var val env)
  (let env-loop ((cenv env))
    (if (eq? cenv the-empty-environment)
        (raise-user-error "Unbound Variable!" var)
        (if (set-binding-in-frame! (first-frame cenv) var val)
            (*void*)
            (env-loop (enclosing-environment cenv))))))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (if (set-binding-in-frame! frame var val)
        (*void*)
        (add-binding-to-frame! frame var val))))






(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (raise-user-error
       'extend-environment
       "Binding expression unbalanced! ~nvars: ~a~nexpressions: ~a"
       vars vals)))

; primitives

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (primitive-implementation proc)
  (cadr proc))

(define (make-boolean-expr test)
  (lambda args (if (apply test args) 'true 'false)))

(define primitive-procedures
  `((car   ,car)
    (cdr   ,cdr)
    (cons  ,cons)
    (null? ,(make-boolean-expr null?))
    (list  ,list)
    (+     ,+)
    (-     ,-)
    (/     ,/)
    (*     ,*)
    (=     ,(make-boolean-expr =))
    (>     ,(make-boolean-expr >))
    (<     ,(make-boolean-expr <))
    (eq?   ,(make-boolean-expr eq?))
    (<=    ,(make-boolean-expr <=))
    (>=    ,(make-boolean-expr >=))
    (sin   ,sin)
    (cos   ,cos)
    (tan   ,tan)
    (expt  ,expt)))

(define (primitive-procedure-names)
  (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map
   (lambda (proc) (list 'primitive (cadr proc)))
   primitive-procedures))

;; setup

(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (define-variable! 'true  'true initial-env)
    (define-variable! 'false 'false initial-env)
    initial-env))

(define the-global-environment (setup-environment))

(define (apply-primitive-procedure proc args)
  (apply ; no period, so this scheme's apply
   (primitive-implementation proc) args))


(initialize-stx)

;; finally, input for the interpreter

(define input-prompt  "~> ")

(define (interpret exp) (eval. exp the-global-environment))

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (cond ((and (not (eof-object? input))
                (not (eq? input 'exit)))
              (let ((evaled (interpret input)))
                (user-print evaled)
                (driver-loop)))
           (else
            (newline)
            (display "GOODBYE.")
            (newline)))))

(define (prompt-for-input str)
  (begin
    (display str)))

(define (user-print object)
  (cond ((void? object) (if #f #f))
        ((compound-procedure? object)
         (display (list 'compound-procedure
                        (procedure-parameters object)
                        (procedure-body object)
                        '<procedure-env>))
         (newline))
        (else (display object)
              (newline))))
(define (start)
    (display "WELCOME TO SCHEME.")
    (newline)
    (driver-loop))
(start)