LambdaINet 0.1.2 → 0.1.2.1
raw patch · 5 files changed
+90/−114 lines, 5 filesdep ~GLFW
Dependency ranges changed: GLFW
Files
- LambdaINet.cabal +3/−6
- src/Diagram.lhs +4/−4
- src/EnableGUI.hs +0/−21
- src/Lambda.lhs +48/−48
- src/Main.lhs +35/−35
LambdaINet.cabal view
@@ -1,5 +1,5 @@ name: LambdaINet-version: 0.1.2+version: 0.1.2.1 homepage: not available maintainer: Paul H. Liu <paul@thev.net> cabal-version: >= 1.6@@ -7,7 +7,7 @@ category: Application synopsis: Graphical Interaction Net Evaluator for Optimal Evaluation description: An experimental evaluator for Interaction Nets that encodes- optimal and call-by-need stragtegies based on Lambdascope, with+ optimal and call-by-need strategies based on Lambdascope, with an interactive graphical interface based on OpenGL and GLFW. See the README in source for more information. license: BSD3@@ -21,9 +21,6 @@ executable LambdaINet Main-is: Main.lhs Other-Modules: Diagram INet Lambda- if os(darwin)- Other-Modules: EnableGUI- cpp-options: -D_EnableGUI_- Build-Depends: base >= 3 && < 5, OpenGL, GLFW, containers, mtl+ Build-Depends: base >= 3 && < 5, OpenGL, GLFW >= 0.5.0.0, containers, mtl Hs-Source-Dirs: src
src/Diagram.lhs view
@@ -554,12 +554,12 @@ > GL.preservingMatrix $ GL.renderPrimitive GL.Quads (do > GL.texCoord (texCoord2 x y) > GL.vertex (vertex3 0 h 0)-> GL.texCoord (texCoord2 (x + dx) y)-> GL.vertex (vertex3 w h 0)+> GL.texCoord (texCoord2 x (y + dy))+> GL.vertex (vertex3 0 0 0) > GL.texCoord (texCoord2 (x + dx) (y + dy)) > GL.vertex (vertex3 w 0 0)-> GL.texCoord (texCoord2 x (y + dy))-> GL.vertex (vertex3 0 0 0))+> GL.texCoord (texCoord2 (x + dx) y)+> GL.vertex (vertex3 w h 0)) > GL.translate (vector3 w 0 0) > renderString s = do
− src/EnableGUI.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-} - -module EnableGUI(enableGUI) where - -import Data.Int -import Foreign - -type ProcessSerialNumber = Int64 - -foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16 -foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO () -foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO () -foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO () -foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO () - -enableGUI = alloca $ \psn -> do - getCurrentProcess psn - cgsDefaultConnection - cpsEnableForegroundOperation psn - cpsSignalAppReady psn - cpsSetFrontProcess psn
src/Lambda.lhs view
@@ -1,6 +1,6 @@ Generalized Lambda for Lambdascope -> {-# LANGUAGE RecursiveDo #-}+> {-# LANGUAGE DoRec #-} > module Lambda ( > Term(..),@@ -36,12 +36,12 @@ > drop i x = drop (i - 1) (tail x) > erasers [] = return []-> erasers (x:xs) = mdo-> e <- eraser x-> es <- erasers xs+> erasers (x:xs) = do+> rec e <- eraser x+> es <- erasers xs > return $ e : es -> termToNet i Z ps = debug ("termToNet: Z " ++ show i) $ mdo+> termToNet i Z ps = debug ("termToNet: Z " ++ show i) $ do > let inp = head ps > out = head (drop i ps) > mid = take (i - 1) (tail ps)@@ -49,84 +49,84 @@ > es <- erasers mid > return $ (a : es) ++ [a] -> termToNet i x@(S t) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ mdo+> termToNet i x@(S t) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ do > let inp = head ps > out = head (drop i ps) > mid = take (i - 1) (tail ps)-> d <- delimiter (head n) inp 0-> n <- termToNet (i - 1) t (d : mid)-> e <- eraser out+> rec d <- delimiter (head n) inp 0+> n <- termToNet (i - 1) t (d : mid)+> e <- eraser out > return $ (d : tail n) ++ [e] -> termToNet i x@(Abs t) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ mdo+> termToNet i x@(Abs t) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ do > let inp = head ps-> a <- abstractor inp (head n) (head (drop (i + 1) n))-> n <- termToNet (i + 1) t ((a : tail ps) ++ [a])+> rec a <- abstractor inp (head n) (head (drop (i + 1) n))+> n <- termToNet (i + 1) t ((a : tail ps) ++ [a]) > let mid = take i (tail n) > return $ a : mid -> termToNet i x@(App t1 t2) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ mdo+> termToNet i x@(App t1 t2) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ do > let inp = head ps-> a <- applicator (head m) (head n) inp-> m <- termToNet i t1 (a : qs)-> n <- termToNet i t2 (a : qs)-> qs <- dup i (tail m) (tail n) (tail ps)+> rec a <- applicator (head m) (head n) inp+> m <- termToNet i t1 (a : qs)+> n <- termToNet i t2 (a : qs)+> qs <- dup i (tail m) (tail n) (tail ps) > return $ a : qs > where > dup 0 _ _ _ = return []-> dup i ~(a:as) ~(b:bs) ~(c:cs) = mdo+> dup i ~(a:as) ~(b:bs) ~(c:cs) = do > d <- duplicator c b a 0 > ds <- dup (i - 1) as bs cs > return $ d : ds -> termToNet i x@(Y t) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ mdo+> termToNet i x@(Y t) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ do > let inp = head ps-> d <- duplicator a b inp 0-> b <- dummy a d-> a <- applicator (head m) b d-> m <- termToNet i t (a : tail ps)+> rec d <- duplicator a b inp 0+> b <- dummy a d+> a <- applicator (head m) b d+> m <- termToNet i t (a : tail ps) > return $ d : tail m -> termToNet i x@(Tup t1 t2) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ mdo+> termToNet i x@(Tup t1 t2) ps = debug ("termToNet: " ++ show x ++ " " ++ show i) $ do > let inp = head ps-> a <- tuple inp (head m) (head n) -> m <- termToNet i t1 (a : qs)-> n <- termToNet i t2 (a : qs)-> qs <- dup i (tail m) (tail n) (tail ps)+> rec a <- tuple inp (head m) (head n) +> m <- termToNet i t1 (a : qs)+> n <- termToNet i t2 (a : qs)+> qs <- dup i (tail m) (tail n) (tail ps) > return $ a : qs > where > dup 0 _ _ _ = return []-> dup i ~(a:as) ~(b:bs) ~(c:cs) = mdo+> dup i ~(a:as) ~(b:bs) ~(c:cs) = do > d <- duplicator c b a 0 > ds <- dup (i - 1) as bs cs > return $ d : ds -> termToNet i x (inp:out) = debug ("termToNet: " ++ show x ++ " " ++ show i) $ mdo+> termToNet i x (inp:out) = debug ("termToNet: " ++ show x ++ " " ++ show i) $ > case x of -> Fst t -> mdo-> a <- twopin 1 "fst" (head n) inp-> n <- termToNet i t (a:out)+> Fst t -> do+> rec a <- twopin 1 "fst" (head n) inp+> n <- termToNet i t (a:out) > return $ a : tail n-> Snd t -> mdo-> a <- twopin 1 "snd" (head n) inp-> n <- termToNet i t (a:out)+> Snd t -> do+> rec a <- twopin 1 "snd" (head n) inp+> n <- termToNet i t (a:out) > return $ a : tail n-> VInt i -> mdo-> a <- single (show i) inp-> n <- erasers out+> VInt i -> do+> rec a <- single (show i) inp+> n <- erasers out > return $ a : n-> VStr s -> mdo-> a <- single s inp-> n <- erasers out+> VStr s -> do+> rec a <- single s inp+> n <- erasers out > return $ a : n-> VFunc arity l t -> mdo-> a <- twopin arity l (head n) inp-> n <- termToNet i t (a:out)+> VFunc arity l t -> do+> rec a <- twopin arity l (head n) inp+> n <- termToNet i t (a:out) > return $ a : tail n -> termToNode t = mdo-> e <- initiator a -> [a] <- termToNet 0 t [e]+> termToNode t = do+> rec e <- initiator a +> [a] <- termToNet 0 t [e] > return e > netToTerm :: INet -> Term
src/Main.lhs view
@@ -1,6 +1,6 @@ The main program for Lambdascope -> {-# LANGUAGE RecursiveDo,CPP #-}+> {-# LANGUAGE DoRec,CPP #-} > module Main where @@ -33,20 +33,9 @@ > GLFW.initialize > initWindow w h > showHelp <- newIORef False-> GLFW.charCallback $= \c b -> when ((c == 'H' || c == 'h') && b == GLFW.Release) -> (modifyIORef showHelp not) > factor <- newIORef (0, 0, 1.0) > netRef <- newIORef net-> loop showHelp factor (handleUserAction factor (keyHandle netRef) (reduce netRef) d)-> GLFW.closeWindow-> GLFW.terminate-> where-> -- prepare an initial diagram to load-> net = nodeToNet (mkNode (termToNode t2')) --(App cube (VInt 3))))-> d = netToDiagram net-> w = 800-> h = 600-> loop showHelp factor handle = do +> let loop handle = do > (UserAction handle', render) <- handle > GL.clear [GL.ColorBuffer] > (cx, cy, s) <- readIORef factor@@ -65,7 +54,16 @@ > GLFW.swapBuffers > GLFW.sleep 0.01 > exit <- GLFW.getKey GLFW.ESC -> unless (exit == GLFW.Press) $ loop showHelp factor handle'+> unless (exit == GLFW.Press) $ loop handle'+> loop (handleUserAction factor (keyHandle showHelp netRef) (reduce netRef) d)+> GLFW.closeWindow+> GLFW.terminate+> where+> -- prepare an initial diagram to load+> net = nodeToNet (mkNode (termToNode t2')) --(App cube (VInt 3))))+> d = netToDiagram net+> w = 800+> h = 600 > helpText = unlines > [ "CTRL+ mouse pan"@@ -91,7 +89,7 @@ > , "D zap duplicator's value (become call-by-need)"] > > -> keyHandle netRef = (fst $ unzip ks, handle)+> keyHandle showHelp netRef = (fst $ unzip ks, handle) > where > -- change the following line to load different programs for 1..9 > -- It currently loads the (opt N) lambda expression.@@ -109,9 +107,11 @@ > ('O', outer), > ('V', viewCounter), > ('L', reLayout),-> ('D', demoteDup)]+> ('D', demoteDup),+> ('H', \n d r -> (n, d, r))] > handle k d r = do > net <- readIORef netRef+> when (k == 'H') $ (modifyIORef showHelp not) > let (net', d', r') = maybe (net, d, r) (\f -> f net d r) (lookup k ks) > writeIORef netRef net' > return (d', r')@@ -248,27 +248,27 @@ We can compose INet nodes by wiring them -> two s = mdo-> a <- abstractor s b e-> b <- abstractor a c m-> c <- applicator d f b-> d <- delimiter e c 0-> e <- duplicator a k d 0-> f <- applicator g l c-> g <- delimiter k f 0-> h <- eraser m-> i <- eraser l-> j <- eraser k-> k <- duplicator e g j 0-> l <- duplicator m i f 0-> m <- duplicator b l h 0+> two s = do+> rec a <- abstractor s b e+> b <- abstractor a c m+> c <- applicator d f b+> d <- delimiter e c 0+> e <- duplicator a k d 0+> f <- applicator g l c+> g <- delimiter k f 0+> h <- eraser m+> i <- eraser l+> j <- eraser k+> k <- duplicator e g j 0+> l <- duplicator m i f 0+> m <- duplicator b l h 0 > return a -> four = mdo-> s <- eraser a-> a <- applicator b b s-> b <- duplicator t a a 0-> t <- two b+> four = do+> rec s <- eraser a+> a <- applicator b b s+> b <- duplicator t a a 0+> t <- two b > return s or we can write a Generalized Lambda term, and convert it to INet.