#lang typed/racket
(require "ast.rkt")
(require racket/treelist)
(: prelude CoreProgram)
(define prelude
  '((define (I x) x) (define (K x y) x) (define (K1 x y) y) (define (S f g x) ((f x) (g x))) (define (compose f g x) (f (g x))) (define (twice f) ((compose f) f))))

(struct State ([stack : Stack] [dump : Dump] [heap : Heap] [globals : Globals] [stats : Stats]))
(define-type Addr Index)
(define-type Stack (Listof Addr))
(define-type Dump Null)
(define-type Heap (TreeListof Node))
(define-type Node (∪ (List Addr Addr) CoreScDefn Integer))
(define-type Globals (Immutable-HashTable Name Addr))
(define-type Stats Nonnegative-Integer)

(: empty-heap Heap)
(define empty-heap
  (treelist))

(: empty-globals Globals)
(define empty-globals
  (make-immutable-hash))

(: empty-dump Dump)
(define empty-dump '())

(: empty-stats Stats)
(define empty-stats 0)

(: empty-stack Stack)
(define empty-stack '())

(: incr-stats (-> Stats Stats))
(define incr-stats add1)

(: update-globals (-> Globals Name Addr Globals))
(define (update-globals globals name addr)
  (hash-set globals name addr))

(: update-stats (-> (-> Stats Stats) State State))
(define (update-stats f mstate)
  (struct-copy State mstate [stats (f (State-stats mstate))]))

(: update-stack (-> (-> Stack Stack) State State))
(define (update-stack f mstate)
  (struct-copy State mstate [stack (f (State-stack mstate))]))

(: allocate-node (-> Heap Node (Values Heap Addr)))
(define (allocate-node heap node)
  (let ([heap (treelist-add heap node)])
    (values heap (treelist-length heap))))

(: lookup-node (-> Heap Addr Node))
(define lookup-node treelist-ref)

(: lookup-globals (-> Globals Name Addr))
(define lookup-globals hash-ref)

(: initialize-heap (-> (Listof CoreScDefn) (Values Heap Globals)))
(define (initialize-heap scs)
  (for/fold ([heap : Heap empty-heap]
             [globals : Globals empty-globals])
            ([sc : CoreScDefn scs])
    (let-values ([(new-heap addr) (allocate-node heap sc)])
      (values new-heap
              (update-globals globals (scdefn-name sc) addr)))))

(: compile-core (-> (Listof CoreScDefn) State))
(define (compile-core scdefs)
  (let-values ([(heap globals) (initialize-heap (append scdefs prelude))])
    (State (list (lookup-globals globals 'main)) empty-dump heap globals empty-stats)))


(: eval-state (-> State (Pairof State (Listof State))))
(define (eval-state st)
  (if (final-state? st)
      (list st)
      (let ([next-st (update-stats incr-stats (step st))])
        (cons st (eval-state next-st)))))

(: data-node? (-> Node Boolean))
(define data-node? integer?)

(: final-state? (-> State Boolean))
(define (final-state? st)
  (match (State-stack st)
    [(list n) (data-node? (lookup-node (State-heap st) n))]
    [_ #f]))

(: step (-> State State))
(define (step state)
  (let ([stack (State-stack state)])
    (match stack
      [(cons addr rstack)
       (step-node rstack state (lookup-node (State-heap state) addr))]
      ['() (error "Invalid state")])))

(: step-node (-> Stack State Node State))
(define (step-node rstack st n)
  (match n
    [(? integer?) (error "A number cannot be stepped any further!")]
    [(list a _) (update-stack (λ (x) (cons a x)) st)]
    [(list 'define (list name args ...) body)
     (step-sc rstack st args body)]))

(: get-arg (-> Heap Addr Addr))
(define (get-arg heap addr)
  (match (lookup-node heap addr)
    [(list _ a) a]
    [_ (error "Not an application node")]))

(: step-sc (-> Stack State (Listof Name) CoreExpr State))
(define (step-sc rstack state arg-names body)
  (let ([heap (State-heap state)])
    (let*-values ([(new-env new-stack)
                  (for/fold ([globals : Globals (State-globals state)]
                             [stack : Stack rstack])
                            ([arg-name : Name arg-names])
                    (if (null? stack)
                        (error "Not enough arguments to apply the supercombinator")
                        (values (update-globals globals arg-name (get-arg heap (car stack))) (cdr stack))))]
                  [(new-heap addr) (instantiate-body body new-env heap)])
      (let ([new-stack (cons addr new-stack)])
        (struct-copy State state [stack new-stack] [heap new-heap])))))

(: instantiate-body (-> CoreExpr Globals Heap (Values Heap Addr)))
(define (instantiate-body e env heap)
  (match e
    [(? integer?) (allocate-node heap e)]
    [(list f a)
     (let*-values ([(heap0 addr-f) (instantiate-body f env heap)]
                   [(heap1 addr-a) (instantiate-body a env heap0)])
       (allocate-node heap1 (list addr-f addr-a)))]
    [(? symbol?) (values heap (lookup-globals env e))]
    [_ (error "unimplemented")]))