loop/src/Dodge/Room/Foreground.hs

--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Foreground where
import Dodge.Data
import Picture
import Geometry
import Shape
import Quaternion
import Bound

--import Dodge.Data.ForegroundShape
import Dodge.Default.Foreground
import Data.List
import Data.Maybe
import Control.Lens
import ShapePicture
import Streaming
import qualified Streaming.Prelude as S

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

diagonalLinesRect 
    :: Point2 
    -> Point2 
    -> Float    -- ^ width
    -> Float    -- ^ vertical distance between lines
    -> 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 
    :: Float -- ^ height
    -> Float -- ^ distance between cross bars
    -> Float -- ^ width
    -> 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

girderVCapL
    :: Float -- ^ "cap" size
    -> Float -- ^ height
    -> Float -- ^ distance between cross bars
    -> Float -- ^ width
    -> Point2 -> Point2 -> Shape
girderVCapL csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
    <> girderV h d w x y
  where
    n = csize *.* vNormal (normalizeV (x -.- y))

girderVCapLR
    :: Float -- ^ "cap" size
    -> Float -- ^ height
    -> Float -- ^ distance between cross bars
    -> Float -- ^ width
    -> Point2 -> Point2 -> Shape
girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
    <> thinHighBar h (y -.- n) (y +.+ n)
    <> girderV h d w x y
  where
    n = csize *.* vNormal (normalizeV (x -.- y))

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

shapePoints :: Shape -> Stream (Of Point2) Identity ()
shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)

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'
    :: Float -- ^ height
    -> Float -- ^ distance between cross bars
    -> Float -- ^ width
    -> 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 
    :: Float -- ^ height
    -> Float -- ^ distance between cross bars
    -> Float -- ^ width
    -> 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
    :: Float -- ^ height
    -> Float -- ^ distance between cross bars
    -> Float -- ^ width
    -> 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

robotArm :: Shape
robotArm = undefined

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)