packages feed

hs-logo 0.2 → 0.3

raw patch · 9 files changed

+599/−1 lines, 9 files

Files

+ 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+  ]
+ 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"
+ 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+                    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 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"
+ Logo/Builtins/Turtle.hs view
@@ -0,0 +1,81 @@+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 view
@@ -0,0 +1,158 @@+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 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)
+ 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+++
hs-logo.cabal view
@@ -1,5 +1,5 @@ Name:                hs-logo-Version:             0.2+Version:             0.3 Synopsis:            Logo turtle graphics interpreter Description:         Interpreter for the Logo programming language,                      specialised for turtle graphics.@@ -23,6 +23,14 @@   Ghc-Options:       -Wall -fno-warn-unused-do-bind   Hs-Source-Dirs:    .   Main-Is:           Logo.hs+  Other-Modules:     Logo.Types+                     Logo.TokenParser+                     Logo.Evaluator+                     Logo.Builtins+                     Logo.Builtins.IO+                     Logo.Builtins.Turtle+                     Logo.Builtins.Arithmetic+                     Logo.Builtins.Control   Build-Depends:     base        >= 4.2      && <  4.6,                      containers  >= 0.3    && <  0.5,                      mtl         >= 1      && < 3.0,