Permalink
Find file
a3a12bd Nov 24, 2016
@colah @diffoperator @shkoo @tolomea @chicagoduane
300 lines (246 sloc) 10.2 KB
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE
-- Allow us to use explicit foralls when writing function type declarations.
{-# LANGUAGE ExplicitForAll #-}
-- FIXME: Required. why?
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
-- A module exporting all of the primitives, and some operations on them.
module Graphics.Implicit.Primitives (
translate,
scale,
outset,
complement, union, intersect, difference,
unionR, intersectR, differenceR,
shell,
getBox,
getImplicit,
extrudeR,
extrudeRM,
extrudeRotateR,
extrudeOnEdgeOf,
sphere,
rect3R,
circle,
cylinder,
cylinder2,
rectR,
polygonR,
rotateExtrude,
rotate3,
rotate3V,
pack3,
rotate,
pack2,
implicit
) where
import Prelude(Maybe(Just, Nothing), Either, map, ($))
import Graphics.Implicit.Definitions (, ℝ2, ℝ3, Box2,
SymbolicObj2(
RectR,
Circle,
PolygonR,
Complement2,
UnionR2,
DifferenceR2,
IntersectR2,
Translate2,
Scale2,
Rotate2,
Outset2,
Shell2,
EmbedBoxedObj2
),
SymbolicObj3(
Rect3R,
Sphere,
Cylinder,
Complement3,
UnionR3,
DifferenceR3,
IntersectR3,
Translate3,
Scale3,
Rotate3,
Rotate3V,
Outset3,
Shell3,
EmbedBoxedObj3,
ExtrudeR,
ExtrudeRotateR,
ExtrudeRM,
RotateExtrude,
ExtrudeOnEdgeOf
)
)
import Graphics.Implicit.MathUtil (pack)
import Graphics.Implicit.ObjectUtil (getBox2, getBox3, getImplicit2, getImplicit3)
-- $ 3D Primitives
sphere ::
-- ^ Radius of the sphere
-> SymbolicObj3 -- ^ Resulting sphere
sphere = Sphere
rect3R ::
-- ^ Rounding of corners
-> ℝ3 -- ^ Bottom.. corner
-> ℝ3 -- ^ Top right... corner
-> SymbolicObj3 -- ^ Resuting cube - (0,0,0) is bottom left...
rect3R = Rect3R
cylinder2 ::
-- ^ Radius of the cylinder
-> -- ^ Second radius of the cylinder
-> -- ^ Height of the cylinder
-> SymbolicObj3 -- ^ Resulting cylinder
cylinder2 r1 r2 h = Cylinder h r1 r2
cylinder ::
-- ^ Radius of the cylinder
-> -- ^ Height of the cylinder
-> SymbolicObj3 -- ^ Resulting cylinder
cylinder r = cylinder2 r r
-- $ 2D Primitives
circle ::
-- ^ radius of the circle
-> SymbolicObj2 -- ^ resulting circle
circle = Circle
rectR ::
-> ℝ2 -- ^ Bottom left corner
-> ℝ2 -- ^ Top right corner
-> SymbolicObj2 -- ^ Resulting square (bottom right = (0,0) )
rectR = RectR
polygonR ::
-- ^ Rouding of the polygon
-> [ℝ2] -- ^ Verticies of the polygon
-> SymbolicObj2 -- ^ Resulting polygon
polygonR = PolygonR
-- $ Shared Operations
class Object obj vec | obj -> vec where
-- | Complement an Object
complement ::
obj -- ^ Object to complement
-> obj -- ^ Result
-- | Rounded union
unionR ::
-- ^ The radius of rounding
-> [obj] -- ^ objects to union
-> obj -- ^ Resulting object
-- | Rounded difference
differenceR ::
-- ^ The radius of rounding
-> [obj] -- ^ Objects to difference
-> obj -- ^ Resulting object
-- | Rounded minimum
intersectR ::
-- ^ The radius of rounding
-> [obj] -- ^ Objects to intersect
-> obj -- ^ Resulting object
-- | Translate an object by a vector of appropriate dimension.
translate ::
vec -- ^ Vector to translate by (Also: a is a vector, blah, blah)
-> obj -- ^ Object to translate
-> obj -- ^ Resulting object
-- | Scale an object
scale ::
vec -- ^ Amount to scale by
-> obj -- ^ Object to scale
-> obj -- ^ Resulting scaled object
-- | Outset of an object.
outset ::
-- ^ distance to outset
-> obj -- ^ object to outset
-> obj -- ^ resulting object
-- | Make a shell of an object.
shell ::
-- ^ width of shell
-> obj -- ^ object to take shell of
-> obj -- ^ resulting shell
-- | Get the bounding box an object
getBox ::
obj -- ^ Object to get box of
-> (vec, vec) -- ^ Bounding box
-- | Get the implicit function for an object
getImplicit ::
obj -- ^ Object to get implicit function of
-> (vec -> ) -- ^ Implicit function
implicit ::
(vec -> ) -- ^ Implicit function
-> (vec, vec) -- ^ Bounding box
-> obj -- ^ Resulting object
instance Object SymbolicObj2 ℝ2 where
translate = Translate2
scale = Scale2
complement = Complement2
unionR = UnionR2
intersectR = IntersectR2
differenceR = DifferenceR2
outset = Outset2
shell = Shell2
getBox = getBox2
getImplicit = getImplicit2
implicit a b= EmbedBoxedObj2 (a,b)
instance Object SymbolicObj3 ℝ3 where
translate = Translate3
scale = Scale3
complement = Complement3
unionR = UnionR3
intersectR = IntersectR3
differenceR = DifferenceR3
outset = Outset3
shell = Shell3
getBox = getBox3
getImplicit = getImplicit3
implicit a b= EmbedBoxedObj3 (a,b)
union :: forall obj vec. Object obj vec => [obj] -> obj
union = unionR 0
difference :: forall obj vec. Object obj vec => [obj] -> obj
difference = differenceR 0
intersect :: forall obj vec. Object obj vec => [obj] -> obj
intersect = intersectR 0
-- 3D operations
extrudeR :: -> SymbolicObj2 -> -> SymbolicObj3
extrudeR = ExtrudeR
extrudeRotateR :: -> -> SymbolicObj2 -> -> SymbolicObj3
extrudeRotateR = ExtrudeRotateR
extrudeRM ::
-> Maybe ( -> )
-> Maybe ( -> )
-> Maybe ( -> ℝ2)
-> SymbolicObj2
-> Either (ℝ2 -> )
-> SymbolicObj3
extrudeRM = ExtrudeRM
rotateExtrude ::
-> Maybe
-> Either ℝ2 ( -> ℝ2)
-> Either ( -> )
-> SymbolicObj2
-> SymbolicObj3
rotateExtrude = RotateExtrude
extrudeOnEdgeOf :: SymbolicObj2 -> SymbolicObj2 -> SymbolicObj3
extrudeOnEdgeOf = ExtrudeOnEdgeOf
rotate3 :: (, , ) -> SymbolicObj3 -> SymbolicObj3
rotate3 = Rotate3
rotate3V :: -> ℝ3 -> SymbolicObj3 -> SymbolicObj3
rotate3V = Rotate3V
-- FIXME: shouldn't this pack into a 3d area, or have a 3d equivalent?
pack3 :: ℝ2 -> -> [SymbolicObj3] -> Maybe SymbolicObj3
pack3 (dx, dy) sep objs =
let
boxDropZ :: forall t t1 t2 t3 t4 t5. ((t2, t3, t), (t4, t5, t1)) -> ((t2, t3), (t4, t5))
boxDropZ ((a,b,_),(d,e,_)) = ((a,b),(d,e))
withBoxes :: [(Box2, SymbolicObj3)]
withBoxes = map (\obj -> ( boxDropZ $ getBox3 obj, obj)) objs
in case pack ((0,0),(dx,dy)) sep withBoxes of
(a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y,0) obj) a
_ -> Nothing
-- 2D operations
rotate :: -> SymbolicObj2 -> SymbolicObj2
rotate = Rotate2
pack2 :: ℝ2 -> -> [SymbolicObj2] -> Maybe SymbolicObj2
pack2 (dx, dy) sep objs =
let
withBoxes :: [(Box2, SymbolicObj2)]
withBoxes = map (\obj -> ( getBox2 obj, obj)) objs
in case pack ((0,0),(dx,dy)) sep withBoxes of
(a, []) -> Just $ union $ map (\((x,y),obj) -> translate (x,y) obj) a
_ -> Nothing