loop/src/Dodge/Room/Foreground.hs

module Dodge.Room.Foreground (
    thinHighBar,
    putShape,
    girder,
    girderZ,
    girderV,
    girderV',
    barPP,
    highDiagonalMesh,
    highMesh,
) where

import Bound
import Control.Lens
import Data.List
import Data.Maybe
import Dodge.Data.GenWorld
import Dodge.Default.ForegroundShape
import Geometry
import Picture
import Quaternion
import Shape
import ShapePicture

highMesh ::
    Point2 ->
    Point2 ->
    -- | width
    Float ->
    Picture
highMesh pa pb w =
    highDiagonalMesh pa pb w 20
        <> highDiagonalMesh (pa +.+ w *.* normalizeV (vNormal (pb -.- pa))) pa (dist pa pb) 20

highDiagonalMesh ::
    Point2 ->
    Point2 ->
    -- | width
    Float ->
    -- | vertical distance between lines
    Float ->
    Picture
highDiagonalMesh pa pb w d =
    setDepth 100 $
        pictures $
            map (thickLine 2 . tflat2) (diagonalLinesRect pb pa w d (3 * pi / 4))
                ++ map (thickLine 2 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi / 4))
  where
    pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa))
    h = dist pa pb

diagonalLinesRect ::
    Point2 ->
    Point2 ->
    -- | width
    Float ->
    -- | vertical distance between lines
    Float ->
    Float ->
    [(Point2, Point2)]
diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
  where
    xVec = negate w *.* vNormal (normalizeV $ pb -.- pa)
    diVec = rotateV ang xVec
    pax = pa +.+ xVec
    pbx = pb +.+ xVec
    lhsPoints = divideLineExact d (pa -.- yN) (pb +.+ yN)
    findDiPoint p =
        head . sortOn (dist p) $
            catMaybes
                [ intersectLineLine' p (p +.+ diVec) pax pbx
                , intersectSegLine pa pax p (p +.+ diVec)
                , intersectSegLine pb pbx p (p +.+ diVec)
                ]
    yN = d * 0.5 *.* normalizeV (pa -.- pb)

thinHighBar :: Float -> Point2 -> Point2 -> Shape
thinHighBar = highBar 3

--thinHighBarLoop :: Float -> [Point2] -> Shape
--thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs

--thinHighBarChain :: Float -> [Point2] -> Shape
--thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs

--thickHighBar :: Float -> Point2 -> Point2 -> Shape
--thickHighBar = highBar 5

highBar :: Float -> Float -> Point2 -> Point2 -> Shape
highBar thickness h x y =
    translateSHz h $
        colorSH orange $
            upperPrismPoly
                thickness
                [x +.+ n, y +.+ n, y -.- n, x -.- n]
  where
    n = 0.5 * thickness *.* normalizeV (vNormal (y -.- x))

--highPipe :: Float -> Point2 -> Point2 -> Shape
--highPipe h x y = colorSH orange $ prismPoly
--    (map (addZ (h + 5)) [x +.+ n2, y +.+ n2, y -.- n2, x -.- n2])
--    (map (addZ h)       [x +.+ n, y +.+ n, y -.- n, x -.- n]    )
--  where
--    n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
--    n = 2.5 *.* normalizeV (vNormal (y -.- x))

girderZ ::
    -- | height
    Float ->
    -- | distance between cross bars
    Float ->
    -- | width
    Float ->
    Point2 ->
    Point2 ->
    Shape
girderZ h d w x y =
    colorSH red $
        mconcat $
            [ thinHighBar h xt yt
            , thinHighBar h xb yb
            ]
                <> zipWith (thinHighBar (h - 1)) ps qs
  where
    n = w *.* normalizeV (vNormal $ y -.- x)
    xb = x +.+ n
    yb = y +.+ n
    xt = x -.- n
    yt = y -.- n
    ps = divideLineExact d xb yb
    qs = tail $ divideLineExact d xt yt

putShape :: Shape -> PSType
putShape sh =
    PutForeground $
        defaultForeground
            & fsPos .~ m
            & fsRad .~ radBounds bnds
            & fsSPic .~ noPic (uncurryV translateSHxy (- m) sh)
  where
    bnds = shapeBounds sh
    m = midBounds bnds

shapePoints :: Shape -> [Point2]
shapePoints = concatMap (map stripZ . _sfVs)

shapeBounds :: Shape -> (Float, Float, Float, Float)
shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints

midBounds :: (Float, Float, Float, Float) -> Point2
midBounds (n, s, e, w) = V2 ((n + s) / 2) ((e + w) / 2)

radBounds :: (Float, Float, Float, Float) -> Float
radBounds (n, s, e, w) = max (n - s) (e - w) / 2

girderV' ::
    -- | height
    Float ->
    -- | distance between cross bars
    Float ->
    -- | width
    Float ->
    Point2 ->
    Point2 ->
    ForegroundShape
girderV' h d w x y =
    defaultForeground
        & fsPos .~ m
        & fsRad .~ dist m x
        & fsSPic .~ noPic sh
  where
    m = midPoint x y
    x' = x - m
    y' = y - m
    sh =
        thinHighBar h (x' -.- n) (x' +.+ n)
            <> thinHighBar h (y' -.- n) (y' +.+ n)
            <> girderV h d w x' y'
    n = min (w + 10) 20 *.* vNormal (normalizeV (x' -.- y'))

girderV ::
    -- | height
    Float ->
    -- | distance between cross bars
    Float ->
    -- | width
    Float ->
    Point2 ->
    Point2 ->
    Shape
girderV h d w x y =
    mconcat $
        [ thinHighBar h xt yt
        , thinHighBar h xb yb
        ]
            <> zipWith (thinHighBar (h - 1)) ps qs
  where
    n = w *.* normalizeV (vNormal $ y -.- x)
    xb = x +.+ n
    yb = y +.+ n
    xt = x -.- n
    yt = y -.- n
    ps = evenDouble $ divideLineExact d xb yb
    qs = head qs' : evenDouble (tail qs')
      where
        qs' = divideLineExact d xt yt
    evenDouble (a : _ : xs) = a : a : evenDouble xs
    evenDouble xs = xs

girder ::
    -- | height
    Float ->
    -- | distance between cross bars
    Float ->
    -- | width
    Float ->
    Point2 ->
    Point2 ->
    Shape
girder h d w x y =
    mconcat $
        [ thinHighBar h xt yt
        , thinHighBar h xb yb
        ]
            <> zipWith (thinHighBar (h - 1)) ps qs
  where
    n = w *.* normalizeV (vNormal $ y -.- x)
    xb = x +.+ n
    yb = y +.+ n
    xt = x -.- n
    yt = y -.- n
    ps = divideLineExact d xb yb
    qs = divideLineExact d xt yt

barPP :: Float -> Point3 -> Point3 -> Shape
barPP w a b
    | a == b = mempty
    | otherwise =
        prismPoly
            (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
            (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w)
  where
    z1 = b -.-.- a

--pipePP :: Float -> Point3 -> Point3 -> Shape
--pipePP w a b = prismPoly
--    (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
--    (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
--  where
--    z1 = b -.-.- a

--tankTopPipe :: Shape
--tankTopPipe = colorSH orange $
--    upperPrismPoly 31 (polyCirc 4 20)
--    <> prismPoly
--        (map (addZ 41) $ polyCirc 4 5)
--        (map (addZ 31) $ polyCirc 4 20)
----    <> pipePP 5 (V3 0 0 51) (V3 0 0 41)