haskell-fidget.hs
Keyring intended as a give-away at a conference
#!/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 Fidget Toy
--
-- description: Keyring intended as a give-away at a conference
--
-- image: https://doscienceto.it/blog/photos/haskell-fidget-01.jpg
import qualified Waterfall
import Linear
import Control.Lens
circlePath :: Waterfall.Path
circlePath = Waterfall.fromPath2D . mconcat . Waterfall.shapePaths $ Waterfall.unitCircle
hoop :: Waterfall.Solid
hoop =
-- Waterfall.translate (unit _z ^* 1.5 )
-- . (`Waterfall.intersection` (Waterfall.scale (V3 100 100 3) Waterfall.centeredCube))
Waterfall.sweep (Waterfall.uScale 4 $ circlePath) (Waterfall.unitCircle)
pathToSolid :: Waterfall.Path2D -> Waterfall.Solid
pathToSolid = Waterfall.prism 12 . Waterfall.uScale2D 3 . Waterfall.makeShape . Waterfall.closeLoop
pivotOutline :: Waterfall.Shape
pivotOutline = Waterfall.uScale2D 4 . Waterfall.makeShape . Waterfall.closeLoop $
Waterfall.pathFrom (V2 (-1) (-1.4))
[ Waterfall.lineTo (V2 (-1) 0)
, Waterfall.arcViaTo (V2 0 1) (V2 1 0)
, Waterfall.lineTo (V2 1 (-1.4))
]
pivotL = 3
pivotG = 1
negOffset = 0.5
filletR = 0.5
pivotA :: Waterfall.Solid
pivotA =
let b = Waterfall.prism pivotL pivotOutline
barL = pivotL *3 + pivotG
bar = Waterfall.scale (V3 1.5 1.5 barL) $ Waterfall.unitCylinder
in Waterfall.rotate (unit _x) (pi/2)
. Waterfall.roundFillet filletR
.Waterfall.rotate (unit _z) (pi/2)
. Waterfall.translate (unit _z ^* (-barL /2 ))
$ (b <> bar <> Waterfall.translate (unit _z ^* (pivotL * 2 + pivotG)) b)
pivotA' :: Waterfall.Solid
pivotA' =
let b = Waterfall.offset negOffset $ Waterfall.prism pivotL pivotOutline
barL = pivotL *3 + pivotG
bar = Waterfall.scale (V3 3 3 barL) $ Waterfall.unitCylinder
in Waterfall.rotate (unit _x) (pi/2)
.Waterfall.rotate (unit _z) (pi/2)
. Waterfall.translate (unit _z ^* (-barL /2 ))
$ (b <> bar <> Waterfall.translate (unit _z ^* (pivotL * 2 + pivotG)) b)
pivotB :: Waterfall.Solid
pivotB =
let b = Waterfall.prism pivotL (pivotOutline `Waterfall.difference` (Waterfall.uScale2D 1.75 Waterfall.unitCircle))
in Waterfall.rotate (unit _x) (pi/2)
. Waterfall.roundFillet filletR
.Waterfall.rotate (unit _z) (-pi/2)
. Waterfall.translate (unit _z ^* (-pivotL/2 ))
$ b
pivotB' :: Waterfall.Solid
pivotB' =
let b = Waterfall.prism pivotL pivotOutline
in Waterfall.rotate (unit _x) (pi/2)
. Waterfall.offset negOffset
.Waterfall.rotate (unit _z) (-pi/2)
. Waterfall.translate (unit _z ^* (-pivotL/2 ))
$ b
hoopPos = V3 0 (12*3) (12/2)
pivot1Pos = V3 21.5 (6*3) (12/2)
pivot2Pos = V3 34 (6*3) (12/2)
crossbeamPos = V3 40 (6*3) (12/2)
partA' :: Waterfall.Solid
partA' = pathToSolid $
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)
]
partA :: Waterfall.Solid
partA =
(partA' `Waterfall.difference` (Waterfall.translate pivot1Pos pivotA' <> Waterfall.translate hoopPos hoop))
<> Waterfall.translate pivot1Pos pivotB
-- <> Waterfall.translate hoopPos hoop
partB' :: Waterfall.Solid
partB' = pathToSolid $
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)
]
partB :: Waterfall.Solid
partB = (partB' `Waterfall.difference` (Waterfall.translate pivot1Pos pivotB' <> Waterfall.translate pivot2Pos pivotA'))
<> Waterfall.translate pivot1Pos pivotA <> Waterfall.translate pivot2Pos pivotB
partC1' = pathToSolid $
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)
]
partC2' = pathToSolid $
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)
]
crossbeam :: Waterfall.Solid
crossbeam =
Waterfall.rotate (unit _x) (pi/2)
. Waterfall.scale (V3 1.5 1.5 10)
$ Waterfall.centeredCylinder
partC :: Waterfall.Solid
partC = ((partC1' <> partC2') `Waterfall.difference` (Waterfall.translate pivot2Pos pivotB'))
<> Waterfall.translate pivot2Pos pivotA
<> Waterfall.translate crossbeamPos crossbeam
object :: Waterfall.Solid
object = partA <> partB <> partC
main :: IO ()
main = Waterfall.writeSTL 0.1 "haskell-fidget.stl" object