hook.hs

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

import qualified Waterfall as W
import Linear
import Data.Function ((&))

-- short-description: Parametric Hook 
--
-- description: In 2018, I designed [a parametric hook](https://www.thingiverse.com/thing:2811955) using OpenSCAD.
-- description: 
-- description: This is a Haskell port of that design, with some minor changes.

properties = HookProperties 
    { hookRadius = 0.25
    , sweepRadius = 1.25
    , sweepAngle = degrees 200
    , hoopRadius = 0.25
    , hoopHeight = 2
    , nHooks = 3
    , arrowheadProperties = ArrowheadProperties 
        { arrowheadWidth = 1
        , arrowheadHeight = 1.2
        , arrowheadNotchDepth = 0.5
        , arrowheadAngle = degrees 0
        }
    }

data ArrowheadProperties = ArrowheadProperties
    { arrowheadWidth :: Double 
    , arrowheadHeight :: Double 
    , arrowheadNotchDepth :: Double
    , arrowheadAngle :: Double
    }

data HookProperties = HookProperties 
    { hookRadius :: Double
    , sweepRadius :: Double
    , sweepAngle :: Double
    , hoopRadius :: Double 
    , hoopHeight :: Double
    , nHooks :: Int
    , arrowheadProperties :: ArrowheadProperties
    }

degrees :: Double -> Double 
degrees = (* (pi / 180))

arrowhead :: Double -> ArrowheadProperties -> W.Solid
arrowhead hookRadius (ArrowheadProperties {..})= 
    -- | set the arrowhead thickness, such that, for a given width,
    -- the edge of the hook is tangent to the surface of the arrowhead 
    let y = arrowheadWidth / 2 
        l = y * arrowheadHeight / (arrowheadHeight + arrowheadNotchDepth)
        theta = asin (hookRadius / l)
        x = hookRadius / (cos theta)
    in W.pointedLoft Nothing
            [ W.closeLoop $ W.pathFrom (x *^ unit _x)
                [ W.lineTo 
                    (y  *^ unit _y 
                    - arrowheadNotchDepth *^ unit _z)
                , W.lineTo (negate (x *^ unit _x))
                ]
            ]
            (Just (arrowheadHeight *^ unit _z))
        & mconcat [id, W.mirror (unit _y)]
        & W.rotate (unit _z) arrowheadAngle

hook :: HookProperties -> W.Solid
hook (HookProperties {..})= mconcat 
    [ W.torus (hoopRadius + hookRadius) hookRadius
        & W.rotate (unit _x) (pi/2)
        & W.translate ((hoopHeight + hoopRadius + hookRadius) *^ unit _z)
    , W.unitCylinder 
        & W.scale (V3 hookRadius hookRadius hoopHeight)
    , let v = (negate sweepRadius *^ unit _x)
          rotate = W.rotate (negate $ unit _y)
          sweepPath = 
                ( let                   
                  in W.arcVia v (rotate (sweepAngle/2) v) (rotate sweepAngle v)
                )
          arrowheadPosition = maybe (error "failed to get pathEndpoints" ) snd $ W.pathEndpoints sweepPath
          positionedArrowhead = 
                arrowhead hookRadius arrowheadProperties
                    & W.rotate (unit _y) (pi-sweepAngle)
                    & W.translate arrowheadPosition
      in W.sweep sweepPath (W.uScale2D hookRadius W.unitCircle )
            & (<> positionedArrowhead)
            & W.translate (sweepRadius *^ unit _x)
            & iterate (W.rotate (unit _z) (pi * 2 / fromIntegral nHooks))
            & take nHooks 
            & mconcat
    ]

hook' :: W.Solid
hook' = hook properties

main :: IO ()
main = W.writeSTL 0.01 "hook.stl" hook'