mirror of
https://github.com/Haskell-Things/ImplicitCAD.git
synced 2024-11-04 01:26:48 +03:00
hit everything with hlint, and remove warnings.
This commit is contained in:
Julia Longtin
parent
05731465fb
commit
aabf08fe9e
@ -11,7 +11,7 @@
|
||||
-- | A module for retrieving approximate represententations of objects.
|
||||
module Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) where
|
||||
|
||||
import Prelude((-), (/), ($), (<), fmap, round, (+), maximum, abs, (*), fromIntegral, max, realToFrac, Int)
|
||||
import Prelude((-), (/), ($), (<), round, (+), maximum, abs, (*), fromIntegral, max, realToFrac, Int)
|
||||
|
||||
-- Definitions for our number system, objects, and the things we can use to approximately represent objects.
|
||||
import Graphics.Implicit.Definitions (ℝ, ℝ2, SymbolicObj2, SymbolicObj3, Polyline, Triangle, TriangleMesh(TriangleMesh), NormedTriangleMesh(NormedTriangleMesh))
|
||||
|
||||
@ -7,9 +7,6 @@ module Graphics.Implicit.Export.Render.GetLoops (getLoops) where
|
||||
-- Explicitly include what we want from Prelude.
|
||||
import Prelude (head, last, tail, (==), Bool(False), (.), null, error, (<>), Show, Eq)
|
||||
|
||||
-- We're working with 3D points here.
|
||||
import Graphics.Implicit.Definitions (ℝ3)
|
||||
|
||||
import Data.List (partition)
|
||||
|
||||
-- | The goal of getLoops is to extract loops from a list of segments.
|
||||
|
||||
@ -45,7 +45,7 @@ reducePolyline (Polyline ((x1,y1):(x2,y2):others)) =
|
||||
-- | Return the last result.
|
||||
reducePolyline l@(Polyline ((_:_))) = l
|
||||
-- Should not happen.
|
||||
reducePolyline (Polyline ([])) = error "empty polyline"
|
||||
reducePolyline (Polyline []) = error "empty polyline"
|
||||
|
||||
{-cleanLoopsFromSegs =
|
||||
connectPolys
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
|
||||
module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where
|
||||
|
||||
import Prelude(foldMap, (<>), ($), fmap, concat, (.), (==), compare, error)
|
||||
import Prelude(foldMap, (<>), ($), fmap, concat, (.), (==), compare, error, otherwise, concatMap)
|
||||
|
||||
import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh), Triangle(Triangle))
|
||||
|
||||
@ -78,9 +78,9 @@ mergedSquareTris sqTris =
|
||||
-- Select for being the same range on X and then merge them on Y
|
||||
-- Then vice versa.
|
||||
joined = fmap
|
||||
( concat . (fmap joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS)
|
||||
. concat . (fmap joinYaligned) . groupWith (\(Sq _ _ _ yS) -> yS)
|
||||
. concat . (fmap joinXaligned) . groupWith (\(Sq _ _ xS _) -> xS))
|
||||
( concatMap joinXaligned . groupWith (\(Sq _ _ xS _) -> xS)
|
||||
. concatMap joinYaligned . groupWith (\(Sq _ _ _ yS) -> yS)
|
||||
. concatMap joinXaligned . groupWith (\(Sq _ _ xS _) -> xS))
|
||||
planeAligned
|
||||
-- Merge them back together, and we have the desired reult!
|
||||
finishedSquares = concat joined
|
||||
@ -97,12 +97,10 @@ joinXaligned quads@((Sq b z xS _):_) =
|
||||
orderedQuads = sortBy
|
||||
(\(Sq _ _ _ (ya,_)) (Sq _ _ _ (yb,_)) -> compare ya yb)
|
||||
quads
|
||||
mergeAdjacent (pres@(Sq _ _ _ (y1a,y2a)) : next@(Sq _ _ _ (y1b,y2b)) : others) =
|
||||
if y2a == y1b
|
||||
then mergeAdjacent ((Sq b z xS (y1a,y2b)): others)
|
||||
else if y1a == y2b
|
||||
then mergeAdjacent ((Sq b z xS (y1b,y2a)): others)
|
||||
else pres : mergeAdjacent (next : others)
|
||||
mergeAdjacent (pres@(Sq _ _ _ (y1a,y2a)) : next@(Sq _ _ _ (y1b,y2b)) : others)
|
||||
| y2a == y1b = mergeAdjacent (Sq b z xS (y1a,y2b) : others)
|
||||
| y1a == y2b = mergeAdjacent (Sq b z xS (y1b,y2a) : others)
|
||||
| otherwise = pres : mergeAdjacent (next : others)
|
||||
mergeAdjacent a = a
|
||||
in
|
||||
mergeAdjacent orderedQuads
|
||||
@ -115,12 +113,10 @@ joinYaligned quads@((Sq b z _ yS):_) =
|
||||
orderedQuads = sortBy
|
||||
(\(Sq _ _ (xa,_) _) (Sq _ _ (xb,_) _) -> compare xa xb)
|
||||
quads
|
||||
mergeAdjacent (pres@(Sq _ _ (x1a,x2a) _) : next@(Sq _ _ (x1b,x2b) _) : others) =
|
||||
if x2a == x1b
|
||||
then mergeAdjacent ((Sq b z (x1a,x2b) yS): others)
|
||||
else if x1a == x2b
|
||||
then mergeAdjacent ((Sq b z (x1b,x2a) yS): others)
|
||||
else pres : mergeAdjacent (next : others)
|
||||
mergeAdjacent (pres@(Sq _ _ (x1a,x2a) _) : next@(Sq _ _ (x1b,x2b) _) : others)
|
||||
| x2a == x1b = mergeAdjacent (Sq b z (x1a,x2b) yS : others)
|
||||
| x1a == x2b = mergeAdjacent (Sq b z (x1b,x2a) yS : others)
|
||||
| otherwise = pres : mergeAdjacent (next : others)
|
||||
mergeAdjacent a = a
|
||||
in
|
||||
mergeAdjacent orderedQuads
|
||||
|
||||
@ -199,8 +199,8 @@ symbolicGetMesh res inputObj@(UnionR3 r objs) = TriangleMesh $
|
||||
sepFree :: [((ℝ3, ℝ3), a)] -> ([a], [a])
|
||||
sepFree ((box,obj):others) =
|
||||
if length (filter (box3sWithin r box) boxes) > 1
|
||||
then first ((:) obj) $ sepFree others
|
||||
else second ((:) obj) $ sepFree others
|
||||
then first (obj : ) $ sepFree others
|
||||
else second (obj : ) $ sepFree others
|
||||
sepFree [] = ([],[])
|
||||
|
||||
(dependants, independents) = sepFree boxedObjs
|
||||
|
||||
@ -9,7 +9,7 @@
|
||||
|
||||
module Graphics.Implicit.Export.Util (normTriangle, normVertex, centroid) where
|
||||
|
||||
import Prelude(Fractional, (/), (-), ($), foldl, realToFrac, length)
|
||||
import Prelude(Fractional, (/), (-), foldl, realToFrac, length)
|
||||
|
||||
import Graphics.Implicit.Definitions (ℝ, ℝ3, Obj3, Triangle(Triangle), NormedTriangle(NormedTriangle))
|
||||
|
||||
@ -48,7 +48,7 @@ normVertex res obj p =
|
||||
|
||||
-- Get a centroid of a series of points.
|
||||
centroid :: (VectorSpace v, Fractional (Scalar v)) => [v] -> v
|
||||
centroid pts = foldl (^+^) zeroV pts ^/ (realToFrac $ length pts)
|
||||
centroid pts = foldl (^+^) zeroV pts ^/ realToFrac (length pts)
|
||||
{-# INLINABLE centroid #-}
|
||||
|
||||
{-
|
||||
|
||||
@ -2,17 +2,16 @@
|
||||
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
|
||||
-- Released under the GNU AGPLV3+, see LICENSE
|
||||
|
||||
-- allow us to specify what package to import what module from.
|
||||
-- We don't actually care, but when we compile our haskell examples, we do.
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
-- Allow us to use string literals to represent Text.
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- Allow the use of \case
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where
|
||||
|
||||
-- be explicit about where we pull things in from.
|
||||
import Prelude (Bool(True, False), Maybe(Just, Nothing), ($), (<>), fmap, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), otherwise, id, foldMap, fromIntegral)
|
||||
import Prelude (Bool(True, False), Maybe(Just, Nothing), ($), (<>), (<$>), fmap, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), otherwise, id, foldMap, fromIntegral)
|
||||
|
||||
import Graphics.Implicit.Definitions (ℝ, ℕ)
|
||||
|
||||
@ -50,12 +49,12 @@ defaultObjects withCSG = VarLookup $ fromList $
|
||||
-- rand, lookup,
|
||||
|
||||
defaultConstants :: [(Symbol, OVal)]
|
||||
defaultConstants = fmap (\(a,b) -> (a, toOObj (b :: ℝ) ))
|
||||
defaultConstants = (\(a,b) -> (a, toOObj (b :: ℝ))) <$>
|
||||
[(Symbol "pi", pi),
|
||||
(Symbol "PI", pi)]
|
||||
|
||||
defaultFunctions :: [(Symbol, OVal)]
|
||||
defaultFunctions = fmap (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))
|
||||
defaultFunctions = (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ))) <$>
|
||||
[
|
||||
(Symbol "sin", sin),
|
||||
(Symbol "cos", cos),
|
||||
@ -79,7 +78,7 @@ defaultFunctions = fmap (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))
|
||||
]
|
||||
|
||||
defaultFunctions2 :: [(Symbol, OVal)]
|
||||
defaultFunctions2 = fmap (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) ))
|
||||
defaultFunctions2 = (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ))) <$>
|
||||
[
|
||||
(Symbol "max", max),
|
||||
(Symbol "min", min),
|
||||
@ -115,10 +114,10 @@ varArgModules =
|
||||
scadOpts <- scadOptions
|
||||
let
|
||||
text :: [(Maybe Symbol, OVal)] -> Text
|
||||
text a = intercalate ", " $ fmap (show') a
|
||||
text a = intercalate ", " $ show' <$> a
|
||||
show' :: (Maybe Symbol, OVal) -> Text
|
||||
show' (Nothing, arg) = pack $ show arg
|
||||
show' (Just (Symbol var), arg) = var <> " = " <> (pack $ show arg)
|
||||
show' (Just (Symbol var), arg) = var <> " = " <> pack (show arg)
|
||||
showe' :: (Maybe Symbol, OVal) -> Text
|
||||
showe' (Nothing, OString arg) = arg
|
||||
showe' (Just (Symbol var), arg) = var <> " = " <> showe' (Nothing, arg)
|
||||
@ -140,7 +139,7 @@ varArgModules =
|
||||
iterator :: [(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]
|
||||
iterator [] = [id]
|
||||
iterator ((Nothing, _):iterators) = iterator iterators
|
||||
iterator ((Just var, vals):iterators) = [outer . varify inner | inner <- fmap (insert var) (valsList vals), outer <- iterator iterators]
|
||||
iterator ((Just var, vals):iterators) = [outer . varify inner | inner <- insert var <$> valsList vals, outer <- iterator iterators]
|
||||
-- convert the loop iterator variable's expression value to a list (possibly of one value)
|
||||
valsList :: OVal -> [OVal]
|
||||
valsList v@(OBool _) = [v]
|
||||
@ -185,10 +184,10 @@ defaultPolymorphicFunctions =
|
||||
|
||||
-- Some key functions are written as OVals in optimizations attempts
|
||||
|
||||
prod = OFunc $ \x -> case x of
|
||||
prod = OFunc $ \case
|
||||
(OList (y:ys)) -> foldl mult y ys
|
||||
(OList []) -> ONum 1
|
||||
(ONum a) -> OFunc $ \y -> case y of
|
||||
(ONum a) -> OFunc $ \case
|
||||
(OList []) -> ONum a
|
||||
(OList n) -> mult (ONum a) (OList n)
|
||||
(ONum b) -> mult (ONum a) (ONum b)
|
||||
@ -201,11 +200,11 @@ defaultPolymorphicFunctions =
|
||||
mult (OList a) (OList b) = OList $ zipWith mult a b
|
||||
mult a b = errorAsAppropriate "product" a b
|
||||
|
||||
divide = OFunc $ \x -> case x of
|
||||
(ONum a) -> OFunc $ \y -> case y of
|
||||
divide = OFunc $ \case
|
||||
(ONum a) -> OFunc $ \case
|
||||
(ONum b) -> ONum (a/b)
|
||||
b -> errorAsAppropriate "divide" (ONum a) b
|
||||
a -> OFunc $ \y -> case y of
|
||||
a -> OFunc $ \case
|
||||
b -> div' a b
|
||||
|
||||
div' (ONum a) (ONum b) = ONum (a/b)
|
||||
@ -215,7 +214,7 @@ defaultPolymorphicFunctions =
|
||||
omod (ONum a) (ONum b) = ONum . fromInteger $ mod (floor a) (floor b)
|
||||
omod a b = errorAsAppropriate "mod" a b
|
||||
|
||||
concatenate = OFunc $ \x -> case x of
|
||||
concatenate = OFunc $ \case
|
||||
(OList (y:ys)) -> foldl append y ys
|
||||
(OList []) -> OList []
|
||||
_ -> OError "concat takes a list"
|
||||
@ -224,10 +223,10 @@ defaultPolymorphicFunctions =
|
||||
append (OString a) (OString b) = OString $ a<>b
|
||||
append a b = errorAsAppropriate "concat" a b
|
||||
|
||||
sumtotal = OFunc $ \x -> case x of
|
||||
sumtotal = OFunc $ \case
|
||||
(OList (y:ys)) -> foldl add y ys
|
||||
(OList []) -> ONum 0
|
||||
(ONum a) -> OFunc $ \y -> case y of
|
||||
(ONum a) -> OFunc $ \case
|
||||
(OList []) -> ONum a
|
||||
(OList n) -> add (ONum a) (OList n)
|
||||
(ONum b) -> add (ONum a) (ONum b)
|
||||
@ -245,8 +244,8 @@ defaultPolymorphicFunctions =
|
||||
sub a b = errorAsAppropriate "subtract" a b
|
||||
|
||||
negatefun (ONum n) = ONum (-n)
|
||||
negatefun (OList l) = OList $ fmap negatefun l
|
||||
negatefun a = OError $ "Can't negate " <> oTypeStr a <> "(" <> (pack $ show a) <> ")"
|
||||
negatefun (OList l) = OList $ negatefun <$> l
|
||||
negatefun a = OError $ "Can't negate " <> oTypeStr a <> "(" <> pack (show a) <> ")"
|
||||
|
||||
index (OList l) (ONum ind) =
|
||||
let
|
||||
@ -297,17 +296,15 @@ defaultPolymorphicFunctions =
|
||||
"Can't " <> name <> " objects of types " <> oTypeStr a <> " and " <> oTypeStr b <> "."
|
||||
|
||||
list_gen :: [ℝ] -> Maybe [ℝ]
|
||||
list_gen [a, b] = Just $ fmap fromInteger [(ceiling a).. (floor b)]
|
||||
list_gen [a, b] = Just $ fromInteger <$> [(ceiling a).. (floor b)]
|
||||
list_gen [a, b, c] =
|
||||
let
|
||||
nr = (c-a)/b
|
||||
n :: ℝ
|
||||
n = fromInteger (floor nr)
|
||||
in if nr - n > 0
|
||||
then Just $ fmap fromInteger
|
||||
[(ceiling a), (ceiling (a+b)).. (floor (c - b*(nr -n)))]
|
||||
else Just $ fmap fromInteger
|
||||
[(ceiling a), (ceiling (a+b)).. (floor c)]
|
||||
then Just $ fromInteger <$> [(ceiling a), (ceiling (a+b)).. (floor (c - b*(nr -n)))]
|
||||
else Just $ fromInteger <$> [(ceiling a), (ceiling (a+b)).. (floor c)]
|
||||
list_gen _ = Nothing
|
||||
|
||||
ternary :: Bool -> t -> t -> t
|
||||
|
||||
@ -26,14 +26,14 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
|
||||
varUnion
|
||||
) where
|
||||
|
||||
import Prelude(Eq, Show, Ord, Maybe(Just), Bool(False), IO, FilePath, (==), show, ($), (<>), and, zipWith, Int)
|
||||
import Prelude(Eq, Show, Ord, Maybe(Just), Bool(False), IO, FilePath, (==), show, ($), (<>), and, zipWith, Int, (<$>))
|
||||
|
||||
-- Resolution of the world, Integer type, and symbolic languages for 2D and 3D objects.
|
||||
import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, SymbolicObj2, SymbolicObj3, fromFastℕ)
|
||||
|
||||
import Control.Applicative (Applicative, Alternative((<|>), empty), pure, (<*>))
|
||||
|
||||
import Control.Monad (Functor, Monad, fmap, (>>=), mzero, mplus, MonadPlus, ap, (>=>))
|
||||
import Control.Monad (Functor, Monad, (>>=), mzero, mplus, MonadPlus, ap, (>=>))
|
||||
|
||||
import Data.Map (Map, lookup, union)
|
||||
|
||||
@ -88,7 +88,7 @@ instance Monad ArgParser where
|
||||
(APTest str tests child) >>= g = APTest str tests (child >>= g)
|
||||
-- And an ArgParserTerminator happily gives away the value it contains
|
||||
(APTerminator a) >>= g = g a
|
||||
(APBranch bs) >>= g = APBranch $ fmap (>>= g) bs
|
||||
(APBranch bs) >>= g = APBranch $ (>>= g) <$> bs
|
||||
|
||||
instance MonadPlus ArgParser where
|
||||
mzero = APFail ""
|
||||
@ -161,7 +161,7 @@ instance Show OVal where
|
||||
show (OList l) = show l
|
||||
show (OString s) = show s
|
||||
show (OFunc _) = "<function>"
|
||||
show (OUModule (Symbol name) arguments _) = "module " <> (unpack name) <> " (" <> (unpack $ intercalate ", " (fmap showArg $ fromMaybe [] arguments)) <> ") {}"
|
||||
show (OUModule (Symbol name) arguments _) = "module " <> unpack name <> " (" <> unpack (intercalate ", " (showArg <$> fromMaybe [] arguments)) <> ") {}"
|
||||
where
|
||||
showArg :: (Symbol, Bool) -> Text
|
||||
showArg (Symbol a, hasDefault) = if hasDefault
|
||||
@ -174,17 +174,17 @@ instance Show OVal where
|
||||
else a <> "=..."
|
||||
showInstances :: [([(Symbol, Bool)], Maybe Bool)] -> Text
|
||||
showInstances [] = ""
|
||||
showInstances [oneInstance] = "module " <> name <> (showInstance oneInstance)
|
||||
showInstances multipleInstances = "Module " <> name <> "[ " <> (intercalate ", " (fmap showInstance multipleInstances)) <> " ]"
|
||||
showInstances [oneInstance] = "module " <> name <> showInstance oneInstance
|
||||
showInstances multipleInstances = "Module " <> name <> "[ " <> intercalate ", " (showInstance <$> multipleInstances) <> " ]"
|
||||
showInstance :: ([(Symbol, Bool)], Maybe Bool) -> Text
|
||||
showInstance (arguments, suiteInfo) = " (" <> intercalate ", " (fmap showArg arguments) <> ") {}" <> showSuiteInfo suiteInfo
|
||||
showInstance (arguments, suiteInfo) = " (" <> intercalate ", " (showArg <$> arguments) <> ") {}" <> showSuiteInfo suiteInfo
|
||||
showSuiteInfo :: Maybe Bool -> Text
|
||||
showSuiteInfo suiteInfo = case suiteInfo of
|
||||
Just requiresSuite -> if requiresSuite
|
||||
then " requiring suite {}"
|
||||
else " accepting suite {}"
|
||||
_ -> ""
|
||||
show (OVargsModule (Symbol name) _) = "varargs module " <> (unpack name)
|
||||
show (OVargsModule (Symbol name) _) = "varargs module " <> unpack name
|
||||
show (OError msg) = unpack $ "Execution Error:\n" <> msg
|
||||
show (OObj2 obj) = "<obj2: " <> show obj <> ">"
|
||||
show (OObj3 obj) = "<obj3: " <> show obj <> ">"
|
||||
@ -214,7 +214,7 @@ data Message = Message MessageType SourcePosition Text
|
||||
deriving (Eq)
|
||||
|
||||
instance Show Message where
|
||||
show (Message mtype pos text) = show mtype <> " at " <> show pos <> ": " <> (unpack text)
|
||||
show (Message mtype pos text) = show mtype <> " at " <> show pos <> ": " <> unpack text
|
||||
|
||||
-- | Options changing the behavior of the extended OpenScad engine.
|
||||
data ScadOpts = ScadOpts
|
||||
|
||||
@ -139,7 +139,7 @@ evalExpr' (fexpr :$ argExprs) = do
|
||||
-- Evaluate a lambda function.
|
||||
evalExpr' (LamE pats fexpr) = do
|
||||
fparts <- for pats $ \pat -> do
|
||||
modify $ \s -> s { patterns = (fmap unpack $ patVars pat) <> patterns s}
|
||||
modify $ \s -> s { patterns = (unpack <$> patVars pat) <> patterns s}
|
||||
pure $ \f xss -> OFunc $ \val -> case patMatch pat val of
|
||||
Just xs -> f (xs <> xss)
|
||||
Nothing -> OError "Pattern match failed"
|
||||
|
||||
@ -120,7 +120,7 @@ runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) =
|
||||
[] -> Nothing
|
||||
((_, suiteInfoFound):_) -> suiteInfoFound
|
||||
when (null possibleInstances) (do
|
||||
errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> (pack $ show (ONModule (Symbol name) implementation forms))
|
||||
errorC sourcePos $ "no instance of " <> name <> " found to match given parameters.\nInstances available:\n" <> pack (show (ONModule (Symbol name) implementation forms))
|
||||
traverse_ (`checkOptions` True) $ fmap (Just . fst) forms
|
||||
)
|
||||
-- Ignore this for now, because all instances we define have the same suite requirements.
|
||||
@ -228,9 +228,9 @@ runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) =
|
||||
(errorC sourcePos $ "missingNotDefaultable: " <> show (length missingNotDefaultable))
|
||||
-}
|
||||
when (not (null missingNotDefaultable) && makeWarnings)
|
||||
(errorC sourcePos $ "Insufficient parameters. " <> (pack parameterReport))
|
||||
(errorC sourcePos $ "Insufficient parameters. " <> pack parameterReport)
|
||||
when (not (null extraUnnamed) && isJust args && makeWarnings)
|
||||
(errorC sourcePos $ "Too many parameters: " <> (pack $ show $ length extraUnnamed) <> " extra. " <> (pack parameterReport))
|
||||
(errorC sourcePos $ "Too many parameters: " <> pack (show $ length extraUnnamed) <> " extra. " <> pack parameterReport)
|
||||
pure $ null missingNotDefaultable && null extraUnnamed
|
||||
namedParameters :: [(Maybe Symbol, Expr)] -> [Symbol]
|
||||
namedParameters = mapMaybe fst
|
||||
@ -254,7 +254,7 @@ runStatementI (StatementI sourcePos (Include name injectVals)) = do
|
||||
name' <- getRelPath (unpack name)
|
||||
content <- liftIO $ readFile name'
|
||||
case parseProgram name' content of
|
||||
Left e -> errorC sourcePos $ "Error parsing " <> name <> ":" <> (pack $ show e)
|
||||
Left e -> errorC sourcePos $ "Error parsing " <> name <> ":" <> pack (show e)
|
||||
Right sts -> withPathShiftedBy (takeDirectory $ unpack name) $ do
|
||||
vals <- getVals
|
||||
putVals []
|
||||
|
||||
@ -65,7 +65,7 @@ expr0 = foldr ($) nonAssociativeExpr levels
|
||||
, \higher -> -- <, <=, >= and > operators
|
||||
chainl1 higher $ binaryOperation <$> (matchLE <|> matchLT <|> matchGE <|> matchGT)
|
||||
, \higher -> -- + and - operators
|
||||
chainl1 higher $ binaryOperation . singleton <$> (oneOf "+-") <* whiteSpace
|
||||
chainl1 higher $ binaryOperation . singleton <$> oneOf "+-" <* whiteSpace
|
||||
, \higher -> -- string/list concatenation operator (++). This is not available in OpenSCAD.
|
||||
chainl1 higher $ binaryOperation <$> matchCAT
|
||||
, \higher -> -- exponent operator (^). This is not available in OpenSCAD.
|
||||
|
||||
@ -108,7 +108,7 @@ include = statementI p <?> "include/use"
|
||||
p = flip Include
|
||||
<$> (matchInclude $> True <|> matchUse $> False)
|
||||
-- FIXME: better definition of valid filename characters.
|
||||
<*> (fmap pack $ between (char '<') (matchTok '>') (many $ noneOf "<> "))
|
||||
<*> (pack <$> between (char '<') (matchTok '>') (many $ noneOf "<> "))
|
||||
|
||||
-- | An assignment (parser)
|
||||
assignment :: GenParser Char st StatementI
|
||||
@ -180,7 +180,7 @@ moduleArgsUnitDecl =
|
||||
do
|
||||
symb <- matchIdentifier
|
||||
expr <- optionMaybe (matchTok '=' *> expr0)
|
||||
pure ((Symbol $ pack symb), expr)
|
||||
pure (Symbol $ pack symb, expr)
|
||||
) matchComma)
|
||||
')'
|
||||
|
||||
|
||||
@ -44,9 +44,9 @@ argument name =
|
||||
val = fromOObj oObjVal
|
||||
errmsg :: Text
|
||||
errmsg = case oObjVal of
|
||||
OError err -> "error in computing value for argument " <> (pack $ show name)
|
||||
OError err -> "error in computing value for argument " <> pack (show name)
|
||||
<> ": " <> err
|
||||
_ -> "arg " <> (pack $ show oObjVal) <> " not compatible with " <> (pack $ show name)
|
||||
_ -> "arg " <> pack (show oObjVal) <> " not compatible with " <> pack (show name)
|
||||
maybe (APFail errmsg) APTerminator val
|
||||
{-# INLINABLE argument #-}
|
||||
|
||||
@ -114,7 +114,7 @@ argMap2 unnamedArgs (VarLookup namedArgs) (AP name fallback _ f) =
|
||||
argMap2 a (VarLookup b) (APTerminator val) =
|
||||
(Just val, ["Unused arguments" | not (P.null a && DM.null b)])
|
||||
|
||||
argMap2 _ _ (APFail err) = (Nothing, [(unpack err)])
|
||||
argMap2 _ _ (APFail err) = (Nothing, [unpack err])
|
||||
|
||||
argMap2 a b (APExample _ child) = argMap2 a b child
|
||||
|
||||
|
||||
@ -144,7 +144,7 @@ oTypeStr (OObj2 _ ) = "2D Object"
|
||||
oTypeStr (OObj3 _ ) = "3D Object"
|
||||
|
||||
getErrors :: OVal -> Maybe Text
|
||||
getErrors (OError er) = Just $ er
|
||||
getErrors (OError er) = Just er
|
||||
getErrors (OList l) = msum $ fmap getErrors l
|
||||
getErrors _ = Nothing
|
||||
|
||||
|
||||
@ -8,13 +8,13 @@
|
||||
module Graphics.Implicit.MathUtil (rmax, rmaximum, rminimum, distFromLineSeg, pack, box3sWithin, reflect) where
|
||||
|
||||
-- Explicitly include what we need from Prelude.
|
||||
import Prelude (Fractional, Num, Bool, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (<>), head, flip, maximum, minimum, (==))
|
||||
import Prelude (Fractional, Bool, Ordering, (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (<>), head, flip, maximum, minimum, (==))
|
||||
|
||||
import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Box2, (⋅))
|
||||
|
||||
import Data.List (sort, sortBy, (!!))
|
||||
|
||||
import Data.VectorSpace ((<.>), Scalar, (^*), InnerSpace, magnitude, normalized, (^-^), (^+^), (*^))
|
||||
import Data.VectorSpace ((<.>), Scalar, InnerSpace, magnitude, normalized, (^-^), (^+^), (*^))
|
||||
|
||||
-- get the distance between two points.
|
||||
import Data.AffineSpace (distance)
|
||||
|
||||
@ -306,9 +306,9 @@ extrudeRM = ExtrudeRM
|
||||
|
||||
|
||||
rotateExtrude :: ℝ -- ^ Angle to sweep to (in rad)
|
||||
-> (Maybe ℝ) -- ^ Loop or path (rounded corner)
|
||||
-> (Either ℝ2 (ℝ -> ℝ2)) -- ^ translate
|
||||
-> (Either ℝ (ℝ -> ℝ )) -- ^ rotate
|
||||
-> Maybe ℝ -- ^ Loop or path (rounded corner)
|
||||
-> Either ℝ2 (ℝ -> ℝ2) -- ^ translate
|
||||
-> Either ℝ (ℝ -> ℝ ) -- ^ rotate
|
||||
-> SymbolicObj2 -- ^ object to extrude
|
||||
-> SymbolicObj3
|
||||
rotateExtrude = RotateExtrude
|
||||
|
||||
2
Makefile
2
Makefile
@ -125,7 +125,7 @@ distclean: clean Setup
|
||||
rm -rf dist-newstyle
|
||||
rm -rf .stack-work
|
||||
rm -f cabal.project.local
|
||||
rm .ghc.environment.${ARCHITECTURE}-${OS}-${GHCVERSION}
|
||||
rm -f .ghc.environment.${ARCHITECTURE}-${OS}-${GHCVERSION}
|
||||
rm -f `find ./ -name "*~"`
|
||||
rm -f `find ./ -name "\#*\#"`
|
||||
|
||||
|
||||
@ -59,10 +59,7 @@ object2 = squarePipe (10,10,10) 1 100
|
||||
-- | A third 3d object to benchmark.
|
||||
object3 :: SymbolicObj3
|
||||
object3 =
|
||||
difference
|
||||
[ rect3R 1 (-1,-1,-1) (1,1,1)
|
||||
, rect3R 1 (0,0,0) (2,2,2)
|
||||
]
|
||||
difference (rect3R 1 (-1,-1,-1) (1,1,1)) [ rect3R 1 (0,0,0) (2,2,2)]
|
||||
|
||||
-- | Example 13 - the rounded union of a cube and a sphere.
|
||||
object4 :: SymbolicObj3
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
-- FIXME: document why we need each of these.
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
import Prelude(IO, Show, String, Int, Maybe(Just,Nothing), Eq, return, ($), show, fmap, (<>), putStrLn, filter, zip, null, undefined, const, Bool(True,False), fst, (.), head, tail, length, (/=), (+), error)
|
||||
import Prelude(IO, Show, String, Int, Maybe(Just,Nothing), Eq, return, ($), show, fmap, (<>), putStrLn, filter, zip, null, undefined, const, Bool(True,False), fst, (.), head, tail, length, (/=), (+), error, print)
|
||||
import Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP,APFail,APExample,APTest,APTerminator,APBranch), Symbol(Symbol), OVal(ONModule), SourcePosition(SourcePosition), StateC)
|
||||
|
||||
@ -72,14 +72,14 @@ dumpPrimitive (Symbol moduleName) moduleDocList level = do
|
||||
forM_ arguments $ \(ArgumentDoc (Symbol name) posfallback description) ->
|
||||
case (posfallback, description) of
|
||||
(Nothing, "") ->
|
||||
putStrLn $ " * `" <> (unpack name) <> "`"
|
||||
putStrLn $ " * `" <> unpack name <> "`"
|
||||
(Just fallback, "") ->
|
||||
putStrLn $ " * `" <> (unpack name) <> " = " <> fallback <> "`"
|
||||
putStrLn $ " * `" <> unpack name <> " = " <> fallback <> "`"
|
||||
(Nothing, _) -> do
|
||||
putStrLn $ " * `" <> (unpack name) <> "`"
|
||||
putStrLn $ " * `" <> unpack name <> "`"
|
||||
putStrLn $ " " <> description
|
||||
(Just fallback, _) -> do
|
||||
putStrLn $ " * `" <> (unpack name) <> " = " <> fallback <> "`"
|
||||
putStrLn $ " * `" <> unpack name <> " = " <> fallback <> "`"
|
||||
putStrLn $ " " <> description
|
||||
putStrLn ""
|
||||
|
||||
@ -155,7 +155,7 @@ getArgParserDocs (APFail _) = return [Empty]
|
||||
|
||||
-- This one confuses me.
|
||||
getArgParserDocs (APBranch children) = do
|
||||
putStrLn $ show $ length children
|
||||
print (length children)
|
||||
otherDocs <- Ex.catch (getArgParserDocs (APBranch $ tail children)) (\(_ :: Ex.SomeException) -> return [])
|
||||
aResults <- getArgParserDocs $ head children
|
||||
if otherDocs /= [Empty]
|
||||
|
||||
@ -13,7 +13,7 @@
|
||||
|
||||
-- Let's be explicit about what we're getting from where :)
|
||||
|
||||
import Prelude (Read(readsPrec), Maybe(Just, Nothing), IO, Bool(True, False), FilePath, Show, Eq, String, (<>), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, fst, min, sqrt, tail, take, length, putStrLn, show, (>>=), lookup, return, unlines, filter, not, null, (||), (&&), (.))
|
||||
import Prelude (Read(readsPrec), Maybe(Just, Nothing), IO, Bool(True, False), FilePath, Show, Eq, String, (<>), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, fst, min, sqrt, tail, take, length, putStrLn, show, (>>=), lookup, return, unlines, filter, not, null, (||), (&&), (.), print)
|
||||
|
||||
-- Our Extended OpenScad interpreter, and functions to write out files in designated formats.
|
||||
import Graphics.Implicit (runOpenscad, writeSVG, writeDXF2, writeBinSTL, writeSTL, writeOBJ, writeSCAD2, writeSCAD3, writeGCodeHacklabLaser, writePNG2, writePNG3)
|
||||
@ -321,7 +321,7 @@ run rawargs = do
|
||||
|
||||
if quiet args
|
||||
then return ()
|
||||
else putStrLn $ show target
|
||||
else print target
|
||||
|
||||
export3 format res output target
|
||||
|
||||
@ -345,7 +345,7 @@ run rawargs = do
|
||||
|
||||
if quiet args
|
||||
then return ()
|
||||
else putStrLn $ show target
|
||||
else print target
|
||||
|
||||
export2 format res output target
|
||||
|
||||
|
||||
@ -54,8 +54,7 @@ import Data.ByteString.Char8 (unpack)
|
||||
import Data.ByteString.UTF8 (fromString)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy as BSL (toStrict)
|
||||
import Data.Text (Text)
|
||||
import Data.Text (pack)
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text.Lazy as TL (toStrict)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Aeson (encode)
|
||||
@ -159,12 +158,12 @@ executeAndExport content callback maybeFormat =
|
||||
showℝ val = fromString $ show val
|
||||
callbackF :: Bool -> Bool -> ℝ -> Text -> ByteString
|
||||
callbackF False is2D w msg =
|
||||
callback <> "([null," <> (BSL.toStrict $ encode msg) <> "," <> showB is2D <> "," <> showℝ w <> "]);"
|
||||
callback <> "([null," <> BSL.toStrict (encode msg) <> "," <> showB is2D <> "," <> showℝ w <> "]);"
|
||||
callbackF True is2D w msg =
|
||||
callback <> "([new Shape()," <> (BSL.toStrict $ encode msg) <> "," <> showB is2D <> "," <> showℝ w <> "]);"
|
||||
callback <> "([new Shape()," <> BSL.toStrict (encode msg) <> "," <> showB is2D <> "," <> showℝ w <> "]);"
|
||||
callbackS :: Text -> Text -> ByteString
|
||||
callbackS str msg =
|
||||
callback <> "([" <> (BSL.toStrict $ encode str) <> "," <> (BSL.toStrict $ encode msg) <> ",null,null]);"
|
||||
callback <> "([" <> BSL.toStrict (encode str) <> "," <> BSL.toStrict (encode msg) <> ",null,null]);"
|
||||
scadOptions = generateScadOpts
|
||||
openscadProgram = runOpenscad scadOptions [] content
|
||||
in
|
||||
@ -195,7 +194,7 @@ executeAndExport content callback maybeFormat =
|
||||
output3d :: Text
|
||||
output3d = maybe (TL.toStrict.jsTHREE) getOutputHandler3 maybeFormat $ discreteAprox res target
|
||||
if fromMaybe "jsTHREE" maybeFormat == "jsTHREE"
|
||||
then (encodeUtf8 output3d) <> callbackF True False w (scadMessages <> unionWarning)
|
||||
then encodeUtf8 output3d <> callbackF True False w (scadMessages <> unionWarning)
|
||||
else callbackS output3d (scadMessages <> unionWarning)
|
||||
(obj:objs, [] , _) -> do
|
||||
let target = if null objs
|
||||
@ -208,7 +207,7 @@ executeAndExport content callback maybeFormat =
|
||||
output3d = maybe (TL.toStrict.jsTHREE) getOutputHandler3 maybeFormat $ discreteAprox res $ extrudeR 0 target res
|
||||
output2d = maybe (TL.toStrict.svg) getOutputHandler2 maybeFormat $ discreteAprox res target
|
||||
if fromMaybe "jsTHREE" maybeFormat == "jsTHREE"
|
||||
then (encodeUtf8 output3d) <> callbackF True True w (scadMessages <> unionWarning)
|
||||
then encodeUtf8 output3d <> callbackF True True w (scadMessages <> unionWarning)
|
||||
else callbackS output2d (scadMessages <> unionWarning)
|
||||
([], [] , _) -> callbackF False False 1 $ scadMessages <> "\n" <> "Nothing to render."
|
||||
_ -> callbackF False False 1 $ scadMessages <> "\n" <> "ERROR: File contains a mixture of 2D and 3D objects, what do you want to render?"
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module GoldenSpec.Spec (spec) where
|
||||
|
||||
import GoldenSpec.Util (golden)
|
||||
import Graphics.Implicit
|
||||
import Graphics.Implicit (cubeR)
|
||||
import Prelude (($), Bool (True))
|
||||
import Test.Hspec ( describe, Spec )
|
||||
|
||||
|
||||
@ -7,8 +7,7 @@ import Control.Monad.IO.Class (liftIO)
|
||||
import Graphics.Implicit (SymbolicObj3, writeSTL)
|
||||
import Prelude (IO, FilePath, Bool (True, False), String, Double, pure, (==), readFile, writeFile, (>>=), (<>), ($))
|
||||
import System.Directory (getTemporaryDirectory, doesFileExist)
|
||||
import System.IO ( hClose )
|
||||
import System.IO (openTempFile)
|
||||
import System.IO (hClose, openTempFile)
|
||||
import Test.Hspec ( it, shouldBe, SpecWith )
|
||||
|
||||
|
||||
|
||||
@ -6,8 +6,12 @@
|
||||
|
||||
module Graphics.Implicit.Test.Instances (Quantizable (quantize), epsilon, observe, (=~=)) where
|
||||
|
||||
import Prelude (Bool (True, False), Int, Double, Integer, (.), flip, uncurry, ($), (>), (<), (&&), all, (>=), length, div, (<*>), (<$>), (+), fmap, (/), fromIntegral, (^), (*), (<>), round, (<=), filter, notElem)
|
||||
|
||||
import Data.VectorSpace (AdditiveGroup((^-^)))
|
||||
import qualified Graphics.Implicit as I
|
||||
|
||||
import qualified Graphics.Implicit as I (scale)
|
||||
|
||||
import Graphics.Implicit
|
||||
( ExtrudeRMScale(Fn, C1, C2),
|
||||
SymbolicObj3,
|
||||
@ -27,6 +31,7 @@ import Graphics.Implicit
|
||||
rotate3,
|
||||
rotate3V,
|
||||
rotate )
|
||||
|
||||
import Graphics.Implicit.Definitions
|
||||
( SymbolicObj3(Cylinder, Complement3, UnionR3, DifferenceR3,
|
||||
IntersectR3, Translate3, Scale3, Rotate3, Rotate3V, Outset3,
|
||||
@ -36,9 +41,11 @@ import Graphics.Implicit.Definitions
|
||||
PolygonR),
|
||||
both,
|
||||
allthree )
|
||||
|
||||
import Graphics.Implicit.Primitives ( Object(getBox, getImplicit) )
|
||||
import Prelude (Bool (True, False), Int, Double, Integer, (.), flip, uncurry, any, ($), (==), not, (>), (<), and, (&&), all, (>=), length, div, (<*>), (<$>), (+), fmap, (/), fromIntegral, (^), (*), (<>), round, (<=), filter )
|
||||
|
||||
import QuickSpec ( Observe(observe), (=~=) )
|
||||
|
||||
import Test.QuickCheck
|
||||
( Arbitrary(arbitrary, shrink),
|
||||
genericShrink,
|
||||
@ -193,14 +200,11 @@ isValid2 (Outset2 _ s) = isValid2 s
|
||||
isValid2 (Shell2 _ s) = isValid2 s
|
||||
isValid2 s@(PolygonR _ ls) = length ls >= 3 &&
|
||||
let (dx, dy) = boxSize s
|
||||
in not $ any (== 0) [dx, dy]
|
||||
isValid2 (SquareR _ (x0, y0)) = and
|
||||
[ 0 < x0
|
||||
, 0 < y0
|
||||
]
|
||||
in notElem 0 [dx, dy]
|
||||
isValid2 (SquareR _ (x0, y0)) = (0 < x0) && (0 < y0)
|
||||
isValid2 s = -- Otherwise, make sure it has > 0 volume
|
||||
let (dx, dy) = boxSize s
|
||||
in not $ any (== 0) [dx, dy]
|
||||
in notElem 0 [dx, dy]
|
||||
|
||||
-- | Determine if a 'SymbolicObj3' is well-constructed. Ensures we don't
|
||||
-- accidentally generate a term which will crash when we attempt to render it.
|
||||
@ -217,15 +221,11 @@ isValid3 (Rotate3 _ s) = isValid3 s
|
||||
isValid3 (Rotate3V _ _ s) = isValid3 s
|
||||
isValid3 (Outset3 _ s) = isValid3 s
|
||||
isValid3 (Shell3 _ s) = isValid3 s
|
||||
isValid3 (CubeR _ (x0, y0, z0)) = and
|
||||
[ 0 < x0
|
||||
, 0 < y0
|
||||
, 0 < z0
|
||||
]
|
||||
isValid3 (CubeR _ (x0, y0, z0)) = (0 < x0) && (0 < y0) && (0 < z0)
|
||||
isValid3 (Cylinder _ r h) = r > 0 && h > 0
|
||||
isValid3 s = -- Otherwise, make sure it has > 0 volume
|
||||
let (dx, dy, dz) = boxSize s
|
||||
in not $ any (== 0) [dx, dy, dz]
|
||||
in notElem 0 [dx, dy, dz]
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module ImplicitSpec (spec) where
|
||||
|
||||
import Prelude
|
||||
import Prelude ((*), (<>), (-), (/=), ($), (.), pi, id)
|
||||
import Test.Hspec ( describe, it, Spec )
|
||||
import Graphics.Implicit.Test.Instances
|
||||
( (=~=), Quantizable(quantize), epsilon )
|
||||
|
||||
Loading…
Reference in New Issue
Block a user