module Graphics.OpenSCAD (
Model, Vector,
Model2d, Model3d, Vector2d, Vector3d,
Facet, TransMatrix,
rectangle, square, circle, polygon, projection, importFile,
sphere, box, cube, cylinder, obCylinder, polyhedron,
multMatrix, linearExtrude, rotateExtrude, surface, solid,
union, intersection, difference, minkowski, hull,
scale, resize, rotate, translate, mirror, color, transparent, up,
render, renderL,
var, fn, fs, fa, def,
diam, draw, drawL, (#),
module Colours)
where
import Data.Colour (Colour, AlphaColour, alphaChannel, darken, over, black)
import Data.Colour.Names as Colours
import Data.Colour.SRGB (channelRed, channelBlue, channelGreen, toSRGB)
import Data.List (elemIndices, nub, intercalate)
import qualified Data.List.NonEmpty as NE
import Data.Semigroup (Semigroup((<>), sconcat), Monoid(mconcat, mempty, mappend))
import qualified Data.Set as Set
import System.FilePath (FilePath)
class Eq a => Vector a where
rVector :: a -> String
toList :: a -> [Double]
(#*) :: a -> a -> a
(#-) :: a -> a -> a
(#.) :: a -> a -> Double
v1 #. v2 = sum $ zipWith (*) (toList v1) (toList v2)
isZero :: a -> Bool
isZero = all (== 0) . toList
collinear :: [a] -> Bool
collinear [] = False
collinear [_] = False
collinear [v1, v2] = v1 /= v2
collinear (v1:v2:vs)
| v1 /= v2 = all (\v -> isZero $ (v2 #- v1) #* (v1 #- v)) vs
| otherwise = collinear (v2:vs)
type Vector2d = (Double, Double)
instance Vector Vector2d where
rVector (x, y) = "[" ++ show x ++ "," ++ show y ++ "]"
toList (x, y) = [x, y]
(x1, y1) #- (x2, y2) = (x1 x2, y1 y2)
(x1, y1) #* (x2, y2) = (0, x1 * y2 y1 * x2)
type Vector3d = (Double, Double, Double)
instance Vector Vector3d where
rVector (x, y, z) = "[" ++ show x ++ "," ++ show y ++ "," ++ show z ++ "]"
toList (x, y, z) = [x, y, z]
(x1, y1, z1) #- (x2, y2, z2) = (x1 x2, y1 y2, z1 z2)
(x1, y1, z1) #* (x2, y2, z2) = (y1 * z2 z1 * y2,
z1 * x2 x1 * z2,
x1 * y2 y1 * x2)
coplanar :: [Vector3d] -> Bool
coplanar vs | length vs <= 3 = True
| collinear $ take 3 vs = coplanar $ tail vs
| otherwise =
all (\v -> (v3 #- v1) #. ((v2 #- v1) #* (v #- v3)) == 0) vs'
where (v1:v2:v3:vs') = vs
type TransMatrix =
((Double, Double, Double, Double), (Double, Double, Double, Double),
(Double, Double, Double, Double), (Double, Double, Double, Double))
data Facet = Fa Double | Fs Double | Fn Int | Def deriving Show
data Join = Bevel | Round | Miter Double deriving Show
data Shape = Rectangle Double Double
| Circle Double Facet
| Polygon Int [Vector2d] [[Int]]
| Projection Bool Model3d
| Offset Double Join Shape
deriving Show
data Sides = Faces [[Int]] | Triangles [[Int]] deriving Show
data Solid = Sphere Double Facet
| Box Double Double Double
| Cylinder Double Double Facet
| ObCylinder Double Double Double Facet
| Polyhedron Int [Vector3d] Sides
| MultMatrix TransMatrix Model3d
| LinearExtrude Double Double Vector2d Int Int Facet Model2d
| RotateExtrude Int Facet Model2d
| Surface FilePath Bool Int
| ToSolid Model2d
deriving Show
data Model v = Shape Shape
| Solid Solid
| Scale v (Model v)
| Resize v (Model v)
| Rotate v (Model v)
| Translate v (Model v)
| Mirror v (Model v)
| Color (Colour Double) (Model v)
| Transparent (AlphaColour Double) (Model v)
| Union [Model v]
| Intersection [Model v]
| Minkowski [Model v]
| Hull [Model v]
| Difference (Model v) (Model v)
| Import FilePath
| Var Facet [Model v]
deriving Show
type Model2d = Model Vector2d
type Model3d = Model Vector3d
rectangle :: Double -> Double -> Model2d
rectangle w h = Shape $ Rectangle w h
square :: Double -> Model2d
square s = rectangle s s
circle :: Double -> Facet -> Model2d
circle r f = Shape $ Circle r f
projection :: Bool -> Model3d -> Model2d
projection c s = Shape $ Projection c s
polygon :: Int -> [[Vector2d]] -> Model2d
polygon convexity paths
| any ((< 3) . length) paths = error "Polygon has fewer than 3 points."
| any collinear paths = error "Points in polygon are collinear."
| otherwise = let points = nub $ concat paths
in Shape . Polygon convexity points
$ map (concatMap (`elemIndices` points)) paths
offset :: Double -> Join -> Model2d -> Model2d
offset d j (Shape s) = Shape $ Offset d j s
sphere :: Double -> Facet -> Model3d
sphere r f = Solid $ Sphere r f
box :: Double -> Double -> Double -> Model3d
box x y z = Solid $ Box x y z
cube :: Double -> Model3d
cube x = box x x x
cylinder :: Double -> Double -> Facet -> Model3d
cylinder h r f = Solid $ Cylinder h r f
obCylinder :: Double -> Double -> Double -> Facet -> Model Vector3d
obCylinder r1 h r2 f= Solid $ ObCylinder r1 h r2 f
polyhedron :: Int -> [[Vector3d]] -> Model3d
polyhedron convexity paths
| any ((< 3) . length) paths = error "Some face has fewer than 3 points."
| any collinear paths = error "Some face has collinear points."
| any (not . coplanar) paths = error "Some face isn't coplanar."
| length vectors /= length (nub vectors) =
error "Some faces have different orientation."
| 2 * length edges /= length vectors = error "Some edges are not in two faces."
| xCross headMax xMax tailMax > 0 =
error "Face orientations are counterclockwise."
| otherwise = Solid . Polyhedron convexity points $ sides sidesIn
where vectors = concatMap (\p -> zip p (tail p ++ [head p])) paths
edges = nub $ map (Set.fromList . \(a, b) -> [a, b]) vectors
points = nub $ concat paths
xMax = maximum points
faceMax = head $ filter (elem xMax) paths
(maxFirst, maxLast) = break (== xMax) faceMax
(headMax, tailMax) = (if null maxFirst
then last maxLast
else last maxFirst,
if null (tail maxLast)
then head maxFirst
else head (tail maxLast))
xCross a b c = (\(a, b, c) -> a) $ (a #- b) #* (b #- c)
sidesIn = map (concatMap (`elemIndices` points)) paths
sides ss | any ((> 3) . length) ss = Faces ss
| all ((== 3) . length) ss = Triangles ss
| otherwise = error "Some faces have fewer than 3 points."
multMatrix :: TransMatrix -> Model3d -> Model3d
multMatrix t m = Solid $ MultMatrix t m
solid :: Model2d -> Model3d
solid = Solid . ToSolid
linearExtrude :: Double
-> Double
-> Vector2d
-> Int
-> Int
-> Facet
-> Model2d
-> Model3d
linearExtrude h t sc sl c f m = Solid $ LinearExtrude h t sc sl c f m
rotateExtrude :: Int -> Facet -> Model2d -> Model3d
rotateExtrude c f m = Solid $ RotateExtrude c f m
surface :: FilePath -> Bool -> Int -> Model3d
surface f i c = Solid $ Surface f i c
importFile :: Vector v => FilePath -> Model v
importFile = Import
scale :: Vector v => v -> Model v -> Model v
scale = Scale
resize :: Vector v => v -> Model v -> Model v
resize = Resize
rotate :: Vector v => v -> Model v -> Model v
rotate = Rotate
translate :: Vector v => v -> Model v -> Model v
translate = Translate
mirror :: Vector v => v -> Model v -> Model v
mirror = Mirror
color :: Vector v => Colour Double -> Model v -> Model v
color = Color
transparent :: Vector v => AlphaColour Double -> Model v -> Model v
transparent = Transparent
up :: Double -> Model3d -> Model3d
up f = translate (0, 0, f)
union :: Vector v => [Model v] -> Model v
union = Union
intersection :: Vector v => [Model v] -> Model v
intersection = Intersection
difference :: Vector v => Model v -> Model v -> Model v
difference = Difference
minkowski :: Vector v => [Model v] -> Model v
minkowski = Minkowski
hull :: Vector v => [Model v] -> Model v
hull = Hull
render :: Vector v => Model v -> String
render (Shape s) = rShape s
render (Solid s) = rSolid s
render (Union ss) = rList "union()" ss
render (Intersection ss) = rList "intersection()" ss
render (Difference s1 s2) = "difference(){" ++ render s1 ++ render s2 ++ "}\n"
render (Minkowski ss) = rList "minkowski()" ss
render (Hull ss) = rList "hull()" ss
render (Scale v s) = rVecSolid "scale" v s
render (Resize v s) = rVecSolid "resize" v s
render (Translate v s) = rVecSolid "translate" v s
render (Rotate v s) = "rotate(" ++ rVector v ++ ")" ++ render s
render (Mirror v s) = rVecSolid "mirror" v s
render (Import f) = "import(\"" ++ f ++ "\");\n"
render (Color c s) = let r = toSRGB c in
"color(" ++ rVector (channelRed r, channelGreen r, channelBlue r) ++ ")\n"
++ render s
render (Transparent c s) =
"color(" ++ rQuad (channelRed r, channelGreen r, channelBlue r, a) ++ ")"
++ render s
where r = toSRGB $ toPure c
a = alphaChannel c
toPure ac = if a > 0 then darken (recip a) (ac `over` black) else black
render (Var (Fa f) ss) = rList ("assign($fa=" ++ show f ++ ")") ss
render (Var (Fs f) ss) = rList ("assign($fs=" ++ show f ++ ")") ss
render (Var (Fn n) ss) = rList ("assign($fn=" ++ show n ++ ")") ss
rShape :: Shape -> String
rShape (Rectangle r f) = "square([" ++ show r ++ "," ++ show f ++ "]);\n"
rShape (Circle r f) = "circle(" ++ show r ++ rFacet f ++ ");\n"
rShape (Projection c s) =
"projection(cut=" ++ (if c then "true)" else "false)") ++ render s
rShape (Polygon c points paths) = "polygon(points=" ++ rVectorL points ++
",paths=" ++ show paths ++ ",convexity=" ++ show c ++ ");\n"
rShape (Offset d j s) =
"offset(delta=" ++ show d ++ "," ++ rJoin j ++ ")" ++ rShape s
rJoin :: Join -> String
rJoin Bevel = "join_type=bevel"
rJoin Round = "join_type=round"
rJoin (Miter l) = "miter_limit=" ++ show l
rSolid :: Solid -> String
rSolid (Sphere x f) = "sphere(" ++ show x ++ rFacet f ++ ");\n"
rSolid (Box x y z) =
"cube([" ++ show x ++ "," ++ show y ++ "," ++ show z ++ "]);\n"
rSolid (Cylinder r h f) =
"cylinder(r=" ++ show r ++ ",h=" ++ show h ++ rFacet f ++ ");\n"
rSolid (ObCylinder r1 h r2 f) =
"cylinder(r1=" ++ show r1 ++ ",h=" ++ show h ++ ",r2=" ++ show r2 ++ rFacet f
++ ");\n"
rSolid (Polyhedron c ps ss) = "polyhedron(points=" ++ rVectorL ps ++ rSides ss
++ ",convexity=" ++ show c ++ ");\n"
rSolid (MultMatrix (a, b, c, d) s) =
"multmatrix([" ++ rQuad a ++ "," ++ rQuad b ++ "," ++ rQuad c ++ ","
++ rQuad d ++"])\n" ++ render s
rSolid (LinearExtrude h t sc sl c f sh) =
"linear_extrude(height=" ++ show h ++ ",twist=" ++ show t ++ ",scale="
++ rVector sc ++ ",slices=" ++ show sl ++ ",convexity=" ++ show c
++ rFacet f ++ ")" ++ render sh
rSolid (RotateExtrude c f sh) =
"rotate_extrude(convexity=" ++ show c ++ rFacet f ++ ")" ++ render sh
rSolid (Surface f i c) =
"surface(file=\"" ++ f ++ "\"," ++ (if i then "invert=true," else "")
++ "convexity=" ++ show c ++ ");\n"
rSolid (ToSolid s) = render s
rVectorL vs = "[" ++ intercalate "," (map rVector vs) ++ "]"
rSides (Faces vs) = ",faces=" ++ rListL vs
rSides (Triangles vs) = ",triangles=" ++ rListL vs
rListL vs = "[" ++ intercalate "," (map show vs) ++ "]"
renderL :: Vector v => [Model v] -> String
renderL = render . union
draw :: Vector v => Model v -> IO ()
draw = putStrLn . render
drawL :: Vector v => [Model v] -> IO ()
drawL = draw . Union
rList n ss = n ++ "{\n" ++ concatMap render ss ++ "}"
rVecSolid n v s = n ++ "(" ++ rVector v ++ ")\n" ++ render s
rQuad (w, x, y, z) =
"[" ++ show w ++ "," ++ show x ++ "," ++ show y ++ "," ++ show z ++ "]"
rFacet Def = ""
rFacet f = "," ++ showFacet f
showFacet :: Facet -> String
showFacet (Fa f) = "$fa=" ++ show f
showFacet (Fs f) = "$fs=" ++ show f
showFacet (Fn n) = "$fn=" ++ show n
showFacet Def = ""
var :: Facet -> [Model v] -> Model v
var = Var
fa :: Double -> Facet
fa = Fa
fs :: Double -> Facet
fs = Fs
fn :: Int -> Facet
fn = Fn
def :: Facet
def = Def
diam :: Double -> Double
diam = (/ 2)
instance Vector v => Semigroup (Model v) where
a <> b = union [a, b]
sconcat = union . NE.toList
instance Vector v => Monoid (Model v) where
mempty = Solid $ Box 0 0 0
mappend a b = union [a, b]
mconcat = union
infixl 8 #
(#) = flip ($)