compounds-of-polyhedra-tree-ornaments.hs

import qualified Waterfall as W
import Linear 

phi :: Double
phi = (1 + sqrt 5) / 2

rotateIntoPlace = W.rotate (V3 1 1 0) (unangle (V2 1 (sqrt 2)) - pi)
            . W.rotate (unit _z) (-pi/4)

rotateBack = W.rotate (unit _z) (pi/4)
    . W.rotate (V3 1 1 0) (pi - unangle (V2 1 (sqrt 2)))

sideLength = 40

addHoop :: W.Solid -> W.Solid
addHoop compound = 
    let Just (_, V3 _ _ h) = W.axisAlignedBoundingBox compound
        hoop = 
            W.translate (h *^ unit _z)
                . W.rotate (unit _x) (pi/2) 
                $ W.torus 6 2
    in compound <> hoop

compoundOfFive :: W.Solid -> W.Solid
compoundOfFive = 
    let axis = V3 1 phi 0
        angle = 2 * pi / 5
        theta = unangle (V2 1 phi)
        tetrahedron = rotateIntoPlace W.tetrahedron
     in mconcat . take 5 . iterate (W.rotate axis angle)

rotateCubes = W.rotate (unit _y) ((unangle (V2 2 (sqrt 3)))/2)

rotateBackCubes = W.rotate (unit _y) (unangle (V2 1 phi) - (unangle (V2 2 (sqrt 3)))/2)

cubes :: W.Solid
cubes = rotateCubes $ compoundOfFive W.centeredCube


-- make the cubes a little smaller, because otherwise they're huge
-- using sqrt 2 as a scale factor makes the face diagonal of the cubes
-- the same length as the tetrahedron edge
ornamentCubes :: W.Solid
ornamentCubes = addHoop $ W.uScale (sideLength/sqrt 2) cubes

-- The compound of five cubes is special amongst these ornaments
-- because one of their sides is _relatively_ flat
-- they can be printed in one piece
-- this clips a little part of one flat surface of the cubes
-- which makes that lie on the build plate better
clip :: Double -> W.Solid -> W.Solid
clip h s = 
    let Just (V3 _ _ lo, _) = W.axisAlignedBoundingBox s 
        mask = 
            W.translate ((lo+h) *^ unit _z)
            . W.uScale 100 
            . W.translate (0.5 *^ unit _z) $ W.centeredCube
    in mask `W.intersection` s

clippedOrnamentCubes :: W.Solid
clippedOrnamentCubes = clip 0.5 . rotateBackCubes $ ornamentCubes


tetrahedra :: W.Solid 
tetrahedra = rotateBack . compoundOfFive . rotateIntoPlace $ W.tetrahedron


ornamentA :: W.Solid
ornamentA = addHoop $ W.uScale sideLength tetrahedra

split :: W.Solid -> W.Solid
split s = 
    let mask = 
            W.uScale 100
            . W.translate (0.5 * unit _z) 
            $ W.centeredCube
        hole = W.uScale 8 W.centeredCube
        joiner = W.uScale 7.5 W.unitCube
        top = (W.intersection mask s) `W.difference` hole
        bottom = W.rotate (unit _x) pi (s `W.difference` (mask <> hole))
        Just (V3 x0 _ _, V3 x1 _ _) = W.axisAlignedBoundingBox top
        Just (V3 x2 _ _,_) = W.axisAlignedBoundingBox bottom
    in (W.translate ((5 + x1 - x2) *^ unit _x) bottom) 
            <> top 
            <> W.translate ((x0 - 10) *^ unit _x) joiner


tetrahedraB :: W.Solid 
tetrahedraB = 
    let mirror s = s <> W.mirror (unit _z) s 
     in rotateBack . mirror. compoundOfFive . rotateIntoPlace $ W.tetrahedron

ornamentB :: W.Solid
ornamentB = addHoop $ W.uScale sideLength tetrahedraB

ornamentC :: W.Solid
ornamentC = addHoop $ W.uScale sideLength (W.tetrahedron <> W.rotate (unit _y) (pi) W.tetrahedron)

octahedra :: W.Solid 
octahedra = 
    let axis = V3 1 phi 0
        angle = 2 * pi / 5
        theta = unangle (V2 1 phi)
     in compoundOfFive W.octahedron
     
ornamentOctahedra :: W.Solid
ornamentOctahedra = addHoop $ W.uScale sideLength octahedra

main :: IO ()
main = 
    let write = W.writeSTL 0.1
    in write "compound-of-cubes-ornament.stl" ornamentCubes
        <> write "compound-of-cubes-ornament-clipped.stl" (clippedOrnamentCubes)
        <> write "compound-of-cubes-ornament-split.stl" (split ornamentCubes)
        <> write "compound-of-tetrahedra-a-ornament.stl" ornamentA
        <> write "compound-of-tetrahedra-a-ornament-split.stl" (split ornamentA)
        <> write "compound-of-tetrahedra-b-ornament.stl" ornamentB
        <> write "compound-of-tetrahedra-b-ornament-split.stl" (split ornamentB)
        <> write "compound-of-tetrahedra-c-ornament.stl" ornamentC
        <> write "compound-of-tetrahedra-c-ornament-split.stl" (split ornamentC)
        <> write "compound-of-octahedra-ornament.stl" ornamentOctahedra
        <> write "compound-of-octahedra-ornament-split.stl" (split ornamentOctahedra)