From dc803b64b0e48ef1487970f8d038841293f59712 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 10 Jul 2022 00:17:09 +0100 Subject: [PATCH] Add wall placement obstructions, start to generalise pictures --- src/Dodge/Placement/PlaceSpot.hs | 39 ++++++++++++++++---------------- src/Dodge/Room/Room.hs | 8 +++---- src/Picture/Base.hs | 21 ++++++++++------- src/Picture/Data.hs | 1 + 4 files changed, 37 insertions(+), 32 deletions(-) diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index ea4f6fa40..e7e2a582b 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -10,6 +10,7 @@ import Dodge.Data --import Dodge.Path import Dodge.Placement.PlaceSpot.Block import Dodge.Placement.PlaceSpot.TriggerDoor +import Dodge.Path import Dodge.Default.Wall import Dodge.ShiftPoint import Dodge.Base.NewID @@ -119,32 +120,30 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) where (evaluatedType, g) = runState rgen (_randGen w) -placeWallPoly :: [Point2] -> Wall -> World -> World -placeWallPoly ps wl = -- rmCrossPaths . - over walls (placeWalls ps wl) --- where --- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps +--placeWallPoly :: [Point2] -> Wall -> World -> World +--placeWallPoly ps wl = -- rmCrossPaths . +-- over walls (placeWalls ps wl) +---- where +---- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps -placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall -placeWalls qs wl wls = foldl' (addPane wl) wls pairs +--placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall +--placeWalls qs wl wls = foldl' (addPane wl) wls pairs +-- where +-- (p:ps) = orderPolygon qs +-- pairs = zip (ps ++ [p]) (p:ps) + +placeWallPoly :: [Point2] -> Wall -> World -> World +placeWallPoly qs wl w = foldl' (addPane wl) w pairs where (p:ps) = orderPolygon qs pairs = zip (ps ++ [p]) (p:ps) -addPane :: Wall -> IM.IntMap Wall -> (Point2,Point2) -> IM.IntMap Wall -addPane wl wls l = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls - where - wlid = IM.newKey wls - ----- | place an new object into an intmap and update its id ---plNewUpID :: ALens' World (IM.IntMap a) --- -> ALens' a Int --- -> a --- -> World --- -> (Int,World) ---plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i)) +addPane :: Wall -> World -> (Point2,Point2) -> World +--addPane wl w l = w & walls %~ IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) +addPane wl w l = w & plNew walls wlID (wl & wlLine .~ l) + & fst . uncurry (obstructPathsCrossing WallObstacle) l -- where --- i = IM.newKey $ w ^# l +-- wlid = IM.newKey (_walls w) mvProp :: Point2 -> Float -> Prop -> Prop mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a )) diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 2f0a463cf..f9286e763 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -325,7 +325,7 @@ spawnerRoom = do corDoor :: State StdGen (MetaTree Room String) corDoor = do - --cor <- shuffleLinks $ cleatOnward corridor - --return $ tToBTree "corDoor" $ treePost [door,cor] - cor <- shuffleLinks corridor - return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door] + cor <- shuffleLinks $ cleatOnward corridor + return $ tToBTree "corDoor" $ treePost [door,cor] +-- cor <- shuffleLinks corridor +-- return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door] diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs index 01ac217ff..41a5baeb4 100644 --- a/src/Picture/Base.hs +++ b/src/Picture/Base.hs @@ -58,22 +58,27 @@ polygonWire :: [Point2] -> Picture {-# INLINE polygonWire #-} polygonWire ps = line (ps ++ [head ps]) +picFormat :: [Verx] -> Picture +picFormat = S.each + -- | Expects clockwise input. polygon :: [Point2] -> Picture {-# INLINE polygon #-} -polygon = S.each . map f . polyToTris +polygon = picFormat . map f . polyToTris where f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum + + polygonZ :: [Point2] -> Float -> Picture {-# INLINE polygonZ #-} -polygonZ ps z = S.each . map (f . zeroZ) $ polyToTris ps +polygonZ ps z = picFormat . map (f . zeroZ) $ polyToTris ps where f pos = Verx pos black [z] BottomLayer polyzNum polygonCol :: [(Point2,RGBA)] -> Picture {-# INLINE polygonCol #-} -polygonCol = S.each . polyToTris . map f +polygonCol = picFormat . polyToTris . map f where f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum @@ -83,7 +88,7 @@ poly3 = poly3Col . map (, black) poly3Col :: [(Point3,RGBA)] -> Picture {-# INLINE poly3Col #-} -poly3Col = S.each . map f . polyToTris +poly3Col = picFormat . map f . polyToTris where f (pos,col) = Verx pos col [] BottomLayer polyNum @@ -122,7 +127,7 @@ bezierQuad cola colc ra rc a b c fc' = extrapolate cIn aIn bIn bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture -bzhelp = S.each . map f +bzhelp = picFormat . map f where f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum @@ -215,7 +220,7 @@ circleSolid = circleSolidCol white white circleSolidCol :: Color -> Color -> Float -> Picture {-# INLINE circleSolidCol #-} -circleSolidCol colC colE r = S.each $ map f +circleSolidCol colC colE r = picFormat $ map f [(V3 (-r) r 0, colC) ,(V3 (-r) (-r) 0, colE) ,(V3 r (-r) 0, black) @@ -237,7 +242,7 @@ stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..] text :: String -> Picture {-# INLINE text #-} -text = S.each . map f . stringToList +text = picFormat . map f . stringToList where f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum @@ -319,7 +324,7 @@ thickArc startA endA rad wdth thickArcHelp :: Float -> Float -> Float -> Float -> Picture {-# INLINE thickArcHelp #-} -thickArcHelp startA endA rad wdth = S.each $ map f +thickArcHelp startA endA rad wdth = picFormat $ map f [ (V3 0 0 0,black,V3 0 0 wdth) ,(V3 xa ya 0,black,V3 1 0 wdth) ,(V3 xb yb 0,black,V3 1 1 wdth) diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index f77177cfb..20beffafb 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -46,6 +46,7 @@ textNum = ShadNum 3 arcNum = ShadNum 4 ellNum = ShadNum 5 type Picture = Stream (Of Verx) IO () +type Picture' = [Verx] flat2 :: V2 a -> [a] flat2 (V2 x y) = [x,y] flat3 :: V3 a -> [a]