mirror of
https://github.com/Haskell-Things/ImplicitCAD.git
synced 2024-09-11 04:55:41 +03:00
comments and spacing changes, and use an integral for counting sides of a polygon, instead of doubles. also, add a tester for polygons.
This commit is contained in:
parent
604041dd22
commit
085248ff78
10
Examples/example14.escad
Normal file
10
Examples/example14.escad
Normal 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);
|
||||||
|
}
|
||||||
|
}
|
@ -2,7 +2,7 @@
|
|||||||
-- Copyright 2016, Julia Longtin (julial@turinglace.com)
|
-- Copyright 2016, Julia Longtin (julial@turinglace.com)
|
||||||
-- Released under the GNU AGPLV3+, see LICENSE
|
-- 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.
|
-- 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.
|
-- Export one set containing all of the primitive object's patern matches.
|
||||||
module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where
|
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)
|
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, (<||>))
|
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 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)
|
import Data.Maybe (isNothing)
|
||||||
@ -32,13 +32,13 @@ import Control.Monad (mplus)
|
|||||||
import Data.VectorSpace (VectorSpace, Scalar, (*^))
|
import Data.VectorSpace (VectorSpace, Scalar, (*^))
|
||||||
import GHC.Real (RealFrac)
|
import GHC.Real (RealFrac)
|
||||||
|
|
||||||
-- The only thing exported here. basically, a list of ... ?
|
-- | 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 :: [(String, [OVal] -> ArgParser (IO [OVal]))]
|
||||||
primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell, rotateExtrude, unit ]
|
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.
|
-- | sphere is a module without a suite.
|
||||||
-- this means that the parser will look for this like
|
-- this means that the parser will look for this like
|
||||||
-- sphere(args...);
|
-- sphere(args...);
|
||||||
sphere :: (String, [OVal] -> ArgParser (IO [OVal]))
|
sphere :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
sphere = moduleWithoutSuite "sphere" $ do
|
sphere = moduleWithoutSuite "sphere" $ do
|
||||||
example "sphere(3);"
|
example "sphere(3);"
|
||||||
@ -56,16 +56,13 @@ sphere = moduleWithoutSuite "sphere" $ do
|
|||||||
|
|
||||||
cube :: (String, [OVal] -> ArgParser (IO [OVal]))
|
cube :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
cube = moduleWithoutSuite "cube" $ do
|
cube = moduleWithoutSuite "cube" $ do
|
||||||
|
|
||||||
-- examples
|
-- examples
|
||||||
example "cube(size = [2,3,4], center = true, r = 0.5);"
|
example "cube(size = [2,3,4], center = true, r = 0.5);"
|
||||||
example "cube(4);"
|
example "cube(4);"
|
||||||
|
|
||||||
-- arguments shared between forms
|
-- arguments shared between forms
|
||||||
r :: ℝ <- argument "r"
|
r :: ℝ <- argument "r"
|
||||||
`doc` "radius of rounding"
|
`doc` "radius of rounding"
|
||||||
`defaultTo` 0
|
`defaultTo` 0
|
||||||
|
|
||||||
-- arguments (two forms)
|
-- arguments (two forms)
|
||||||
((x1,x2), (y1,y2), (z1,z2)) <-
|
((x1,x2), (y1,y2), (z1,z2)) <-
|
||||||
do
|
do
|
||||||
@ -79,7 +76,7 @@ cube = moduleWithoutSuite "cube" $ do
|
|||||||
`doc` "should center? (non-intervals)"
|
`doc` "should center? (non-intervals)"
|
||||||
`defaultTo` False
|
`defaultTo` False
|
||||||
let
|
let
|
||||||
toInterval' :: Fractional t => t -> (t, t)
|
toInterval' :: ℝ -> (ℝ, ℝ)
|
||||||
toInterval' = toInterval center
|
toInterval' = toInterval center
|
||||||
return (either toInterval' id x,
|
return (either toInterval' id x,
|
||||||
either toInterval' id y,
|
either toInterval' id y,
|
||||||
@ -92,28 +89,23 @@ cube = moduleWithoutSuite "cube" $ do
|
|||||||
`defaultTo` False
|
`defaultTo` False
|
||||||
let (x,y, z) = either (\w -> (w,w,w)) id size
|
let (x,y, z) = either (\w -> (w,w,w)) id size
|
||||||
return (toInterval center x, toInterval center y, toInterval center z)
|
return (toInterval center x, toInterval center y, toInterval center z)
|
||||||
|
|
||||||
-- Tests
|
-- Tests
|
||||||
test "cube(4);"
|
test "cube(4);"
|
||||||
`eulerCharacteristic` 2
|
`eulerCharacteristic` 2
|
||||||
test "cube(size=[2,3,4]);"
|
test "cube(size=[2,3,4]);"
|
||||||
`eulerCharacteristic` 2
|
`eulerCharacteristic` 2
|
||||||
|
|
||||||
addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2)
|
addObj3 $ Prim.rect3R r (x1, y1, z1) (x2, y2, z2)
|
||||||
|
|
||||||
square :: (String, [OVal] -> ArgParser (IO [OVal]))
|
square :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
square = moduleWithoutSuite "square" $ do
|
square = moduleWithoutSuite "square" $ do
|
||||||
|
|
||||||
-- examples
|
-- examples
|
||||||
example "square(x=[-2,2], y=[-1,5]);"
|
example "square(x=[-2,2], y=[-1,5]);"
|
||||||
example "square(size = [3,4], center = true, r = 0.5);"
|
example "square(size = [3,4], center = true, r = 0.5);"
|
||||||
example "square(4);"
|
example "square(4);"
|
||||||
|
|
||||||
-- arguments shared between forms
|
-- arguments shared between forms
|
||||||
r :: ℝ <- argument "r"
|
r :: ℝ <- argument "r"
|
||||||
`doc` "radius of rounding"
|
`doc` "radius of rounding"
|
||||||
`defaultTo` 0
|
`defaultTo` 0
|
||||||
|
|
||||||
-- arguments (two forms)
|
-- arguments (two forms)
|
||||||
((x1,x2), (y1,y2)) <-
|
((x1,x2), (y1,y2)) <-
|
||||||
do
|
do
|
||||||
@ -125,7 +117,7 @@ square = moduleWithoutSuite "square" $ do
|
|||||||
`doc` "should center? (non-intervals)"
|
`doc` "should center? (non-intervals)"
|
||||||
`defaultTo` False
|
`defaultTo` False
|
||||||
let
|
let
|
||||||
toInterval' :: Fractional t => t -> (t, t)
|
toInterval' :: ℝ -> (ℝ, ℝ)
|
||||||
toInterval' = toInterval center
|
toInterval' = toInterval center
|
||||||
return (either toInterval' id x,
|
return (either toInterval' id x,
|
||||||
either toInterval' id y)
|
either toInterval' id y)
|
||||||
@ -137,22 +129,18 @@ square = moduleWithoutSuite "square" $ do
|
|||||||
`defaultTo` False
|
`defaultTo` False
|
||||||
let (x,y) = either (\w -> (w,w)) id size
|
let (x,y) = either (\w -> (w,w)) id size
|
||||||
return (toInterval center x, toInterval center y)
|
return (toInterval center x, toInterval center y)
|
||||||
|
|
||||||
-- Tests
|
-- Tests
|
||||||
test "square(2);"
|
test "square(2);"
|
||||||
`eulerCharacteristic` 0
|
`eulerCharacteristic` 0
|
||||||
test "square(size=[2,3]);"
|
test "square(size=[2,3]);"
|
||||||
`eulerCharacteristic` 0
|
`eulerCharacteristic` 0
|
||||||
|
|
||||||
addObj2 $ Prim.rectR r (x1, y1) (x2, y2)
|
addObj2 $ Prim.rectR r (x1, y1) (x2, y2)
|
||||||
|
|
||||||
cylinder :: (String, [OVal] -> ArgParser (IO [OVal]))
|
cylinder :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
cylinder = moduleWithoutSuite "cylinder" $ do
|
cylinder = moduleWithoutSuite "cylinder" $ do
|
||||||
|
|
||||||
example "cylinder(r=10, h=30, center=true);"
|
example "cylinder(r=10, h=30, center=true);"
|
||||||
example "cylinder(r1=4, r2=6, h=10);"
|
example "cylinder(r1=4, r2=6, h=10);"
|
||||||
example "cylinder(r=5, h=10, $fn = 6);"
|
example "cylinder(r=5, h=10, $fn = 6);"
|
||||||
|
|
||||||
-- arguments
|
-- arguments
|
||||||
r :: ℝ <- argument "r"
|
r :: ℝ <- argument "r"
|
||||||
`defaultTo` 1
|
`defaultTo` 1
|
||||||
@ -166,19 +154,17 @@ cylinder = moduleWithoutSuite "cylinder" $ do
|
|||||||
r2 :: ℝ <- argument "r2"
|
r2 :: ℝ <- argument "r2"
|
||||||
`defaultTo` 1
|
`defaultTo` 1
|
||||||
`doc` "top radius; overrides r"
|
`doc` "top radius; overrides r"
|
||||||
fn :: ℕ <- argument "$fn"
|
sides :: ℕ <- argument "$fn"
|
||||||
`defaultTo` (-1)
|
`defaultTo` (-1)
|
||||||
`doc` "number of sides, for making prisms"
|
`doc` "number of sides, for making prisms"
|
||||||
center :: Bool <- argument "center"
|
center :: Bool <- argument "center"
|
||||||
`defaultTo` False
|
`defaultTo` False
|
||||||
`doc` "center cylinder with respect to z?"
|
`doc` "center cylinder with respect to z?"
|
||||||
|
|
||||||
-- Tests
|
-- Tests
|
||||||
test "cylinder(r=10, h=30, center=true);"
|
test "cylinder(r=10, h=30, center=true);"
|
||||||
`eulerCharacteristic` 0
|
`eulerCharacteristic` 0
|
||||||
test "cylinder(r=5, h=10, $fn = 6);"
|
test "cylinder(r=5, h=10, $fn = 6);"
|
||||||
`eulerCharacteristic` 0
|
`eulerCharacteristic` 0
|
||||||
|
|
||||||
let
|
let
|
||||||
(h1, h2) = either (toInterval center) id h
|
(h1, h2) = either (toInterval center) id h
|
||||||
dh = h2 - h1
|
dh = h2 - h1
|
||||||
@ -187,49 +173,36 @@ cylinder = moduleWithoutSuite "cylinder" $ do
|
|||||||
if h1 == 0
|
if h1 == 0
|
||||||
then id
|
then id
|
||||||
else Prim.translate (0,0,h1)
|
else Prim.translate (0,0,h1)
|
||||||
|
|
||||||
-- The result is a computation state modifier that adds a 3D object,
|
-- The result is a computation state modifier that adds a 3D object,
|
||||||
-- based on the args.
|
-- based on the args.
|
||||||
addObj3 $ if r1 == 1 && r2 == 1
|
addObj3 $ if r1 == 1 && r2 == 1
|
||||||
then let
|
then let
|
||||||
obj2 = if fn < 0 then Prim.circle r else Prim.polygonR 0 $
|
obj2 = if sides < 0 then Prim.circle r else Prim.polygonR 0 $
|
||||||
let
|
[(r*cos θ, r*sin θ )| θ <- [2*pi*(fromℕtoℝ n)/(fromℕtoℝ sides) | n <- [0 .. sides - 1]]]
|
||||||
sides :: ℝ
|
|
||||||
sides = fromIntegral fn
|
|
||||||
in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]
|
|
||||||
obj3 = Prim.extrudeR 0 obj2 dh
|
obj3 = Prim.extrudeR 0 obj2 dh
|
||||||
in shift obj3
|
in shift obj3
|
||||||
else shift $ Prim.cylinder2 r1 r2 dh
|
else shift $ Prim.cylinder2 r1 r2 dh
|
||||||
|
|
||||||
circle :: (String, [OVal] -> ArgParser (IO [OVal]))
|
circle :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
circle = moduleWithoutSuite "circle" $ do
|
circle = moduleWithoutSuite "circle" $ do
|
||||||
|
|
||||||
example "circle(r=10); // circle"
|
example "circle(r=10); // circle"
|
||||||
example "circle(r=5, $fn=6); //hexagon"
|
example "circle(r=5, $fn=6); //hexagon"
|
||||||
|
|
||||||
-- Arguments
|
-- Arguments
|
||||||
r :: ℝ <- argument "r"
|
r :: ℝ <- argument "r"
|
||||||
`doc` "radius of the circle"
|
`doc` "radius of the circle"
|
||||||
fn :: ℕ <- argument "$fn"
|
sides :: ℕ <- argument "$fn"
|
||||||
`doc` "if defined, makes a regular polygon with n sides instead of a circle"
|
`doc` "if defined, makes a regular polygon with n sides instead of a circle"
|
||||||
`defaultTo` (-1)
|
`defaultTo` (-1)
|
||||||
|
|
||||||
test "circle(r=10);"
|
test "circle(r=10);"
|
||||||
`eulerCharacteristic` 0
|
`eulerCharacteristic` 0
|
||||||
|
addObj2 $ if sides < 3
|
||||||
addObj2 $ if fn < 3
|
|
||||||
then Prim.circle r
|
then Prim.circle r
|
||||||
else Prim.polygonR 0 $
|
else Prim.polygonR 0 $
|
||||||
let
|
[(r*cos θ, r*sin θ )| θ <- [2*pi*(fromℕtoℝ n)/(fromℕtoℝ sides) | n <- [0 .. sides - 1]]]
|
||||||
sides :: ℝ
|
|
||||||
sides = fromIntegral fn
|
|
||||||
in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]
|
|
||||||
|
|
||||||
polygon :: (String, [OVal] -> ArgParser (IO [OVal]))
|
polygon :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
polygon = moduleWithoutSuite "polygon" $ do
|
polygon = moduleWithoutSuite "polygon" $ do
|
||||||
|
|
||||||
example "polygon ([(0,0), (0,10), (10,0)]);"
|
example "polygon ([(0,0), (0,10), (10,0)]);"
|
||||||
|
|
||||||
points :: [ℝ2] <- argument "points"
|
points :: [ℝ2] <- argument "points"
|
||||||
`doc` "vertices of the polygon"
|
`doc` "vertices of the polygon"
|
||||||
paths :: [ℕ] <- argument "paths"
|
paths :: [ℕ] <- argument "paths"
|
||||||
@ -242,7 +215,6 @@ polygon = moduleWithoutSuite "polygon" $ do
|
|||||||
[] -> addObj2 $ Prim.polygonR r points
|
[] -> addObj2 $ Prim.polygonR r points
|
||||||
_ -> return $ return []
|
_ -> return $ return []
|
||||||
|
|
||||||
|
|
||||||
union :: (String, [OVal] -> ArgParser (IO [OVal]))
|
union :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
union = moduleWithSuite "union" $ \children -> do
|
union = moduleWithSuite "union" $ \children -> do
|
||||||
r :: ℝ <- argument "r"
|
r :: ℝ <- argument "r"
|
||||||
@ -272,10 +244,8 @@ difference = moduleWithSuite "difference" $ \children -> do
|
|||||||
|
|
||||||
translate :: (String, [OVal] -> ArgParser (IO [OVal]))
|
translate :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
translate = moduleWithSuite "translate" $ \children -> do
|
translate = moduleWithSuite "translate" $ \children -> do
|
||||||
|
|
||||||
example "translate ([2,3]) circle (4);"
|
example "translate ([2,3]) circle (4);"
|
||||||
example "translate ([5,6,7]) sphere(5);"
|
example "translate ([5,6,7]) sphere(5);"
|
||||||
|
|
||||||
(x,y,z) <-
|
(x,y,z) <-
|
||||||
do
|
do
|
||||||
x :: ℝ <- argument "x"
|
x :: ℝ <- argument "x"
|
||||||
@ -293,7 +263,6 @@ translate = moduleWithSuite "translate" $ \children -> do
|
|||||||
Left x -> (x,0,0)
|
Left x -> (x,0,0)
|
||||||
Right (Left (x,y) ) -> (x,y,0)
|
Right (Left (x,y) ) -> (x,y,0)
|
||||||
Right (Right (x,y,z)) -> (x,y,z)
|
Right (Right (x,y,z)) -> (x,y,z)
|
||||||
|
|
||||||
return $ return $
|
return $ return $
|
||||||
objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children
|
objMap (Prim.translate (x,y)) (Prim.translate (x,y,z)) children
|
||||||
|
|
||||||
@ -308,7 +277,6 @@ rotate = moduleWithSuite "rotate" $ \children -> do
|
|||||||
v <- argument "v"
|
v <- argument "v"
|
||||||
`defaultTo` (0, 0, 1)
|
`defaultTo` (0, 0, 1)
|
||||||
`doc` "Vector to rotate around if a is a single angle"
|
`doc` "Vector to rotate around if a is a single angle"
|
||||||
|
|
||||||
-- caseOType matches depending on whether size can be coerced into
|
-- caseOType matches depending on whether size can be coerced into
|
||||||
-- the right object. See Graphics.Implicit.ExtOpenScad.Util
|
-- the right object. See Graphics.Implicit.ExtOpenScad.Util
|
||||||
-- Entries must be joined with the operator <||>
|
-- Entries must be joined with the operator <||>
|
||||||
@ -324,17 +292,14 @@ rotate = moduleWithSuite "rotate" $ \children -> do
|
|||||||
|
|
||||||
scale :: (String, [OVal] -> ArgParser (IO [OVal]))
|
scale :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
scale = moduleWithSuite "scale" $ \children -> do
|
scale = moduleWithSuite "scale" $ \children -> do
|
||||||
|
|
||||||
example "scale(2) square(5);"
|
example "scale(2) square(5);"
|
||||||
example "scale([2,3]) square(5);"
|
example "scale([2,3]) square(5);"
|
||||||
example "scale([2,3,4]) cube(5);"
|
example "scale([2,3,4]) cube(5);"
|
||||||
v <- argument "v"
|
v <- argument "v"
|
||||||
`doc` "vector or scalar to scale by"
|
`doc` "vector or scalar to scale by"
|
||||||
|
|
||||||
let
|
let
|
||||||
scaleObjs stretch2 stretch3 =
|
scaleObjs stretch2 stretch3 =
|
||||||
objMap (Prim.scale stretch2) (Prim.scale stretch3) children
|
objMap (Prim.scale stretch2) (Prim.scale stretch3) children
|
||||||
|
|
||||||
return $ return $ case v of
|
return $ return $ case v of
|
||||||
Left x -> scaleObjs (x,1) (x,1,1)
|
Left x -> scaleObjs (x,1) (x,1,1)
|
||||||
Right (Left (x,y)) -> scaleObjs (x,y) (x,y,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 :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
extrude = moduleWithSuite "linear_extrude" $ \children -> do
|
extrude = moduleWithSuite "linear_extrude" $ \children -> do
|
||||||
example "linear_extrude(10) square(5);"
|
example "linear_extrude(10) square(5);"
|
||||||
|
|
||||||
height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1
|
height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` Left 1
|
||||||
`doc` "height to extrude to..."
|
`doc` "height to extrude to..."
|
||||||
center :: Bool <- argument "center" `defaultTo` False
|
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..."
|
`doc` "translate according to this funciton as we extrude..."
|
||||||
r :: ℝ <- argument "r" `defaultTo` 0
|
r :: ℝ <- argument "r" `defaultTo` 0
|
||||||
`doc` "round the top?"
|
`doc` "round the top?"
|
||||||
|
|
||||||
let
|
let
|
||||||
heightn = case height of
|
heightn = case height of
|
||||||
Left h -> h
|
Left h -> h
|
||||||
@ -365,21 +328,17 @@ extrude = moduleWithSuite "linear_extrude" $ \children -> do
|
|||||||
height' = case height of
|
height' = case height of
|
||||||
Right f -> Right $ uncurry f
|
Right f -> Right $ uncurry f
|
||||||
Left a -> Left a
|
Left a -> Left a
|
||||||
|
|
||||||
shiftAsNeeded :: SymbolicObj3 -> SymbolicObj3
|
shiftAsNeeded :: SymbolicObj3 -> SymbolicObj3
|
||||||
shiftAsNeeded =
|
shiftAsNeeded =
|
||||||
if center
|
if center
|
||||||
then Prim.translate (0,0,-heightn/2.0)
|
then Prim.translate (0,0,-heightn/2.0)
|
||||||
else id
|
else id
|
||||||
|
|
||||||
funcify :: (VectorSpace a, Fractional (Scalar a)) => Either a (ℝ -> a) -> ℝ -> a
|
funcify :: (VectorSpace a, Fractional (Scalar a)) => Either a (ℝ -> a) -> ℝ -> a
|
||||||
funcify (Left val) h = realToFrac (h/heightn) *^ val
|
funcify (Left val) h = realToFrac (h/heightn) *^ val
|
||||||
funcify (Right f ) h = f h
|
funcify (Right f ) h = f h
|
||||||
|
|
||||||
twist' = fmap funcify twist
|
twist' = fmap funcify twist
|
||||||
scale' = fmap funcify scaleArg
|
scale' = fmap funcify scaleArg
|
||||||
translate' = fmap funcify translateArg
|
translate' = fmap funcify translateArg
|
||||||
|
|
||||||
return $ return $ obj2UpMap (
|
return $ return $ obj2UpMap (
|
||||||
\obj -> case height of
|
\obj -> case height of
|
||||||
Left constHeight | isNothing twist && isNothing scaleArg && isNothing translateArg ->
|
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 :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do
|
rotateExtrude = moduleWithSuite "rotate_extrude" $ \children -> do
|
||||||
example "rotate_extrude() translate(20) circle(10);"
|
example "rotate_extrude() translate(20) circle(10);"
|
||||||
|
|
||||||
totalRot :: ℝ <- argument "a" `defaultTo` 360
|
totalRot :: ℝ <- argument "a" `defaultTo` 360
|
||||||
`doc` "angle to sweep"
|
`doc` "angle to sweep"
|
||||||
r :: ℝ <- argument "r" `defaultTo` 0
|
r :: ℝ <- argument "r" `defaultTo` 0
|
||||||
translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)
|
translateArg :: Either ℝ2 (ℝ -> ℝ2) <- argument "translate" `defaultTo` Left (0,0)
|
||||||
rotateArg :: Either ℝ (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0
|
rotateArg :: Either ℝ (ℝ -> ℝ ) <- argument "rotate" `defaultTo` Left 0
|
||||||
|
|
||||||
let
|
let
|
||||||
is360m :: RealFrac a => a -> Bool
|
is360m :: RealFrac a => a -> Bool
|
||||||
is360m n = 360 * fromInteger (round $ n / 360) /= n
|
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 ( /= (0,0)) (\f -> f 0 /= f totalRot) translateArg
|
||||||
|| either is360m (\f -> is360m (f 0 - f totalRot)) rotateArg
|
|| either is360m (\f -> is360m (f 0 - f totalRot)) rotateArg
|
||||||
capM = if cap then Just r else Nothing
|
capM = if cap then Just r else Nothing
|
||||||
|
|
||||||
return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translateArg rotateArg) children
|
return $ return $ obj2UpMap (Prim.rotateExtrude totalRot capM translateArg rotateArg) children
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
{-
|
{-
|
||||||
rotateExtrudeStatement :: (String, [OVal] -> ArgParser (IO [OVal]))
|
rotateExtrudeStatement :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do
|
rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do
|
||||||
@ -426,21 +380,17 @@ shell :: (String, [OVal] -> ArgParser (IO [OVal]))
|
|||||||
shell = moduleWithSuite "shell" $ \children -> do
|
shell = moduleWithSuite "shell" $ \children -> do
|
||||||
w :: ℝ <- argument "w"
|
w :: ℝ <- argument "w"
|
||||||
`doc` "width of the shell..."
|
`doc` "width of the shell..."
|
||||||
|
|
||||||
return $ return $ objMap (Prim.shell w) (Prim.shell w) children
|
return $ return $ objMap (Prim.shell w) (Prim.shell w) children
|
||||||
|
|
||||||
-- Not a permanent solution! Breaks if can't pack.
|
-- Not a permanent solution! Breaks if can't pack.
|
||||||
pack :: (String, [OVal] -> ArgParser (IO [OVal]))
|
pack :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
pack = moduleWithSuite "pack" $ \children -> do
|
pack = moduleWithSuite "pack" $ \children -> do
|
||||||
|
|
||||||
example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"
|
example "pack ([45,45], sep=2) { circle(10); circle(10); circle(10); circle(10); }"
|
||||||
|
|
||||||
-- arguments
|
-- arguments
|
||||||
size :: ℝ2 <- argument "size"
|
size :: ℝ2 <- argument "size"
|
||||||
`doc` "size of 2D box to pack objects within"
|
`doc` "size of 2D box to pack objects within"
|
||||||
sep :: ℝ <- argument "sep"
|
sep :: ℝ <- argument "sep"
|
||||||
`doc` "mandetory space between objects"
|
`doc` "mandetory space between objects"
|
||||||
|
|
||||||
-- The actual work...
|
-- The actual work...
|
||||||
return $
|
return $
|
||||||
let (obj2s, obj3s, others) = divideObjs children
|
let (obj2s, obj3s, others) = divideObjs children
|
||||||
@ -458,13 +408,10 @@ pack = moduleWithSuite "pack" $ \children -> do
|
|||||||
|
|
||||||
unit :: (String, [OVal] -> ArgParser (IO [OVal]))
|
unit :: (String, [OVal] -> ArgParser (IO [OVal]))
|
||||||
unit = moduleWithSuite "unit" $ \children -> do
|
unit = moduleWithSuite "unit" $ \children -> do
|
||||||
|
|
||||||
example "unit(\"inch\") {..}"
|
example "unit(\"inch\") {..}"
|
||||||
|
|
||||||
-- arguments
|
-- arguments
|
||||||
name :: String <- argument "unit"
|
name :: String <- argument "unit"
|
||||||
`doc` "the unit you wish to work in"
|
`doc` "the unit you wish to work in"
|
||||||
|
|
||||||
let
|
let
|
||||||
mmRatio :: Fractional a => String -> Maybe a
|
mmRatio :: Fractional a => String -> Maybe a
|
||||||
mmRatio "inch" = Just 25.4
|
mmRatio "inch" = Just 25.4
|
||||||
@ -482,7 +429,6 @@ unit = moduleWithSuite "unit" $ \children -> do
|
|||||||
mmRatio "um" = mmRatio "µm"
|
mmRatio "um" = mmRatio "µm"
|
||||||
mmRatio "nm" = Just 0.0000001
|
mmRatio "nm" = Just 0.0000001
|
||||||
mmRatio _ = Nothing
|
mmRatio _ = Nothing
|
||||||
|
|
||||||
-- The actual work...
|
-- The actual work...
|
||||||
return $ case mmRatio name of
|
return $ case mmRatio name of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
@ -491,7 +437,6 @@ unit = moduleWithSuite "unit" $ \children -> do
|
|||||||
Just r ->
|
Just r ->
|
||||||
return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children
|
return $ objMap (Prim.scale (r,r)) (Prim.scale (r,r,r)) children
|
||||||
|
|
||||||
|
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
(<|>) :: ArgParser a -> ArgParser a -> ArgParser a
|
(<|>) :: ArgParser a -> ArgParser a -> ArgParser a
|
||||||
|
Loading…
Reference in New Issue
Block a user