2d polyline offset/thickness/closing for waterfall-cad-svg

PathState2D.hs

-- | 2d version of https://gist.github.com/aavogt/8fb7162e572d72049748e1e42b12bbd2
--
-- Example output:
-- https://i.ibb.co/yFBtS903/cup.png
--
-- > p0 = execPath $
-- >   do
-- >     hliner 140
-- >     vliner 160
-- >     hliner 140
-- >     vliner 300
-- >     hliner 40
-- >     closeThick
-- >
-- > p1 = execPath $
-- >   do
-- >     hliner 140
-- >     vliner 160
-- >     hliner 140
-- >     vliner 300
-- >     liner 45 45
-- >     hliner 40
-- >     closeThick
-- >
-- > p2 = execPath $
-- >   do
-- >     hliner 140
-- >     vliner 160
-- >     hliner 140
-- >     vliner 300
-- >     liner 25 85
-- >     hliner 40
-- >     closeThick
--
-- > main =
-- >   writeDiagramSVG "cup.svg" $
-- >         pathDiagram SharpLine Visible p0
-- >           <> translate2D (V2 300 0) (pathDiagram SharpLine Visible p1)
-- >           <> translate2D (V2 600 0) (pathDiagram SharpLine Visible p2)
--
--
-- TODO
-- chamfer/fillet
-- approximate ellipses, arcs
-- union intersection of polygons
-- from point set
module PathState2D
  ( PathState,
    closeLoop,
    closeThick,
    offsetPath,
    getEnds,

    -- ** get a waterfall-cad Path2D
    execPath,
    runPath,

    -- * draw lines

    -- | functions are all named line with additions:
    --
    -- * V takes a V2
    --
    -- * no V takes one or two Doubles
    --
    -- * Relative or r suffix means the coordinates are an offset, vs
    --
    -- * leading l is for functions that grow the start (left end)
    --
    -- * h v are for functions taking a single double, which go horizontal or vertical

    -- ** taking V2
    lineV,
    llineV,
    lineVRelative,
    llineVRelative,

    -- ** taking two doubles
    liner,
    lliner,
    line,
    lline,

    -- ** taking one double
    hliner,
    vliner,
    lvliner,
    lhliner,
  )
where

import Control.Lens
import Control.Monad.Trans.State (State, execState, get, modify, put, runState)
import Data.Foldable
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Linear
import Waterfall.TwoD.Path2D (Path2D, closeLoop2D, line2D, pathEndpoints2D)

-- | Convention: the right end of the Seq is the newer end (current point).
type PathState = State (Seq (V2 Double))

-- | Get (start, end), which are possibly the same point
getEnds :: PathState (Maybe (V2 Double, V2 Double))
getEnds = liftA2 (,) <$> preuse _head <*> preuse _last

-- | Draw a line to absolute point: append vertex
lineV :: V2 Double -> PathState (V2 Double)
lineV p = do
  modify (:> p)
  pure p

-- | Draw a line to absolute point: append vertex to the left
llineV p = do
  modify (p :<)
  pure p

-- | @line x y = lineV (V2 x y)@
line :: Double -> Double -> PathState (V2 Double)
line x y = lineV (V2 x y)

lline :: Double -> Double -> PathState (V2 Double)
lline x y = llineV (V2 x y)

-- | @liner x y = lineVRelative (V2 x y)@
liner :: Double -> Double -> PathState (V2 Double)
liner x y = lineVRelative (V2 x y)

-- | @lliner x y = llineVRelative (V2 x y)@
lliner :: Double -> Double -> PathState (V2 Double)
lliner x y = llineVRelative (V2 x y)

-- | horizontal or vertical lines
hliner, vliner :: Double -> PathState (V2 Double)
hliner x = liner x 0
vliner y = liner 0 y

lvliner, lhliner :: Double -> PathState (V2 Double)
lvliner y = lliner 0 y
lhliner x = lliner x 0

-- | Draw a lineV to a point relative to current end (or origin)
lineVRelative :: V2 Double -> PathState (V2 Double)
lineVRelative dp = maybe (lineV dp) (lineV . (+ dp)) =<< preuse _last

-- | Draw a llineV relative to the current beginning
llineVRelative dp = maybe (llineV dp) (llineV . (+ dp)) =<< preuse _head

-- | Close loop by appending the start vertex if not already equal
closeLoop :: PathState ()
closeLoop = do
  mse <- getEnds
  case mse of
    Just (s, e) | s /= e -> modify (:> s)
    _ -> pure ()

closeThick1 :: [V2 Double] -> [V2 Double] -> [V2 Double]
closeThick1 (a : b : c : d : ds) accum = closeThick1 (p : c : d : ds) (p : accum)
  where
    -- path bisector at c
    q = angle $ (/ 2) $ unangle (d - c) + unangle (b - c)
    r = b - c

    V2 s t = luSolveFinite (transpose $ V2 q r) (c - a)
    p = c - s *^ q
closeThick1 [a, b, c] accum = c : perpCap : accum
  where
    -- other options might involve the same orientation
    -- as the initial cap, or the same relative orientation
    -- as the initial cap
    perpCap = project (perp (c - b)) (a - b) + c

-- | completes the second half of a 2d profile. The cap that determines the
-- profile thickness is the last segment drawn, and a right angled cap of the
-- same size is added as the very last segment that closes the loop.
closeThick :: PathState ()
closeThick = do
  let r ps = Seq.fromList $ reverse $ closeThick1 (toList (Seq.reverse ps)) []
  modify (\e -> e <> r e)

-- | @offset h@ replaces the current path with offset profile of thickness 2h.
-- The caps are perpendicular and straight also extending h beyond the end points
-- returns the old line.
offsetPath :: Double -> PathState (Seq (V2 Double))
offsetPath h = (id <<%= offset1 h) <* closeLoop

offset1 :: Double -> Seq (V2 Double) -> Seq (V2 Double)
offset1 h (toList -> abbs) = Seq.fromList $ closeThick1 upp $ closeThick1 downp []
  where
    upp = addH h abbs
    downp = addH h (reverse abbs)

    -- addH1 on both ends
    addH h abbs = addH1 h $ reverse $ addH1 h $ reverse abbs

    -- add an extra h-length segment to the left end
    addH1 :: Double -> [V2 Double] -> [V2 Double]
    addH1 h abbs@(a : b : _) = (a + h *^ normalize (perp (a - b))) : abbs

execPath :: PathState a -> Path2D
execPath st =
  foldl
    (\p ab -> p <> uncurry line2D ab)
    mempty
    $ pairs
    $ execState st mempty

runPath :: PathState a -> (a, Path2D)
runPath st =
  foldl
    (\p ab -> p <> uncurry line2D ab)
    mempty
    . pairs
    <$> runState st mempty

pairs :: Seq (V2 Double) -> [(V2 Double, V2 Double)]
pairs s = zip (toList s) (drop 1 (toList s))