Haskell-Things/ImplicitCAD
1
1
Fork 0
mirror of https://github.com/Haskell-Things/ImplicitCAD.git synced 2024-08-14 15:30:41 +03:00
Code Issues Projects Releases Wiki Activity

comments and spacing changes, and use an integral for counting sides of a polygon, instead of doubles. also, add a tester for polygons.

Browse Source
This commit is contained in:
Julia Longtin 2019-05-07 18:42:52 +01:00
parent 604041dd22
commit 085248ff78
2 changed files with 31 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Examples/example14.escad Normal file
View File

@ -0,0 +1,10 @@
// example7.escad -- A twisted rounded extrusion of the rounded union of 5 hexagonical solids.
linear_extrude (height = 40, center=true, twist=90, r=5){
union ( r = 8) {
circle (10,$fn=6);
translate ([22,0]) circle (10,$fn=6);
translate ([0,22]) circle (10,$fn=6);
translate ([-22,0]) circle (10,$fn=6);
translate ([0,-22]) circle (10,$fn=6);
}
}

97
Graphics/Implicit/ExtOpenScad/Primitives.hs
View File

@ -2,7 +2,7 @@
-- Copyright 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE
-- Idealy, we'd like to parse openscad code, with some improvements, for backwards compatability.
-- Idealy, we'd like to parse a superset of openscad code, with some improvements.
-- This file provides primitive objects for the openscad parser.
@ -12,9 +12,9 @@
-- Export one set containing all of the primitive object's patern matches.
module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where
import Prelude(String, IO, Either(Left, Right), Bool(False), Maybe(Just, Nothing), Fractional, ($), return, either, id, (-), (==), (&&), (<), fromIntegral, (*), cos, sin, pi, (/), (>), const, uncurry, realToFrac, fmap, fromInteger, round, (/=), (||), not, null, map, (++), putStrLn)
import Prelude(String, IO, Either(Left, Right), Bool(False), Maybe(Just, Nothing), Fractional, ($), return, either, id, (-), (==), (&&), (<), (*), cos, sin, pi, (/), (>), const, uncurry, realToFrac, fmap, fromInteger, round, (/=), (||), not, null, map, (++), putStrLn)
import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, ℕ, SymbolicObj2, SymbolicObj3)
import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, ℕ, SymbolicObj2, SymbolicObj3, fromℕtoℝ)
import Graphics.Implicit.ExtOpenScad.Definitions (OVal (OObj2, OObj3), ArgParser)
@ -22,7 +22,7 @@ import Graphics.Implicit.ExtOpenScad.Util.ArgParser (doc, defaultTo, argument, e
import Graphics.Implicit.ExtOpenScad.Util.OVal (caseOType, divideObjs, (<||>))
-- note the use of a qualified import, so we don't have the functions in this file conflict with what we're importing.
-- Note the use of a qualified import, so we don't have the functions in this file conflict with what we're importing.
import qualified Graphics.Implicit.Primitives as Prim (sphere, rect3R, rectR, translate, circle, polygonR, extrudeR, cylinder2, union, unionR, intersect, intersectR, difference, differenceR, rotate, rotate3V, rotate3, scale, extrudeR, extrudeRM, rotateExtrude, shell, pack3, pack2)
import Data.Maybe (isNothing)
@ -32,13 +32,13 @@ import Control.Monad (mplus)
import Data.VectorSpace (VectorSpace, Scalar, (*^))
import GHC.Real (RealFrac)
-- The only thing exported here. basically, a list of ... ?
primitives :: [(String, [OVal] -> ArgParser (IO [OVal]) )]
-- | The only thing exported here. basically, a list of functions, which accept OVal arguments and retrun an ArgParser ?
primitives :: [(String, [OVal] -> ArgParser (IO [OVal]))]
primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell, rotateExtrude, unit ]
-- sphere is a module without a suite.
-- this means that the parser will look for this like
-- sphere(args...);
-- | sphere is a module without a suite.
-- this means that the parser will look for this like
-- sphere(args...);
sphere :: (String, [OVal] -> ArgParser (IO [OVal]))
sphere = moduleWithoutSuite "sphere" $ do
example "sphere(3);"
@ -56,16 +56,13 @@ sphere = moduleWithoutSuite "sphere" $ do
cube :: (String, [OVal] -> ArgParser (IO [OVal]))
cube = moduleWithoutSuite "cube" $ do
-- examples
example "cube(size = [2,3,4], center = true, r = 0.5);"
example "cube(4);"
-- arguments shared between forms
r :: ℝ <- argument "r"
`doc` "radius of rounding"
`defaultTo` 0
-- arguments (two forms)
((x1,x2), (y1,y2), (z1,z2)) <-
do
@ -79,7 +76,7 @@ cube = moduleWithoutSuite "cube" $ do
`doc` "should center? (non-intervals)"
`defaultTo` False
let
toInterval' :: Fractional t => t -> (t, t)
toInterval' :: ℝ -> (ℝ, ℝ)
toInterval' = toInterval center
return (either toInterval' id x,
either toInterval' id y,
@ -92,28 +89,23 @@ cube = moduleWithoutSuite "cube" $ do
`defaultTo` False
let (x,y, z) = either (\w -> (w,w,w)) id size
return (toInterval center x, toInterval center y, toInterval center z)
-- Tests
test "cube(4);"
`eulerCharacteristic` 2
test "cube(size=[2,3,4]);"
`eulerCharacteristic` 2
addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2)
square :: (String, [OVal] -> ArgParser (IO [OVal]))
square = moduleWithoutSuite "square" $ do
-- examples
example "square(x=[-2,2], y=[-1,5]);"
example "square(size = [3,4], center = true, r = 0.5);"
example "square(4);"
-- arguments shared between forms
r :: ℝ <- argument "r"
`doc` "radius of rounding"
`defaultTo` 0
-- arguments (two forms)
((x1,x2), (y1,y2)) <-
do
@ -125,7 +117,7 @@ square = moduleWithoutSuite "square" $ do
`doc` "should center? (non-intervals)"
`defaultTo` False
let
toInterval' :: Fractional t => t -> (t, t)
toInterval' :: ℝ -> (ℝ, ℝ)
toInterval' = toInterval center
return (either toInterval' id x,
either toInterval' id y)
@ -137,22 +129,18 @@ square = moduleWithoutSuite "square" $ do
`defaultTo` False
let (x,y) = either (\w -> (w,w)) id size
return (toInterval center x, toInterval center y)
-- Tests
test "square(2);"
`eulerCharacteristic` 0
test "square(size=[2,3]);"
`eulerCharacteristic` 0
addObj2 $ Prim.rectR r (x1, y1) (x2, y2)
cylinder :: (String, [OVal] -> ArgParser (IO [OVal]))
cylinder = moduleWithoutSuite "cylinder" $ do
example "cylinder(r=10, h=30, center=true);"
example "cylinder(r1=4, r2=6, h=10);"
example "cylinder(r=5, h=10, $fn = 6);"
-- arguments
r :: ℝ <- argument "r"
`defaultTo` 1
@ -166,19 +154,17 @@ cylinder = moduleWithoutSuite "cylinder" $ do
r2 :: ℝ <- argument "r2"
`defaultTo` 1
`doc` "top radius; overrides r"
fn :: ℕ <- argument "$fn"
sides :: ℕ <- argument "$fn"
`defaultTo` (-1)
`doc` "number of sides, for making prisms"
center :: Bool <- argument "center"
`defaultTo` False
`doc` "center cylinder with respect to z?"
-- Tests
test "cylinder(r=10, h=30, center=true);"
`eulerCharacteristic` 0
test "cylinder(r=5, h=10, $fn = 6);"
`eulerCharacteristic` 0
let
(h1, h2) = either (toInterval center) id h
dh = h2 - h1
@ -187,49 +173,36 @@ cylinder = moduleWithoutSuite "cylinder" $ do
if h1 == 0
then id
else Prim.translate (0,0,h1)
-- The result is a computation state modifier that adds a 3D object,
-- based on the args.
addObj3 $ if r1 == 1 && r2 == 1
then let
obj2 = if fn < 0 then Prim.circle r else Prim.polygonR 0 $
let
sides :: ℝ
sides = fromIntegral fn
in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]
obj2 = if sides < 0 then Prim.circle r else Prim.polygonR 0 $
[(r*cos θ, r*sin θ )| θ <- [2*pi*(fromℕtoℝ n)/(fromℕtoℝ sides) | n <- [0 .. sides - 1]]]
obj3 = Prim.extrudeR 0 obj2 dh
in shift obj3
else shift $ Prim.cylinder2 r1 r2 dh
circle :: (String, [OVal] -> ArgParser (IO [OVal]))
circle = moduleWithoutSuite "circle" $ do
example "circle(r=10); // circle"
example "circle(r=5, $fn=6); //hexagon"
-- Arguments
r :: ℝ <- argument "r"
`doc` "radius of the circle"
fn :: ℕ <- argument "$fn"
`doc` "if defined, makes a regular polygon with n sides instead of a circle"
`defaultTo` (-1)
r :: ℝ <- argument "r"
`doc` "radius of the circle"
sides :: ℕ <- argument "$fn"
`doc` "if defined, makes a regular polygon with n sides instead of a circle"
`defaultTo` (-1)
test "circle(r=10);"
`eulerCharacteristic` 0
addObj2 $ if fn < 3
addObj2 $ if sides < 3
then Prim.circle r
else Prim.polygonR 0 $
let
sides :: ℝ
sides = fromIntegral fn
in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]
[(r*cos θ, r*sin θ )| θ <- [2*pi*(fromℕtoℝ n)/(fromℕtoℝ sides) | n <- [0 .. sides - 1]]]
polygon :: (String, [OVal] -> ArgParser (IO [OVal]))
polygon = moduleWithoutSuite "polygon" $ do
example "polygon ([(0,0), (0,10), (10,0)]);"
points :: [ℝ2] <- argument "points"
`doc` "vertices of the polygon"
paths :: [ℕ] <- argument "paths"
@ -242,7 +215,6 @@ polygon = moduleWithoutSuite "polygon" $ do
[] -> addObj2 $ Prim.polygonR r points
_ -> return $ return []
union :: (String, [OVal] -> ArgParser (IO [OVal]))
union = moduleWithSuite "union" $ \children -> do
r :: ℝ <- argument "r"
@ -272,10 +244,8 @@ difference = moduleWithSuite "difference" $ \children -> do
translate :: (String, [OVal] -> ArgParser (IO [OVal]))
translate = moduleWithSuite "translate" $ \children -> do
example "translate ([2,3]) circle (4);"
example "translate ([5,6,7]) sphere(5);"
(x,y,z) <-
do
x :: ℝ <- argument "x"
@ -293,7 +263,6 @@ translate = moduleWithSuite "translate" $ \children -> do
Left x -> (x,0,0)
Right (Left (x,y) ) -> (x,y,0)
Right (Right (x,y,z)) -> (x,y,z)
return $ return $
objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children
@ -308,7 +277,6 @@ rotate = moduleWithSuite "rotate" $ \children -> do
v <- argument "v"
`defaultTo` (0, 0, 1)
`doc` "Vector to rotate around if a is a single angle"
-- caseOType matches depending on whether size can be coerced into
-- the right object. See Graphics.Implicit.ExtOpenScad.Util
-- Entries must be joined with the operator <||>
@ -324,17 +292,14 @@ rotate = moduleWithSuite "rotate" $ \children -> do
scale :: (String, [OVal] -> ArgParser (IO [OVal]))
scale = moduleWithSuite "scale" $ \children -> do
example "scale(2) square(5);"
example "scale([2,3]) square(5);"
example "scale([2,3,4]) cube(5);"
v <- argument "v"
`doc` "vector or scalar to scale by"
let
scaleObjs stretch2 stretch3 =
objMap (Prim.scale stretch2) (Prim.scale stretch3) children
return $ return $ case v of
Left x -> scaleObjs (x,1) (x,1,1)
Right (Left (x,y)) -> scaleObjs (x,y) (x,y,1)
@ -343,7 +308,6 @@ scale = moduleWithSuite "scale" $ \children -> do
extrude :: (String, [OVal] -> ArgParser (IO [OVal]))
extrude = moduleWithSuite "linear_extrude" $ \children -> do
example "linear_extrude(10) square(5);"
height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1
`doc` "height to extrude to..."
center :: Bool <- argument "center" `defaultTo` False
@ -356,7 +320,6 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
`doc` "translate according to this funciton as we extrude..."
r :: ℝ <- argument "r" `defaultTo` 0
`doc` "round the top?"
let
heightn = case height of
Left h -> h
@ -365,21 +328,17 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
height' = case height of
Right f -> Right $ uncurry f
Left a -> Left a
shiftAsNeeded :: SymbolicObj3 -> SymbolicObj3
shiftAsNeeded =
if center
then Prim.translate (0,0,-heightn/2.0)
else id
funcify :: (VectorSpace a, Fractional (Scalar a)) => Either a (ℝ -> a) -> ℝ -> a
funcify (Left val) h = realToFrac (h/heightn) *^ val
funcify (Right f ) h = f h
twist' = fmap funcify twist
scale' = fmap funcify scaleArg
translate' = fmap funcify translateArg
return $ return $ obj2UpMap (
\obj -> case height of
Left constHeight | isNothing twist && isNothing scaleArg && isNothing translateArg ->
@ -391,13 +350,11 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
rotateExtrude :: (String, [OVal] -> ArgParser (IO [OVal]))
rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do
example "rotate_extrude() translate(20) circle(10);"
totalRot :: ℝ <- argument "a" `defaultTo` 360
`doc` "angle to sweep"
r :: ℝ <- argument "r" `defaultTo` 0
translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)
rotateArg :: Either ℝ (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0
let
is360m :: RealFrac a => a -> Bool
is360m n = 360 * fromInteger (round $ n / 360) /= n
@ -405,11 +362,8 @@ rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do
|| either ( /= (0,0)) (\f -> f 0 /= f totalRot) translateArg
|| either is360m (\f -> is360m (f 0 - f totalRot)) rotateArg
capM = if cap then Just r else Nothing
return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translateArg rotateArg) children
{-
rotateExtrudeStatement :: (String, [OVal] -> ArgParser (IO [OVal]))
rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do
@ -426,21 +380,17 @@ shell :: (String, [OVal] -> ArgParser (IO [OVal]))
shell = moduleWithSuite "shell" $ \children -> do
w :: ℝ <- argument "w"
`doc` "width of the shell..."
return $ return $ objMap (Prim.shell w) (Prim.shell w) children
-- Not a permanent solution! Breaks if can't pack.
pack :: (String, [OVal] -> ArgParser (IO [OVal]))
pack = moduleWithSuite "pack" $ \children -> do
example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"
-- arguments
size :: ℝ2 <- argument "size"
`doc` "size of 2D box to pack objects within"
sep :: ℝ <- argument "sep"
`doc` "mandetory space between objects"
-- The actual work...
return $
let (obj2s, obj3s, others) = divideObjs children
@ -458,13 +408,10 @@ pack = moduleWithSuite "pack" $ \children -> do
unit :: (String, [OVal] -> ArgParser (IO [OVal]))
unit = moduleWithSuite "unit" $ \children -> do
example "unit(\"inch\") {..}"
-- arguments
name :: String <- argument "unit"
`doc` "the unit you wish to work in"
let
mmRatio :: Fractional a => String -> Maybe a
mmRatio "inch" = Just 25.4
@ -482,7 +429,6 @@ unit = moduleWithSuite "unit" $ \children -> do
mmRatio "um" = mmRatio "µm"
mmRatio "nm" = Just 0.0000001
mmRatio _ = Nothing
-- The actual work...
return $ case mmRatio name of
Nothing -> do
@ -491,7 +437,6 @@ unit = moduleWithSuite "unit" $ \children -> do
Just r ->
return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children
---------------
(<|>) :: ArgParser a -> ArgParser a -> ArgParser a