packages feed

hs-logo 0.4 → 0.5

raw patch · 23 files changed

+1016/−666 lines, 23 filesdep +HUnitdep +QuickCheckdep +colourdep −diagrams-contribdep ~diagrams-svg

Dependencies added: HUnit, QuickCheck, colour, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependencies removed: diagrams-contrib

Dependency ranges changed: diagrams-svg

Files

− Logo.hs 
@@ -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 ()
− Logo/Builtins.hs 
@@ -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-  ]
− Logo/Builtins/Arithmetic.hs 
@@ -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"
− Logo/Builtins/Control.hs 
@@ -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_
− Logo/Builtins/IO.hs 
@@ -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"
− Logo/Builtins/Turtle.hs 
@@ -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"
− Logo/Evaluator.hs 
@@ -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
− Logo/TokenParser.hs 
@@ -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)
− Logo/Types.hs 
@@ -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---
README.md view
@@ -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.
hs-logo.cabal view
@@ -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
+ src/Diagrams/TwoD/Path/Turtle.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Diagrams.TwoD.Path.Turtle+-- Copyright   :  (c) 2011 Michael Sloan+-- License     :  BSD-style (see LICENSE)+-- Maintainer  :  Michael Sloan <mgsloan at gmail>+--+-- 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
+ src/Logo.hs view
@@ -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 ()
+ src/Logo/Builtins.hs view
@@ -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+  ]
+ src/Logo/Builtins/Arithmetic.hs view
@@ -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"
+ src/Logo/Builtins/Control.hs view
@@ -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_
+ src/Logo/Builtins/IO.hs view
@@ -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"
+ src/Logo/Builtins/Turtle.hs view
@@ -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"
+ src/Logo/Evaluator.hs view
@@ -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
+ src/Logo/TokenParser.hs view
@@ -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)
+ src/Logo/Types.hs view
@@ -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+++
+ tests/Diagrams/TwoD/Path/Turtle/Tests.hs view
@@ -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)
+ tests/TestSuite.hs view
@@ -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 ]