diff --git a/Logo.hs b/Logo.hs deleted file mode 100644 --- a/Logo.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Main where - -import Diagrams.Prelude -import Diagrams.Backend.SVG.CmdLine -import Diagrams.TwoD.Path.Turtle - -import Logo.Types -import Logo.TokenParser -import Logo.Builtins -import Logo.Evaluator - -import System.Environment (getProgName, withArgs) - -import System.Console.CmdArgs.Implicit - -import qualified Data.Map as M - - -data LogoOpts = LogoOpts - { output :: String -- output file to write to - , src :: Maybe String -- source file to read from - } deriving (Show, Data, Typeable) - -logoOpts :: String -> LogoOpts -logoOpts prog = LogoOpts - { output = "logo.svg" - &= typFile - &= help "Output image file (default=logo.svg)" - , src = def - &= typFile - &= args - } - &= summary "hs-logo Logo Interpreter v0.1" - &= program prog - -main :: IO () -main = do - prog <- getProgName - opts <- cmdArgs (logoOpts prog) - case src opts of - Nothing -> error "Source file not specified" - Just s -> renderLogo s (output opts) - -renderLogo :: String -> String -> IO () -renderLogo s o = do - tokens <- readSource s - diag <- stroke <$> runTurtleT (evaluateSourceTokens tokens) - withArgs ["-o", o, "-w", "400", "-h", "400"] $ defaultMain (diag # lw (0.005 * width diag) # centerXY # pad 1.1) - -readSource :: FilePath -> IO [LogoToken] -readSource f = do - tokens <- tokenize f <$> readFile f - case tokens of - Left x -> error $ show x - Right t -> return t - -evaluateSourceTokens :: [LogoToken] -> TurtleIO () -evaluateSourceTokens tokens = do - let initialContext = LogoContext builtins M.empty M.empty - res <- evaluateWithContext tokens initialContext - case res of - Left err -> error $ show err - Right _ -> return () diff --git a/Logo/Builtins.hs b/Logo/Builtins.hs deleted file mode 100644 --- a/Logo/Builtins.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Logo.Builtins (builtins) where - -import qualified Data.Map as M - -import Logo.Types - -import Logo.Builtins.Control (controlBuiltins) -import Logo.Builtins.Arithmetic (arithmeticBuiltins) -import Logo.Builtins.Turtle (turtleBuiltins) -import Logo.Builtins.IO (ioBuiltins) - -builtins :: M.Map String LogoFunctionDef -builtins = foldl1 M.union $ - [ controlBuiltins - , arithmeticBuiltins - , turtleBuiltins - , ioBuiltins - ] diff --git a/Logo/Builtins/Arithmetic.hs b/Logo/Builtins/Arithmetic.hs deleted file mode 100644 --- a/Logo/Builtins/Arithmetic.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Logo.Builtins.Arithmetic (arithmeticBuiltins) where - -import qualified Data.Map as M - -import Logo.Types - -sin_, cos_, tan_, arctan, sqrt_ :: [LogoToken] -> LogoEvaluator LogoToken - -arithmeticBuiltins :: M.Map String LogoFunctionDef -arithmeticBuiltins = M.fromList - [ ("sin", LogoFunctionDef 1 sin_) - , ("cos", LogoFunctionDef 1 cos_) - , ("tan", LogoFunctionDef 1 tan_) - , ("arctan", LogoFunctionDef 1 arctan) - , ("sqrt", LogoFunctionDef 1 sqrt_) - ] - -sin_ [NumLiteral n] = return $ NumLiteral (sin $ fromDegrees n) -sin_ _ = error "Invalid arguments for sin" - -cos_ [NumLiteral n] = return $ NumLiteral (cos $ fromDegrees n) -cos_ _ = error "Invalid arguments for cos" - -tan_ [NumLiteral n] = return $ NumLiteral (tan $ fromDegrees n) -tan_ _ = error "Invalid arguments for cos" - -arctan [NumLiteral n] = return $ NumLiteral (atan $ fromDegrees n) -arctan _ = error "Invalid arguments for cos" - -fromDegrees :: Double -> Double -fromDegrees n = n * (pi/180) - -sqrt_ [NumLiteral n] = return . NumLiteral . sqrt $ n -sqrt_ _ = error "Invalid arguments to sqrt" diff --git a/Logo/Builtins/Control.hs b/Logo/Builtins/Control.hs deleted file mode 100644 --- a/Logo/Builtins/Control.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Logo.Builtins.Control (controlBuiltins) where - -import qualified Data.Map as M - -import Control.Applicative ((<$>)) - -import Text.Parsec.Prim (modifyState, many) -import Text.Parsec.Combinator (manyTill) - -import Logo.Types -import Logo.Evaluator - -repeat_, repcount, for, dotimes, to, if_, ifelse :: [LogoToken] -> LogoEvaluator LogoToken - -controlBuiltins :: M.Map String LogoFunctionDef -controlBuiltins = M.fromList - [ ("repeat", LogoFunctionDef 2 repeat_) - , ("repcount", LogoFunctionDef 0 repcount) - , ("for", LogoFunctionDef 2 for) - , ("dotimes", LogoFunctionDef 2 dotimes) - , ("to", LogoFunctionDef 0 to) - , ("if", LogoFunctionDef 2 if_) - , ("ifelse", LogoFunctionDef 3 ifelse) - ] - -repeat_ (NumLiteral n : (t@(LogoList _) : [])) = - repeatWithIterCount 1 - where - repeatWithIterCount x - | x > n = return $ StrLiteral "" - | otherwise = evaluateInLocalContext (M.fromList [("repcount", NumLiteral x)]) $ do - evaluateList t - repeatWithIterCount (x + 1) - -repeat_ _ = error "Invalid arguments for repeat" - -repcount [] = do - rc <- M.lookup "repcount" <$> getLocals - case rc of - Just c -> return c - Nothing -> error "repcount does not exist" - -repcount _ = error "Invalid call to repcount" - -for [ control@(LogoList _), instructionList@(LogoList _) ] = do - mapM_ loop forList - return $ StrLiteral "" - where LogoList [Identifier v, NumLiteral start, NumLiteral end, NumLiteral step] = control - forList = takeWhile withinBounds $ iterate (+ step) start - withinBounds x = if step < 0 then x >= end else x <= end - loop cur = evaluateInLocalContext (M.fromList [(v, NumLiteral cur)]) $ - evaluateList instructionList - -for _ = error "Invalid arguments for function 'for'" - -dotimes [ control@(LogoList _), instructionList@(LogoList _) ] = do - mapM_ loop forList - return $ StrLiteral "" - where LogoList [Identifier v, NumLiteral times] = control - forList = takeWhile (< times) $ iterate (+ 1) 0 - loop cur = evaluateInLocalContext (M.fromList [(v, NumLiteral cur)]) $ - evaluateList instructionList - -dotimes _ = error "Invalid arguments for dotimes" - -if_ [StrLiteral val, ifList] - | val == "TRUE" = evaluateList ifList - | val == "FALSE" = return $ StrLiteral "" - -if_ _ = undefined - -ifelse [StrLiteral val, ifList, elseList] - | val == "TRUE" = evaluateList ifList - | val == "FALSE" = evaluateList elseList - -ifelse _ = error "Invalid arguments for if" - -to [] = do - (Identifier name) <- anyLogoToken - args <- map fromVar <$> many (satisfy isVarLiteral) - tokens <- manyTill anyLogoToken (logoToken $ Identifier "end") - modifyState (addFunction name $ LogoFunctionDef (length args) (createLogoFunction args tokens)) - return $ StrLiteral "" - where - isVarLiteral (VarLiteral _) = True - isVarLiteral _ = False - - fromVar (VarLiteral s) = s - fromVar _ = undefined - - addFunction name fn ctx = ctx { functions = M.insert name fn (functions ctx) } - -to _ = undefined - -createLogoFunction :: [String] -> [LogoToken] -> LogoFunction -createLogoFunction vars_ tokens_ args = - evaluateInLocalContext (M.fromList $ zip vars_ args) $ - evaluateTokens tokens_ diff --git a/Logo/Builtins/IO.hs b/Logo/Builtins/IO.hs deleted file mode 100644 --- a/Logo/Builtins/IO.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Logo.Builtins.IO (ioBuiltins) where - -import qualified Data.Map as M - -import Control.Applicative ((<$>)) -import Control.Monad.Trans (lift, liftIO) - -import System.Random (randomIO) - -import Logo.Types - -turtleIO :: IO a -> LogoEvaluator a -turtleIO = lift . liftIO - -pr, random :: [LogoToken] -> LogoEvaluator LogoToken - -ioBuiltins :: M.Map String LogoFunctionDef -ioBuiltins = M.fromList - [ ("pr", LogoFunctionDef 1 pr) - , ("random", LogoFunctionDef 1 random) - ] - -pr [t] = turtleIO $ do - putStrLn (show t) - return $ StrLiteral "" - -pr _ = error "Invalid arguments to pr" - -random [NumLiteral n] = turtleIO $ (NumLiteral . fromIntegral . (round :: Double -> Integer) . (* n) <$> randomIO) - -random _ = error "Invalid arguments to random" diff --git a/Logo/Builtins/Turtle.hs b/Logo/Builtins/Turtle.hs deleted file mode 100644 --- a/Logo/Builtins/Turtle.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Logo.Builtins.Turtle (turtleBuiltins) where - -import qualified Data.Map as M - -import Control.Monad.Trans (lift) -import Diagrams.TwoD.Path.Turtle -import Diagrams.TwoD.Types (p2) - -import Logo.Types - -updateTurtle :: TurtleIO a -> LogoEvaluator a -updateTurtle = lift - -fd, bk, rt, lt, home, setxy, seth, pu, pd :: [LogoToken] -> LogoEvaluator LogoToken - -turtleBuiltins :: M.Map String LogoFunctionDef -turtleBuiltins = M.fromList - [ ("fd", LogoFunctionDef 1 fd) - , ("bk", LogoFunctionDef 1 bk) - , ("rt", LogoFunctionDef 1 rt) - , ("lt", LogoFunctionDef 1 lt) - , ("home", LogoFunctionDef 0 home) - , ("setxy", LogoFunctionDef 2 setxy) - , ("seth", LogoFunctionDef 1 seth) - , ("pu", LogoFunctionDef 0 pu) - , ("pd", LogoFunctionDef 0 pd) - ] - -fd (NumLiteral d : []) = do - updateTurtle (forward d) - return $ StrLiteral "" - -fd args = error $ "Invalid arguments to fd" ++ show args - -bk (NumLiteral d : []) = do - updateTurtle (backward d) - return $ StrLiteral "" - -bk _ = error "Invalid arguments to fd" - -rt (NumLiteral a : []) = do - updateTurtle (right a) - return $ StrLiteral "" - -rt _ = error "Invalid arguments to rt" - -lt (NumLiteral a : []) = do - updateTurtle (left a) - return $ StrLiteral "" - -lt _ = error "Invalid arguments to lt" - -home [] = do - updateTurtle (setPos (p2 (0,0))) - return $ StrLiteral "" - -home _ = error "Invalid arguments to home" - -setxy [NumLiteral x, NumLiteral y] = do - updateTurtle (setPos (p2 (x,y))) - return $ StrLiteral "" - -setxy _ = error "Invalid arguments to setxy" - -seth [NumLiteral n] = do - updateTurtle (setHeading n) - return $ StrLiteral "" - -seth _ = error "Invalid arguments to seth" - -pu [] = do - updateTurtle penUp - return $ StrLiteral "" - -pu _ = error "Invalid arguments to pu" - -pd [] = do - updateTurtle penDown - return $ StrLiteral "" - -pd _ = error "Invalid arguments to pd" diff --git a/Logo/Evaluator.hs b/Logo/Evaluator.hs deleted file mode 100644 --- a/Logo/Evaluator.hs +++ /dev/null @@ -1,158 +0,0 @@ -module Logo.Evaluator where - -import Logo.Types - -import qualified Data.Map as M - -import Control.Monad (replicateM) -import Control.Applicative ((<$>), (<|>)) -import Control.Arrow ((&&&), (***)) -import Control.Monad.Trans (lift) - -import Text.Parsec.Prim (runParserT, tokenPrim, getState, putState, modifyState) -import Text.Parsec.Combinator (many1, choice, chainl1) -import Text.Parsec.Error (ParseError) - --- ---------------------------------------------------------------------- - --- Expression Evaluation - --- ---------------------------------------------------------------------- - --- Expression := RelationalExpression --- RelationalExpression := AdditiveExpression [ ( '=' | '<' | '>' | '<=' | '>=' | '<>' ) AdditiveExpression ... ] --- AdditiveExpression := MultiplicativeExpression [ ( '+' | '-' ) MultiplicativeExpression ... ] --- MultiplicativeExpression := PowerExpression [ ( '*' | '/' | '%' ) PowerExpression ... ] --- PowerExpression := UnaryExpression [ '^' UnaryExpression ] --- UnaryExpression := ( '-' ) UnaryExpression --- | FinalExpression --- FinalExpression := string-literal --- | number-literal --- | list --- | variable-reference --- | procedure-call --- | '(' Expression ')' - -evaluateWithContext :: [LogoToken] -> LogoContext -> TurtleIO (Either ParseError ([LogoToken], LogoContext)) -evaluateWithContext tokens ctx = runParserT expression ctx "(stream)" tokens - -evaluateTokens :: [LogoToken] -> LogoEvaluator LogoToken -evaluateTokens [] = return $ StrLiteral "" -evaluateTokens tokens = do - ctx <- getState - - (t,s) <- lift $ do - res <- evaluateWithContext tokens ctx - case res of - Left e -> error $ show e - Right r -> return r - putState s - return $ LogoList t - -evaluateList :: LogoToken -> LogoEvaluator LogoToken -evaluateList (LogoList l) = evaluateTokens l -evaluateList _ = undefined - -satisfy :: (LogoToken -> Bool) -> LogoEvaluator LogoToken -satisfy f = - tokenPrim (\c -> show [c]) - (\pos _ _ -> pos) - (\c -> if f c then Just c else Nothing) - -logoToken :: LogoToken -> LogoEvaluator LogoToken -logoToken x = satisfy (==x) - -anyLogoToken :: LogoEvaluator LogoToken -anyLogoToken = satisfy (const True) - -expression :: LogoEvaluator ([LogoToken], LogoContext) -expression = do - t <- many1 relationalExpression - s <- getState - return (t,s) - -relationalExpression :: LogoEvaluator LogoToken -relationalExpression = parseWithOperators ["<", ">", "=", "<=", ">=", "<>"] additiveExpression - -additiveExpression :: LogoEvaluator LogoToken -additiveExpression = parseWithOperators ["+", "-"] multiplicativeExpression - -multiplicativeExpression :: LogoEvaluator LogoToken -multiplicativeExpression = parseWithOperators ["*", "/", "%"] powerExpression - -powerExpression :: LogoEvaluator LogoToken -powerExpression = parseWithOperators ["^"] finalExpression - -finalExpression :: LogoEvaluator LogoToken -finalExpression = do - token <- anyLogoToken - case token of - Identifier s -> dispatchFn s - VarLiteral v -> lookupVar v - LogoExpr e -> do LogoList res <- evaluateTokens e - return $ head res - _ -> return token - -parseWithOperators :: [String] -> LogoEvaluator LogoToken -> LogoEvaluator LogoToken -parseWithOperators operators parser = parser `chainl1` func - where - func = do op <- choice $ map (logoToken . OperLiteral) operators - return $ eval op - -eval :: LogoToken -> LogoToken -> LogoToken -> LogoToken - --- Arithmetic -eval (OperLiteral "+") (NumLiteral l) (NumLiteral r) = NumLiteral (l + r) -eval (OperLiteral "-") (NumLiteral l) (NumLiteral r) = NumLiteral (l - r) -eval (OperLiteral "*") (NumLiteral l) (NumLiteral r) = NumLiteral (l * r) -eval (OperLiteral "/") (NumLiteral l) (NumLiteral r) = NumLiteral (l / r) -eval (OperLiteral "%") (NumLiteral l) (NumLiteral r) = NumLiteral $ fromIntegral ((truncate l `rem` truncate r) :: Integer ) -eval (OperLiteral "^") (NumLiteral l) (NumLiteral r) = NumLiteral (l ** r) - --- Logical -eval (OperLiteral "<") (NumLiteral l) (NumLiteral r) = StrLiteral (if l < r then "TRUE" else "FALSE") -eval (OperLiteral ">") (NumLiteral l) (NumLiteral r) = StrLiteral (if l > r then "TRUE" else "FALSE") -eval (OperLiteral "=") (NumLiteral l) (NumLiteral r) = StrLiteral (if l == r then "TRUE" else "FALSE") -eval (OperLiteral "<>") (NumLiteral l) (NumLiteral r) = StrLiteral (if l /= r then "TRUE" else "FALSE") -eval (OperLiteral "<=") (NumLiteral l) (NumLiteral r) = StrLiteral (if l <= r then "TRUE" else "FALSE") -eval (OperLiteral ">=") (NumLiteral l) (NumLiteral r) = StrLiteral (if l >= r then "TRUE" else "FALSE") - --- Undefined -eval op a b = error $ "Evaluation undefined for " ++ show [op, a, b] - -setLocals :: LogoSymbolTable -> LogoEvaluator () -setLocals l = modifyState $ \s -> s { locals = l } - -getLocals :: LogoEvaluator LogoSymbolTable -getLocals = locals <$> getState - -evaluateInLocalContext :: LogoSymbolTable -> LogoEvaluator a -> LogoEvaluator a -evaluateInLocalContext localVars computation = do - old <- getLocals - setLocals $ localVars `M.union` old - res <- computation - setLocals old - return res - -lookupVar :: String -> LogoEvaluator LogoToken -lookupVar v = do - (l,g) <- (M.lookup v *** M.lookup v) . (locals &&& globals) <$> getState - case l <|> g of - Just x -> return x - _ -> error $ "variable " ++ v ++ " not in scope" - -dispatchFn :: String -> LogoEvaluator LogoToken -dispatchFn fn = do - -- get function definition - ctx <- getState - let fns = functions ctx - f = case M.lookup fn fns of - Just x -> x - _ -> error ("Function undefined: " ++ fn) - -- find arity - let (LogoFunctionDef a func) = f - -- get number of tokens - -- FIXME evaludate the token before getting a list of expressions - arguments <- replicateM a relationalExpression - -- call function and update context - func arguments diff --git a/Logo/TokenParser.hs b/Logo/TokenParser.hs deleted file mode 100644 --- a/Logo/TokenParser.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Logo.TokenParser (tokenize) where - -import Logo.Types - -import Control.Applicative ((<|>), (<$>), many) - -import Text.ParserCombinators.Parsec ( - char, letter, digit, alphaNum, string, space, - parse, many1, skipMany, notFollowedBy, noneOf, try, (), eof, - ParseError, Parser) - -import Text.ParserCombinators.Parsec.Number (natFloat, sign) - -tokenize :: String -> String -> Either ParseError [LogoToken] -tokenize progName = parse logo progName - -logo :: Parser [LogoToken] -logo = do - skipMany space - expressions <- many1 logoExpr - skipMany space - eof - return $ concat expressions - -logoExpr :: Parser [LogoToken] -logoExpr = try comment - <|> try list - <|> try binaryExpr - <|> try parenExpr - <|> try word - "Logo Expression" - -comment :: Parser [LogoToken] -comment = do - skipMany space - string ";" - skipMany $ noneOf "\n" - skipMany space - return [] - -word :: Parser [LogoToken] -word = try identifier - <|> try stringLiteral - <|> try varLiteral - <|> try numLiteral - "Logo terminal" - -identifier :: Parser [LogoToken] -identifier = do - skipMany space - s <- letter - i <- many alphaNum - return . return $ (Identifier (s:i)) - --- FIXME support escaping -stringLiteral :: Parser [LogoToken] -stringLiteral = do - skipMany space - char '"' - s <- many1 $ noneOf "\t\n []()\"" - return . return $ StrLiteral s - -varLiteral :: Parser [LogoToken] -varLiteral = do - skipMany space - char ':' - s <- letter - v <- many alphaNum - return . return $ VarLiteral (s:v) - -numLiteral :: Parser [LogoToken] -numLiteral = do - skipMany space - s <- sign - n <- natFloat - return . return . NumLiteral . s $ case n of - Left i -> fromInteger i - Right f -> f - -operExpr :: Parser [LogoToken] -operExpr = try parenExpr - <|> try word - -binaryExpr :: Parser [LogoToken] -binaryExpr = do - lhs <- operExpr - op <- operLiteral - rhs <- try binaryExpr <|> operExpr - return . concat $ [lhs, op, rhs] - -operLiteral :: Parser [LogoToken] -operLiteral = do - s <- many space - (return . OperLiteral) <$> - ( string "+" - <|> if (length s) == 0 then (string "-") else ((string "-") >> notFollowedBy digit >> (return "-")) - <|> string "*" - <|> string "/" - <|> string "%" - <|> string "^" - <|> try (string ">=") - <|> try (string "<=") - <|> try (string "<>") - <|> string "=" - <|> string "<" - <|> string ">" ) - -list :: Parser [LogoToken] -list = do - skipMany space - char '[' - expr <- many logoExpr - skipMany space - char ']' - return . return $ LogoList (concat expr) - -parenExpr :: Parser [LogoToken] -parenExpr = do - skipMany space - char '(' - skipMany space - expr <- many logoExpr - skipMany space - char ')' - return . return $ LogoExpr (concat expr) diff --git a/Logo/Types.hs b/Logo/Types.hs deleted file mode 100644 --- a/Logo/Types.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Logo.Types where - -import Data.Map (Map) -import Text.Parsec.Prim (ParsecT) -import Diagrams.TwoD.Path.Turtle (TurtleT) - -data LogoToken = Identifier String -- Identifier - | StrLiteral String -- String Literal, e.g @"word@ - | VarLiteral String -- Variable, e.g @:size@ - | NumLiteral Double -- Number - | OperLiteral String -- Operator - | LogoList [LogoToken] -- Input definition/variable reference - | LogoExpr [LogoToken] -- Expression inside parentheses - deriving (Eq) - -instance Show LogoToken where - show (Identifier s) = "@" ++ s ++ "@" - show (StrLiteral s) = s - show (VarLiteral s) = ":" ++ s - show (NumLiteral s) = show s - show (OperLiteral s) = s - show (LogoList l) = show l - show (LogoExpr e) = "(" ++ show e ++ ")" - -type TurtleIO = TurtleT IO - -type LogoEvaluator = ParsecT [LogoToken] LogoContext TurtleIO - -type LogoFunction = [LogoToken] -> LogoEvaluator LogoToken - -type LogoSymbolTable = Map String LogoToken - -data LogoFunctionDef = LogoFunctionDef - { arity :: Int -- Number of arguments - , runFn :: LogoFunction -- Consumes an argument - } deriving Show - -data LogoContext = LogoContext - { functions :: Map String LogoFunctionDef -- Functions that can be called, mapped by the identifier - , locals :: LogoSymbolTable -- Vars in local context - , globals :: LogoSymbolTable -- Vars in global context - } deriving Show - - - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +[![Build Status](https://secure.travis-ci.org/deepakjois/hs-logo.png)](http://travis-ci.org/deepakjois/hs-logo) + Logo interpreter written in Haskell, specialized for turtle graphics. Still very much a WIP. Lot of the language still needs to be implemented, but it is fairly functional already. diff --git a/hs-logo.cabal b/hs-logo.cabal --- a/hs-logo.cabal +++ b/hs-logo.cabal @@ -1,5 +1,5 @@ Name: hs-logo -Version: 0.4 +Version: 0.5 Synopsis: Logo turtle graphics interpreter Description: Interpreter for the Logo programming language, specialised for turtle graphics. @@ -12,16 +12,12 @@ Synopsis: Logo interpreter written in Haskell Category: Parser -Cabal-Version: >=1.6 +Cabal-Version: >=1.8 Data-Files: README.md -Source-Repository head - type: git - location: https://github.com/deepakjois/hs-logo - Executable hs-logo Ghc-Options: -Wall -fno-warn-unused-do-bind - Hs-Source-Dirs: . + Hs-Source-Dirs: src Main-Is: Logo.hs Other-Modules: Logo.Types Logo.TokenParser @@ -31,14 +27,47 @@ Logo.Builtins.Turtle Logo.Builtins.Arithmetic Logo.Builtins.Control - Build-Depends: base >= 4.2 && < 4.6, + Diagrams.TwoD.Path.Turtle + Build-Depends: base >= 4.2 && < 4.6, containers >= 0.3 && < 0.5, mtl >= 1 && < 3.0, parsec >= 3.0 && < 3.2, cmdargs >= 0.6 && <= 0.9, random >= 1.0, parsec-numbers, - diagrams-core >= 0.5 && < 0.6, - diagrams-lib >= 0.5 && < 0.6, - diagrams-contrib >= 0.1 && < 0.2, - diagrams-svg >= 0.3 && < 0.4 + colour, + diagrams-core >= 0.5 && < 0.6, + diagrams-lib >= 0.5 && < 0.6, + diagrams-svg >= 0.3.3 && < 0.4 + +Test-suite turtle-tests + Type: exitcode-stdio-1.0 + Hs-source-dirs: src tests + Main-is: TestSuite.hs + Ghc-options: -Wall + + Other-modules: Diagrams.TwoD.Path.Turtle.Tests + + Build-depends: + HUnit >= 1.2 && < 1.3, + QuickCheck >= 2.4 && < 2.5, + containers >= 0.3 && < 0.5, + test-framework >= 0.4 && < 0.7, + test-framework-hunit >= 0.2 && < 0.3, + test-framework-quickcheck2 >= 0.2 && < 0.3, + -- Copied from regular dependencies + base >= 4.2 && < 4.6, + containers >= 0.3 && < 0.5, + mtl >= 1 && < 3.0, + parsec >= 3.0 && < 3.2, + cmdargs >= 0.6 && <= 0.9, + random >= 1.0, + parsec-numbers, + colour, + diagrams-core >= 0.5 && < 0.6, + diagrams-lib >= 0.5 && < 0.6, + diagrams-svg >= 0.3.3 && < 0.4 + +Source-Repository head + type: git + location: https://github.com/deepakjois/hs-logo diff --git a/src/Diagrams/TwoD/Path/Turtle.hs b/src/Diagrams/TwoD/Path/Turtle.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Path/Turtle.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Path.Turtle +-- Copyright : (c) 2011 Michael Sloan +-- License : BSD-style (see LICENSE) +-- Maintainer : Michael Sloan +-- +-- Stateful domain specific language for diagram paths, modelled after the +-- classic \"turtle\" graphics language. +-- +----------------------------------------------------------------------------- +module Diagrams.TwoD.Path.Turtle + ( Turtle, TurtleT + + -- * Turtle control commands + , runTurtle, runTurtleT + + -- * Motion commands + , forward, backward, left, right + + -- * State accessors / setters + , heading, setHeading, towards + , pos, setPos, setPenWidth, setPenColor + + -- * Drawing control + , penUp, penDown, isDown + ) where + +import qualified Control.Monad.State as ST +import Control.Monad.Identity (Identity(..)) + +import Data.Colour(Colour) +import Diagrams.Prelude +import qualified Diagrams.TwoD.Path.Turtle.Internal as T + + +type TurtleT = ST.StateT T.Turtle + +type Turtle = TurtleT Identity + +-- | A more general way to run the turtle. Returns a computation in the +-- underlying monad @m@ yielding a path consisting of the traced trails +runTurtleT :: (Monad m, Functor m, (Renderable (Path R2) b)) => TurtleT m a -> m (Diagram b R2) +runTurtleT t = T.getTurtleDiagram . snd + <$> ST.runStateT t T.startTurtle + +-- | Run the turtle, yielding a path consisting of the traced trails. +runTurtle :: (Renderable (Path R2) b) => Turtle a -> Diagram b R2 +runTurtle = runIdentity . runTurtleT + +-- Motion commands + +-- | Move the turtle forward, along the current heading. +forward :: Monad m => Double -> TurtleT m () +forward x = ST.modify $ T.forward x + +-- | Move the turtle backward, directly away from the current heading. +backward :: Monad m => Double -> TurtleT m () +backward x = ST.modify $ T.backward x + +-- | Modify the current heading to the left by the specified angle in degrees. +left :: Monad m => Double -> TurtleT m () +left d = ST.modify $ T.left d + +-- | Modify the current heading to the right by the specified angle in degrees. +right :: Monad m => Double -> TurtleT m () +right d = ST.modify $ T.right d + +-- State accessors / setters + +-- | Set the current turtle angle, in degrees. +setHeading :: Monad m => Double -> TurtleT m () +setHeading d = ST.modify $ T.setHeading d + +-- | Get the current turtle angle, in degrees. +heading :: Monad m => TurtleT m Double +heading = ST.gets ((\(Deg x) -> x) . T.heading) + +-- | Sets the heading towards a given location. +towards :: Monad m => P2 -> TurtleT m () +towards pt = ST.modify $ T.towards pt + +-- | Set the current turtle X/Y position. +setPos :: Monad m => P2 -> TurtleT m () +setPos p = ST.modify $ T.setPenPos p + +-- | Get the current turtle X/Y position. +pos :: Monad m => TurtleT m P2 +pos = ST.gets T.penPos + +-- Drawing control. + +-- | Ends the current path, and enters into "penUp" mode +penUp :: Monad m => TurtleT m () +penUp = ST.modify T.penUp + +-- | Ends the current path, and enters into "penDown" mode +penDown :: Monad m => TurtleT m () +penDown = ST.modify T.penDown + +-- | Queries whether the pen is currently drawing a path or not. +isDown :: Monad m => TurtleT m Bool +isDown = ST.gets T.isPenDown + +-- | Sets the pen color +setPenColor :: Monad m => Colour Double -> TurtleT m () +setPenColor c = ST.modify $ T.setPenColor c + +-- | Sets the pen size +setPenWidth :: Monad m => Double -> TurtleT m () +setPenWidth s = ST.modify $ T.setPenWidth s diff --git a/src/Logo.hs b/src/Logo.hs new file mode 100644 --- /dev/null +++ b/src/Logo.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Main where + +import Diagrams.Prelude +import Diagrams.Backend.SVG.CmdLine +import Diagrams.TwoD.Path.Turtle + +import Logo.Types +import Logo.TokenParser +import Logo.Builtins +import Logo.Evaluator + +import System.Environment (getProgName, withArgs) + +import System.Console.CmdArgs.Implicit + +import qualified Data.Map as M + + +data LogoOpts = LogoOpts + { output :: String -- output file to write to + , src :: Maybe String -- source file to read from + } deriving (Show, Data, Typeable) + +logoOpts :: String -> LogoOpts +logoOpts prog = LogoOpts + { output = "logo.svg" + &= typFile + &= help "Output image file (default=logo.svg)" + , src = def + &= typFile + &= args + } + &= summary "hs-logo Logo Interpreter v0.1" + &= program prog + +main :: IO () +main = do + prog <- getProgName + opts <- cmdArgs (logoOpts prog) + case src opts of + Nothing -> error "Source file not specified" + Just s -> renderLogo s (output opts) + +renderLogo :: String -> String -> IO () +renderLogo s o = do + tokens <- readSource s + diag <- runTurtleT (evaluateSourceTokens tokens) + withArgs ["-o", o, "-w", "400", "-h", "400"] $ defaultMain (diag # lw (0.005 * width diag) # centerXY # pad 1.1) + +readSource :: FilePath -> IO [LogoToken] +readSource f = do + tokens <- tokenize f <$> readFile f + case tokens of + Left x -> error $ show x + Right t -> return t + +evaluateSourceTokens :: [LogoToken] -> TurtleIO () +evaluateSourceTokens tokens = do + let initialContext = LogoContext builtins M.empty M.empty + res <- evaluateWithContext tokens initialContext + case res of + Left err -> error $ show err + Right _ -> return () diff --git a/src/Logo/Builtins.hs b/src/Logo/Builtins.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Builtins.hs @@ -0,0 +1,18 @@ +module Logo.Builtins (builtins) where + +import qualified Data.Map as M + +import Logo.Types + +import Logo.Builtins.Control (controlBuiltins) +import Logo.Builtins.Arithmetic (arithmeticBuiltins) +import Logo.Builtins.Turtle (turtleBuiltins) +import Logo.Builtins.IO (ioBuiltins) + +builtins :: M.Map String LogoFunctionDef +builtins = foldl1 M.union $ + [ controlBuiltins + , arithmeticBuiltins + , turtleBuiltins + , ioBuiltins + ] diff --git a/src/Logo/Builtins/Arithmetic.hs b/src/Logo/Builtins/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Builtins/Arithmetic.hs @@ -0,0 +1,34 @@ +module Logo.Builtins.Arithmetic (arithmeticBuiltins) where + +import qualified Data.Map as M + +import Logo.Types + +sin_, cos_, tan_, arctan, sqrt_ :: [LogoToken] -> LogoEvaluator LogoToken + +arithmeticBuiltins :: M.Map String LogoFunctionDef +arithmeticBuiltins = M.fromList + [ ("sin", LogoFunctionDef 1 sin_) + , ("cos", LogoFunctionDef 1 cos_) + , ("tan", LogoFunctionDef 1 tan_) + , ("arctan", LogoFunctionDef 1 arctan) + , ("sqrt", LogoFunctionDef 1 sqrt_) + ] + +sin_ [NumLiteral n] = return $ NumLiteral (sin $ fromDegrees n) +sin_ _ = error "Invalid arguments for sin" + +cos_ [NumLiteral n] = return $ NumLiteral (cos $ fromDegrees n) +cos_ _ = error "Invalid arguments for cos" + +tan_ [NumLiteral n] = return $ NumLiteral (tan $ fromDegrees n) +tan_ _ = error "Invalid arguments for cos" + +arctan [NumLiteral n] = return $ NumLiteral (atan $ fromDegrees n) +arctan _ = error "Invalid arguments for cos" + +fromDegrees :: Double -> Double +fromDegrees n = n * (pi/180) + +sqrt_ [NumLiteral n] = return . NumLiteral . sqrt $ n +sqrt_ _ = error "Invalid arguments to sqrt" diff --git a/src/Logo/Builtins/Control.hs b/src/Logo/Builtins/Control.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Builtins/Control.hs @@ -0,0 +1,98 @@ +module Logo.Builtins.Control (controlBuiltins) where + +import qualified Data.Map as M + +import Control.Applicative ((<$>)) + +import Text.Parsec.Prim (modifyState, many) +import Text.Parsec.Combinator (manyTill) + +import Logo.Types +import Logo.Evaluator + +repeat_, repcount, for, dotimes, to, if_, ifelse :: [LogoToken] -> LogoEvaluator LogoToken + +controlBuiltins :: M.Map String LogoFunctionDef +controlBuiltins = M.fromList + [ ("repeat", LogoFunctionDef 2 repeat_) + , ("repcount", LogoFunctionDef 0 repcount) + , ("for", LogoFunctionDef 2 for) + , ("dotimes", LogoFunctionDef 2 dotimes) + , ("to", LogoFunctionDef 0 to) + , ("if", LogoFunctionDef 2 if_) + , ("ifelse", LogoFunctionDef 3 ifelse) + ] + +repeat_ (NumLiteral n : (t@(LogoList _) : [])) = + repeatWithIterCount 1 + where + repeatWithIterCount x + | x > n = return $ StrLiteral "" + | otherwise = evaluateInLocalContext (M.fromList [("repcount", NumLiteral x)]) $ do + evalList t + repeatWithIterCount (x + 1) + +repeat_ _ = error "Invalid arguments for repeat" + +repcount [] = do + rc <- M.lookup "repcount" <$> getLocals + case rc of + Just c -> return c + Nothing -> error "repcount does not exist" + +repcount _ = error "Invalid call to repcount" + +for [ control@(LogoList _), instructionList@(LogoList _) ] = do + mapM_ loop forList + return $ StrLiteral "" + where LogoList [Identifier v, NumLiteral start, NumLiteral end, NumLiteral step] = control + forList = takeWhile withinBounds $ iterate (+ step) start + withinBounds x = if step < 0 then x >= end else x <= end + loop cur = evaluateInLocalContext (M.fromList [(v, NumLiteral cur)]) $ + evalList instructionList + +for _ = error "Invalid arguments for function 'for'" + +dotimes [ control@(LogoList _), instructionList@(LogoList _) ] = do + mapM_ loop forList + return $ StrLiteral "" + where LogoList [Identifier v, NumLiteral times] = control + forList = takeWhile (< times) $ iterate (+ 1) 0 + loop cur = evaluateInLocalContext (M.fromList [(v, NumLiteral cur)]) $ + evalList instructionList + +dotimes _ = error "Invalid arguments for dotimes" + +if_ [StrLiteral val, ifList] + | val == "TRUE" = evalList ifList + | val == "FALSE" = return $ StrLiteral "" + +if_ _ = undefined + +ifelse [StrLiteral val, ifList, elseList] + | val == "TRUE" = evalList ifList + | val == "FALSE" = evalList elseList + +ifelse _ = error "Invalid arguments for if" + +to [] = do + (Identifier name) <- anyLogoToken + args <- map fromVar <$> many (satisfy isVarLiteral) + tokens <- manyTill anyLogoToken (logoToken $ Identifier "end") + modifyState (addFunction name $ LogoFunctionDef (length args) (createLogoFunction args tokens)) + return $ StrLiteral "" + where + isVarLiteral (VarLiteral _) = True + isVarLiteral _ = False + + fromVar (VarLiteral s) = s + fromVar _ = undefined + + addFunction name fn ctx = ctx { functions = M.insert name fn (functions ctx) } + +to _ = undefined + +createLogoFunction :: [String] -> [LogoToken] -> LogoFunction +createLogoFunction vars_ tokens_ args = + evaluateInLocalContext (M.fromList $ zip vars_ args) $ + evaluateTokens tokens_ diff --git a/src/Logo/Builtins/IO.hs b/src/Logo/Builtins/IO.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Builtins/IO.hs @@ -0,0 +1,31 @@ +module Logo.Builtins.IO (ioBuiltins) where + +import qualified Data.Map as M + +import Control.Applicative ((<$>)) +import Control.Monad.Trans (lift, liftIO) + +import System.Random (randomIO) + +import Logo.Types + +turtleIO :: IO a -> LogoEvaluator a +turtleIO = lift . liftIO + +pr, random :: [LogoToken] -> LogoEvaluator LogoToken + +ioBuiltins :: M.Map String LogoFunctionDef +ioBuiltins = M.fromList + [ ("pr", LogoFunctionDef 1 pr) + , ("random", LogoFunctionDef 1 random) + ] + +pr [t] = turtleIO $ do + putStrLn (show t) + return $ StrLiteral "" + +pr _ = error "Invalid arguments to pr" + +random [NumLiteral n] = turtleIO $ (NumLiteral . fromIntegral . (round :: Double -> Integer) . (* n) <$> randomIO) + +random _ = error "Invalid arguments to random" diff --git a/src/Logo/Builtins/Turtle.hs b/src/Logo/Builtins/Turtle.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Builtins/Turtle.hs @@ -0,0 +1,117 @@ +module Logo.Builtins.Turtle (turtleBuiltins) where + +import Prelude hiding (tan) +import qualified Data.Map as M + +import Control.Monad.Trans (lift) +import Diagrams.TwoD.Path.Turtle +import Diagrams.TwoD.Types (p2) +import Data.Colour (Colour) +import Data.Colour.Names + +import Logo.Types + +updateTurtle :: TurtleIO a -> LogoEvaluator a +updateTurtle = lift + +fd, bk, rt, lt, home, setxy, seth, pu, pd, setpensize, setpencolor :: [LogoToken] -> LogoEvaluator LogoToken + +turtleBuiltins :: M.Map String LogoFunctionDef +turtleBuiltins = M.fromList + [ ("fd", LogoFunctionDef 1 fd) + , ("bk", LogoFunctionDef 1 bk) + , ("rt", LogoFunctionDef 1 rt) + , ("lt", LogoFunctionDef 1 lt) + , ("home", LogoFunctionDef 0 home) + , ("setxy", LogoFunctionDef 2 setxy) + , ("seth", LogoFunctionDef 1 seth) + , ("pu", LogoFunctionDef 0 pu) + , ("pd", LogoFunctionDef 0 pd) + , ("setpensize", LogoFunctionDef 1 setpensize) + , ("setpencolor", LogoFunctionDef 1 setpencolor) + ] + +fd (NumLiteral d : []) = do + updateTurtle (forward d) + return $ StrLiteral "" + +fd args = error $ "Invalid arguments to fd" ++ show args + +bk (NumLiteral d : []) = do + updateTurtle (backward d) + return $ StrLiteral "" + +bk _ = error "Invalid arguments to fd" + +rt (NumLiteral a : []) = do + updateTurtle (right a) + return $ StrLiteral "" + +rt _ = error "Invalid arguments to rt" + +lt (NumLiteral a : []) = do + updateTurtle (left a) + return $ StrLiteral "" + +lt _ = error "Invalid arguments to lt" + +home [] = do + updateTurtle (setPos (p2 (0,0))) + return $ StrLiteral "" + +home _ = error "Invalid arguments to home" + +setxy [NumLiteral x, NumLiteral y] = do + updateTurtle (setPos (p2 (x,y))) + return $ StrLiteral "" + +setxy _ = error "Invalid arguments to setxy" + +seth [NumLiteral n] = do + updateTurtle (setHeading n) + return $ StrLiteral "" + +seth _ = error "Invalid arguments to seth" + +pu [] = do + updateTurtle penUp + return $ StrLiteral "" + +pu _ = error "Invalid arguments to pu" + +pd [] = do + updateTurtle penDown + return $ StrLiteral "" + +pd _ = error "Invalid arguments to pd" + +setpensize [NumLiteral d] = do + updateTurtle (setPenWidth d) + return $ StrLiteral "" + +setpensize _ = error "Invalid arguments to setpensize" + +setpencolor [NumLiteral d] = do + updateTurtle (setPenColor (numToColor . round $ d)) + return $ StrLiteral "" + where + numToColor :: Int -> Colour Double + numToColor 0 = black + numToColor 1 = blue + numToColor 2 = green + numToColor 3 = cyan + numToColor 4 = red + numToColor 5 = magenta + numToColor 6 = yellow + numToColor 7 = white + numToColor 8 = brown + numToColor 9 = tan + numToColor 10 = forestgreen + numToColor 11 = aqua + numToColor 12 = salmon + numToColor 13 = purple + numToColor 14 = orange + numToColor 15 = grey + numToColor _ = error "Color values greater than 15 are not supported" + +setpencolor _ = error "Invalid arguments to setpencolor" diff --git a/src/Logo/Evaluator.hs b/src/Logo/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Evaluator.hs @@ -0,0 +1,167 @@ +module Logo.Evaluator where + +import Logo.Types + +import qualified Data.Map as M + +import Control.Monad (replicateM) +import Control.Applicative ((<$>), (<|>)) +import Control.Arrow ((&&&), (***)) +import Control.Monad.Trans (lift) + +import Text.Parsec.Prim (runParserT, tokenPrim, getState, putState, modifyState) +import Text.Parsec.Combinator (many1, choice, chainl1) +import Text.Parsec.Error (ParseError) + +-- ---------------------------------------------------------------------- + +-- Expression Evaluation + +-- ---------------------------------------------------------------------- + +-- Expression := RelationalExpression +-- RelationalExpression := AdditiveExpression [ ( '=' | '<' | '>' | '<=' | '>=' | '<>' ) AdditiveExpression ... ] +-- AdditiveExpression := MultiplicativeExpression [ ( '+' | '-' ) MultiplicativeExpression ... ] +-- MultiplicativeExpression := PowerExpression [ ( '*' | '/' | '%' ) PowerExpression ... ] +-- PowerExpression := UnaryExpression [ '^' UnaryExpression ] +-- UnaryExpression := ( '-' ) UnaryExpression +-- | FinalExpression +-- FinalExpression := string-literal +-- | number-literal +-- | list +-- | variable-reference +-- | procedure-call +-- | '(' Expression ')' + +evaluateWithContext :: [LogoToken] -> LogoContext -> TurtleIO (Either ParseError ([LogoToken], LogoContext)) +evaluateWithContext tokens ctx = runParserT expression ctx "(stream)" tokens + +evaluateTokens :: [LogoToken] -> LogoEvaluator LogoToken +evaluateTokens [] = return $ StrLiteral "" +evaluateTokens tokens = do + ctx <- getState + + (t,s) <- lift $ do + res <- evaluateWithContext tokens ctx + case res of + Left e -> error $ show e + Right r -> return r + putState s + return $ LogoList t + +satisfy :: (LogoToken -> Bool) -> LogoEvaluator LogoToken +satisfy f = + tokenPrim (\c -> show [c]) + (\pos _ _ -> pos) + (\c -> if f c then Just c else Nothing) + +logoToken :: LogoToken -> LogoEvaluator LogoToken +logoToken x = satisfy (==x) + +anyLogoToken :: LogoEvaluator LogoToken +anyLogoToken = satisfy (const True) + +expression :: LogoEvaluator ([LogoToken], LogoContext) +expression = do + t <- many1 relationalExpression + s <- getState + return (t,s) + +relationalExpression :: LogoEvaluator LogoToken +relationalExpression = parseWithOperators ["<", ">", "=", "<=", ">=", "<>"] additiveExpression + +additiveExpression :: LogoEvaluator LogoToken +additiveExpression = parseWithOperators ["+", "-"] multiplicativeExpression + +multiplicativeExpression :: LogoEvaluator LogoToken +multiplicativeExpression = parseWithOperators ["*", "/", "%"] powerExpression + +powerExpression :: LogoEvaluator LogoToken +powerExpression = parseWithOperators ["^"] finalExpression + +finalExpression :: LogoEvaluator LogoToken +finalExpression = anyLogoToken >>= evalFinal + +evalFinal, evalList, eval :: LogoToken -> LogoEvaluator LogoToken + +evalFinal (Identifier s) = dispatchFn s + +evalFinal (VarLiteral v) = lookupVar v + +evalFinal (LogoExpr e) = do + LogoList res <- evaluateTokens e + return $ head res + +evalFinal token = return token + +evalList (LogoList l) = evaluateTokens l +evalList _ = undefined + +-- Forces evaluation of a token, even if it is a list +eval token = case token of + LogoList _ -> evalList token + _ -> evalFinal token + +parseWithOperators :: [String] -> LogoEvaluator LogoToken -> LogoEvaluator LogoToken +parseWithOperators operators parser = parser `chainl1` func + where + func = do op <- choice $ map (logoToken . OperLiteral) operators + return $ evalBinOp op + +evalBinOp :: LogoToken -> LogoToken -> LogoToken -> LogoToken + +-- Arithmetic +evalBinOp (OperLiteral "+") (NumLiteral l) (NumLiteral r) = NumLiteral (l + r) +evalBinOp (OperLiteral "-") (NumLiteral l) (NumLiteral r) = NumLiteral (l - r) +evalBinOp (OperLiteral "*") (NumLiteral l) (NumLiteral r) = NumLiteral (l * r) +evalBinOp (OperLiteral "/") (NumLiteral l) (NumLiteral r) = NumLiteral (l / r) +evalBinOp (OperLiteral "%") (NumLiteral l) (NumLiteral r) = NumLiteral $ fromIntegral ((truncate l `rem` truncate r) :: Integer ) +evalBinOp (OperLiteral "^") (NumLiteral l) (NumLiteral r) = NumLiteral (l ** r) + +-- Logical +evalBinOp (OperLiteral "<") (NumLiteral l) (NumLiteral r) = StrLiteral (if l < r then "TRUE" else "FALSE") +evalBinOp (OperLiteral ">") (NumLiteral l) (NumLiteral r) = StrLiteral (if l > r then "TRUE" else "FALSE") +evalBinOp (OperLiteral "=") (NumLiteral l) (NumLiteral r) = StrLiteral (if l == r then "TRUE" else "FALSE") +evalBinOp (OperLiteral "<>") (NumLiteral l) (NumLiteral r) = StrLiteral (if l /= r then "TRUE" else "FALSE") +evalBinOp (OperLiteral "<=") (NumLiteral l) (NumLiteral r) = StrLiteral (if l <= r then "TRUE" else "FALSE") +evalBinOp (OperLiteral ">=") (NumLiteral l) (NumLiteral r) = StrLiteral (if l >= r then "TRUE" else "FALSE") + +-- Undefined +evalBinOp op a b = error $ "Evaluation undefined for " ++ show [op, a, b] + +setLocals :: LogoSymbolTable -> LogoEvaluator () +setLocals l = modifyState $ \s -> s { locals = l } + +getLocals :: LogoEvaluator LogoSymbolTable +getLocals = locals <$> getState + +evaluateInLocalContext :: LogoSymbolTable -> LogoEvaluator a -> LogoEvaluator a +evaluateInLocalContext localVars computation = do + old <- getLocals + setLocals $ localVars `M.union` old + res <- computation + setLocals old + return res + +lookupVar :: String -> LogoEvaluator LogoToken +lookupVar v = do + (l,g) <- (M.lookup v *** M.lookup v) . (locals &&& globals) <$> getState + case l <|> g of + Just x -> return x + _ -> error $ "variable " ++ v ++ " not in scope" + +dispatchFn :: String -> LogoEvaluator LogoToken +dispatchFn fn = do + -- get function definition + ctx <- getState + let fns = functions ctx + f = case M.lookup fn fns of + Just x -> x + _ -> error ("Function undefined: " ++ fn) + -- find arity + let (LogoFunctionDef a func) = f + -- get number of tokens + -- FIXME evaludate the token before getting a list of expressions + arguments <- replicateM a relationalExpression + -- call function and update context + func arguments diff --git a/src/Logo/TokenParser.hs b/src/Logo/TokenParser.hs new file mode 100644 --- /dev/null +++ b/src/Logo/TokenParser.hs @@ -0,0 +1,125 @@ +module Logo.TokenParser (tokenize) where + +import Logo.Types + +import Control.Applicative ((<|>), (<$>), many) + +import Text.ParserCombinators.Parsec ( + char, letter, digit, alphaNum, string, space, + parse, many1, skipMany, notFollowedBy, noneOf, try, (), eof, + ParseError, Parser) + +import Text.ParserCombinators.Parsec.Number (natFloat, sign) + +tokenize :: String -> String -> Either ParseError [LogoToken] +tokenize progName = parse logo progName + +logo :: Parser [LogoToken] +logo = do + skipMany space + expressions <- many1 logoExpr + skipMany space + eof + return $ concat expressions + +logoExpr :: Parser [LogoToken] +logoExpr = try comment + <|> try list + <|> try binaryExpr + <|> try parenExpr + <|> try word + "Logo Expression" + +comment :: Parser [LogoToken] +comment = do + skipMany space + string ";" + skipMany $ noneOf "\n" + skipMany space + return [] + +word :: Parser [LogoToken] +word = try identifier + <|> try stringLiteral + <|> try varLiteral + <|> try numLiteral + "Logo terminal" + +identifier :: Parser [LogoToken] +identifier = do + skipMany space + s <- letter + i <- many alphaNum + return . return $ (Identifier (s:i)) + +-- FIXME support escaping +stringLiteral :: Parser [LogoToken] +stringLiteral = do + skipMany space + char '"' + s <- many1 $ noneOf "\t\n []()\"" + return . return $ StrLiteral s + +varLiteral :: Parser [LogoToken] +varLiteral = do + skipMany space + char ':' + s <- letter + v <- many alphaNum + return . return $ VarLiteral (s:v) + +numLiteral :: Parser [LogoToken] +numLiteral = do + skipMany space + s <- sign + n <- natFloat + return . return . NumLiteral . s $ case n of + Left i -> fromInteger i + Right f -> f + +operExpr :: Parser [LogoToken] +operExpr = try parenExpr + <|> try word + +binaryExpr :: Parser [LogoToken] +binaryExpr = do + lhs <- operExpr + op <- operLiteral + rhs <- try binaryExpr <|> operExpr + return . concat $ [lhs, op, rhs] + +operLiteral :: Parser [LogoToken] +operLiteral = do + s <- many space + (return . OperLiteral) <$> + ( string "+" + <|> if (length s) == 0 then (string "-") else ((string "-") >> notFollowedBy digit >> (return "-")) + <|> string "*" + <|> string "/" + <|> string "%" + <|> string "^" + <|> try (string ">=") + <|> try (string "<=") + <|> try (string "<>") + <|> string "=" + <|> string "<" + <|> string ">" ) + +list :: Parser [LogoToken] +list = do + skipMany space + char '[' + expr <- many logoExpr + skipMany space + char ']' + return . return $ LogoList (concat expr) + +parenExpr :: Parser [LogoToken] +parenExpr = do + skipMany space + char '(' + skipMany space + expr <- many logoExpr + skipMany space + char ')' + return . return $ LogoExpr (concat expr) diff --git a/src/Logo/Types.hs b/src/Logo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Logo/Types.hs @@ -0,0 +1,45 @@ +module Logo.Types where + +import Data.Map (Map) +import Text.Parsec.Prim (ParsecT) +import Diagrams.TwoD.Path.Turtle (TurtleT) + +data LogoToken = Identifier String -- Identifier + | StrLiteral String -- String Literal, e.g @"word@ + | VarLiteral String -- Variable, e.g @:size@ + | NumLiteral Double -- Number + | OperLiteral String -- Operator + | LogoList [LogoToken] -- Input definition/variable reference + | LogoExpr [LogoToken] -- Expression inside parentheses + deriving (Eq) + +instance Show LogoToken where + show (Identifier s) = "@" ++ s ++ "@" + show (StrLiteral s) = s + show (VarLiteral s) = ":" ++ s + show (NumLiteral s) = show s + show (OperLiteral s) = s + show (LogoList l) = show l + show (LogoExpr e) = "(" ++ show e ++ ")" + +type TurtleIO = TurtleT IO + +type LogoEvaluator = ParsecT [LogoToken] LogoContext TurtleIO + +type LogoFunction = [LogoToken] -> LogoEvaluator LogoToken + +type LogoSymbolTable = Map String LogoToken + +data LogoFunctionDef = LogoFunctionDef + { arity :: Int -- Number of arguments + , runFn :: LogoFunction -- Consumes an argument + } deriving Show + +data LogoContext = LogoContext + { functions :: Map String LogoFunctionDef -- Functions that can be called, mapped by the identifier + , locals :: LogoSymbolTable -- Vars in local context + , globals :: LogoSymbolTable -- Vars in global context + } deriving Show + + + diff --git a/tests/Diagrams/TwoD/Path/Turtle/Tests.hs b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Diagrams/TwoD/Path/Turtle/Tests.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ViewPatterns #-} +module Diagrams.TwoD.Path.Turtle.Tests + ( tests + ) where + +import Control.Arrow ((***)) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import Diagrams.Prelude +import Diagrams.TwoD.Path.Turtle.Internal + +import Debug.Trace + +tests = + [ testProperty "Moves forward correctly" movesForward + , testProperty "Moves backward correctly" movesBackward + , testProperty "Moves backward and forward correctly" movesBackwardAndForward + , testProperty "Moves left correctly" movesLeft + , testProperty "Moves right correctly" movesRight + , testProperty "Current trail is empty when pen is up" trailEmptyWhenPenUp + ] + +-- | The turtle moves forward by the right distance +movesForward :: Turtle + -> Property +movesForward t = isPenDown t ==> + round diffPos == round x -- position is set correctly + && round lenCurrTrail == round x -- most recent trail has the right length + where + x = 2.0 + t' = t # forward x + diffPos = magnitude $ penPos t' .-. penPos t + lenCurrTrail = flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t' + +-- | The turtle moves forward by the right distance +movesBackward :: Turtle + -> Property +movesBackward t = isPenDown t ==> + round diffPos == round x -- position is set correctly + && round lenCurrTrail == round x -- most recent trail has the right length + where + x = 2.0 + t' = t # backward x + diffPos = magnitude $ penPos t' .-. penPos t + lenCurrTrail = flip arcLength 0.0001 . head . trailSegments . snd . currTrail $ t' + +-- | The turtle moves forward and backward by the same distance and returns to +-- the same position +movesBackwardAndForward :: Turtle + -> Property +movesBackwardAndForward t = isPenDown t ==> + abs(endX - startX) < 0.0001 + && abs(endY - startY) < 0.0001 + && totalSegmentsAdded == 2 + where + x = 2.0 + t' = t # forward x # backward x + (unp2 -> (startX, startY)) = penPos t + (unp2 -> (endX, endY)) = penPos t' + totalSegmentsAdded = (uncurry (-)) . (getTrailLength *** getTrailLength) $ (t',t) + getTrailLength = (length . trailSegments . snd . currTrail) + +-- | The turtle moves left four times and returns to the same position +movesLeft :: Turtle + -> Property +movesLeft t = isPenDown t ==> + abs(endX - startX) < 0.0001 + && abs(endY - startY) < 0.0001 + where + x = 2.0 + turn = 90 + t' = t # forward x # left turn + # forward x # left turn + # forward x # left turn + # forward x + (unp2 -> (startX, startY)) = penPos t + (unp2 -> (endX, endY)) = penPos t' + +-- | The turtle moves right four times and returns to the same position +movesRight :: Turtle + -> Property +movesRight t = isPenDown t ==> + abs(endX - startX) < 0.0001 + && abs(endY - startY) < 0.0001 + where + x = 2.0 + turn = 90 + t' = t # forward x # right turn + # forward x # right turn + # forward x # right turn + # forward x + (unp2 -> (startX, startY)) = penPos t + (unp2 -> (endX, endY)) = penPos t' + +-- | When the trail is empty, @currTrail@ always remains empty and no new paths +-- are added +trailEmptyWhenPenUp :: Turtle + -> Property +trailEmptyWhenPenUp t = isPenDown t ==> trailIsEmpty + where + t' = t # penUp # forward 4 # backward 3 + trailIsEmpty = null . trailSegments . snd . currTrail $ t' + +instance Show Turtle where + show t@(Turtle a b c _ _ _) = show (a,b,c) + + +-- | Arbitrary instance for the Turtle type. +instance Arbitrary Turtle where + arbitrary = + Turtle <$> arbitrary + <*> arbitrary + <*> (Deg <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + +-- | Arbitrary instance for Diagrams type P2 +instance Arbitrary P2 where + arbitrary = p2 <$> arbitrary + +-- | Arbitrary instance for TurtlePath +instance Arbitrary TurtlePath where + arbitrary = TurtlePath <$> arbitrary <*> arbitrary + +-- | Arbitrary instance of PenStyle +-- +-- The color of the pen is chosen from black, blue or brown only +instance Arbitrary PenStyle where + arbitrary = do + penWidth_ <- arbitrary + colorCode <- choose (1,3) :: Gen Int + case colorCode of + 1 -> return $ PenStyle penWidth_ black + 2 -> return $ PenStyle penWidth_ blue + 3 -> return $ PenStyle penWidth_ brown + +-- | Arbitrary instance of Segment +-- +-- Currently this only generates linear segments only +instance Arbitrary (Segment R2) where + arbitrary = do + h <- Deg <$> arbitrary + x <- r2 <$> arbitrary + return $ rotate h (Linear x) + +instance Arbitrary (Trail R2) where + arbitrary = Trail <$> arbitrary <*> (return False) diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,11 @@ +-- | Main module to run all tests. +-- +module Main where + +import Test.Framework (defaultMain, testGroup) + +import qualified Diagrams.TwoD.Path.Turtle.Tests + +main :: IO () +main = defaultMain + [ testGroup "Diagrams.TwoD.Path.Turtle.Tests" Diagrams.TwoD.Path.Turtle.Tests.tests ]