21-rlcweaep-le.rkt

#lang plai

;; Recursion (via special environments)
;; Procedures (lexical)
;; Conditionals
;; With (via Lexical Environments)
;; and Arithmetic Expressions and Primitives

;; LAZY-EVALUATION

(define identifier? symbol?)

(define-type EXP
  [num (n number?)]
  [bool (b boolean?)]
  
  [arith (operation symbol?) (lhs EXP?) (rhs EXP?)]
  [comp  (operation symbol?) (lhs EXP?) (rhs EXP?)]
  [show  (arg EXP?)]

  [lst (operation symbol?) (arg EXP?)]
  [mkcons (car EXP?) (cdr EXP?)]
    
  [id (id identifier?)]
  [with (id identifier?) (arg EXP?) (body EXP?)]

  [branch (test? EXP?) (then EXP?) (else EXP?)]

  [fun (id identifier?) (body EXP?)]
  [app (fun EXP?) (arg EXP?)]

  [rec (funid identifier?) (argid identifier?) (fun-body EXP?) (body EXP?)]

  [seq (first EXP?) (second EXP?)]
  )


;; parse : s-exp -> EXP
;; convert s-expression to EXP
(define (parse s)
  (cond
    [(number? s) (num s)]
    [(boolean? s) (bool s)]
    [(identifier? s) (id s)]
    [(list? s)   (case (car s)
                   [(+ - *) (arith (car s) (parse (cadr s)) (parse (caddr s)))]
                   [(< = >) (comp  (car s) (parse (cadr s)) (parse (caddr s)))]
                   [(print) (show (parse (cadr s)))]

                   [(null? head tail) (lst (car s) (parse (cadr s)))]
                   [(cons)            (mkcons (parse (cadr s)) (parse (caddr s)))]
                   
                   [(with) (with (caadr s) (parse (cadadr s)) (parse (caddr s)))]
                   [(if) (branch (parse (cadr s)) (parse (caddr s)) (parse (cadddr s)))]
                   [(fun) (fun (cadr s) (parse (caddr s)))]
                   [(app) (app (parse (cadr s)) (parse (caddr s)))]
                   [(rec) (rec (cadr s) (caddr s) (parse (cadddr s)) (parse (car (cddddr s))))]
                   [(seq) (seq (parse (cadr s)) (parse (caddr s)))]
                   [else (error "not an EXP")])]
    [else (error "not an EXP")]))

;; unparse :: EXP -> sexp
;; provide (canonical) sexp for EXP
(define (unparse a)
  (type-case EXP a
    [num (n) n]
    [bool (b) b]
    
    [arith (o l r)  `(,o ,(unparse l) ,(unparse r))]
    [comp (o l r)   `(,o ,(unparse l) ,(unparse r))]
    [show (a)       `(print ,(unparse a))]

    [lst (o a)      `(,o ,(unparse a))]
    [mkcons (a b)   `(cons ,(unparse a) ,(unparse b))]
        
    [id (i) i]
    [with (i a b) `(with (,i ,(unparse a)) (unparse b))]
    
    [branch (? t e) `(if ,(unparse ?) ,(unparse t) ,(unparse e))]

    [fun (i b) `(fun ,i ,(unparse b))]
    [app (f a) `(app ,(unparse f) ,(unparse a))]

    [rec (fi ai fb b) `(rec ,fi ,ai ,(unparse fb) ,(unparse b))]

    [seq (a b) `(seq ,(unparse a) ,(unparse b))]
    ))

;;expressed values and primitives over those values
(define ((box-of ?) v)
  (and (box? v)
       (? (unbox v))))

(define-type VAL
  [numV (n number?)]
  [boolV (b boolean?)]
  [funV (i identifier?) (b EXP?) (e ENV?)]
  [voidV]
  
  [nullV]
  [consV (car VAL?) (cdr VAL?)]

  [thunkV (a EXP?) (e ENV?) (v (box-of VAL?))]
  [not_a_V]        ;; not evaluated
  [blackholeV]     ;; someone else is already doing it
  )

(define (arith-op o)
  (case o
    [(+) +]
    [(-) -]
    [(*) *]
    [else "unrecognized op" o]))

(define (arith-prim! o l r)
  (type-case VAL (strict l)
    [numV (n) (type-case VAL (strict r)
                [numV (m) (numV ((arith-op o) n m))]
                [else (error "not a number" r)])]
    [else (error "not a number" l)]))

(define (comp-op o)
  (case o
    [(=) =]
    [(>) >]
    [(<) <]
    [else "unrecognized op" o]))

(define (comp-prim! o l r)
  (type-case VAL (strict l)
    [numV (n) (type-case VAL (strict r)
                [numV (m) (boolV ((comp-op o) n m))]
                [else (error "not a number" r)])]
    [else (error "not a number" l)]))

(define (bool-prim! ? t e)
  (type-case VAL (strict ?)
    [boolV (b) (if b t e)]
    [else (error "not a boolean" ?)]))

(define (list-prim! o a)
  (type-case VAL (strict a)
    [nullV () (if (eqv? o 'null?)
                  (boolV #t)
                  (error "NOT A CONS" a))]
    [consV (a d) (case o
                   [(null?) (boolV #f)]
                   [(head)  a]
                   [(tail)  d])]
    [else (error "NOT A LIST" a)]))

(define (fun-prim! f a e)
  (type-case VAL (strict f)
    [funV (i b g) (eval b
                        (extenv i (eval a e) g))]
    [else (error "not a function" f)]))

(define (show-prim! v)
  (display (strict! v))
  (newline)
  (voidV))

(define (seq-prim! v1 v2)
  (strict! v1)
  v2)

;;environments
(define-type ENV
  [emptyenv]
  [extenv (i identifier?) (v VAL?) (e ENV?)]
  [recenv (fun-id identifier?) (ai identifier?) (fun-body EXP?) (e ENV?)]
  )

;; lookup : id * ENV -> VAL
(define (lookup i e)
  (type-case ENV e
    [emptyenv () (error "identifier not bound" i)]
    [extenv (j v f) (if (eqv? i j)
                        v
                        (lookup i f))]
    [recenv (fi ai b f) (if (eqv? i fi)
                            (funV ai b e)
                            (lookup i f))]
    ))

;; eval : EXP * ENV -> VAL
;; semantics for evaluation
(define (eval a e)
  (thunkV a e (box (not_a_V))))

;; reduce :: EXP * ENV -> VAL --- one step
(define (reduce a e)
  (type-case EXP a
    [num (n) (numV n)]
    [bool (b) (boolV b)]
    
    [arith (o l r) (arith-prim! o (eval l e) (eval r e))]
    [comp (o l r) (comp-prim! o (eval l e) (eval r e))]
    [show (a) (show-prim! (eval a e))]
    
    [mkcons (a d) (consV (eval a e)
                         (eval d e))]
    [lst (o a) (list-prim! o (eval a e))]
    
    [id (i) (lookup i e)]
    [with (i a b) (eval b (extenv i (eval a e) e))]
    
    [branch (? th el) (eval (bool-prim! (eval ? e) th el) e)]
    
    [fun (i b) (funV i b e)]
    [app (f a) (fun-prim! (eval f e) a e)]
    [rec (fi ai fb b) (eval b (recenv fi ai fb e))]
    [seq (a b) (seq-prim! (eval a e)
                          (eval b e))]
    ))

;; strict :: VAL -> VAL --- reduce until weak head-normal form
(define (strict v)
  (type-case VAL v
    [thunkV (a e _v) (let ([v (unbox _v)])
                       (type-case VAL v
                         [not_a_V () (begin
                                       (set-box! _v (blackholeV))
                                       (let ([v (strict (reduce a e))])
                                         (set-box! _v v)
                                         v))]
                         [blackholeV ()  ; wait for other to finish ... cannot happen here
                                         (error "INCONSISTENT BLACKHOLE" v)]
                         [else v]))]
    [else v]))

;; strict! :: VAL -> VAL --- reduce until strong head-normal form
(define (strict! v)
  (type-case VAL v
    [consV (a d) (consV (strict! a) (strict! d))]
    [thunkV (a e _v) (strict! (strict v))]
    [else v]))
  
;; run : s-exp -> number
;; run a program
(define (run s)
  (strict! (eval (parse s)
                 (extenv 'null (nullV)
                         (emptyenv)))))