haskell-gimbal-keyring.hs

Keyring intended as a give-away at a conference

gimbal-keyring.stl

raw haskell source 

#!/usr/bin/env stack
{- stack script --resolver lts-23.15 
    --package linear
    --package waterfall-cad
    --extra-dep waterfall-cad-0.6.1.0
    --extra-dep opencascade-hs-0.6.1.0
-}

-- short-description: Haskell Gimbal Toy 
--
-- description: Keyring intended as a give-away at a conference
--
-- image: https://doscienceto.it/blog/photos/haskell-gimbal-01.jpg
-- image: https://doscienceto.it/blog/photos/haskell-gimbal-02.jpg
import qualified Waterfall
import Linear 
import Control.Lens

haskellLogo = 
    let paths = [
            Waterfall.pathFrom (V2 0 12)
                [ Waterfall.lineTo (V2 4 6)
                , Waterfall.lineTo (V2 0 0)
                , Waterfall.lineTo (V2 3 0)
                , Waterfall.lineTo (V2 7 6)
                , Waterfall.lineTo (V2 3 12)
                ],
            Waterfall.pathFrom (V2 4 0)
                [ Waterfall.lineTo (V2 8 6)
                , Waterfall.lineTo (V2 4 12)
                , Waterfall.lineTo (V2 7 12)
                , Waterfall.lineTo (V2 15 0)
                , Waterfall.lineTo (V2 12 0)
                , Waterfall.lineTo (V2 9.5 3.75)
                , Waterfall.lineTo (V2 7 0)
                ], 
             Waterfall.pathFrom (V2 13.66 3.5)
                [ Waterfall.lineTo (V2 12.333 5.5)
                , Waterfall.lineTo (V2 17 5.5)
                , Waterfall.lineTo (V2 17 3.5)
                ],
            Waterfall.closeLoop $ Waterfall.pathFrom (V2 11.666 6.5)
                [ Waterfall.lineTo (V2 10.333 8.5)
                , Waterfall.lineTo (V2 17 8.5)
                , Waterfall.lineTo (V2 17 6.5)
                ]
            ]
        logo = mconcat . fmap (Waterfall.prism 3 . Waterfall.makeShape . Waterfall.closeLoop) $ paths
        Just (lo, hi) = Waterfall.axisAlignedBoundingBox logo
        w = (hi - lo) ^. _x
        m = Waterfall.centerOfMass logo
    in Waterfall.scale (V3 1 1 10) 
            . Waterfall.uScale ( 0.55* ((r-(segWidth +gapWidth))*2 ) / w ) 
            . Waterfall.translate (negate m) 
            $ logo

h :: Double 
h = 12

r :: Double 
r = 20

segWidth :: Double
segWidth = 3

gapWidth :: Double 
gapWidth = 0.5

insetWidth :: Double 
insetWidth = 2.5

heightMask :: Waterfall.Solid
heightMask = Waterfall.scale (V3 (r*6) (r*6) h) Waterfall.centeredCube

coneMask :: Waterfall.Solid
coneMask = Waterfall.scale (V3 20 (r*6) h) Waterfall.centeredCube


cone :: Double -> Waterfall.Solid 
cone r = 
        Waterfall.intersection coneMask
        . Waterfall.uScale r  
        . Waterfall.rotate (unit _x) (pi/2)
        . Waterfall.translate (negate $ unit _z) 
        $ Waterfall.unitCone 

cones :: Double -> Waterfall.Solid 
cones r = 
        mconcat $ 
            [ Waterfall.rotate (unit _z) t $ cone r
            | t <- [0, pi]
            ]

chamfer :: Waterfall.Solid -> Waterfall.Solid
chamfer = Waterfall.chamfer 1 

ringHole :: Waterfall.Solid
ringHole = 
    let hole = Waterfall.translate (unit _y ^* (r - segWidth/2 - 0.25))
                . Waterfall.scale (V3 1.5 0.75 100)
                $ Waterfall.centeredCylinder

        holeH = 5
        divots = mconcat 
            [
                 Waterfall.translate (unit _y ^* (r - segWidth/2 - 0.25) + unit _z^* v)
                 . Waterfall.rotate (unit _x) (-pi/2)
                . Waterfall.scale (V3 1.5 1.5 100)
                $ Waterfall.unitCylinder
                | v <- [holeH/2, -holeH/2] 
            ]
        divots' = mconcat 
            [
                 Waterfall.translate (unit _y ^* (r - segWidth/2 - 0.25) + unit _z^* v)
                . Waterfall.scale (V3 3 3 (h-holeH))
                . Waterfall.translate (unit _y ^* (0.5))
                $ Waterfall.centeredCube
                | v <- [h/2, -h/2] 
            ]
    in hole <> divots <> divots'

grip :: Waterfall.Solid
grip =
    let n = 64
    in mconcat
        . take n
        . iterate (Waterfall.rotate (unit _z) (pi * 2 / fromIntegral n))
        . Waterfall.rotate (unit _y) (pi/6) 
        . Waterfall.translate (unit _y ^* r)
        . Waterfall.scale (V3 0.5 0.5 100)
        $ Waterfall.centeredCylinder

gimbalSegmentA :: Waterfall.Solid 
gimbalSegmentA = 
    let outerSphere = Waterfall.uScale r $ Waterfall.unitSphere 
        innerSphere = Waterfall.uScale (r - segWidth) $ Waterfall.unitSphere
        cutout = Waterfall.rotate (unit _z) (pi/2) $ cones (r + insetWidth - segWidth)
        filleted = chamfer ((outerSphere `Waterfall.intersection` heightMask) `Waterfall.difference` innerSphere)
    in filleted `Waterfall.difference` (cutout <> ringHole <> grip)

    
gimbalSegmentB :: Waterfall.Solid 
gimbalSegmentB = 
    let outerSphere = Waterfall.uScale (r - segWidth - gapWidth) $ Waterfall.unitSphere 
        innerSphere = Waterfall.uScale (r - segWidth * 2 - gapWidth ) $ Waterfall.unitSphere
        pin = (Waterfall.rotate (unit _z) (pi/2) $ cone (r + insetWidth - segWidth - gapWidth))
                `Waterfall.difference` (Waterfall.uScale (r - segWidth * 1.55 - gapWidth ) $ Waterfall.unitSphere)
        pin' = Waterfall.rotate (unit _z) (pi-0.001) pin
        cutout = cones (r + insetWidth - segWidth *2 - gapWidth)
        filleted = chamfer $ (outerSphere `Waterfall.intersection` heightMask) `Waterfall.difference` (innerSphere)
    in (filleted `Waterfall.difference` cutout) <> (pin <> pin')


gimbalSegmentC :: Waterfall.Solid 
gimbalSegmentC = 
    let outerSphere = Waterfall.uScale (r - segWidth * 2 - gapWidth * 2 ) $ Waterfall.unitSphere 
        pin = cones (r + insetWidth - segWidth *2 - gapWidth*2)
        face = chamfer (outerSphere `Waterfall.intersection` heightMask)
    in (face <> pin) `Waterfall.difference` haskellLogo

gimbalSegments :: Waterfall.Solid
gimbalSegments = gimbalSegmentA <> gimbalSegmentB <> gimbalSegmentC

main :: IO ()
main = Waterfall.writeSTL 0.1 "gimbal-keyring.stl" gimbalSegments