fidget-spinner-generator.hs

import qualified Waterfall as W
import Linear
import Control.Lens

loadFont :: IO W.Font
loadFont = W.fontFromPath "/home/joseph/.fonts/GothamRounded-Bold.otf" 40

bearingHeight = 7

totalHeight = 7 + 4

joinerT = 6

bearingT = 2

bearingR = 11

bearingInnerR = 7.5 / 2

outerR = bearingR + bearingT

bearingPlug :: W.Solid
bearingPlug = mconcat 
    [ W.scale (V3 (bearingR - 0.5) (bearingR - 0.5) 2) $ W.unitCylinder
    , W.scale (V3 bearingInnerR bearingInnerR 4) . W.translate ((-0.5) *^ unit _z) $ W.unitCylinder
    , W.scale (V3 (bearingInnerR + 1) (bearingInnerR + 1) 1) $ W.centeredCylinder
    ]

spinner :: W.Font -> String -> (W.Solid, W.Solid)
spinner font content =
    let f (a, b) = 
            if (not (nearZero (a ^. _z))) && nearZero ((a-b) ^. _z) 
                then Just 1
                else Nothing
        name = W.roundConditionalFillet f $ W.prism totalHeight $ W.text font content
        Just (V3 _ minY _, V3 maxX maxY _) = W.axisAlignedBoundingBox name
        name' = W.translate ((negate (maxY + minY)/2) *^ unit _y) name
        joiner = 
            W.centeredCube 
                & W.translate (0.5 *^ unit _z)
                & W.scale (V3 (2*(maxX-4)) joinerT bearingHeight)
        
        spaceOut solid = mconcat
            [   W.translate ((dy * (maxX - bearingR) ) *^ unit _x)
                    $ solid
                | dy <- [-1, 0, 1]
            ]
        bearingOuter = 
            spaceOut  
            . W.scale (V3 outerR outerR bearingHeight) 
            $ W.unitCylinder

        bearingHoles = 
            W.translate (0.01)
            . spaceOut  
            . W.scale (V3 bearingR bearingR 100) 
            $ W.centeredCylinder
        outer = (name' <> joiner <> bearingOuter) `W.difference` bearingHoles
        bearings = spaceOut bearingPlug
        
        bearingMasks = 
            spaceOut  
            . W.translate (bearingHeight *^ unit _z)
            . W.scale (V3 (bearingR-0.5) (bearingR-0.5) 100) 
            $ W.unitCylinder
        maskedName = W.translate ((-bearingHeight) *^ unit _z)(bearingMasks `W.intersection` name')
        inner = W.translate (bearingHeight *^ unit _z)(maskedName <> bearings)
    in (outer, inner)

save :: String -> (W.Solid, W.Solid) -> IO ()
save name (outer, inner) =  do
    let write = W.writeSTL 0.01 
    write (name <> "-fidget-spinner.stl") outer
    write (name <> "-fidget-spinner-disks.stl") inner
    print name

main :: IO ()
main = do
    font <- loadFont 
    save "ben" (spinner font "BEN")
    save "alex" (spinner font "ALEX")
    save "ivy" (spinner font "IVY")
    W.writeSTL 0.01 "bearing-plug.stl" bearingPlug