justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Modify/Girder.hs
+137 -87
View File
@@ -1,76 +1,90 @@
module Dodge.Room.Modify.Girder
( addGirderLights
, addGirderFrom
, addHighGirder
, addHighGirder'
, addGirderEW
, addGirderNS
, addGirderNS'
) where
--import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.Data
--import Dodge.Room.Procedural
import Dodge.Room.Foreground
--import Dodge.Room.RoadBlock
--import Dodge.Placement.Instance
--import Dodge.Placement.TopDecoration
import Dodge.PlacementSpot
import Dodge.LightSource
--import Padding
import Color
import Shape
import LensHelp
import Geometry
import RandomHelp
module Dodge.Room.Modify.Girder (
addGirderLights,
addGirderFrom,
addHighGirder,
addHighGirder',
addGirderEW,
addGirderNS,
addGirderNS',
) where
import Data.Maybe
import Color
import Data.List (nub)
import Data.Maybe
import qualified Data.Set as S
import Dodge.Data.GenWorld
import Dodge.LevelGen.Data
import Dodge.LightSource
import Dodge.PlacementSpot
import Dodge.Room.Foreground
import Geometry
import LensHelp
import RandomHelp
import Shape
addGirderNS :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderNS shapef col room = do
let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
girderPosOrder <- shuffle [1 .. nwestlnks - 2]
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : [ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder]
)
return $
room & rmPmnts
.:~ foldr1
setFallback
( sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder
]
)
addGirderFrom :: CardinalPoint -> Int -> (Point2 -> Point2 -> Shape) -> Color -> Room -> Room
addGirderFrom cp fromi shapef col = rmPmnts .:~ foldr1 setFallback
[ sps0 PutNothing
, twoRoomPoss rmposcond rmposcond
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) ]
addGirderFrom cp fromi shapef col =
rmPmnts
.:~ foldr1
setFallback
[ sps0 PutNothing
, twoRoomPoss rmposcond rmposcond $
\ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
]
where
rmposcond = isUnusedLnkType (FromEdge cp fromi)
-- | Allows girder to be on edge
addGirderNS' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderNS' shapef col room = do
let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
girderPosOrder <- shuffle [0 .. nwestlnks - 1]
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : [ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder]
)
return $
room & rmPmnts
.:~ foldr1
setFallback
( sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge West i))
(isUnusedLnkType (FromEdge West i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder
]
)
addGirderEW :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirderEW shapef col room = do
let nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
girderPosOrder <- shuffle [1 .. nwestlnks - 2]
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge South i))
(isUnusedLnkType (FromEdge South i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder]
)
return $
room & rmPmnts
.:~ foldr1
setFallback
( sps0 PutNothing :
[ twoRoomPoss
(isUnusedLnkType (FromEdge South i))
(isUnusedLnkType (FromEdge South i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- girderPosOrder
]
)
-- TODO add a central light to this, with mounted light fallback?
addGirder :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
@@ -80,14 +94,19 @@ addGirder shapef col room = do
nsgirds = girdson (FromEdge East) nslnks
ewgirds = girdson (FromEdge North) ewlnks
girders <- shuffle $ nsgirds ++ ewgirds
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : girders)
return $
room & rmPmnts
.:~ foldr1
setFallback
(sps0 PutNothing : girders)
where
girdson f numlnks = [ twoRoomPoss
girdson f numlnks =
[ twoRoomPoss
(isUnusedLnkType (f i))
(isUnusedLnkType (f i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [1 .. numlnks - 2] ]
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [1 .. numlnks - 2]
]
addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
addGirder' shapef col room = do
@@ -96,41 +115,53 @@ addGirder' shapef col room = do
nsgirds = girdson (FromEdge East) nslnks
ewgirds = girdson (FromEdge North) ewlnks
girders <- shuffle $ nsgirds ++ ewgirds
return $ room & rmPmnts .:~ foldr1 setFallback
(sps0 PutNothing : girders)
return $
room & rmPmnts
.:~ foldr1
setFallback
(sps0 PutNothing : girders)
where
girdson f numlnks = [ twoRoomPoss
girdson f numlnks =
[ twoRoomPoss
(isUnusedLnkType (f i))
(isUnusedLnkType (f i))
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [0 .. numlnks - 1] ]
$ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2)
| i <- [0 .. numlnks - 1]
]
addHighGirder :: RandomGen g => Room -> State g Room
addHighGirder r = do
gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
gsize <- takeOne [(20, 10), (30, 10), (40, 10), (30, 15)]
hgshape <-
takeOne $
map
(\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
addGirder hgshape black r
addHighGirder' :: RandomGen g => Room -> State g Room
addHighGirder' r = do
gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)]
hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
gsize <- takeOne [(20, 10), (30, 10), (40, 10), (30, 15)]
hgshape <-
takeOne $
map
(\f -> uncurry (f 96) gsize)
[girder, girderZ, girderV]
addGirder' hgshape black r
randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)]
randomLightPositions :: RandomGen g => Room -> State g [(Int, Int)]
randomLightPositions rm = do
let rmtype = _rmType rm
xs <- shuffle [0.._numLinkEW rmtype]
ys <- shuffle [0.._numLinkNS rmtype]
xs <- shuffle [0 .. _numLinkEW rmtype]
ys <- shuffle [0 .. _numLinkNS rmtype]
let n = max (length xs) (length ys)
return $ take n $ zip (xs ++ xs) (ys ++ ys)
intsToPos :: Room -> (Int,Int) -> Point2
intsToPos rm (x,y) = V2
(20 + _linkGapEW rmtype * fromIntegral x)
(20 + _linkGapNS rmtype * fromIntegral y)
intsToPos :: Room -> (Int, Int) -> Point2
intsToPos rm (x, y) =
V2
(20 + _linkGapEW rmtype * fromIntegral x)
(20 + _linkGapNS rmtype * fromIntegral y)
where
rmtype = _rmType rm
@@ -149,15 +180,34 @@ addGirderLights rm = do
w = _rmWidth rmtype
h = _rmHeight rmtype
midw = wiToFloat rm midi
extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis
extragirders = mapMaybe (\(i,hi) -> case i of
x | x < 0 -> Just $ girderV' 96 20 10 (V2 (midw - 10) (hiToFloat rm hi))
(V2 0 (hiToFloat rm hi))
x | x > 0 -> Just $ girderV' 96 20 10 (V2 (midw + 10) (hiToFloat rm hi))
(V2 w (hiToFloat rm hi))
_ -> Nothing
) extragirderpos
return $ rm & rmPmnts .++~
(sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h))
: map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
) ++ map (sps0 . PutForeground) extragirders
extragirderpos = nub $ map (\(wi, hi) -> (wi - midi, hi)) lpis
extragirders =
mapMaybe
( \(i, hi) -> case i of
x
| x < 0 ->
Just $
girderV'
96
20
10
(V2 (midw - 10) (hiToFloat rm hi))
(V2 0 (hiToFloat rm hi))
x
| x > 0 ->
Just $
girderV'
96
20
10
(V2 (midw + 10) (hiToFloat rm hi))
(V2 w (hiToFloat rm hi))
_ -> Nothing
)
extragirderpos
return $
rm & rmPmnts
.++~ ( sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h)) :
map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
)
++ map (sps0 . PutForeground) extragirders