scala-logo-with-base.hs

{- stack script --resolver lts-23.15 
    --package linear
    --package waterfall-cad
    --extra-dep waterfall-cad-0.6.3.0
    --extra-dep opencascade-hs-0.6.3.0
-}

-- short-description: Scala Logo
--
-- description: It's the Scala logo, but it's designed in Haskell
--
-- image: https://doscienceto.it/blog/photos/scala-logo-02.jpg
-- image: https://doscienceto.it/blog/photos/scala-logo-03.jpg

import qualified Waterfall
import Linear
import Control.Lens ((^.))
import Data.Function ((&))

-- References:
-- 1. A. Riskus, "Approximation of a Cubic Bezier Curve by Circular Arcs and Vice Versa"
-- 2. Imre Juhasz, "Approximating the helix with rational cubic Bezier curves"
createHelicalArc :: Double -> Double -> Double -> Waterfall.Path 
createHelicalArc r pitch incAngle =
  let alpha = incAngle / 2 -- half included angle
      p = pitch/(2* pi) --  helix height per radian
      ax = r * cos alpha
      ay = r * sin alpha
      b = p * alpha * (r - ax) * (3*r - ax)/(ay * (4*r - ax) * tan alpha)
      b0 = V3 ax (negate ay) (negate alpha*p)
      b1 = V3 ((4*r - ax)/3) (negate $ (r - ax)*(3*r - ax)/(3*ay)) (negate b)
      b2 = V3 ((4*r - ax)/3) ((r - ax)*(3*r - ax)/(3*ay)) b
      b3 = V3 ax ay (alpha*p)
  in Waterfall.bezier b0 b1 b2 b3

scalaLogo :: Waterfall.Solid
scalaLogo = 
    let radius = 20 
        pitch = 20
        segmentsPerTurn = 8
        segmentsPerTurn' = fromIntegral segmentsPerTurn
        incAngle = 2 * pi / segmentsPerTurn'
        incHeight = pitch / segmentsPerTurn'
        segment = createHelicalArc radius pitch incAngle
        oneStep = Waterfall.translate (incHeight *^ unit _z) . Waterfall.rotate (unit _z) incAngle
        totalSegments = 5 * segmentsPerTurn `div` 2 
        path = mconcat . take totalSegments . iterate oneStep $ segment
        profile = Waterfall.uScale2D 7.5 Waterfall.unitCircle
        mask = Waterfall.scale (V3 radius radius 150) Waterfall.centeredCylinder `Waterfall.difference`
            Waterfall.scale (V3 (radius-2.5) (radius-2.5) 200) Waterfall.centeredCylinder
        logo = Waterfall.rotate (unit _z) (pi + incAngle/2) 
                (Waterfall.sweep path profile `Waterfall.intersection` mask)
        Just (V3 _ _ minZ, _) = Waterfall.axisAlignedBoundingBox logo
    in Waterfall.translate (negate minZ *^ unit _z) logo

lsugBase :: Waterfall.Font -> Waterfall.Solid
lsugBase font = 
    let mkText = Waterfall.rotate (unit _x) (pi/2) . Waterfall.prism 2 . Waterfall.text font
        textLines = mkText <$> reverse ["London", "Scala", "User", "Group"]
        allText = mconcat $ zipWith (Waterfall.translate . (V3 0 0)) [5, 12  .. ] textLines
        sideL = 50
        sideH = 31
        bevelCondition :: (V3 Double, V3 Double) -> Maybe Double
        bevelCondition (v1, v2) = 
            if ((v1 ^. _z) == 0) && ((v2 ^. _z) == 0)
                then Nothing
                else if ((v1 ^. _xy) == (v2 ^. _xy)) 
                        then Just 10
                        else Just 2   
        box = Waterfall.centeredCube 
            & Waterfall.translate (0.5 *^ unit _z)
            & Waterfall.scale (V3 sideL sideL sideH)
            & Waterfall.roundConditionalFillet bevelCondition
        coinGap = Waterfall.scale (V3 15 15 12) Waterfall.centeredCylinder
        positionedText = Waterfall.translate ((1 - sideL/2) *^ unit _y) allText
        positionedLogo = Waterfall.translate ((sideH - 5) *^ unit _z) scalaLogo
     in (box `Waterfall.difference` (positionedText <> coinGap)) <> positionedLogo


subtleBase :: Waterfall.Solid
subtleBase = 
    let r = 18
        h = 5
        coinGap = Waterfall.scale (V3 15 15 8) Waterfall.centeredCylinder
     in Waterfall.centeredCylinder 
            & Waterfall.translate (unit _z /2)
            & Waterfall.scale (V3 r r h)
            & (`Waterfall.difference` coinGap )
            & (<> scalaLogo)


main :: IO ()
main = do
    font <- Waterfall.fontFromSystem "monospace" Waterfall.Regular 8
    Waterfall.writeSTL 0.25 "scala-logo-lsug-base.stl" (lsugBase font)
    Waterfall.writeSTL 0.25 "scala-logo-subtle-base.stl" subtleBase