implicit-0.0.2: Graphics/Implicit/ExtOpenScad/Primitives.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.
-- This file provides primitive objects for the openscad parser.
-- The code is fairly straightforward; an explanation of how
-- the first one works is provided.
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables #-}
module Graphics.Implicit.ExtOpenScad.Primitives (primitives) where
import Graphics.Implicit.Definitions
import Graphics.Implicit.ExtOpenScad.Definitions
import Graphics.Implicit.ExtOpenScad.Util
import Graphics.Implicit.ExtOpenScad.Util.ArgParser
import Graphics.Implicit.ExtOpenScad.Util.Computation
import qualified Graphics.Implicit.Primitives as Prim
import Data.Maybe (fromMaybe, isNothing)
import qualified Graphics.Implicit.SaneOperators as S
primitives :: [(String, [ComputationStateModifier] -> ArgParser ComputationStateModifier)]
primitives = [ sphere, cube, square, cylinder, circle, polygon, union, difference, intersect, translate, scale, rotate, extrude, pack, shell ]
moduleWithSuite name modArgMapper = (name, modArgMapper)
moduleWithoutSuite name modArgMapper = (name, \suite -> modArgMapper)
-- **Exmaple of implementing a module**
-- sphere is a module without a suite named sphere,
-- this means that the parser will look for this like
-- sphere(args...);
sphere = moduleWithoutSuite "sphere" $ do
example "sphere(3);"
example "sphere(r=5);"
-- What are the arguments?
-- The radius, r, which is a (real) number.
-- Because we don't provide a default, this ends right
-- here if it doesn't get a suitable argument!
r :: ℝ <- argument "r"
`doc` "radius of the sphere"
-- So what does this module do?
-- It adds a 3D object, a sphere of radius r,
-- using the sphere implementation in Prim
-- (Graphics.Implicit.Primitives)
addObj3 $ Prim.sphere r
cube = moduleWithoutSuite "cube" $ do
-- examples
example "cube(size = [2,3,4], center = true, r = 0.5);"
example "cube(4);"
-- arguments
size :: Either ℝ ℝ3 <- argument "size"
`doc` "cube size"
center :: Bool <- argument "center"
`doc` "should center?"
`defaultTo` False
r :: ℝ <- argument "r"
`doc` "radius of rounding"
`defaultTo` 0
-- Tests
test "cube(4);"
`eulerCharacteristic` 2
test "cube(size=[2,3,4]);"
`eulerCharacteristic` 2
-- A helper function for making rect3's accounting for centerdness
let rect3 x y z =
if center
then Prim.rect3R r (-x/2, -y/2, -z/2) (x/2, y/2, z/2)
else Prim.rect3R r (0, 0, 0) (x, y, z)
case size of
Right (x,y,z) -> addObj3 $ rect3 x y z
Left w -> addObj3 $ rect3 w w w
square = moduleWithoutSuite "square" $ do
-- examples
example "square(size = [3,4], center = true, r = 0.5);"
example "square(4);"
-- arguments
size :: Either ℝ ℝ2 <- argument "size"
`doc` "square size"
center :: Bool <- argument "center"
`doc` "should center?"
`defaultTo` False
r :: ℝ <- argument "r"
`doc` "radius of rounding"
`defaultTo` 0
-- Tests
test "square(2);"
`eulerCharacteristic` 0
test "square(size=[2,3]);"
`eulerCharacteristic` 0
-- A helper function for making rect2's accounting for centerdness
let rect x y =
if center
then Prim.rectR r (-x/2, -y/2) (x/2, y/2)
else Prim.rectR r ( 0, 0 ) ( x, y )
-- caseOType matches depending on whether size can be coerced into
-- the right object. See Graphics.Implicit.ExtOpenScad.Util
case size of
Left w -> addObj2 $ rect w w
Right (x,y) -> addObj2 $ rect x y
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
`doc` "radius of cylinder"
h :: ℝ <- argument "h"
`defaultTo` 1
`doc` "height of cylinder"
r1 :: ℝ <- argument "r1"
`defaultTo` 1
`doc` "bottom radius; overrides r"
r2 :: ℝ <- argument "r2"
`defaultTo` 1
`doc` "top radius; overrides r"
fn :: ℕ <- 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
-- 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 = fromIntegral fn
in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]
obj3 = Prim.extrudeR 0 obj2 h
in if center
then Prim.translate (0,0,-h/2) obj3
else obj3
else if center
then Prim.translate (0,0,-h/2) $ Prim.cylinder2 r1 r2 h
else Prim.cylinder2 r1 r2 h
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)
test "circle(r=10);"
`eulerCharacteristic` 0
if fn < 3
then addObj2 $ Prim.circle r
else addObj2 $ Prim.polygonR 0 $
let sides = fromIntegral fn
in [(r*cos θ, r*sin θ )| θ <- [2*pi*n/sides | n <- [0.0 .. sides - 1.0]]]
polygon = moduleWithoutSuite "polygon" $ do
example "polygon ([(0,0), (0,10), (10,0)]);"
points :: [ℝ2] <- argument "points"
`doc` "vertices of the polygon"
paths :: [ℕ ] <- argument "paths"
`doc` "order to go through vertices; ignored for now"
`defaultTo` []
r :: ℝ <- argument "r"
`doc` "rounding of the polygon corners; ignored for now"
`defaultTo` 0
case paths of
[] -> addObj2 $ Prim.polygonR 0 points
_ -> noChange;
union = moduleWithSuite "union" $ \suite -> do
r :: ℝ <- argument "r"
`defaultTo` 0.0
`doc` "Radius of rounding for the union interface"
if r > 0
then getAndCompressSuiteObjs suite (Prim.unionR r) (Prim.unionR r)
else getAndCompressSuiteObjs suite Prim.union Prim.union
intersect = moduleWithSuite "intersection" $ \suite -> do
r :: ℝ <- argument "r"
`defaultTo` 0.0
`doc` "Radius of rounding for the intersection interface"
if r > 0
then getAndCompressSuiteObjs suite (Prim.intersectR r) (Prim.intersectR r)
else getAndCompressSuiteObjs suite Prim.intersect Prim.intersect
difference = moduleWithSuite "difference" $ \suite -> do
r :: ℝ <- argument "r"
`defaultTo` 0.0
`doc` "Radius of rounding for the difference interface"
if r > 0
then getAndCompressSuiteObjs suite (Prim.differenceR r) (Prim.differenceR r)
else getAndCompressSuiteObjs suite Prim.difference Prim.difference
translate = moduleWithSuite "translate" $ \suite -> do
example "translate ([2,3]) circle (4);"
example "translate ([5,6,7]) sphere(5);"
v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"
`doc` "vector to translate by"
let
translateObjs shift2 shift3 =
getAndTransformSuiteObjs suite (Prim.translate shift2) (Prim.translate shift3)
case v of
Left x -> translateObjs (x,0) (x,0,0)
Right (Left (x,y)) -> translateObjs (x,y) (x,y,0.0)
Right (Right (x,y,z)) -> translateObjs (x,y) (x,y,z)
deg2rad x = x / 180.0 * pi
-- This is mostly insane
rotate = moduleWithSuite "rotate" $ \suite -> do
a <- argument "a"
`doc` "value to rotate by; angle or list of angles"
-- 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 <||>
-- Final entry must be fall through.
caseOType a $
( \xy ->
getAndTransformSuiteObjs suite (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad xy, 0, 0) )
) <||> ( \(yz,xy,xz) ->
getAndTransformSuiteObjs suite (Prim.rotate $ deg2rad xy ) (Prim.rotate3 (deg2rad yz, deg2rad xz, deg2rad xy) )
) <||> ( \(yz,xz) ->
getAndTransformSuiteObjs suite (id ) (Prim.rotate3 (deg2rad yz, deg2rad xz, 0))
) <||> ( \_ -> noChange )
scale = moduleWithSuite "scale" $ \suite -> do
example "scale(2) square(5);"
example "scale([2,3]) square(5);"
example "scale([2,3,4]) cube(5);"
v :: Either ℝ (Either ℝ2 ℝ3) <- argument "v"
`doc` "vector or scalar to scale by"
let
scaleObjs strech2 strech3 =
getAndTransformSuiteObjs suite (Prim.scale strech2) (Prim.scale strech3)
case v of
Left x -> scaleObjs (x,0) (x,0,0)
Right (Left (x,y)) -> scaleObjs (x,y) (x,y,0.0)
Right (Right (x,y,z)) -> scaleObjs (x,y) (x,y,z)
extrude = moduleWithSuite "linear_extrude" $ \suite -> do
example "extrude(10) square(5);"
height :: Either ℝ (ℝ -> ℝ -> ℝ) <- argument "height" `defaultTo` (Left 1)
`doc` "height to extrude to..."
center :: Bool <- argument "center" `defaultTo` False
`doc` "center? (the z component)"
twist :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "twist" `defaultTo` Nothing
`doc` "twist as we extrude, either a total amount to twist or a function..."
scale :: Maybe (Either ℝ (ℝ -> ℝ)) <- argument "scale" `defaultTo` Nothing
`doc` "scale according to this funciton as we extrud..."
translate :: Maybe (Either ℝ2 (ℝ -> ℝ2)) <- argument "translate" `defaultTo` Nothing
`doc` "translate according to this funciton as we extrude..."
r :: ℝ <- argument "r" `defaultTo` 0
`doc` "round the top?"
let
degRotate = (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ))) . (*(2*pi/360))
heightn = case height of
Left h -> h
Right f -> f 0 0
height' = case height of
Right f -> Right $ uncurry f
Left a -> Left a
shiftAsNeeded =
if center
then Prim.translate (0,0,-heightn/2.0)
else id
funcify :: S.Multiplicative ℝ a a => Either a (ℝ -> a) -> ℝ -> a
funcify (Left val) h = (h/heightn) S.* val
funcify (Right f ) h = f h
twist' = fmap funcify twist
scale' = fmap funcify scale
translate' = fmap funcify translate
getAndModUpObj2s suite $ \obj -> case height of
Left constHeight | isNothing twist && isNothing scale && isNothing translate ->
shiftAsNeeded $ Prim.extrudeR r obj constHeight
_ ->
shiftAsNeeded $ Prim.extrudeRM r twist' scale' translate' obj height'
{-rotateExtrudeStatement = moduleWithSuite "rotate_extrude" $ \suite -> do
h <- realArgument "h"
center <- boolArgumentWithDefault "center" False
twist <- realArgumentWithDefault 0.0
r <- realArgumentWithDefault "r" 0.0
getAndModUpObj2s suite (\obj -> Prim.extrudeRMod r (\θ (x,y) -> (x*cos(θ)+y*sin(θ), y*cos(θ)-x*sin(θ)) ) obj h)
-}
shell = moduleWithSuite "shell" $ \suite -> do
w :: ℝ <- argument "w"
`doc` "width of the shell..."
getAndTransformSuiteObjs suite (Prim.shell w) (Prim.shell w)
-- Not a perenant solution! Breaks if can't pack.
pack = moduleWithSuite "pack" $ \suite -> 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 $ \ ioWrappedState -> do
(varlookup, obj2s, obj3s) <- ioWrappedState
(varlookup2, obj2s2, obj3s2) <- runComputations (return (varlookup, [], [])) suite
if not $ null obj3s2
then case Prim.pack3 size sep obj3s2 of
Just solution -> return (varlookup2, obj2s, obj3s ++ [solution] )
Nothing -> do
putStrLn "Can't pack given objects in given box with present algorithm"
return (varlookup2, obj2s, obj3s)
else case Prim.pack2 size sep obj2s2 of
Just solution -> return (varlookup2, obj2s ++ [solution], obj3s)
Nothing -> do
putStrLn "Can't pack given objects in given box with present algorithm"
return (varlookup2, obj2s, obj3s)