Add some girders

This commit is contained in:
2021-06-21 17:49:18 +02:00
parent c2297cd114
commit 52eaeead5d
3 changed files with 55 additions and 2 deletions
+52
View File
@@ -1,6 +1,7 @@
module Dodge.Room.Foreground
where
import Dodge.Picture
import Dodge.Base
import Picture
import Geometry
import Geometry.Data
@@ -52,5 +53,56 @@ highPipe x y = pictures
,verticalPipe 5 orange (0.5 *.* (x +.+ y)) (-0.1) (-0.2)
]
girderZ :: Float -> Point2 -> Point2 -> Picture
girderZ w x y = setDepth (-0.1) $ color red $ pictures $
[ thickLine [xt,yt] 3
, thickLine [xb,yb] 3
]
++ map (flip thickLine 3 . flat2) ls
where
n = w *.* (normalizeV $ vNormal $ y -.- x)
xb = x +.+ n
yb = y +.+ n
xt = x -.- n
yt = y -.- n
ps = divideLineExact (w*2) xb yb
dia = rotateV (pi/4) n
ps' = map (\p -> intersectSegLine' xt yt p (p +.+ dia)) ps
ls = catMaybes $ zipWith (fmap . (,)) ps ps'
girderV :: Float -> Point2 -> Point2 -> Picture
girderV w x y = setDepth (-0.1) $ color red $ pictures $
[ thickLine [xt,yt] 3
, thickLine [xb,yb] 3
]
++ map (flip thickLine 3 . flat2) as'
++ map (flip thickLine 3 . flat2) bs'
where
n = w *.* (normalizeV $ vNormal $ y -.- x)
xb = x +.+ n
yb = y +.+ n
xt = x -.- n
yt = y -.- n
ps = divideLineExact (w*2) xb yb
(as,bs) = evenOddSplit ps
f a = map (\p -> intersectSegLine' xt yt p (p +.+ (rotateV a n)))
as' = catMaybes $ zipWith (fmap . (,)) as $ f (pi/4) as
bs' = catMaybes $ zipWith (fmap . (,)) as $ f (3*pi/4) as
girder :: Float -> Point2 -> Point2 -> Picture
girder w x y = setDepth (-0.1) $ color red $ pictures $
[ thickLine [xt,yt] 3
, thickLine [xb,yb] 3
]
++ map (flip thickLine 3 . flat2) ls
where
n = w *.* (normalizeV $ vNormal $ y -.- x)
xb = x +.+ n
yb = y +.+ n
xt = x -.- n
yt = y -.- n
ps = divideLineExact (w*2) xb yb
ps' = map (\p -> intersectSegLine' xt yt p (p +.+ n)) ps
ls = catMaybes $ zipWith (fmap . (,)) ps ps'
--highGirder :: Point2 -> Point2 -> Picture
--highGirder x y =