Add simple high pipes

src/Dodge/Picture.hs

@@ -40,3 +40,17 @@ wedgeOfThickness t x y
         ]
   where 
     n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
+
+verticalPipe :: Float -> Color -> Point2 -> Float -> Float -> Picture
+verticalPipe w col (xx,xy) za zb = pictures $ map (poly3D . f) ps
+  where
+    x = (xx,xy,0)
+    xs = map (\(a,b) -> x +.+.+ (a,b,za)) [(w,0),(0,w),(-w,0),(0,-w)]
+    ps = zip xs (tail xs ++ [head xs])
+    f (a,b) = map f' [a,b,g b,g a]
+    g :: Point3 -> Point3
+    g (a,b,_) = (a,b,zb)
+    f' a = (a,col)
+
+thickLinePlane :: Float -> Point3 -> Point3 -> Point3 -> [Point3]
+thickLinePlane = undefined

src/Dodge/Room/Foreground.hs

@@ -1,5 +1,6 @@
 module Dodge.Room.Foreground
     where
+import Dodge.Picture
 import Picture
 import Geometry
 import Geometry.Data
@@ -14,11 +15,11 @@ highDiagonalMesh
     -> Float    -- ^ vertical distance between lines
     -> Picture
 highDiagonalMesh pa pb w d = setDepth (-0.2) $ pictures $
-    (map (flip thickLine 1 . flat2) $ diagonalLinesRect pb pa w d (pi/4))
+    (map (flip thickLine 3 . flat2) $ diagonalLinesRect pb pa w d (3*pi/4))
     ++ 
-    (map (flip thickLine 1 . flat2) $ diagonalLinesRect pa pc h d (3* pi/4))
+    (map (flip thickLine 3 . flat2) $ diagonalLinesRect pb pc (negate h) d (pi/4))
   where
-    pc = pa +.+ w *.* normalizeV (vNormal (pb -.- pa))
+    pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa))
     h = dist pa pb
 
 diagonalLinesRect 
@@ -34,10 +35,22 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
     diVec = rotateV ang xVec
     pax = pa +.+ xVec
     pbx = pb +.+ xVec
-    lhsPoints = divideLine d (pa -.- yN) (pb +.+ yN)
+    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)
+
+highPipe :: Point2 -> Point2 -> Picture
+highPipe x y = pictures 
+    [setDepth (-0.2) $ thickLine [x,y] 10
+    ,setDepth (-0.19) $ color orange $ thickLine [x,y] 10
+    ,verticalPipe 5 orange x 0 (-0.2) 
+    ,verticalPipe 5 orange y 0 (-0.2) 
+    ,verticalPipe 5 orange (0.5 *.* (x +.+ y)) (-0.1) (-0.2) 
+    ]
+
+--highGirder :: Point2 -> Point2 -> Picture
+--highGirder x y = 

src/Dodge/Room/Start.hs

@@ -18,12 +18,13 @@ startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     let fground = sPS (0,0) 0 $ PutForeground $ pictures
-            [ highDiagonalMesh (0,0) (0,h) w 25
+            --[ highDiagonalMesh (0,0) (0,h) w 50
-            --, setDepth (-0.1) $ color orange $ pictures
+            ----, setDepth (-0.1) $ color orange $ pictures
-            --    [ polygon $ rectNSEW 50 40 140 (-20)
+            ----    [ polygon $ rectNSEW 50 40 140 (-20)
-            --    , translate 60 45 $ scale 0.5 1 $  thickArc 0 pi 75 10
+            ----    , translate 60 45 $ scale 0.5 1 $  thickArc 0 pi 75 10
-            --    , translate (-20) 300 $ polygon $ rectNSEW 10 0 40 0
+            ----    , translate (-20) 300 $ polygon $ rectNSEW 10 0 40 0
-            --    ]
+            ----    ]
-            , highDiagonalMesh (w,0) (0,0) h 25
+            --, highDiagonalMesh (w,0) (0,0) h 50
+            [ highPipe (0,h/2) (w, h/2)
             ]
     pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))

src/Geometry.hs

@@ -399,6 +399,13 @@ divideLineOddNumPoints x a b = take 5000
         | even numPoints' = numPoints'
         | otherwise       = numPoints' + 1
     ns = [0 .. numPoints] :: [Int]
+
+divideLineExact :: Float -> Point2 -> Point2 -> [Point2]
+divideLineExact x a b = map ( (a +.+ ) . ( *.* v) ) [0 , x .. d]
+  where 
+    d = dist a b
+    v = normalizeV $ b -.- a
+
 -- | Given two pairs of Ints, returns a list of pairs of Ints that form 
 -- a digital line between them.
 digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]

src/Geometry/Vector.hs

@@ -2,7 +2,7 @@
 module Geometry.Vector
     where
 import Geometry.Data
-{- | Moves from to three dimensions, adding zero in z direction.  -}
+{- | Moves from two to three dimensions, adding zero in z direction.  -}
 zeroZ :: Point2 -> Point3
 {-# INLINE zeroZ #-}
 zeroZ (x,y) = (x,y,0)

src/Picture.hs

@@ -2,6 +2,7 @@ module Picture
     ( module Picture.Data
     , polygon
     , polygonCol
+    , poly3D
     , bezierQuad
     , arc
     , arcSolid
@@ -65,6 +66,10 @@ polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
 polygonCol = PolygonCol 0
 
+poly3D :: [(Point3,RGBA)] -> Picture
+{-# INLINE poly3D #-}
+poly3D = Poly3D 0
+
 -- note that much of work computing the width of the bezier curve is done here
 bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
 bezierQuad cola colc ra rc a b c 

src/Picture/Data.hs

@@ -80,6 +80,7 @@ data Picture
     | Polygon Int [Point2]
     | BezierQuad Int [(Point2,RGBA,Point2,Point2)]
     | PolygonCol Int [(Point2,RGBA)]
+    | Poly3D Int [(Point3,RGBA)]
     | Circle Int RGBA RGBA Float
     | ThickArc Int Float Float Float Float
     | Line Int [Point2]

src/Picture/Tree.hs

@@ -24,6 +24,7 @@ picToLTree mx (Polygon i ps)
 picToLTree mx (PolygonCol i vs)
     = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
         where (ps,cs) = unzip vs
+picToLTree mx (Poly3D i vs) = filtB mx i $ LLeaf $ RenderPoly $ polyToTris vs
 picToLTree mx (BezierQuad i vs) 
     = filtB mx i $ LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
         where (ps,cols,offps,rads) = unzip4 vs