#lang racket/base
;; skeleton for cs4613 final

(module sae plait
  (define-type SAE
    [Num  (val : Number)]
    [Add  (l : SAE) (r : SAE)]
    [Div  (l : SAE) (r : SAE)]
    [Id   (name : Symbol)]
    [Let1 (id : Symbol) (named-expr : SAE) (bound-body : SAE)]
    [Select (switch-on : SAE) (expr-list : (Listof SAE))])
  
  (define-type ENV
    [EmptyEnv]
    [Extend (name : Symbol) (val : Number) (end : ENV)])
  (define (lookup name env)
    (type-case ENV env
      [(EmptyEnv) (error 'lookup "no binding")]
      [(Extend id val rest-env) (if (eq? id name) val (lookup name rest-env))]))

  (define (interp expr env)
    (type-case SAE expr
      [(Num n) n]
      [(Add l r) (+ (interp l env) (interp r env))]
      [(Div l r) (/ (interp l env) (interp r env))]
      [(Let1 bound-id named-expr bound-body)
       (interp bound-body (Extend bound-id  (interp named-expr env) env))]
      [(Select switch-on expr-list) ....]
      [(Id name) (lookup name env)]))

  (print-only-errors #t)
  (test (interp (Select (Num 1) (list (Div (Num 3) (Num 0)) (Num 4) (Num 5)))
                (EmptyEnv))     4)
  (test (interp
         (Let1 'i (Num 2)
               (Select (Id 'i) (list (Div (Num 3) (Num 0)) (Num 4) (Num 5))))
         (EmptyEnv))    5)
  (test (interp
         (Let1 'i (Num 2)
               (Select (Id 'i) (list (Div (Num 3) (Num 0)) (Num 4)
                                     (Add (Id 'i) (Num 5)))))
         (EmptyEnv))    7)
  (test/exn (interp (Select (Num 0) empty) (EmptyEnv)) "index out of bounds")
  )
(require (only-in 'sae))

(module slang plait
  (define-type SLANG
    [Str (v : String)]
    [Num (v : Number)]
    [Times (l : SLANG) (r : SLANG)])
  (define-type VAL [NumV (n : Number)] [StrV (s : String)])
  (define-type Type [NumT] [StrT])
  
  (define (times n str) (if (zero? n) "" (string-append str (times (sub1 n) str))))
  
  (define (interp slang)
    (type-case SLANG slang
      [(Str s) (StrV s)]
      [(Num n) (NumV n)]
      [(Times l r)
       (let ([l-v (interp l)] [r-v (interp r)])
         (cond
           [(and (NumV? l-v) (NumV? r-v)) (NumV (* (NumV-n l-v) (NumV-n r-v)))]
           [(NumV? l-v) (StrV (times (NumV-n l-v) (StrV-s r-v)))]
           [(NumV? r-v) (StrV (times (NumV-n r-v) (StrV-s l-v)))]
           [else (error 'interp "type mismatch")]))]))

  (print-only-errors #t)
  (test (interp (Times (Num 6) (Num 7))) (NumV 42))
  (test (interp (Times (Num 3) (Str "ha"))) (StrV "hahaha"))
  (test (interp (Times (Num 2) (Times (Num 2) (Str "ha")))) (StrV "hahahaha"))
  (test/exn (interp (Times (Str "hello") (Str "world"))) "type mismatch")

  (define (typecheck slang)
    ....)

  (test (typecheck (Times (Num 6) (Num 7))) (NumT))
  (test (typecheck (Times (Num 3) (Str "ha"))) (StrT))
  (test (typecheck (Times (Num 2) (Times (Num 2) (Str "ha")))) (StrT))
  (test/exn (typecheck (Times (Str "hello") (Str "world"))) "mismatch")
  )
(require (only-in 'slang))

(module blam plait
  (define-type BLAM
    [Zero]
    [One]
    [Id (sym : Symbol)]
    [Call (fun : BLAM) (arg1 : BLAM) (arg2 : BLAM)]
    [Lam (param1 : Symbol) (param2 : Symbol) (body : BLAM)])
  
  (define-type VAL
    [OneV]
    [ZeroV]
    [LamV (param1 : Symbol) (param2 : Symbol) (body : BLAM) (env : Env)])
  
  (define-type Env
    [EmptyEnv]
    [Extend (name : Symbol) (value : VAL) (rest : Env)])
  
  (define (lookup name env)
    (type-case Env env
      [(EmptyEnv) (error 'lookup "no binding")]
      [(Extend id val rest-env)
       (if (eq? id name) val (lookup name rest-env))]))

  (define-type CONT
    [EmptyCont]
    [Call1 (arg1 : BLAM) (arg2 : BLAM) (env : Env) (k : CONT)]
    [Call2 (fun-val : VAL) (arg2 : BLAM) (env : Env) (k : CONT)]
    [Call3 (fun-val : VAL) (arg1-val : VAL) (k : CONT)])

  (define (interp blam env k)
    (type-case BLAM blam
      [(One) (continue k (OneV))]
      [(Zero) (continue k (ZeroV))]
      [(Id sym) (continue k (lookup sym env))]
      [(Lam x y b) (continue k (LamV x y b env))]
      [(Call fun x y) (interp fun env (Call1 x y env k))]))

  (define (continue k val)
    ....)

  (define (run blam)
    (interp blam (EmptyEnv) (EmptyCont)))
  
  (print-only-errors #t)
  (test (run (One)) (OneV))
  (test (run (Call (Lam 'x 'y (Id 'y)) (One) (Zero))) (ZeroV))
  (test (run (Call
              (Call
               (Lam 'x 'dummy (Lam 'y 'z (Id 'x)))
               (One) (Zero))
              (Zero) (Zero)))
        (OneV))
  )
(require (only-in 'blam))

(module move racket
  ;; Emulate a small part of the plai/gc2/collector language
  (define current-heap (make-parameter (make-vector 0 #f)))
  (define (heap-set! index val) (vector-set!  (current-heap) index val))
  (define (heap-ref index) (vector-ref (current-heap) index))
  (define (heap-size) (vector-length (current-heap)))
  (define-syntax-rule (with-heap vec expr ...)
    (parameterize  ([current-heap vec]) (begin expr ...)))
  (require (only-in plai error test test/exn print-only-errors))
  
  ;; Convenience functions for tagged heap access
  (define (expect addr tag)
    (unless (equal? (heap-ref addr) tag)
      (error 'expect "expecting ~a at ~a" tag addr)))
  (define (heap-put! tag addr offset val)
    (expect addr tag) (heap-set! (+ addr offset) val))
  (define (heap-get tag addr offset)
    (expect addr tag) (heap-ref (+ addr offset)))
  
  ;; Partial implementation of a collector API
  (define (gc:deref addr) (heap-get 'flat addr 1))
  (define (gc:alloc-flat x)
    (define loc (malloc 2))
    (heap-set! loc 'flat)
    (heap-put! 'flat loc 1 x)
    loc)
  
  (define (gc:first addr) (heap-get 'cons addr 1))
  (define (gc:rest addr) (heap-get 'cons addr 2))
  (define (gc:cons f r)
    (define loc (malloc 3))
    (heap-set! loc 'cons)
    (heap-put! 'cons loc 1 f)
    (heap-put! 'cons loc 2 r)
    loc)
  
  (define (init-allocator) (set-space! 0) (set-ptr! (space-start)))

  (define metadata-size 2)
  (define (get-ptr) (heap-ref 0))
  (define (set-ptr! v) (heap-set! 0 v))
  (define (space-size) (quotient (- (heap-size) metadata-size) 2))
  (define (space-start) (+ metadata-size (* (get-space) (space-size))))
  (define (space-bound) (+ metadata-size (* (add1 (get-space)) (space-size))))
  (define (get-space) (heap-ref 1))
  (define (set-space! v) (heap-set! 1 v))
  (define (swap-space!)
    (set-space! (modulo (add1 (get-space)) 2))
    (set-ptr! (space-start)))
  
  (define (malloc size)
    (define ptr (get-ptr))
    (when (>= (+ ptr size) (space-bound)) (error 'alloc "out of memory"))
    (set-ptr! (+ ptr size))
    ptr)

  (define (move from-loc)
    (void))

  (print-only-errors #t)
  
  (with-heap (make-vector 10 #f)
    (init-allocator)
    (define loc (gc:alloc-flat 'hello))
    (test (current-heap) #(4 0 flat hello #f #f #f #f #f #f))
  
    (swap-space!)
    (define dest (move loc))
  
    (test dest 6)
    (test (current-heap) #(8 1 flat hello #f #f flat hello #f #f)))
  
  (with-heap (make-vector 30 #f)
    (init-allocator)
    ;; allocate a list (1 2) aka (cons 1 (cons 2 '()))
    (define loc (gc:cons (gc:alloc-flat 1)
                         (gc:cons (gc:alloc-flat 2) (gc:alloc-flat empty))))
    (test (current-heap)
          #(14 0 flat 1 flat 2 flat () cons 4 6 cons 2 8 #f #f
               #f #f #f #f #f #f #f #f #f #f #f #f #f #f))
  
    (swap-space!)
    (move loc)
  
    ;; Children must be moved before parents for this test to pass
    (test (current-heap)
          '#(28 1 flat 1 flat 2 flat () cons 4 6 cons 2 8 #f #f
                flat 1 flat 2 flat () cons 18 20 cons 16 22 #f #f)))
  )
(require (only-in 'move))