LangDev

Haskell로 만들어본 초간단 G-Machine

semmal

Implementing Functional Languages : a tutorial 에 있는 G-Machine도 꽤나 복잡해서 조금 더 간단하게 만들어봤습니다. 정확하게 따지자면 G-Machine과 동작이 약간 다릅니다. 그래도 개념은 완전히 같으니 그냥 G-Machine이라고 하는게 맞을 것 같네요. 원래 처음부터 C++로 작성하다가 꿈이 너무 높아서 좌절하던 와중에, 더 간단한 버전을 만들기 위한 노력의 결과물입니다.(그래봐야 어제 하루) 이제는 C++로 어떻게 만들어야할지 좀 감이 올 것 같네요.

모듈이름은 세모(semo)입니다. 원래 셈모(셈하는 기계)라고 할려고 했는데, 어감이 안좋아서 그냥 세모로 했지요. 앞으로 semmal에 abstract machine이 올라간다면 그 이름은 세모입니다.

compiler는 만들지 않았습니다. 단지 G-Machine만 테스트하기 위한 코듭니다. 초간단 lexer와 parser는 만들었는데, indentation때문에 고민중이라서 compiler까지는 못나가고 있어요. keyword(또는 key operator)가 거의 없는 syntax를 만들려고하니 보통 문제가 아닙니다. 죽기전까지 만들 수 있을라나 모르겠네요.

> eval initState

하면 답을 구할 때까지 실행한 기계 상태가 모두 나옵니다.

대충 설명하자면

Main = S K I 3 -- 이건 주석처리중
Main = If False 4 3

Main함수는 이걸 처리합니다.

S f g x = f x (g x)
K x y = x
I x = x

If p c a = p c a
True c a = c
False c a = a

이런 함수(supercombinator)가 이름자리(namespace)에 들어가 있고, 이름자리에 있는 이름과 heap에 있는 함수의 index는 대응합니다. G-Machine은 코드를 뒤에서부터 만드는데, 제껀 앞에서부터 만듭니다. stack spine의 방향이 반대라고 보는게 맞을지도 모릅니다. 이편이 훨씬 보기 쉬워서 그렇게 만들었습니다. 또한 G-Machine의 Push 명령도, Pusharg로 바꾸고 스택에서의 높이를 입력하게 만듭니다. 그래서 조금 더 스택을 해석하기 쉽습니다.

이를 위해서, 인자의 차례도 바뀌었는데요.

If p c a

에서 맨마지막 인자가 index 0을 부여받고, c와 p가 1, 2를 부여받아서 Pusharg가 동작하게 됩니다.

이렇게 하면 partial application이나 다른 확장에 대한 고려가 없기 때문에, 나중에 문제가 생길 수 있다는 거겠지요. 그러면 또 완전히 재작성해야할 수도 있겠네요. 생각하면 머리가 복잡해져서 일단 머리속에서는 지웠습니다.

module Semo where

type IntValue = Int
type Index = Int
type Number = Int
data Instruction
    = Pushname String
    | Pushlit IntValue
    | Pusharg Index
    | MkAp
    | Unwind
    | Slide Number
    deriving Show

data Node
    = SC Number [Instruction]
    | Lit IntValue
    | Ap Index Index
    deriving Show

initCode = [Pushname "Main", Unwind]
--heapMain = SC 0 [Pushname "S", Pushname "K", MkAp, Pushname "I", MkAp, Pushlit 3, MkAp, Slide 1, Unwind]
heapMain = SC 0 [Pushname "If", Pushname "False", MkAp, Pushlit 4, MkAp, Pushlit 3, MkAp, Slide 1, Unwind]
heapS = SC 3 [Pusharg 2, Pusharg 0, MkAp, Pusharg 1, Pusharg 0, MkAp, MkAp, Slide 4, Unwind]
heapK = SC 2 [Pusharg 1, Slide 3, Unwind]
heapI = SC 1 [Pusharg 0, Slide 2, Unwind]
heapIF = SC 3 [Pusharg 2, Pusharg 1, MkAp, Pusharg 0, MkAp, Slide 4, Unwind]
heapTRUE = SC 2 [Pusharg 1, Slide 3, Unwind]
heapFALSE = SC 2 [Pusharg 0, Slide 3, Unwind]
initState = (initCode,[],[heapMain,heapS,heapK,heapI,heapIF,heapTRUE,heapFALSE],["Main","S","K","I","If","True","False"])

code (c,s,h,n) = c
stack (c,s,h,n) = s
heap (c,s,h,n) = h
name (c,s,h,n) = n

setCode c' (c,s,h,n) = (c',s,h,n)
setStack s' (c,s,h,n) = (c,s',h,n)
setHeap h' (c,s,h,n) = (c,s,h',n)
setName n' (c,s,h,n) = (c,s,h,n')

addr i ss = ss!!i
arg i ss = (reverse ss)!!i

slide 0 ss = ss
slide i ss = slide (i-1) (init ss)

eval ([],[],[],[]) = []
eval s = s:eval (eval' s cs)
    where
        cs = code s
        eval' state [] = ([],[],[],[])
        eval' state code@(Pushname nm:cs) = setCode cs $ setStack ((findName nm (name state)):(stack state)) state
        eval' state code@(Pushlit i:cs) = setCode cs $ setHeap ((heap state)++[Lit i]) $ setStack ((length (heap state)):(stack state)) state
        eval' state code@(Pusharg i:cs) = let ss = stack state in setCode cs $ setStack ((arg i ss):ss) state
        eval' state code@(Unwind:cs) =
            case findHeap (addr 0 (stack state)) (heap state) of
                sc@(SC _ _) -> setCode ((sccode sc)++cs) state
                Lit _ -> setCode cs state
                ap@(Ap s0 s1) -> let (s:ss) = stack state in setStack (s0:s1:ss) state
        eval' state code@(MkAp:cs) = let (s1:s0:ss) = stack state in setCode cs $ setHeap ((heap state)++[Ap s0 s1]) $ setStack ((length (heap state)):ss) state
        eval' state code@(Slide n:cs) = setCode cs $ setStack (slide n (stack state)) state

findName n ns = findName' n ns 0
    where
        findName' n' (n:ns) c | n == n' = c
        findName' n' (n:ns) c = findName' n' ns (c+1)


sccode (SC n is) = is

findHeap i hs = hs!!i

치명적인 버그가 있었는데, 코딩을 잘못했더군요. Ap를 해석하는 과정에서 s1과 s0을 분리하는게 아니었습니다. 눈앞의 책을 보면서도 제대로 코딩을 못했네요.

> showResult $ eval initState

위 처럼 적어서 결과를 확인할 수 있습니다.

> showState 1 $ eval initState

버그를 수정하느라, 디버거처럼 동작하는 showState 함수를 추가했습니다. 스탭(예제에서는 1)을 입력하면, 해당 스탭에서의 코드, 스택, 그리고 스택에 있는 알맹이(item)의 heap 노드를 풀어서 보여줍니다.

또, 지금은 Sample4 함수만 실행하도록 Main이 만들어져있는데,

> showResult $ eval $ runState "Sample1"

위 처럼 적어서 Sample1 함수를 돌려볼 수 있습니다. Sample1, Sample2, Sample3, Sample4 함수 4개가 정의되어 있으니 바꿔서 해보시면 됩니다.

앞서보다, 꽤 많이 수정했는데, 일단 리터럴도 이름으로 동작하도록 동작방식을 변경했습니다. 책에 있는 Exercise 3.6을 적용한 결과인데요, 제대로 한 건지 모르겠습니다. 또, Mark 2에서 Lazy하게 동작하도록 Indirection 노드를 추가했고, 추가적으로 Partial Application 노드도 추가했습니다. 이런 식으로 하는 건지 잘 모르겠는데 일단 넣어놓고 다시 공부해야겠네요.

stack을 나누어서 스윗칭하는 부분이 있는데, 역시나 Pusharg가 원래 G-Machine과 동작이 다른 문제점 때문에 그렇습니다. 나눠서 스위칭까지 하는 스택이 과연 스택일까 의심이 들기는 합니다만, 뭐 어쨌든 동작은 하는 것 같습니다.

주말에 이 짓 하느라 시간을 다 보냈네요. 언제 또 삘을 받아서 이렇게 할 수 있을까 아쉽습니다.

module Semo where

type IntValue = Int
type Index = Int
type Number = Int
data Instruction
    = Pushname String
    | Pusharg Index
    | MkAp
    | Unwind
    | Slide Number
    | Indirect
    deriving Show

data Node
    = SC Number [Instruction]
    | Lit IntValue
    | Ap Index Index
    | Ind Index
    | PAp Index
    deriving Show

initCode = [Pushname "Main", Unwind]
-- main = Sample4
heapMain = SC 0 [Pushname "Sample4", Indirect, Slide 1, Unwind]
-- Sample1 = S K I 3
heapSample1 = SC 0 [Pushname "S", Pushname "K", MkAp, Pushname "I", MkAp, Pushname "3", MkAp, Indirect, Slide 1, Unwind]
-- Sample2 = If True 4 3
heapSample2 = SC 0 [Pushname "If", Pushname "True", MkAp, Pushname "4", MkAp, Pushname "3", MkAp, Indirect, Slide 1, Unwind]
-- Sample3 = S K K 2
heapSample3 = SC 0 [Pushname "S", Pushname "K", MkAp, Pushname "K", MkAp, Pushname "2", MkAp, Indirect, Slide 1, Unwind]
-- S f g x = f x (g x)
heapS = SC 3 [Pusharg 2, Pusharg 0, MkAp, Pusharg 1, Pusharg 0, MkAp, MkAp, Indirect, Slide 4, Unwind]
-- K x y = x
heapK = SC 2 [Pusharg 1, Indirect, Slide 3, Unwind]
-- I x = x
heapI = SC 1 [Pusharg 0, Indirect, Slide 2, Unwind]
-- If p c a = p c a
heapIf = SC 3 [Pusharg 2, Pusharg 1, MkAp, Pusharg 0, MkAp, Indirect, Slide 4, Unwind]
-- True c a = c
heapTrue = SC 2 [Pusharg 1, Indirect, Slide 3, Unwind]
-- False c a = a
heapFalse = SC 2 [Pusharg 0, Indirect, Slide 3, Unwind]
-- Twice f x = f (f x)
heapTwice = SC 2 [Pusharg 1, Pusharg 1, Pusharg 0, MkAp, MkAp, Indirect, Slide 3, Unwind]
-- Id x = x
heapId = SC 1 [Pusharg 0, Indirect, Slide 2, Unwind]
-- Sample4 = Twice Twice Id 3
heapSample4 = SC 0 [Pushname "Twice", Pushname "Twice", MkAp, Pushname "Id", MkAp, Pushname "5", MkAp, Indirect, Slide 1, Unwind]
--heapSample4 = SC 0 [Pushname "Twice", Pushname "Twice", MkAp, Pushname "Id", MkAp, Indirect, Slide 1, Unwind] -- Partial Application Test
initState = (initCode,[],[heapMain,heapSample1,heapSample2,heapSample3,heapS,heapK,heapI,heapIf,heapTrue,heapFalse,heapTwice,heapId,heapSample4,Lit 3,Lit 4,Lit 2,Lit 5],["Main","Sample1","Sample2","Sample3","S","K","I","If","True","False","Twice","Id","Sample4","3","4","2","5"])

runMain s = SC 0 [Pushname s, Indirect, Slide 1, Unwind]
runState s = (initCode,[],[runMain s,heapSample1,heapSample2,heapSample3,heapS,heapK,heapI,heapIf,heapTrue,heapFalse,heapTwice,heapId,heapSample4,Lit 3,Lit 4,Lit 2,Lit 5],["Main","Sample1","Sample2","Sample3","S","K","I","If","True","False","Twice","Id","Sample4","3","4","2","5"])

code (c,s,h,n) = c
stack (c,s,h,n) = s
heap (c,s,h,n) = h
name (c,s,h,n) = n

setCode c' (c,s,h,n) = (c',s,h,n)
setStack s' (c,s,h,n) = (c,s',h,n)
setHeap h' (c,s,h,n) = (c,s,h',n)
setName n' (c,s,h,n) = (c,s,h,n')

addr i [] = error "no stack"
addr i ss = ss!!i
arg i ss = (reverse ss)!!i

slide 0 ss = ss
slide i ss = slide (i-1) (init ss)

eval ([],[],[],[]) = []
eval s = s:eval (eval' s cs)
    where
        cs = code s
        eval' state [] = ([],[],[],[])
        eval' state code@(Pushname nm:cs) = setCode cs $ setStack ((findName nm (name state)):(stack state)) state
        eval' state code@(Pusharg i:cs) =
            let ss = stack state
                s = arg i ss
                i' = apvalue i $ findHeap s $ heap $ state
            in  setCode cs $ setStack (i':ss) state
        eval' state code@(Unwind:cs) =
            case findHeap (addr 0 (stack state)) (heap state) of
                SC n cs' -> case compare (n+1) (length $ stack state) of
                    LT -> let (fs,bs) = splitAt (n+1) (stack state) in setCode (cs'++cs) $ setStack (bs++fs) state
                    EQ -> setCode (cs'++cs) state
                    GT -> let (s:ss) = stack state in setCode cs $ setHeap ((heap state)++[PAp s]) $ setStack ((length (heap state)):ss) state
                Lit _ -> setCode cs state
                Ap s0 s1 -> let (s:ss) = stack state in setStack (s0:s:ss) state
                Ind s0 -> let (s:ss) = stack state in setStack (s0:ss) state 
        eval' state code@(MkAp:cs) = let (s1:s0:ss) = stack state in setCode cs $ setHeap ((heap state)++[Ap s0 s1]) $ setStack ((length (heap state)):ss) state
        eval' state code@(Slide n:cs) = setCode cs $ setStack (slide n (stack state)) state
        eval' state code@(Indirect:cs) = let (s:ss) = stack state in setCode cs $ setHeap ((heap state)++[Ind s]) $ setStack ((length (heap state)):ss) state


findName n ns = findName' n ns 0
    where
        findName' n' (n:ns) c | n == n' = c
        findName' n' (n:ns) c = findName' n' ns (c+1)

apvalue n (Ap x y) = y
apvalue n _ = n

findHeap i hs = hs!!i

showResult ss = let state = last ss in findHeap (addr 0 $ stack state) $ heap state

showStack [] state = "\n"
showStack (s:ss) state = show s ++ "\t" ++ show (findHeap s $ heap state) ++ "\n" ++ showStack ss state

showState n states =
    let
        state = last $ take n $ states
        cs = code state
        ss = stack state
    in
        putStr $ show cs ++ "\n" ++ show ss ++ "\n" ++ showStack ss state
semmal

점점 무한정 길어지는데 답이 없네요.

letrec을 만들려고 보니 Y combinator를 구현하고픈 욕심이 생겨서, let을 만들기도 전에 primitive instruction을 추가해버렸습니다. factorial을 만들려면 사칙연산과 비교연산이 안되면 안되거든요.

그전에 church encoding으로 만들어보려고 했는데, reduction이 너무 길어져서 stack overflow로 죽어버리더군요. 그래서 결국 primitive를 추가했습니다.

Sample5는 간단한 빼기 코드, Sample6은 그냥 factorial을 구하는 것이고, Sample7과 Sample8이 Y combinator를 써서 factorial을 구합니다.

현재 lambda expression은 아직 지원하지 않기때문에 따로 함수로 정의해서 Y2를 만들었습니다.

> showResult $ eval $ runState "Sample8"
Lit 120

위 처럼 동작합니다.

primitive는 나중에 세모를 다시 C++로 개발하게 되면, GMP에 있는 연산으로 바꿀 생각입니다. 필히 그전에 FFI를 어떻게 만들어야 할지 고민해봐야합니다. 사원수도 기본적으로 지원하고 싶은데, GMP와 중복되지 않는 쓸만한 라이브러리가 있는지 모르겠습니다.

  • 왜 아래 pre 가 깨지는지 모르겠네요.
  • pre를 div로 한번 더 싸니 해결됩니다.

module Semo where

type IntValue = Int
type Index = Int
type Number = Int
data Instruction
    = Pushname String
    | Pusharg Index
    | MkAp
    | Unwind
    | Slide Number
    | Indirect
    | Add
    | Sub
    | Mult
    | Div
    | Eq
    | Lt
    | Gt
    | Ne
    | Le
    | Ge
    deriving Show

data Node
    = SC Number [Instruction]
    | Lit IntValue
    | Ap Index Index
    | Ind Index
    | PAp Index
    deriving Show

initCode = [Pushname "Main", Unwind]
-- main = Sample4
heapMain = SC 0 [Pushname "Sample4", Indirect, Slide 1, Unwind]
-- Sample1 = S K I 3
heapSample1 = SC 0 [Pushname "S", Pushname "K", MkAp, Pushname "I", MkAp, Pushname "3", MkAp, Indirect, Slide 1, Unwind]
-- Sample2 = If True 4 3
heapSample2 = SC 0 [Pushname "If", Pushname "True", MkAp, Pushname "4", MkAp, Pushname "3", MkAp, Indirect, Slide 1, Unwind]
-- Sample3 = S K K 2
heapSample3 = SC 0 [Pushname "S", Pushname "K", MkAp, Pushname "K", MkAp, Pushname "2", MkAp, Indirect, Slide 1, Unwind]
-- S f g x = f x (g x)
heapS = SC 3 [Pusharg 2, Pusharg 0, MkAp, Pusharg 1, Pusharg 0, MkAp, MkAp, Indirect, Slide 4, Unwind]
-- K x y = x
heapK = SC 2 [Pusharg 1, Indirect, Slide 3, Unwind]
-- I x = x
heapI = SC 1 [Pusharg 0, Indirect, Slide 2, Unwind]
-- If p c a = p c a
heapIf = SC 3 [Pusharg 2, Pusharg 1, MkAp, Pusharg 0, MkAp, Indirect, Slide 4, Unwind]
-- True c a = c
heapTrue = SC 2 [Pusharg 1, Indirect, Slide 3, Unwind]
-- False c a = a
heapFalse = SC 2 [Pusharg 0, Indirect, Slide 3, Unwind]
-- Twice f x = f (f x)
heapTwice = SC 2 [Pusharg 1, Pusharg 1, Pusharg 0, MkAp, MkAp, Indirect, Slide 3, Unwind]
-- Id x = x
heapId = SC 1 [Pusharg 0, Indirect, Slide 2, Unwind]
-- Sample4 = Twice Twice Id 3
heapSample4 = SC 0 [Pushname "Twice", Pushname "Twice", MkAp, Pushname "Id", MkAp, Pushname "5", MkAp, Indirect, Slide 1, Unwind]
--heapSample4 = SC 0 [Pushname "Twice", Pushname "Twice", MkAp, Pushname "Id", MkAp, Indirect, Slide 1, Unwind] -- Partial Application Test
-- Sample5 = Sub 3 4
heapSample5 = SC 0 [Pushname "Sub", Pushname "3", MkAp, Pushname "4", MkAp, Indirect, Slide 1, Unwind]
heapAdd = SC 2 [Pusharg 1, Unwind, Pusharg 0, Unwind, Add, Indirect, Slide 3, Unwind]
heapSub = SC 2 [Pusharg 1, Unwind, Pusharg 0, Unwind, Sub, Indirect, Slide 3, Unwind]
heapMult = SC 2 [Pusharg 1, Unwind, Pusharg 0, Unwind, Mult, Indirect, Slide 3, Unwind]
heapDiv = SC 2 [Pusharg 1, Unwind, Pusharg 0, Unwind, Div, Indirect, Slide 3, Unwind]
heapEq = SC 2 [Pusharg 1, Unwind, Pusharg 0, Unwind, Eq, Indirect, Slide 3, Unwind]
heapNe = SC 2 [Pusharg 1, Unwind, Pusharg 0, Unwind, Ne, Indirect, Slide 3, Unwind]
-- Fact x = If (Eq x 0) 1 (Mult x (Fact (Sub x 1)))
heapFact = SC 1 [Pushname "If", Pushname "Eq", Pusharg 0, MkAp, Pushname "0", MkAp, MkAp, Pushname "1", MkAp, Pushname "Mult", Pusharg 0, MkAp, Pushname "Fact", Pushname "Sub", Pusharg 0, MkAp, Pushname "1", MkAp, MkAp, MkAp, MkAp, Indirect, Slide 2, Unwind]
-- Sample6 = Fact 5
heapSample6 = SC 0 [Pushname "Fact", Pushname "5", MkAp, Indirect, Slide 1, Unwind]
-- Y f = f (Y f)
heapY = SC 1 [Pusharg 0, Pushname "Y", Pusharg 0, MkAp, MkAp, Indirect, Slide 1, Unwind]
-- FactF f x = If (Eq x 0) 1 (Mult x (f (Sub x 1)))
heapFactF = SC 2 [Pushname "If", Pushname "Eq", Pusharg 0, MkAp, Pushname "0", MkAp, MkAp, Pushname "1", MkAp, Pushname "Mult", Pusharg 0, MkAp, Pusharg 1, Pushname "Sub", Pusharg 0, MkAp, Pushname "1", MkAp, MkAp, MkAp, MkAp, Indirect, Slide 3, Unwind]
-- Sample7 = Y FactF 5
heapSample7 = SC 0 [Pushname "Y", Pushname "FactF", MkAp, Pushname "5", MkAp, Indirect, Slide 1, Unwind]
-- LambdaY f x = f (x x)
-- Y2 f = (LambdaY f) (LambdaY f)
-- Sample8 = Y2 FactF 5
heapLambdaY = SC 2 [Pusharg 1, Pusharg 0, Pusharg 0, MkAp, MkAp, Indirect, Slide 3, Unwind]
heapY2 = SC 1 [Pushname "LambdaY", Pusharg 0, MkAp, Pushname "LambdaY", Pusharg 0, MkAp, MkAp, Indirect, Slide 2, Unwind]
heapSample8 = SC 0 [Pushname "Y2", Pushname "FactF", MkAp, Pushname "5", MkAp, Indirect, Slide 1, Unwind]

initState = (initCode,[],[heapMain,heapSample1,heapSample2,heapSample3,heapS,heapK,heapI,heapIf,heapTrue,heapFalse,heapTwice,heapId,heapSample4,heapSample5,heapAdd,heapSub,heapMult,heapDiv,heapEq,heapNe,heapFact,heapSample6,heapY,heapFactF,heapSample7,heapLambdaY,heapY2,heapSample8,Lit 0,Lit 1,Lit 3,Lit 4,Lit 2,Lit 5],["Main","Sample1","Sample2","Sample3","S","K","I","If","True","False","Twice","Id","Sample4","Sample5","Add","Sub","Mult","Div","Eq","Ne","Fact","Sample6","Y","FactF","Sample7","LambdaY","Y2","Sample8","0","1","3","4","2","5"])

runMain s = SC 0 [Pushname s, Indirect, Slide 1, Unwind]
runState s = (initCode,[],[runMain s,heapSample1,heapSample2,heapSample3,heapS,heapK,heapI,heapIf,heapTrue,heapFalse,heapTwice,heapId,heapSample4,heapSample5,heapAdd,heapSub,heapMult,heapDiv,heapEq,heapNe,heapFact,heapSample6,heapY,heapFactF,heapSample7,heapLambdaY,heapY2,heapSample8,Lit 0,Lit 1,Lit 3,Lit 4,Lit 2,Lit 5],["Main","Sample1","Sample2","Sample3","S","K","I","If","True","False","Twice","Id","Sample4","Sample5","Add","Sub","Mult","Div","Eq","Ne","Fact","Sample6","Y","FactF","Sample7","LambdaY","Y2","Sample8","0","1","3","4","2","5"])

code (c,s,h,n) = c
stack (c,s,h,n) = s
heap (c,s,h,n) = h
name (c,s,h,n) = n

setCode c' (c,s,h,n) = (c',s,h,n)
setStack s' (c,s,h,n) = (c,s',h,n)
setHeap h' (c,s,h,n) = (c,s,h',n)
setName n' (c,s,h,n) = (c,s,h,n')

addr i [] = error "no stack"
addr i ss = ss!!i
arg i ss = (reverse ss)!!i

slide 0 ss = ss
slide i ss = slide (i-1) (init ss)

eval ([],[],[],[]) = []
eval s = s:eval (eval' s cs)
    where
        cs = code s
        eval' state [] = ([],[],[],[])
        eval' state code@(Pushname nm:cs) = setCode cs $ setStack ((findName nm (name state)):(stack state)) state
        eval' state code@(Pusharg i:cs) =
            let ss = stack state
                s = arg i ss
                i' = apvalue i $ findHeap s $ heap $ state
            in  setCode cs $ setStack (i':ss) state
        eval' state code@(Unwind:cs) =
            case findHeap (addr 0 (stack state)) (heap state) of
                SC n cs' -> case compare (n+1) (length $ stack state) of
                    LT -> let (fs,bs) = splitAt (n+1) (stack state) in setCode (cs'++cs) $ setStack (bs++fs) state
                    EQ -> setCode (cs'++cs) state
                    GT -> let (s:ss) = stack state in setCode cs $ setHeap ((heap state)++[PAp s]) $ setStack ((length (heap state)):ss) state
                Lit _ -> setCode cs state
                Ap s0 s1 -> let (s:ss) = stack state in setStack (s0:s:ss) state
                Ind s0 -> let (s:ss) = stack state in setStack (s0:ss) state 
        eval' state code@(MkAp:cs) = let i = findHeapNode (Ap s0 s1) $ heap state ; (s1:s0:ss) = stack state in if 0 <= i then setCode cs $ setStack (i:ss) state else setCode cs $ setHeap ((heap state)++[Ap s0 s1]) $ setStack ((length (heap state)):ss) state
        eval' state code@(Slide n:cs) = setCode cs $ setStack (slide n (stack state)) state
        eval' state code@(Indirect:cs) = let i = findHeapNode (Ind s) $ heap state ; (s:ss) = stack state in if 0 <= i then setCode cs $ setStack (i:ss) state else setCode cs $ setHeap ((heap state)++[Ind s]) $ setStack ((length (heap state)):ss) state
    eval' state code@(Add:cs) = let hs = heap state ; r = v0+v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; i = findHeapNode (Lit r) hs ; (s1:s0:ss) = stack state in if 0 <= i then setCode cs $ setStack (i:ss) state else setCode cs $ setHeap (hs++[Lit r]) $ setStack ((length hs):ss) state
    eval' state code@(Sub:cs) = let hs = heap state ; r = v0-v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; i = findHeapNode (Lit r) hs ; (s1:s0:ss) = stack state in if 0 <= i then setCode cs $ setStack (i:ss) state else setCode cs $ setHeap (hs++[Lit r]) $ setStack ((length hs):ss) state
    eval' state code@(Mult:cs) = let hs = heap state ; r = v0*v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; i = findHeapNode (Lit r) hs ; (s1:s0:ss) = stack state in if 0 <= i then setCode cs $ setStack (i:ss) state else setCode cs $ setHeap (hs++[Lit r]) $ setStack ((length hs):ss) state
    eval' state code@(Div:cs) = let hs = heap state ; r = div v0 div v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; i = findHeapNode (Lit r) hs ; (s1:s0:ss) = stack state in if 0 <= i then setCode cs $ setStack (i:ss) state else setCode cs $ setHeap (hs++[Lit r]) $ setStack ((length hs):ss) state
    eval' state code@(Eq:cs) = let hs = heap state ; r = v0==v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; (s1:s0:ss) = stack state in if r then setCode cs $ setStack (findName "True" (name state):ss) state else setCode cs $ setStack (findName "False" (name state):ss) state
    eval' state code@(Ne:cs) = let hs = heap state ; r = v0/=v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; (s1:s0:ss) = stack state in if r then setCode cs $ setStack (findName "True" (name state):ss) state else setCode cs $ setStack (findName "False" (name state):ss) state
    eval' state code@(Lt:cs) = let hs = heap state ; r = v0v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; (s1:s0:ss) = stack state in if r then setCode cs $ setStack (findName "True" (name state):ss) state else setCode cs $ setStack (findName "False" (name state):ss) state
    eval' state code@(Le:cs) = let hs = heap state ; r = v0<=v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; (s1:s0:ss) = stack state in if r then setCode cs $ setStack (findName "True" (name state):ss) state else setCode cs $ setStack (findName "False" (name state):ss) state
    eval' state code@(Ge:cs) = let hs = heap state ; r = v0>=v1 ; (Lit v0) = findHeap s0 hs ; (Lit v1) = findHeap s1 hs ; (s1:s0:ss) = stack state in if r then setCode cs $ setStack (findName "True" (name state):ss) state else setCode cs $ setStack (findName "False" (name state):ss) state

findName n ns = findName' n ns 0
    where
        findName' n' (n:ns) c | n == n' = c
        findName' n' (n:ns) c = findName' n' ns (c+1)

apvalue n (Ap x y) = y
apvalue n _ = n

findHeap i hs = hs!!i

findHeapNode n hs = findHeapNode' n hs 0
    where
        findHeapNode' n [] c = -1
        findHeapNode' (Ap x' y') (Ap x y:hs) c | x'==x&&y'==y = c
        findHeapNode' (Ind x') (Ind x:hs) c | x'==x = c
    findHeapNode' (Lit x') (Lit x:hs) c | x'==x = c
        findHeapNode' n (h:hs) c = findHeapNode' n hs (c+1)

showResult ss = let state = last ss in findHeap (addr 0 $ stack state) $ heap state

showStack [] state = "\n"
showStack (s:ss) state = show s ++ "\t" ++ show (findHeap s $ heap state) ++ "\n" ++ showStack ss state

showState n states =
    let
        state = last $ take n $ states
        cs = code state
        ss = stack state
    in
        putStr $ show cs ++ "\n" ++ show ss ++ "\n" ++ showStack ss state
semmal