{listToString, listToVector, pairp, cons, car, cdr, caar, cddr, cdar,
 cadr, caadr, cadar, caddr, nilp, nil, setcdr,
 metacadr, setcar} = require "cons-lists/lists"
{map} = require "cons-lists/reduce"
{length} = require "cons-lists/reduce"
{Node, Comment, Symbol} = require '../chapter5/reader_types'
{inspect} = require 'util'

itap = (a) -> return inspect a, true, null, false

class Value
  constructor: (@v) ->

inValue = (f) ->
  new Value(f)

class LispInterpreterError extends Error
  name: 'LispInterpreterError'
  constructor: (@message) ->

the_false_value = (cons "false", "boolean")

eq = (id1, id2) ->
  if id1 instanceof Symbol and id2 instanceof Symbol
    return id1.name == id2.name
  id1 == id2

cadddr = metacadr('cadddr')

consp = (e) ->
  ((pairp e) and (typeof (car e) == 'number') and
  ((car e) > 0) and (pairp cdr e) and (typeof (cadr e) == 'number') and
  ((cadr e) > 0) and (nilp cddr e))

convert = (exp, store) ->
  conv = (e) ->
    if consp e
      cons (conv (store (car e)).v), (conv (store (cadr e)).v)
    else
      if symbolp e then e.name
      else if stringp e then '"' + e | '"'
      else e
  conv exp.v

# 5.2.4
# f[y → z] = λx . if y = x then z else f(x) endif
# 
# Accepts a parent function, and ID and a value.  Returns a function
# that takes a request ID.  If the request ID equals the ID above,
# return the value, else call the parent function with the request
# ID.
#
# Calls allocate 

extend = (next, id, value) ->
  (x) -> if (eq x, id) then value else (next x)

# f[y* → z*] = if #y>0 then f[y*†1 → z*†1][y*↓1 → z*↓1] else f endif
#
# Helper.  Builds a stack of extend() functions, at tail of which it
# appends the parent function.
#
#
lextends = (fn, ids, values) ->
  if (pairp ids)
    extend (lextends fn, (cdr ids), (cdr values)), (car ids), (car values)
  else
    fn

translate = (exp, store, qont) ->
  if (pairp exp)
    translate (car exp), store, (val1, store1) ->
      translate (cdr exp), store1, (val2, store2) ->
        allocate store2, 2, (store, addrs) ->
          qont (inValue addrs), (extend (extend store, (car addrs), val1), (cadr addrs), val2)
  else
    qont (inValue exp), store
  
# Allocate is a function that takes a store, a number of addresses to
# allocate within that store, and a continuation; at the end, it calls
# the continuation with the store object and the new addresses.
        
allocate = (->
  loc = 0
  (store, num, qont) ->
    aloop = (n, a) ->
      if (n > 0)
        loc = loc - 1
        aloop (n - 1), (cons loc, a)
      else
        qont store, a
    aloop(num, cons()))()


listp =     (cell) -> cell.__type == 'list'
atomp =     (cell) -> not (cell.__type?) or (not cell.__type == 'list')
symbolp =   (cell) -> cell instanceof Symbol
commentp =  (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == ";"
numberp =   (cell) -> typeof cell == 'number'
stringp =   (cell) -> typeof cell == 'string' and cell.length > 0 and cell[0] == "\""
boolp =     (cell) -> typeof cell == 'boolean'
nullp =     (cell) -> cell == null
vectorp =   (cell) -> (not straight_evaluation.listp cell) and toString.call(cell) == '[object Array]'
recordp =   (cell) -> (not cell._prototype?) and toSTring.call(cell) == '[object Object]'
objectp =   (cell) -> (cell._prototype?) and toString.call(cell) == '[object Object]'
nilp =      (cell) -> nilp(cell)
nvalu =     (cell) -> cell
mksymbols = (cell) -> cell

sBehavior = new Symbol 'behavior'
sBoolean  = new Symbol 'boolean'
sBoolify  = new Symbol 'boolify'
sFunction = new Symbol 'function'
sSymbol   = new Symbol 'symbol'
sString   = new Symbol 'string'
sQuote    = new Symbol 'quote'
sLambda   = new Symbol 'lambda'
sIf       = new Symbol 'if'
sValue    = new Symbol 'value'
sChars    = new Symbol 'chars'
sBegin    = new Symbol 'begin'
sName     = new Symbol 'name'
sNumber   = new Symbol 'number'
sNull     = new Symbol 'null'
sTag      = new Symbol 'tag'
sSet      = new Symbol 'set'
sType     = new Symbol 'type'
sValue    = new Symbol 'value'
sPair     = new Symbol 'pair'
sCar      = new Symbol 'car'
sCdr      = new Symbol 'cdr'
sSetCar   = new Symbol 'setcar'
sSetCdr   = new Symbol 'setcdr'

ValueToFunction = (e) ->
  c = e.v
  if (typeof c == 'function') then c else throw new LispInterpreterError("Not a function: " + Object.toString(c))

ValueToPair = (e) ->
  c = e.v
  if pairp c then c else throw new LispInterpreterError("Not a pair: " + Object.toString(c))

ValueToNumber = (e) ->
  c = parseInt(e.v, 10)
  if (typeof c == 'number') then c else throw new LispInterpreterError("Not a number: " + Object.toString(c))

ValueToPrimitive = (e) ->
  return e.v

store_init = (a) -> throw new LispInterpreterError "No such address"
env_init = (a) -> throw new LispInterpreterError "No such variable"  

class Interpreter
  constructor: ->
    arity_check = (name, arity, fn) =>
      (values, kont, store) =>
        if not eq (length values), arity
          throw new LispInterpreterError "Incorrect Arity for #{name}"
        fn.call(@, values, kont, store)

    @definitial "cons", inValue arity_check "cons", 2, (values, kont, store) =>
      allocate store, 2, (store, addrs) =>
        kont (inValue (cons (car addrs), (cadr addrs))), (lextends store, addrs, values)
  
    @definitial "car", inValue arity_check "car", 1, (values, kont, store) =>
      kont (store car @valueToPair (car values)), store
  
    @definitial "cdr", inValue arity_check "car", 1, (values, kont, store) =>
      kont (store cadr @valueToPair (car values)), store
  
    @defprimitive "pair?", ((v) -> inValue (consp v.v)), 1
    @defprimitive "eq?", ((v1, v2) -> inValue (eq v1.v, v2.v)), 2
    @defprimitive "symbol?", ((v) -> inValue (symbolp v.v)), 1
  
    @definitial "set-car!", inValue arity_check, "set-car!", 2, (values, kont, store) ->
      kont (car values), (extend store, (car (ValueToPair (car values))), (cadr values))
  
    @definitial "set-cdr!", inValue arity_check, "set-cdr!", 2, (values, kont, store) ->
      kont (car values), (extend store, (cadr (ValueToPair (car values))), (cadr values))

    @defarithmetic "+",  ((x, y) -> x + y),  2
    @defarithmetic "-",  ((x, y) -> x - y),  2
    @defarithmetic "*",  ((x, y) -> x * y),  2
    @defarithmetic "/",  ((x, y) -> x / y),  2
    @defarithmetic "<",  ((x, y) -> x < y),  2
    @defarithmetic ">",  ((x, y) -> x > y),  2
    @defarithmetic "=",  ((x, y) -> x == y), 2
    @defarithmetic "<=", ((x, y) -> x <= y), 2
    @defarithmetic ">=", ((x, y) -> x >= y), 2
    @defarithmetic "%",  ((x, y) -> x % y),  2
  
    @definitial "apply", arity_check "apply", 2, inValue (values, kont, store) ->
      flat = (v) ->
        if pairp v.v
          cons (store (car (ValueToPair v))), (flat (store (cadr (ValueToPair v))))
        else
          cons()

      collect = (values) ->
        if nullp cdr values
          flat car values
        else
          cons (car values), (collect cdr values)

      (ValueToFunction (car values)) (collect (cdr values)), kont, store

    @definitial '#t', (inValue true)
    @definitial '#f', (inValue false)
    @definitial 'nil', (inValue cons())

    @definitial "x", null
    @definitial "y", null
    @definitial "z", null
    @definitial "a", null
    @definitial "b", null
    @definitial "c", null
    @definitial "foo", null
    @definitial "bar", null
    @definitial "hux", null
    @definitial "fib", null
    @definitial "fact", null
    @definitial "visit", null
    @definitial "length", null
    @definitial "primes", null

  meaning: (e) ->
    meaningTable =
      "quote":      ((e) => @meaningQuotation (cadr e))
      'lambda': ((e) => @meaningAbstraction (cadr e), (cddr e))
      'if':     ((e) => @meaningAlternative (cadr e), (caddr e), (cadddr e))
      'begin':  ((e) => @meaningSequence (cdr e))
      'set!':   ((e) => @meaningAssignment (cadr e), (caddr e))

    if (atomp e)
      return if (symbolp e) then (@meaningReference e.name) else (@meaningQuotation e)

    n = if symbolp (car e) then (car e).name else (car e)
    if meaningTable[n]?
      meaningTable[n](e)
    else
      @meaningApplication (car e), (cdr e)

  meaningQuotation: (val) ->
    (env, kont, store) ->
      (translate val, store, kont)

  meaningReference: (name) ->
    (env, kont, store) ->
      kont (store (env name)), store

  # Extensional alternative

  meaningAlternative: (exp1, exp2, exp3) ->
    boolify = (value) ->
      if (eq? value (inValue false)) then ((x, y) -> y) else ((x, y) -> x)

    ef = (val, val1, val2) ->
      val val1, val2

    (env, kont, store) =>
      hkont = (val, store1) =>
        ef (boolify val), ((@meaning exp2) env, kont, store1), ((@meaning exp3) env, kont, store1)
      (@meaning exp1)(env, hkont, store)

  # Assignment

  meaningAssignment: (name, exp) ->
    (env, kont, store) =>
      hkont = (val, store1) ->
        kont value, (extend store1, (env name), val)

      (@meaning exp)(env, hkont, store)

  # Abstraction (keeps a lambda)

  meaningAbstraction: (names, exps) ->
    (env, kont, store) =>
      funcrep = (vals, kont1, store1) =>
        if not (eq (length vals), (length names))
          throw new LispInterpreterError("Incorrect Arity.")
        functostore = (store2, addrs) =>
          (@meaningsSequence exps) (lextends env, names, addrs), kont1, (lextends store2, addrs, vals)
        allocate store1, (length names), functostore
      kont inValue, funcrep

  meaningVariable: (name) ->
    (m) ->
      (vals, env, kont, store) ->
        allocate store, 1, (store, addrs) ->
          addr = (car addrs)
          m (cdr vals), (extend env, names, addr), kont, (extend store, addr, (car vals))

  meaningApplication: (exp, exps) ->
    (env, kont, store) =>
      hkont = (func, store1) =>
        kont2 = (values, store2) ->
          (ValueToFunction func) values, kont, store2
        (@meanings exps) env, kont2, store1
      (@meaning exp) env, hkont, store

  meaningSequence: (exps) ->
    meaningsMultipleSequence = (exp, exps) =>
      (env, kont, store) =>
        hkont = (values, store1) ->
          (meaningsSequence exps) env, kont, store1
        (@meaning exp) env, hkont, store

    meaningsSingleSequence = (exp) =>
      (env, kont, store) =>
        (@meaning exp) env, kont, store

    (env, kont, store) ->
      if not (pairp exps)
        throw new LispInterpreterError("Illegal Syntax")
      if pairp cdr exps
        meaningsMultipleSequence (car exps), (cdr exps)
      else
        meaningSingleSequence (car exps)

  meanings: (exps) =>
    meaningSomeArguments = (exp, exps) =>
      (env, kont, store) =>
        hkont = (value, store1) =>
          hkont2 = (values, store2) ->
            kont (cons value, values), store2
          (@meanings exps) env, hkont2, store1
        (@meaning exp) env, hkont, store

    meaningNoArguments = ->
      (env, kont, store) ->
        kont (cons()), store

    if pairp exps
      meaningSomeArguments (car exps), (cdr exps)
    else
      meaningNoArguments()

  definitial: (name, value) ->
    allocate store_init, 1, (store, addrs) ->
      env_init = extend env_init, name, (car addrs)
      store_init = extend store, (car addrs), value
      name

  defprimitive: (name, value, arity) ->
    callable = (values, kont, store) =>
      if not eq arity, (length values)
        throw new LispInterpreterError "Incorrect Arity for #{name}"
      kont (value.apply(null, listToVector(values))), store
    @definitial name, (inValue callable)

  defarithmetic: (name, value, arity) ->
    callable = (values, kont, store) ->
      if not eq arity, (length values)
        throw new LispInterpreterError "Incorrect Arity for #{name}"
      kont (inValue (value.apply(null, listToVector(map values, ValueToNumber)))), store
    @definitial name, (inValue callable)

module.exports = (ast, kont) ->
  interpreter = new Interpreter()
  store_current = store_init
  (interpreter.meaning ast)(env_init,
    ((value, store_final) -> kont (convert value, store_final)), store_current)