diff --git a/src/Dodge/Picture.hs b/src/Dodge/Picture.hs index c3ca72e3e..c5de93c77 100644 --- a/src/Dodge/Picture.hs +++ b/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 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 955073729..3624af7ed 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/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 = diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 5c8e066af..f242ae0ae 100644 --- a/src/Dodge/Room/Start.hs +++ b/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 - --, setDepth (-0.1) $ color orange $ pictures - -- [ polygon $ rectNSEW 50 40 140 (-20) - -- , translate 60 45 $ scale 0.5 1 $ thickArc 0 pi 75 10 - -- , translate (-20) 300 $ polygon $ rectNSEW 10 0 40 0 - -- ] - , highDiagonalMesh (w,0) (0,0) h 25 + --[ highDiagonalMesh (0,0) (0,h) w 50 + ----, setDepth (-0.1) $ color orange $ pictures + ---- [ polygon $ rectNSEW 50 40 140 (-20) + ---- , translate 60 45 $ scale 0.5 1 $ thickArc 0 pi 75 10 + ---- , translate (-20) 300 $ polygon $ rectNSEW 10 0 40 0 + ---- ] + --, 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 :)) diff --git a/src/Geometry.hs b/src/Geometry.hs index 9fba1f4d1..a3644c582 100644 --- a/src/Geometry.hs +++ b/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)] diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 0c1b3f28c..5889a5c14 100644 --- a/src/Geometry/Vector.hs +++ b/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) diff --git a/src/Picture.hs b/src/Picture.hs index 2457068d8..61e575812 100644 --- a/src/Picture.hs +++ b/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 diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 652f56251..abda207e3 100644 --- a/src/Picture/Data.hs +++ b/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] diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs index 53c87d363..61267bdb8 100644 --- a/src/Picture/Tree.hs +++ b/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