implicit-0.0.1: Graphics/Implicit/ExtOpenScad/Expressions.hs
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Released under the GNU GPL, see LICENSE
-- We'd like to parse openscad code, with some improvements, for backwards compatability.
module Graphics.Implicit.ExtOpenScad.Expressions where
-- We need lookup from Data.Map
import Prelude hiding (lookup)
import Data.Map (Map, lookup)
import Graphics.Implicit.Definitions
import Graphics.Implicit.ExtOpenScad.Definitions
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
variableSymb = many1 (noneOf " ,|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=") <?> "variable"
variable :: GenParser Char st (VariableLookup -> OpenscadObj)
variable = fmap (\varstr -> \varlookup -> case lookup varstr varlookup of
Nothing -> OUndefined
Just a -> a )
variableSymb
literal :: GenParser Char st (VariableLookup -> OpenscadObj)
literal =
try ( (string "true" >> return (\map -> OBool True) )
<|> (string "false" >> return (\map -> OBool False) )
<?> "boolean" )
<|> try ( try (do
a <- (many1 digit);
char '.';
b <- (many digit);
return ( \map -> ONum ( read (a ++ "." ++ b) :: ℝ) );
) <|> (do
a <- (many1 digit);
return ( \map -> ONum ( read a :: ℝ) );
) <?> "number" )
<|> try ( ( do
string "\"";
strlit <- many $ try (string "\\\"" >> return '\"') <|> try (string "\\n" >> return '\n') <|> ( noneOf "\"\n");
string "\"";
return $ \map -> OString $ strlit;
) <?> "string" )
<?> "literal"
-- We represent the priority or 'fixity' of different types of expressions
-- by the Int argument
expression :: Int -> GenParser Char st (VariableLookup -> OpenscadObj)
expression 10 = (try literal) <|> (try variable )
<|> ((do
string "(";
expr <- expression 0;
string ")";
return expr;
) <?> "bracketed expression" )
<|> ( try ( do
string "[";
exprs <- sepBy (expression 0) (char ',' );
string "]";
return $ \varlookup -> OList (map ($varlookup) exprs )
) <|> ( do
string "[";
exprs <- sepBy (expression 0) (char ':' );
string "]";
return $ \varlookup -> OList $ map ONum $ case map (coerceNum.($varlookup)) exprs of
a:[] -> [a]
a:b:[] -> [a .. b]
a:b:c:xs -> [a, a+b .. c]
)<?> "vector/list" )
expression 9 =
let
-- Like in Haskell, we're going to think of functions of
-- many variables as functions that result in functions.
-- So f(a,b) = f(a)(b) :)
applyArgs :: OpenscadObj -> [OpenscadObj] -> OpenscadObj
applyArgs obj [] = obj
applyArgs (OFunc f) (arg:others) = applyArgs (f arg) others
applyArgs _ _ = OUndefined
-- List splicing, like in Python. 'Cause list splicing is
-- awesome!
splice :: [a] -> ℝ -> ℝ -> [a]
splice [] _ _ = []
splice (x:xs) a b
| floor a < 0 = splice xs (fromIntegral $ length xs + floor a) (fromIntegral $ floor b)
| floor b < 0 = splice xs (fromIntegral $ floor a) ( fromIntegral $ length xs + floor b)
| floor a > 0 = splice xs (fromIntegral $ floor a - 1) (fromIntegral $ floor b)
| floor b > 0 = x : (splice xs (fromIntegral $ floor a) (fromIntegral $ floor b - 1 ) )
| otherwise = []
in ( try( do
f <- expression 10;
many space
string "(";
args <- sepBy (expression 0) (many space >> char ',' >> many space);
string ")";
return $ \varlookup -> applyArgs (f varlookup) (map ($varlookup) args)
) <?> "function appliation" )
<|> ( try( do
l <- expression 10;
string "[";
i <- expression 0;
string "]";
return $ \varlookup ->
case (l varlookup, i varlookup) of
(OList actual_list, ONum ind) -> actual_list !! (floor ind)
(OString str, ONum ind) -> OString $ [str !! (floor ind)]
_ -> OUndefined
) <?> "list indexing" )
<|> ( try( do
l <- expression 10;
string "[";
start <- (try $ expression 0) <|> (many space >> return (\_ -> OUndefined));
char ':';
end <- (try $ expression 0) <|> (many space >> return (\_ -> OUndefined));
string "]";
return $ \varlookup ->
case (l varlookup, start varlookup, end varlookup) of
(OList list, ONum a, ONum b ) -> OList $ splice list a b
(OString str, ONum a, ONum b ) -> OString $ splice str a b
(OList list, OUndefined, ONum b ) -> OList $ splice list 0 b
(OString str, OUndefined, ONum b ) -> OString $ splice str 0 b
(OList list, ONum a, OUndefined) -> OList $ splice list a (1.0/0.0)
(OString str, ONum a, OUndefined) -> OString $ splice str a (1.0/0.0)
(OList list, OUndefined, OUndefined) -> OList $ splice list 0 (1.0/0.0)
(OString str, OUndefined, OUndefined) -> OString $ splice str 0 (1.0/0.0)
_ -> OUndefined
) <?> "list splicing" )
<|> try (expression 10)
expression n@8 = try (( do
a <- expression (n+1);
string "^";
b <- expression n;
return $ \varlookup -> case (a varlookup, b varlookup) of
(ONum na, ONum nb) -> ONum (na ** nb)
_ -> OUndefined
) <?> "exponentiation")
<|> try (expression $ n+1)
expression n@7 = try (expression $ n+1)
expression n@6 =
let
mult (ONum a) (ONum b) = ONum (a*b)
mult (ONum a) (OList b) = OList (map (mult (ONum a)) b)
mult (OList a) (ONum b) = OList (map (mult (ONum b)) a)
mult _ _ = OUndefined
div (ONum a) (ONum b) = ONum (a/b)
div (OList a) (ONum b) = OList (map (\x -> div x (ONum b)) a)
div _ _ = OUndefined
in try (( do
exprs <- sepBy1 (sepBy1 (expression $ n+1) (char '/')) (char '*')
return $ \varlookup -> foldl1 mult $ map ( (foldl1 div) . (map ($varlookup) ) ) exprs;
) <?> "multiplication/division")
<|>try (expression $ n+1)
expression n@5 =
let
append (OList a) (OList b) = OList $ a++b
append (OString a) (OString b) = OString $ a++b
append _ _ = OUndefined
in try (( do
exprs <- sepBy1 (expression $ n+1) (string "++")
return $ \varlookup -> foldl1 append $ map ($varlookup) exprs;
) <?> "append")
<|>try (expression $ n+1)
expression n@4 =
let
add (ONum a) (ONum b) = ONum (a+b)
add (OList a) (OList b) = OList $ zipWith add a b
add _ _ = OUndefined
sub (ONum a) (ONum b) = ONum (a-b)
sub (OList a) (OList b) = OList $ zipWith sub a b
sub _ _ = OUndefined
in try (( do
exprs <- sepBy1 (sepBy1 (expression $ n+1) ( char '-')) (char '+')
return $ \varlookup -> foldl1 add $ map ( (foldl1 sub) . (map ($varlookup) ) ) exprs;
) <?> "addition/subtraction")
<|>try (expression $ n+1)
expression n@3 =
let
negate (ONum n) = ONum (-n)
negate (OList l) = OList $ map negate l
negate _ = OUndefined
in try (do
char '-'
many space
expr <- expression $ n+1
return $ \varlookup -> negate $ expr varlookup
) <|> try (expression $ n+1)
expression n@2 = try (expression $ n+1)
expression n@1 = try (expression $ n+1)
expression n@0 = try (do { many space; expr <- expression $ n+1; many space; return expr}) <|> try (expression $ n+1)