229 lines
6.4 KiB
Haskell
229 lines
6.4 KiB
Haskell
--{-# 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 = (0,0,0,0) -- 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)
|