-- 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.Default where import Graphics.Implicit.Definitions import Graphics.Implicit.ExtOpenScad.Definitions import Graphics.Implicit.ExtOpenScad.Util.OVal import Graphics.Implicit.ExtOpenScad.Primitives import Data.Map (Map, fromList) defaultObjects :: VarLookup -- = Map String OVal defaultObjects = fromList $ defaultConstants ++ defaultFunctions ++ defaultFunctions2 ++ defaultFunctionsSpecial ++ defaultModules ++ defaultPolymorphicFunctions -- Missing standard ones: -- rand, lookup, defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) )) [("pi", pi)] defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ))) [ ("sin", sin), ("cos", cos), ("tan", tan), ("asin", asin), ("acos", acos), ("atan", atan), ("sinh", sinh), ("cosh", cosh), ("tanh", tanh), ("abs", abs), ("sign", signum), ("floor", fromIntegral . floor ), ("ceil", fromIntegral . ceiling ), ("round", fromIntegral . round ), ("exp", exp), ("ln", log), ("log", log), ("sign", signum), ("sqrt", sqrt) ] defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) )) [ ("max", max), ("min", min), ("atan2", atan2), ("pow", (**)) ] defaultFunctionsSpecial = [ ("map", toOObj $ flip $ (map :: (OVal -> OVal) -> [OVal] -> [OVal] ) ) ] defaultModules = map (\(a,b) -> (a, OModule b)) primitives -- more complicated ones: defaultPolymorphicFunctions = [ ("+", sum), ("sum", sum), ("*", prod), ("prod", prod), ("/", div), ("-", toOObj sub), ("^", toOObj ((**) :: ℝ -> ℝ -> ℝ)), ("negate", toOObj negate), ("index", toOObj index), ("splice", toOObj osplice), ("<", toOObj ((<) :: ℝ -> ℝ -> Bool) ), (">", toOObj ((>) :: ℝ -> ℝ -> Bool) ), (">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ), ("<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ), ("==", toOObj ((==) :: OVal -> OVal -> Bool) ), ("!=", toOObj ((/=) :: OVal -> OVal -> Bool) ), ("?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ), ("&&", toOObj (&&) ), ("||", toOObj (||) ), ("!", toOObj not ), ("list_gen", toOObj list_gen), ("++", concat), ("len", toOObj olength), ("str", toOObj (show :: OVal -> String)) ] where -- Some key functions are written as OVals in optimizations attempts prod = OFunc $ \x -> case x of (OList (x:xs)) -> foldl mult x xs (OList []) -> ONum 1 a -> OError ["Product takes a list"] 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 a b = errorAsAppropriate "multiply" a b div = OFunc $ \x -> case x of (ONum a) -> OFunc $ \y -> case y of (ONum b) -> ONum (a/b) b -> errorAsAppropriate "divide" (ONum a) b a -> OFunc $ \y -> case y of b -> div' a b div' (ONum a) (ONum b) = ONum (a/b) div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a) div' a b = errorAsAppropriate "divide" a b omod (ONum a) (ONum b) = ONum $ fromIntegral $ mod (floor a) (floor b) omod a b = errorAsAppropriate "modulo" a b append (OList a) (OList b) = OList $ a++b append (OString a) (OString b) = OString $ a++b append a b = errorAsAppropriate "append" a b concat = OFunc $ \x -> case x of (OList (x:xs)) -> foldl append x xs (OList []) -> OList [] _ -> OError ["concat takes a list"] sum = OFunc $ \x -> case x of (OList (x:xs)) -> foldl add x xs (OList []) -> ONum 0 a -> OError ["Product takes a list"] add (ONum a) (ONum b) = ONum (a+b) add (OList a) (OList b) = OList $ zipWith add a b add a b = errorAsAppropriate "add" a b sub (ONum a) (ONum b) = ONum (a-b) sub (OList a) (OList b) = OList $ zipWith sub a b sub a b = errorAsAppropriate "subtract" a b negate (ONum n) = ONum (-n) negate (OList l) = OList $ map negate l negate a = OError ["Can't negate " ++ oTypeStr a ++ "(" ++ show a ++ ")"] {-numCompareToExprCompare :: (ℝ -> ℝ -> Bool) -> Oval -> OVal -> Bool numCompareToExprCompare f a b = case (fromOObj a :: Maybe ℝ, fromOObj b :: Maybe ℝ) of (Just a, Just b) -> f a b _ -> False-} index (OList l) (ONum ind) = let n = floor ind in if n < length l then l !! n else OError ["List accessd out of bounds"] index (OString s) (ONum ind) = let n = floor ind in if n < length s then OString [s !! n] else OError ["List accessd out of bounds"] index a b = errorAsAppropriate "index" a b osplice (OList list) (ONum a) ( ONum b ) = OList $ splice list (floor a) (floor b) osplice (OString str) (ONum a) ( ONum b ) = OString $ splice str (floor a) (floor b) osplice (OList list) (OUndefined) (ONum b ) = OList $ splice list 0 (floor b) osplice (OString str) (OUndefined) (ONum b ) = OString $ splice str 0 (floor b) osplice (OList list) (ONum a) ( OUndefined) = OList $ splice list (floor a) (length list + 1) osplice (OString str) (ONum a) ( OUndefined) = OString $ splice str (floor a) (length str + 1) osplice (OList list) (OUndefined) (OUndefined) = OList $ splice list 0 (length list + 1) osplice (OString str) (OUndefined) (OUndefined) = OString $ splice str 0 (length str + 1) osplice _ _ _ = OUndefined splice :: [a] -> Int -> Int -> [a] splice [] _ _ = [] splice (l@(x:xs)) a b | a < 0 = splice l (a+n) b | b < 0 = splice l a (b+n) | a > 0 = splice xs (a-1) (b-1) | b > 0 = x:(splice xs a (b-1) ) | otherwise = [] where n = length l errorAsAppropriate _ err@(OError _) _ = err errorAsAppropriate _ _ err@(OError _) = err errorAsAppropriate name a b = OError ["Can't " ++ name ++ " objects of types " ++ oTypeStr a ++ " and " ++ oTypeStr b ++ "."] list_gen :: [ℝ] -> Maybe [ℝ] list_gen [a,b] = Just [fromIntegral (ceiling a).. fromIntegral (floor b)] list_gen [a, b, c] = let nr = (c-a)/b n = fromIntegral (floor nr) in if nr - n > 0 then Just [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor (c - b*(nr -n)))] else Just [fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor c)] list_gen _ = Nothing ternary True a b = a ternary False a b = b olegnth (OString s) = ONum $ fromIntegral $ length s olength (OList s) = ONum $ fromIntegral $ length s olength a = OError ["Can't take length of a " ++ oTypeStr a ++ "."]