Refactor tractor beam

src/Dodge/Room/Foreground.hs

@@ -1,8 +1,8 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Foreground
     where
-import Dodge.Picture
-import Dodge.Base
+--import Dodge.Picture
+--import Dodge.Base
 import Picture
 import Geometry
 --import Geometry.Data
@@ -53,59 +53,63 @@ highPipe h x y = translateSHz h $ colorSH orange $ upperPrismPoly 5
   where
     n = 2.5 *.* normalizeV (vNormal (y -.- x))
 
-girderZ :: Float -> Point2 -> Point2 -> Picture
-girderZ w x y = setDepth 50 $ color red $ pictures $
-    [ thickLine [xt,yt] 3 
-    , thickLine [xb,yb] 3
+girderZ 
+    :: Float -- ^ height
+    -> Float -- ^ distance between cross bars
+    -> Float -- ^ width
+    -> Point2 -> Point2 -> Shape
+girderZ h d w x y = colorSH red $ mconcat $
+    [ highPipe h xt yt
+    , highPipe h xb yb
     ]
-    ++ map (flip thickLine 3 . tflat2) ls
+    <> zipWith (highPipe (h- 5)) ps qs
   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 :: Color -> Float -> Point2 -> Point2 -> Picture
-girderV col w x y = setDepth 50 $ color col $ pictures $
-    [ thickLine [xt,yt] 3 
-    , thickLine [xb,yb] 3
+    ps = divideLineExact d xb yb
+    qs = tail $ divideLineExact d xt yt
+
+girderV 
+    :: Float -- ^ height
+    -> Float -- ^ distance between cross bars
+    -> Float -- ^ width
+    -> Point2 -> Point2 -> Shape
+girderV h d w x y = colorSH red $ mconcat $
+    [ highPipe h xt yt
+    , highPipe h xb yb
     ]
-    ++ map (flip thickLine 3 . tflat2) as'
-    ++ map (flip thickLine 3 . tflat2) bs'
+    <> zipWith (highPipe (h- 5)) ps qs
   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,_) = 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 :: Color -> Float -> Point2 -> Point2 -> Picture
-girder col w x y = pictures $
-    setDepth 50 (color col $ pictures $
-        [ thickLine [xt,yt] 3 
-        , thickLine [xb,yb] 3
-        ]
-        ++ map (flip thickLine 3 . tflat2) ls
-    )
-    : map (\p -> verticalPipe 1.5 col p 0 (-0.1)) [xb,xt,yb,yt]
+    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 = colorSH red $ mconcat $
+    [ highPipe h xt yt
+    , highPipe h xb yb
+    ]
+    <> zipWith (highPipe (h- 5)) ps qs
   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 = 
+    ps = divideLineExact d xb yb
+    qs = divideLineExact d xt yt

src/Dodge/Room/Start.hs

@@ -24,7 +24,7 @@ startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     let fground = sPS (V2 0 0) 0 $ PutForeground $ 
-               highPipe 80 (V2  0    (h/3)) (V2  w    (h/2))
+               girderV 50 20 10 (V2  0    (h/5)) (V2  w    (h/5))
             <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/3))
             <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
         theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.75 0.75)