module Game.LambdaHack.Server.DungeonGen.AreaRnd
(
mkFixed, pointInArea, findPointInArea, mkVoidRoom, mkRoom
, connectGrid, randomConnection
, HV(..), Corridor, connectPlaces
, SpecialArea(..), grid
#ifdef EXPOSE_INTERNAL
, connectGrid', sortPoint, mkCorridor, borderPlace
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Functor.Identity (runIdentity)
import qualified Data.IntSet as IS
import Game.LambdaHack.Common.Area
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Core.Random
import Game.LambdaHack.Definition.Defs
mkFixed :: (X, Y)
-> Area
-> Point
-> Area
mkFixed :: (Key, Key) -> Area -> Point -> Area
mkFixed (Key
xMax, Key
yMax) Area
area p :: Point
p@Point{Key
px :: Key
py :: Key
px :: Point -> Key
py :: Point -> Key
..} =
let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
xradius :: Key
xradius = Key -> Key -> Key
forall a. Ord a => a -> a -> a
min ((Key
xMax Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key
forall a. Ord a => a -> a -> a
min (Key
px Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0) (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
px)
yradius :: Key
yradius = Key -> Key -> Key
forall a. Ord a => a -> a -> a
min ((Key
yMax Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key
forall a. Ord a => a -> a -> a
min (Key
py Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0) (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
py)
a :: (Key, Key, Key, Key)
a = (Key
px Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
xradius, Key
py Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
yradius, Key
px Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
xradius, Key
py Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
yradius)
in Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> ((Key, Key, Key, Key), Key, Key, Area, Point) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` ((Key, Key, Key, Key)
a, Key
xMax, Key
yMax, Area
area, Point
p)) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
a
pointInArea :: Area -> Rnd Point
pointInArea :: Area -> Rnd Point
pointInArea Area
area = do
let (Point Key
x0 Key
y0, Key
xspan, Key
yspan) = Area -> (Point, Key, Key)
spanArea Area
area
Key
pxy <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
let Point{Key
px :: Point -> Key
py :: Point -> Key
px :: Key
py :: Key
..} = Key -> Key -> Point
punindex Key
xspan Key
pxy
Point -> Rnd Point
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> Rnd Point) -> Point -> Rnd Point
forall a b. (a -> b) -> a -> b
$! Key -> Key -> Point
Point (Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
px) (Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
py)
findPointInArea :: Area -> (Point -> Maybe Point)
-> Int -> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea :: Area
-> (Point -> Maybe Point)
-> Key
-> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea Area
area Point -> Maybe Point
g Key
gnumTries Point -> Maybe Point
f =
let (Point Key
x0 Key
y0, Key
xspan, Key
yspan) = Area -> (Point, Key, Key)
spanArea Area
area
checkPoint :: Applicative m
=> (Point -> Maybe Point) -> m (Maybe Point) -> Int
-> m (Maybe Point)
{-# INLINE checkPoint #-}
checkPoint :: forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
check m (Maybe Point)
fallback Key
pxyRelative =
let Point{Key
px :: Point -> Key
py :: Point -> Key
px :: Key
py :: Key
..} = Key -> Key -> Point
punindex Key
xspan Key
pxyRelative
pos :: Point
pos = Key -> Key -> Point
Point (Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
px) (Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
py)
in case Point -> Maybe Point
check Point
pos of
Just Point
p -> Maybe Point -> m (Maybe Point)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Point -> m (Maybe Point)) -> Maybe Point -> m (Maybe Point)
forall a b. (a -> b) -> a -> b
$ Point -> Maybe Point
forall a. a -> Maybe a
Just Point
p
Maybe Point
Nothing -> m (Maybe Point)
fallback
gsearch :: Key -> Rnd (Maybe Point)
gsearch Key
0 = Key -> Rnd (Maybe Point)
fsearch (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
10)
gsearch Key
count = do
Key
pxy <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
(Point -> Maybe Point)
-> Rnd (Maybe Point) -> Key -> Rnd (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
g (Key -> Rnd (Maybe Point)
gsearch (Key
count Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)) Key
pxy
fsearch :: Key -> Rnd (Maybe Point)
fsearch Key
0 = Maybe Point -> Rnd (Maybe Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Point -> Rnd (Maybe Point))
-> Maybe Point -> Rnd (Maybe Point)
forall a b. (a -> b) -> a -> b
$! Identity (Maybe Point) -> Maybe Point
forall a. Identity a -> a
runIdentity (Identity (Maybe Point) -> Maybe Point)
-> Identity (Maybe Point) -> Maybe Point
forall a b. (a -> b) -> a -> b
$ Key -> Identity (Maybe Point)
searchAll (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
fsearch Key
count = do
Key
pxy <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
(Point -> Maybe Point)
-> Rnd (Maybe Point) -> Key -> Rnd (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
f (Key -> Rnd (Maybe Point)
fsearch (Key
count Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)) Key
pxy
searchAll :: Key -> Identity (Maybe Point)
searchAll (-1) = Maybe Point -> Identity (Maybe Point)
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Point
forall a. Maybe a
Nothing
searchAll Key
pxyRelative =
(Point -> Maybe Point)
-> Identity (Maybe Point) -> Key -> Identity (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
f (Key -> Identity (Maybe Point)
searchAll (Key
pxyRelative Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)) Key
pxyRelative
in Key -> Rnd (Maybe Point)
gsearch Key
gnumTries
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom Area
area = do
let core :: Area
core = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe Area
area (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
area
Point
pxy <- Area -> Rnd Point
pointInArea Area
core
Area -> Rnd Area
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Area -> Rnd Area) -> Area -> Rnd Area
forall a b. (a -> b) -> a -> b
$! Point -> Area
trivialArea Point
pxy
mkRoom :: (X, Y)
-> (X, Y)
-> Area
-> Rnd Area
mkRoom :: (Key, Key) -> (Key, Key) -> Area -> Rnd Area
mkRoom (Key
xm, Key
ym) (Key
xM, Key
yM) Area
area = do
let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
xspan :: Key
xspan = Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
yspan :: Key
yspan = Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
aW :: (Key, Key, Key, Key)
aW = (Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
xm Key
xspan, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
ym Key
yspan, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
xM Key
xspan, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
yM Key
yspan)
areaW :: Area
areaW = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (Key, Key, Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key, Key, Key, Key)
aW) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
aW
Point Key
xW Key
yW <- Area -> Rnd Point
pointInArea Area
areaW
let a1 :: (Key, Key, Key, Key)
a1 = (Key
x0, Key
y0, Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
x0 (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
xW Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1), Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
y0 (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
yW Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1))
area1 :: Area
area1 = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (Key, Key, Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key, Key, Key, Key)
a1) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
a1
Point Key
rx1 Key
ry1 <- Area -> Rnd Point
pointInArea Area
area1
let a3 :: (Key, Key, Key, Key)
a3 = (Key
rx1, Key
ry1, Key
rx1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
xW Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1, Key
ry1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
yW Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
area3 :: Area
area3 = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (Key, Key, Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key, Key, Key, Key)
a3) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
a3
Area -> Rnd Area
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Area -> Rnd Area) -> Area -> Rnd Area
forall a b. (a -> b) -> a -> b
$! Area
area3
connectGrid :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]
connectGrid :: EnumSet Point -> (Key, Key) -> Rnd [(Point, Point)]
connectGrid EnumSet Point
voidPlaces (Key
nx, Key
ny) = do
let unconnected :: EnumSet Point
unconnected = [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromDistinctAscList [ Key -> Key -> Point
Point Key
x Key
y
| Key
y <- [Key
0..Key
nyKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1], Key
x <- [Key
0..Key
nxKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1] ]
Point
p <- [Point] -> Rnd Point
forall a. [a] -> Rnd a
oneOf ([Point] -> Rnd Point) -> [Point] -> Rnd Point
forall a b. (a -> b) -> a -> b
$ EnumSet Point -> [Point]
forall k. Enum k => EnumSet k -> [k]
ES.elems (EnumSet Point -> [Point]) -> EnumSet Point -> [Point]
forall a b. (a -> b) -> a -> b
$ EnumSet Point
unconnected EnumSet Point -> EnumSet Point -> EnumSet Point
forall k. EnumSet k -> EnumSet k -> EnumSet k
ES.\\ EnumSet Point
voidPlaces
let candidates :: EnumSet Point
candidates = Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k
ES.singleton Point
p
EnumSet Point
-> (Key, Key)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (Key
nx, Key
ny) EnumSet Point
unconnected EnumSet Point
candidates []
connectGrid' :: ES.EnumSet Point -> (X, Y)
-> ES.EnumSet Point -> ES.EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' :: EnumSet Point
-> (Key, Key)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (Key
nx, Key
ny) EnumSet Point
unconnected EnumSet Point
candidates ![(Point, Point)]
acc
| EnumSet Point
unconnected EnumSet Point -> EnumSet Point -> Bool
forall k. EnumSet k -> EnumSet k -> Bool
`ES.isSubsetOf` EnumSet Point
voidPlaces = [(Point, Point)] -> Rnd [(Point, Point)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Point, Point)]
acc
| Bool
otherwise = do
let candidatesBest :: EnumSet Point
candidatesBest = EnumSet Point
candidates EnumSet Point -> EnumSet Point -> EnumSet Point
forall k. EnumSet k -> EnumSet k -> EnumSet k
ES.\\ EnumSet Point
voidPlaces
Point
c <- [Point] -> Rnd Point
forall a. [a] -> Rnd a
oneOf ([Point] -> Rnd Point) -> [Point] -> Rnd Point
forall a b. (a -> b) -> a -> b
$ EnumSet Point -> [Point]
forall k. Enum k => EnumSet k -> [k]
ES.elems (EnumSet Point -> [Point]) -> EnumSet Point -> [Point]
forall a b. (a -> b) -> a -> b
$ if EnumSet Point -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet Point
candidatesBest
then EnumSet Point
candidates
else EnumSet Point
candidatesBest
let ns :: EnumSet Point
ns = [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromList ([Point] -> EnumSet Point) -> [Point] -> EnumSet Point
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Point -> [Point]
vicinityCardinal Key
nx Key
ny Point
c
nu :: EnumSet Point
nu = Point -> EnumSet Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete Point
c EnumSet Point
unconnected
(EnumSet Point
nc, EnumSet Point
ds) = (Point -> Bool) -> EnumSet Point -> (EnumSet Point, EnumSet Point)
forall k.
Enum k =>
(k -> Bool) -> EnumSet k -> (EnumSet k, EnumSet k)
ES.partition (Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
nu) EnumSet Point
ns
[(Point, Point)] -> [(Point, Point)]
new <- if EnumSet Point -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet Point
ds
then ([(Point, Point)] -> [(Point, Point)])
-> StateT SMGen Identity ([(Point, Point)] -> [(Point, Point)])
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Point, Point)] -> [(Point, Point)]
forall a. a -> a
id
else do
Point
d <- [Point] -> Rnd Point
forall a. [a] -> Rnd a
oneOf (EnumSet Point -> [Point]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet Point
ds)
([(Point, Point)] -> [(Point, Point)])
-> StateT SMGen Identity ([(Point, Point)] -> [(Point, Point)])
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Point, Point) -> (Point, Point)
sortPoint (Point
c, Point
d) (Point, Point) -> [(Point, Point)] -> [(Point, Point)]
forall a. a -> [a] -> [a]
:)
EnumSet Point
-> (Key, Key)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (Key
nx, Key
ny) EnumSet Point
nu
(Point -> EnumSet Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete Point
c (EnumSet Point
candidates EnumSet Point -> EnumSet Point -> EnumSet Point
forall k. EnumSet k -> EnumSet k -> EnumSet k
`ES.union` EnumSet Point
nc)) ([(Point, Point)] -> [(Point, Point)]
new [(Point, Point)]
acc)
sortPoint :: (Point, Point) -> (Point, Point)
sortPoint :: (Point, Point) -> (Point, Point)
sortPoint (Point
a, Point
b) | Point
a Point -> Point -> Bool
forall a. Ord a => a -> a -> Bool
<= Point
b = (Point
a, Point
b)
| Bool
otherwise = (Point
b, Point
a)
randomConnection :: (X, Y) -> Rnd (Point, Point)
randomConnection :: (Key, Key) -> Rnd (Point, Point)
randomConnection (Key
nx, Key
ny) =
Bool -> Rnd (Point, Point) -> Rnd (Point, Point)
forall a. HasCallStack => Bool -> a -> a
assert (Key
nx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1 Bool -> Bool -> Bool
&& Key
ny Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0 Bool -> Bool -> Bool
|| Key
nx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0 Bool -> Bool -> Bool
&& Key
ny Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1 Bool -> (Key, Key) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Key
nx, Key
ny)) (Rnd (Point, Point) -> Rnd (Point, Point))
-> Rnd (Point, Point) -> Rnd (Point, Point)
forall a b. (a -> b) -> a -> b
$ do
Bool
rb <- [Bool] -> Rnd Bool
forall a. [a] -> Rnd a
oneOf [Bool
False, Bool
True]
if Bool
rb Bool -> Bool -> Bool
&& Key
nx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1 Bool -> Bool -> Bool
|| Key
ny Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
1
then do
Key
rx <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
nx Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
2)
Key
ry <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
ny Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
(Point, Point) -> Rnd (Point, Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Key -> Point
Point Key
rx Key
ry, Key -> Key -> Point
Point (Key
rxKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) Key
ry)
else do
Key
rx <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
nx Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
Key
ry <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
ny Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
2)
(Point, Point) -> Rnd (Point, Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Key -> Point
Point Key
rx Key
ry, Key -> Key -> Point
Point Key
rx (Key
ryKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1))
data HV = Horiz | Vert
deriving HV -> HV -> Bool
(HV -> HV -> Bool) -> (HV -> HV -> Bool) -> Eq HV
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HV -> HV -> Bool
== :: HV -> HV -> Bool
$c/= :: HV -> HV -> Bool
/= :: HV -> HV -> Bool
Eq
type Corridor = (Point, Point, Point, Point)
mkCorridor :: HV
-> Point
-> Bool
-> Point
-> Bool
-> Area
-> Rnd Corridor
mkCorridor :: HV -> Point -> Bool -> Point -> Bool -> Area -> Rnd Corridor
mkCorridor HV
hv (Point Key
x0 Key
y0) Bool
p0floor (Point Key
x1 Key
y1) Bool
p1floor Area
area = do
Point Key
rxRaw Key
ryRaw <- Area -> Rnd Point
pointInArea Area
area
let (Key
sx0, Key
sy0, Key
sx1, Key
sy1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
rx :: Key
rx = if | Key
rxRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sx0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 Bool -> Bool -> Bool
&& Bool
p0floor -> Key
sx0
| Key
rxRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sx1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 Bool -> Bool -> Bool
&& Bool
p1floor -> Key
sx1
| Bool
otherwise -> Key
rxRaw
ry :: Key
ry = if | Key
ryRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sy0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 Bool -> Bool -> Bool
&& Bool
p0floor -> Key
sy0
| Key
ryRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sy1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 Bool -> Bool -> Bool
&& Bool
p1floor -> Key
sy1
| Bool
otherwise -> Key
ryRaw
Corridor -> Rnd Corridor
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Corridor -> Rnd Corridor) -> Corridor -> Rnd Corridor
forall a b. (a -> b) -> a -> b
$! case HV
hv of
HV
Horiz -> (Key -> Key -> Point
Point Key
x0 Key
y0, Key -> Key -> Point
Point Key
rx Key
y0, Key -> Key -> Point
Point Key
rx Key
y1, Key -> Key -> Point
Point Key
x1 Key
y1)
HV
Vert -> (Key -> Key -> Point
Point Key
x0 Key
y0, Key -> Key -> Point
Point Key
x0 Key
ry, Key -> Key -> Point
Point Key
x1 Key
ry, Key -> Key -> Point
Point Key
x1 Key
y1)
connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area)
-> Rnd (Maybe Corridor)
connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area) -> Rnd (Maybe Corridor)
connectPlaces (Area
_, Fence
_, Area
sg) (Area
_, Fence
_, Area
tg) | Area
sg Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
== Area
tg = Maybe Corridor -> Rnd (Maybe Corridor)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Corridor
forall a. Maybe a
Nothing
connectPlaces s3 :: (Area, Fence, Area)
s3@(Area
sqarea, Fence
spfence, Area
sg) t3 :: (Area, Fence, Area)
t3@(Area
tqarea, Fence
tpfence, Area
tg) = do
let (Area
sa, Area
so, Bool
stiny) = Area -> Fence -> (Area, Area, Bool)
borderPlace Area
sqarea Fence
spfence
(Area
ta, Area
to, Bool
ttiny) = Area -> Fence -> (Area, Area, Bool)
borderPlace Area
tqarea Fence
tpfence
trim :: Area -> Area
trim Area
area =
let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
dx :: Key
dx = case (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2 of
Key
0 -> Key
0
Key
1 -> Key
1
Key
2 -> Key
1
Key
3 -> Key
1
Key
_ -> Key
3
dy :: Key
dy = case (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2 of
Key
0 -> Key
0
Key
1 -> Key
1
Key
2 -> Key
1
Key
3 -> Key
1
Key
_ -> Key
3
in Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (Area, (Area, Fence, Area), (Area, Fence, Area)) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Area
area, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3))
(Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
dx, Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
dy, Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
dx, Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
dy)
Point Key
sx Key
sy <- Area -> Rnd Point
pointInArea (Area -> Rnd Point) -> Area -> Rnd Point
forall a b. (a -> b) -> a -> b
$ Area -> Area
trim Area
sa
Point Key
tx Key
ty <- Area -> Rnd Point
pointInArea (Area -> Rnd Point) -> Area -> Rnd Point
forall a b. (a -> b) -> a -> b
$ Area -> Area
trim Area
ta
let (Key
_, Key
_, Key
sax1Raw, Key
say1Raw) = Area -> (Key, Key, Key, Key)
fromArea Area
sa
sslim :: Bool
sslim = Bool
stiny Bool -> Bool -> Bool
&& Fence
spfence Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone
(Key
sax1, Key
say1) = if Bool
sslim
then (Key
sax1Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1, Key
say1Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
else (Key
sax1Raw, Key
say1Raw)
(Key
tax0Raw, Key
tay0Raw, Key
_, Key
_) = Area -> (Key, Key, Key, Key)
fromArea Area
ta
tslim :: Bool
tslim = Bool
ttiny Bool -> Bool -> Bool
&& Fence
tpfence Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone
(Key
tax0, Key
tay0) = if Bool
tslim
then (Key
tax0Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1, Key
tay0Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1)
else (Key
tax0Raw, Key
tay0Raw)
(Key
_, Key
_, Key
sox1, Key
soy1) = Area -> (Key, Key, Key, Key)
fromArea Area
so
(Key
tox0, Key
toy0, Key
_, Key
_) = Area -> (Key, Key, Key, Key)
fromArea Area
to
(Key
sgx0, Key
sgy0, Key
sgx1, Key
sgy1) = Area -> (Key, Key, Key, Key)
fromArea Area
sg
(Key
tgx0, Key
tgy0, Key
tgx1, Key
tgy1) = Area -> (Key, Key, Key, Key)
fromArea Area
tg
(HV
hv, Area
area, Point
p0, Point
p1)
| Key
sgx1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
tgx0 =
let x0 :: Key
x0 = if Key
sgy0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
ty Bool -> Bool -> Bool
&& Key
ty Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sgy1 then Key
sox1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 else Key
sgx1
x1 :: Key
x1 = if Key
tgy0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sy Bool -> Bool -> Bool
&& Key
sy Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
tgy1 then Key
tox0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 else Key
sgx1
in case (Key, Key, Key, Key) -> Maybe Area
toArea (Key
x0, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
sy Key
ty, Key
x1, Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
sy Key
ty) of
Just Area
a -> (HV
Horiz, Area
a, Key -> Key -> Point
Point (Key
sax1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key
sy, Key -> Key -> Point
Point (Key
tax0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Key
ty)
Maybe Area
Nothing -> [Char] -> (HV, Area, Point, Point)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (HV, Area, Point, Point))
-> [Char] -> (HV, Area, Point, Point)
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (Key, Key, Key, Key, (Area, Fence, Area), (Area, Fence, Area))
-> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)
| Bool
otherwise = Bool -> (HV, Area, Point, Point) -> (HV, Area, Point, Point)
forall a. HasCallStack => Bool -> a -> a
assert (Key
sgy1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
tgy0) ((HV, Area, Point, Point) -> (HV, Area, Point, Point))
-> (HV, Area, Point, Point) -> (HV, Area, Point, Point)
forall a b. (a -> b) -> a -> b
$
let y0 :: Key
y0 = if Key
sgx0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
tx Bool -> Bool -> Bool
&& Key
tx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sgx1 then Key
soy1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 else Key
sgy1
y1 :: Key
y1 = if Key
tgx0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sx Bool -> Bool -> Bool
&& Key
sx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
tgx1 then Key
toy0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 else Key
sgy1
in case (Key, Key, Key, Key) -> Maybe Area
toArea (Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
sx Key
tx, Key
y0, Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
sx Key
tx, Key
y1) of
Just Area
a -> (HV
Vert, Area
a, Key -> Key -> Point
Point Key
sx (Key
say1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1), Key -> Key -> Point
Point Key
tx (Key
tay0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1))
Maybe Area
Nothing -> [Char] -> (HV, Area, Point, Point)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (HV, Area, Point, Point))
-> [Char] -> (HV, Area, Point, Point)
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (Key, Key, Key, Key, (Area, Fence, Area), (Area, Fence, Area))
-> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)
nin :: Point -> Bool
nin Point
p = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Area -> Point -> Bool
inside Area
sa Point
p Bool -> Bool -> Bool
|| Area -> Point -> Bool
inside Area
ta Point
p
!_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
sslim Bool -> Bool -> Bool
|| Bool
tslim
Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall v. Show v => (v -> Bool) -> [v] -> Bool
allB Point -> Bool
nin [Point
p0, Point
p1] Bool
-> (Key, Key, Key, Key, (Area, Fence, Area), (Area, Fence, Area))
-> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)) ()
cor :: Corridor
cor@(Point
c1, Point
c2, Point
c3, Point
c4) <- HV -> Point -> Bool -> Point -> Bool -> Area -> Rnd Corridor
mkCorridor HV
hv Point
p0 (Area
sa Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
== Area
so) Point
p1 (Area
ta Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
== Area
to) Area
area
let !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
sslim Bool -> Bool -> Bool
|| Bool
tslim Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall v. Show v => (v -> Bool) -> [v] -> Bool
allB Point -> Bool
nin [Point
c1, Point
c2, Point
c3, Point
c4]
Bool
-> (Corridor, Key, Key, Key, Key, (Area, Fence, Area),
(Area, Fence, Area))
-> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Corridor
cor, Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)) ()
Maybe Corridor -> Rnd (Maybe Corridor)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Corridor -> Rnd (Maybe Corridor))
-> Maybe Corridor -> Rnd (Maybe Corridor)
forall a b. (a -> b) -> a -> b
$ Corridor -> Maybe Corridor
forall a. a -> Maybe a
Just Corridor
cor
borderPlace :: Area -> Fence -> (Area, Area, Bool)
borderPlace :: Area -> Fence -> (Area, Area, Bool)
borderPlace Area
qarea Fence
pfence = case Fence
pfence of
Fence
FWall -> (Area
qarea, Area -> Area
expand Area
qarea, Bool
False)
Fence
FFloor -> (Area
qarea, Area
qarea, Bool
False)
Fence
FGround -> (Area
qarea, Area
qarea, Bool
False)
Fence
FNone -> case Area -> Maybe Area
shrink Area
qarea of
Maybe Area
Nothing -> (Area
qarea, Area
qarea, Bool
True)
Just Area
sr -> (Area
sr, Area
qarea, Bool
False)
data SpecialArea =
SpecialArea Area
| SpecialFixed Point (Freqs PlaceKind) Area
| SpecialMerged SpecialArea Point
deriving Key -> SpecialArea -> ShowS
[SpecialArea] -> ShowS
SpecialArea -> [Char]
(Key -> SpecialArea -> ShowS)
-> (SpecialArea -> [Char])
-> ([SpecialArea] -> ShowS)
-> Show SpecialArea
forall a.
(Key -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> SpecialArea -> ShowS
showsPrec :: Key -> SpecialArea -> ShowS
$cshow :: SpecialArea -> [Char]
show :: SpecialArea -> [Char]
$cshowList :: [SpecialArea] -> ShowS
showList :: [SpecialArea] -> ShowS
Show
grid :: EM.EnumMap Point (Freqs PlaceKind) -> [Point] -> Area -> (X, Y)
-> ((X, Y), EM.EnumMap Point SpecialArea)
grid :: EnumMap Point (Freqs PlaceKind)
-> [Point]
-> Area
-> (Key, Key)
-> ((Key, Key), EnumMap Point SpecialArea)
grid EnumMap Point (Freqs PlaceKind)
fixedCenters [Point]
boot Area
area (Key, Key)
cellSize =
let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
f :: Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
zsize Key
z1 Key
n Key
prev (Key
c1 : Key
c2 : [Key]
rest) =
let len :: Key
len = Key
c2 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
c1
cn :: Key
cn = Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
n Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
zsize
in
if Key
cn Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
2
then let mid1 :: Key
mid1 = (Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
c2) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2
mid2 :: Key
mid2 = (Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
c2) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`divUp` Key
2
mid :: Key
mid = if Key
mid1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
prev Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
4 then Key
mid1 else Key
mid2
in (Key
prev, Key
mid, Key -> Maybe Key
forall a. a -> Maybe a
Just Key
c1) (Key, Key, Maybe Key)
-> [(Key, Key, Maybe Key)] -> [(Key, Key, Maybe Key)]
forall a. a -> [a] -> [a]
: Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
zsize Key
z1 Key
n Key
mid (Key
c2 Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
rest)
else (Key
prev, Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn), Key -> Maybe Key
forall a. a -> Maybe a
Just Key
c1)
(Key, Key, Maybe Key)
-> [(Key, Key, Maybe Key)] -> [(Key, Key, Maybe Key)]
forall a. a -> [a] -> [a]
: [ ( Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
z Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn)
, Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
z Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn)
, Maybe Key
forall a. Maybe a
Nothing )
| Key
z <- [Key
1 .. Key
cn Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1] ]
[(Key, Key, Maybe Key)]
-> [(Key, Key, Maybe Key)] -> [(Key, Key, Maybe Key)]
forall a. [a] -> [a] -> [a]
++ Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
zsize Key
z1 Key
n (Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn))
(Key
c2 Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
rest)
f Key
_ Key
z1 Key
_ Key
prev [Key
c1] = [(Key
prev, Key
z1, Key -> Maybe Key
forall a. a -> Maybe a
Just Key
c1)]
f Key
_ Key
_ Key
_ Key
_ [] = [Char] -> [(Key, Key, Maybe Key)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [(Key, Key, Maybe Key)])
-> [Char] -> [(Key, Key, Maybe Key)]
forall a b. (a -> b) -> a -> b
$ [Char]
"empty list of centers" [Char] -> EnumMap Point (Freqs PlaceKind) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` EnumMap Point (Freqs PlaceKind)
fixedCenters
(IntSet
xCenters, IntSet
yCenters) = [Key] -> IntSet
IS.fromList ([Key] -> IntSet)
-> ([Key] -> IntSet) -> ([Key], [Key]) -> (IntSet, IntSet)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Key] -> IntSet
IS.fromList
(([Key], [Key]) -> (IntSet, IntSet))
-> ([Key], [Key]) -> (IntSet, IntSet)
forall a b. (a -> b) -> a -> b
$ [(Key, Key)] -> ([Key], [Key])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Key, Key)] -> ([Key], [Key])) -> [(Key, Key)] -> ([Key], [Key])
forall a b. (a -> b) -> a -> b
$ (Point -> (Key, Key)) -> [Point] -> [(Key, Key)]
forall a b. (a -> b) -> [a] -> [b]
map (Point -> Key
px (Point -> Key) -> (Point -> Key) -> Point -> (Key, Key)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point -> Key
py) ([Point] -> [(Key, Key)]) -> [Point] -> [(Key, Key)]
forall a b. (a -> b) -> a -> b
$ EnumMap Point (Freqs PlaceKind) -> [Point]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys EnumMap Point (Freqs PlaceKind)
fixedCenters
distFromIS :: IntSet -> Key -> Key
distFromIS IntSet
is Key
z =
- [Key] -> Key
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Key
forall a. Bounded a => a
maxBound Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: (Key -> Key) -> [Key] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
i -> Key -> Key
forall a. Num a => a -> a
abs (Key
i Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
z)) (IntSet -> [Key]
IS.toList IntSet
is))
xboot :: [Key]
xboot = [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Key) -> [Key] -> [Key]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (IntSet -> Key -> Key
distFromIS IntSet
xCenters)
([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> IntSet -> Bool
`IS.notMember` IntSet
xCenters) ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Point -> Key) -> [Point] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Key
px [Point]
boot
yboot :: [Key]
yboot = [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Key) -> [Key] -> [Key]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (IntSet -> Key -> Key
distFromIS IntSet
yCenters)
([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> IntSet -> Bool
`IS.notMember` IntSet
yCenters) ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Point -> Key) -> [Point] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Key
py [Point]
boot
xcellsInArea :: Key
xcellsInArea = (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> a
fst (Key, Key)
cellSize
ycellsInArea :: Key
ycellsInArea = (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> b
snd (Key, Key)
cellSize
xbootN :: Key
xbootN = Bool -> Key -> Key
forall a. HasCallStack => Bool -> a -> a
assert (Key
xcellsInArea Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key
xcellsInArea Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.size IntSet
xCenters
ybootN :: Key
ybootN = Bool -> Key -> Key
forall a. HasCallStack => Bool -> a -> a
assert (Key
ycellsInArea Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key
ycellsInArea Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.size IntSet
yCenters
xset :: IntSet
xset = IntSet
xCenters IntSet -> IntSet -> IntSet
`IS.union` [Key] -> IntSet
IS.fromList (Key -> [Key] -> [Key]
forall a. Key -> [a] -> [a]
take Key
xbootN [Key]
xboot)
yset :: IntSet
yset = IntSet
yCenters IntSet -> IntSet -> IntSet
`IS.union` [Key] -> IntSet
IS.fromList (Key -> [Key] -> [Key]
forall a. Key -> [a] -> [a]
take Key
ybootN [Key]
yboot)
xsize :: Key
xsize = IntSet -> Key
IS.findMax IntSet
xset Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.findMin IntSet
xset
ysize :: Key
ysize = IntSet -> Key
IS.findMax IntSet
yset Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.findMin IntSet
yset
lgrid :: (Key, Key)
lgrid = ( Key
xsize Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> a
fst (Key, Key)
cellSize
, Key
ysize Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> b
snd (Key, Key)
cellSize )
xallSegments :: [(Key, (Key, Key, Maybe Key))]
xallSegments = [Key] -> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
0..] ([(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))])
-> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
xsize Key
x1 ((Key, Key) -> Key
forall a b. (a, b) -> a
fst (Key, Key)
lgrid) Key
x0 ([Key] -> [(Key, Key, Maybe Key)])
-> [Key] -> [(Key, Key, Maybe Key)]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList IntSet
xset
yallSegments :: [(Key, (Key, Key, Maybe Key))]
yallSegments = [Key] -> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
0..] ([(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))])
-> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
ysize Key
y1 ((Key, Key) -> Key
forall a b. (a, b) -> b
snd (Key, Key)
lgrid) Key
y0 ([Key] -> [(Key, Key, Maybe Key)])
-> [Key] -> [(Key, Key, Maybe Key)]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList IntSet
yset
in
( ([(Key, (Key, Key, Maybe Key))] -> Key
forall a. [a] -> Key
length [(Key, (Key, Key, Maybe Key))]
xallSegments, [(Key, (Key, Key, Maybe Key))] -> Key
forall a. [a] -> Key
length [(Key, (Key, Key, Maybe Key))]
yallSegments)
, [(Point, SpecialArea)] -> EnumMap Point SpecialArea
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList
[ ( Key -> Key -> Point
Point Key
x Key
y
, case (Maybe Key
mcx, Maybe Key
mcy) of
(Just Key
cx, Just Key
cy) ->
case Point -> EnumMap Point (Freqs PlaceKind) -> Maybe (Freqs PlaceKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup (Key -> Key -> Point
Point Key
cx Key
cy) EnumMap Point (Freqs PlaceKind)
fixedCenters of
Maybe (Freqs PlaceKind)
Nothing -> Area -> SpecialArea
SpecialArea Area
sarea
Just Freqs PlaceKind
placeFreq -> Point -> Freqs PlaceKind -> Area -> SpecialArea
SpecialFixed (Key -> Key -> Point
Point Key
cx Key
cy) Freqs PlaceKind
placeFreq Area
sarea
(Maybe Key, Maybe Key)
_ -> Area -> SpecialArea
SpecialArea Area
sarea )
| (Key
y, (Key
cy0, Key
cy1, Maybe Key
mcy)) <- [(Key, (Key, Key, Maybe Key))]
yallSegments
, (Key
x, (Key
cx0, Key
cx1, Maybe Key
mcx)) <- [(Key, (Key, Key, Maybe Key))]
xallSegments
, let sarea :: Area
sarea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key
x, Key
y))
(Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key
cx0, Key
cy0, Key
cx1, Key
cy1) ] )