diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,17 +1,49 @@ +{-# LANGUAGE RecordWildCards #-} + module Main ( main ) where -import System.Environment ( getArgs ) +import Options.Applicative +import Sylvia.Renderer.Impl.Cairo import Sylvia.Text.Parser import Sylvia.UI.GTK main :: IO () -main = do - args <- getArgs - case args of - [input] -> case parseExp input of - Left err -> putStrLn $ show err - Right res -> showInWindow res - _ -> putStrLn "Usage: sylvia 'expression'" +main = execParser opts >>= process + where + opts = info (helper <*> sylvia) + ( fullDesc + & progDesc "Render a lambda expression" + & header "sylvia - a lambda calculus visualizer" + ) + +process :: Sylvia -> IO () +process (Sylvia{..}) = do + case parseExp input of + Left derp -> print derp + Right e -> case outputFile of + Nothing -> showInWindow [e] + Just filename -> writePNG filename $ render e + +data Sylvia = Sylvia + { outputFile :: Maybe FilePath + , input :: String + } + deriving (Show) + +sylvia :: Parser Sylvia +sylvia = Sylvia + <$> nullOption + ( long "output" + & short 'o' + & metavar "FILENAME" + & help "Write the result to a PNG image" + & value Nothing + & reader (Just . Just) + ) + <*> argument Just + ( metavar "EXPR" + & help "Expression to render, in zero-based De Bruijn index notation" + ) diff --git a/README.mkd b/README.mkd --- a/README.mkd +++ b/README.mkd @@ -11,12 +11,11 @@ Quick start ----------- - git clone git://github.com/chrisyco/sylvia + git clone git://github.com/lfairy/sylvia cd sylvia - cabal configure --enable-tests + cabal configure cabal install --only-dependencies cabal build - cabal test dist/build/sylvia See [Building from source][] for more detailed instructions. diff --git a/Sylvia/Renderer/Impl.hs b/Sylvia/Renderer/Impl.hs --- a/Sylvia/Renderer/Impl.hs +++ b/Sylvia/Renderer/Impl.hs @@ -29,6 +29,9 @@ , Result(..) , Rhyme , RhymeUnit(..) + + -- * Miscellany + , stackHorizontally ) where import Control.Applicative @@ -163,12 +166,14 @@ -- Shift the main image to the left, then draw a line next to it image = relativeTo (-lineLength :| 0) image' <> throatLine throatLine = drawZigzag (-lineLength :| throatY') (0 :| throatY) - throatY = if outerIsLam && isLambda e then throatY' - 1 else throatY' + throatY = if outerIsLam && containsLam e then throatY' - 1 else throatY' size = size' |+| (lineLength :| 0) -isLambda :: Exp a -> Bool -isLambda (Lam _) = True -isLambda _ = False +containsLam :: Exp a -> Bool +containsLam e = case e of + Ref _ -> False + Lam _ -> True + App _ b -> containsLam b -- | Render a lambda expression. renderLambda :: RenderImpl r => Exp (Inc Integer) -> Result r @@ -220,3 +225,10 @@ extendRhyme srcX destX = foldMap $ drawLine <$> (srcX :|) . ruDest <*> (destX :|) . ruDest + +-- | Take a list of images and line them up in a row. +stackHorizontally :: RenderImpl r => [(r, PInt)] -> (r, PInt) +stackHorizontally = foldr step (mempty, 0 :| 0) + where + step (image', (w' :| h')) (image, (w :| h)) + = (relativeTo ((-w - 1) :| 0) image' <> image, (w + w' + 2) :| max h h') diff --git a/Sylvia/Renderer/Impl/Cairo.hs b/Sylvia/Renderer/Impl/Cairo.hs --- a/Sylvia/Renderer/Impl/Cairo.hs +++ b/Sylvia/Renderer/Impl/Cairo.hs @@ -11,10 +11,13 @@ ( -- * Types Image - , runImage - , runImage' , Context(..) + -- * Drawing the image + , runImage + , runImageWithPadding + , writePNG + -- * Testing , testRender @@ -23,11 +26,10 @@ ) where import Control.Applicative -import Control.Arrow ( (***) ) import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Default -import Data.Monoid ( Monoid(..), (<>) ) +import Data.Monoid (Monoid(..)) import Graphics.Rendering.Cairo import Sylvia.Renderer.Impl @@ -38,11 +40,26 @@ type ImageM = ReaderT Context Render +-- | Render an image. +-- +-- The resulting image's throat will be at (0, 0); in practice, this will +-- mean that if the result is run directly, most of the image would be +-- off the page. To fix this, use the 'translate' function or call +-- 'runImageWithPadding' instead. runImage :: Context -> Image -> Render () runImage ctx = flip runReaderT ctx . unI -runImage' :: Context -> (Image, PInt) -> (Render (), PInt) -runImage' ctx = runImage ctx *** (ctxGridSize ctx |*|) +-- | Render an image, translating it so its top-left corner is at (0, 0). +-- +-- If you only want to render the thing, this is the function to use. +runImageWithPadding + :: Context + -> (Image, PInt) -- The image, along with its size in grid units + -> (Render (), PInt) -- Rendering action, with its size in pixels +runImageWithPadding ctx (image, innerSize) = (action, realSize) + where + action = runImage ctx $ relativeTo (innerSize |+| (1 :| 1)) image + realSize = ctxGridSize ctx |*| (innerSize |+| (2 :| 2)) -- | Lift a rendering action into the 'ImageM' monad, wrapping it in -- calls to 'save' and 'restore' to stop its internal state from leaking @@ -54,9 +71,16 @@ restore return result +-- | A 'Context' contains the environment required for rendering an +-- expression. data Context = C { ctxGridSize :: PInt + -- ^ The size of one grid unit. Whenever the rendering code + -- specifies a coordinate, it is multiplied by this factor before + -- it is drawn on the screen. , ctxOffset :: PInt + -- ^ The origin of the image. You shouldn't need to fiddle with + -- this directly – try 'relativeTo' instead. } instance Default Context where @@ -129,23 +153,20 @@ addOffset ctx@C{ ctxOffset = offset } = ctx{ ctxOffset = offset |+| delta } -dumpPNG :: PInt -> Image -> IO () -dumpPNG size action = withImageSurface FormatRGB24 w h $ \surface -> do +writePNG :: FilePath -> (Image, PInt) -> IO () +writePNG filename imagePack = withImageSurface FormatRGB24 w h $ \surface -> do -- Fill the background with white renderWith surface $ setSourceRGB 1 1 1 >> paint -- Render ALL the things - let action' = relativeTo (1 :| 1) action - renderWith surface $ runImage def action' + renderWith surface $ action -- Save the image - surfaceWriteToPNG surface "result.png" + surfaceWriteToPNG surface filename where - w :| h = ctxGridSize def |*| (size |+| (2 :| 2)) -- padding + (action, (w :| h)) = runImageWithPadding def imagePack testRender :: IO () -testRender = uncurry dumpPNG $ foldl step (0 :| 0, mempty) es +testRender = writePNG "result.png" . stackHorizontally $ map render es where - step ((w :| h), image) e = ((w + w' + 1) :| (max h h'), image <> relativeTo ((w + w') :| h') image') - where (image', (w' :| h')) = render e es = map (fromRight . parseExp) $ [ "L 0" , "LL 1" diff --git a/Sylvia/UI/GTK.hs b/Sylvia/UI/GTK.hs --- a/Sylvia/UI/GTK.hs +++ b/Sylvia/UI/GTK.hs @@ -24,8 +24,8 @@ title :: String title = "Sylvia" -showInWindow :: Exp Void -> IO () -showInWindow e = do +showInWindow :: [Exp Void] -> IO () +showInWindow es = do "Initializing GTK" -:- do initGUI @@ -40,26 +40,25 @@ "Creating canvas" -:- do canvas <- drawingAreaNew - let (_, (w :| h)) = renderCairo e + let (_, (w :| h)) = renderCairo es widgetSetSizeRequest canvas w h set window [ containerChild := canvas ] - canvas `on` exposeEvent $ updateCanvas e + canvas `on` exposeEvent $ updateCanvas es "Show ALL the things!" -:- do widgetShowAll window mainGUI -updateCanvas :: Exp Void -> EventM EExpose Bool -updateCanvas e = do +updateCanvas :: [Exp Void] -> EventM EExpose Bool +updateCanvas es = do win <- eventWindow liftIO $ do - let (action, size) = renderCairo e - let (w :| h) = fmap fromIntegral $ size |+| ctxGridSize def - renderWithDrawable win $ translate w h >> action + let (action, _) = renderCairo es + renderWithDrawable win action return True -renderCairo :: Exp Void -> (Render (), PInt) -renderCairo = runImage' def . render +renderCairo :: [Exp Void] -> (Render (), PInt) +renderCairo = runImageWithPadding def . stackHorizontally . map render infixr 1 -:- (-:-) :: String -> IO a -> IO a diff --git a/sylvia.cabal b/sylvia.cabal --- a/sylvia.cabal +++ b/sylvia.cabal @@ -1,5 +1,5 @@ Name: sylvia -Version: 0.2.0.1 +Version: 0.2.1 Synopsis: Lambda calculus visualization Category: Game @@ -19,7 +19,7 @@ License: GPL License-File: LICENSE -Copyright: 2011 Chris Wong +Copyright: 2012 Chris Wong Build-Type: Simple Extra-Source-Files: README.mkd @@ -31,6 +31,7 @@ Build-Depends: base == 4.* , data-default + , optparse-applicative == 0.4.* , parsec >= 3.1.2 && < 3.2 , transformers , void >= 0.5.5 && < 0.6