{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings #-} module Plane (dbNewPlane, planetName, randomPlanetName, planeDepth, dbGetCurrentPlane, dbDistanceBetweenSquared, pickRandomClearSite_withTimeout, pickRandomClearSite, getPlanarPosition, getBeneath, getSubsequent, terrainAt, setTerrainAt, whatIsOccupying, isTerrainPassable, getBiome) where import Grids import DB import TerrainData import PlaneData import Control.Monad import Data.Maybe import Data.List import Position import PlayerState import FactionData import qualified Data.ByteString.Char8 as B import Logging dbNewPlane :: (PlaneLocation l) => B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef dbNewPlane name tg_data l = do rns <- getRandoms random_id <- getRandomR (1,1000000) dbAddPlane (Plane { plane_biome = tg_biome tg_data, plane_terrain = generateTerrain tg_data rns, plane_random_id = random_id, plane_planet_name = name}) l planetName :: (DBReadable db) => PlaneRef -> db B.ByteString planetName = liftM plane_planet_name . dbGetPlane randomPlanetName :: (DBReadable db) => Faction -> db B.ByteString randomPlanetName faction = do planet_number <- getRandomR (1000 :: Integer,9999) return $ factionPrefix faction `B.append` "-" `B.append` B.pack (show planet_number) planeDepth :: (DBReadable db) => PlaneRef -> db Integer planeDepth this_plane = do l <- dbWhere this_plane case extractParent l of Just (Beneath above) -> liftM succ $ planeDepth above Nothing -> return 0 -- | -- If this object is anywhere on a plane (such as carried by a creature who is on the plane), -- returns the position of this object on that plane. -- TODO: this function seems generic enough that it should be moved and renamed. -- getPlanarPosition :: (DBReadable db,ReferenceType a,LocationParent p) => Reference a -> db (Maybe (Location (Reference ()) p)) getPlanarPosition ref = liftM (listToMaybe . mapMaybe coerceLocationRecord) $ dbGetAncestors ref -- | -- Get the plane beneath this one, if it exists. -- getBeneath :: (DBReadable db) => PlaneRef -> db (Maybe PlaneRef) getBeneath item = do (plane_locs :: [Location PlaneRef Beneath]) <- dbGetContents item return $ fmap child $ listToMaybe plane_locs -- | -- Get the plane subsequent to this one, if it exists. -- getSubsequent :: (DBReadable db) => PlaneRef -> db (Maybe PlaneRef) getSubsequent item = do (plane_locs :: [Location PlaneRef Subsequent]) <- dbGetContents item return $ fmap child $ listToMaybe plane_locs -- | -- Distance between two entities. If the entities are not on the same plane, or for some other reason it doesn't make -- sense to ask their distance, the Nothing. -- dbDistanceBetweenSquared :: (DBReadable db,ReferenceType a,ReferenceType b) => Reference a -> Reference b -> db (Maybe Integer) dbDistanceBetweenSquared a_ref b_ref = do m_a <- liftM (fmap parent) $ getPlanarPosition a_ref m_b <- liftM (fmap parent) $ getPlanarPosition b_ref return $ do (p_a :: PlaneRef,a :: MultiPosition) <- m_a (p_b,b :: MultiPosition) <- m_b guard $ p_a == p_b return $ distanceBetweenSquared a b -- | -- Gets the current plane of interest based on whose turn it is. -- dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef) dbGetCurrentPlane = liftM (fmap parent) $ maybe (return Nothing) getPlanarPosition . creatureOf =<< playerState -- | -- Selects sites at random until one seems reasonably clear. It begins at -- the specified Position on the map, and then picks more sites further and further away from the center -- until it one seems clear -- this tends to concentrate sites near the center. -- -- A site is considered clear if there are no objects at all within object_clear squares, and -- only appropriate terrain (as defined by a predicate) within terrain_clear squares. -- Distance is chessboard distance. -- -- This function will gradually expand the search radius if encounters the slightest -- difficulty finding a qualifying position. The search radius parameter is strictly advisory. -- -- This function can take an optional timeout parameter (pickRandomClearSite_withTimeout). When used -- without a timeout parameter, it may not terminate. The only possible cause of non-termination is that no -- site satisfies the terrain predicate. However, if satisfactory sites are sufficiently rare, -- extreme slowness is likely. -- -- The timeout value should be a small integer greater or equal to one, since this function becomes slow with large timeout values. -- pickRandomClearSite :: (DBReadable db) => Integer -> Integer -> Integer -> Position -> (TerrainPatch -> Bool) -> PlaneRef -> db Position pickRandomClearSite search_radius object_clear terrain_clear p terrainPredicate plane_ref = liftM (fromMaybe $ error "pickRandomClearSite: impossible") $ pickRandomClearSite_withTimeout Nothing search_radius object_clear terrain_clear p terrainPredicate plane_ref pickRandomClearSite_withTimeout :: (DBReadable db) => Maybe Integer -> Integer -> Integer -> Integer -> Position -> (TerrainPatch -> Bool) -> PlaneRef -> db (Maybe Position) pickRandomClearSite_withTimeout (Just x) _ _ _ _ _ _ | x <= 0 = return Nothing pickRandomClearSite_withTimeout timeout search_radius object_clear terrain_clear (Position (start_x,start_y)) terrainPredicate plane_ref = do logDB log_plane DEBUG $ "Searching for clear site . . ." xys <- liftM2 (\a b -> map Position $ zip a b) (mapM (\x -> liftM (+start_x) $ getRandomR (-x,x)) [1..search_radius]) (mapM (\x -> liftM (+start_y) $ getRandomR (-x,x)) [1..search_radius]) terrain <- liftM plane_terrain $ dbGetPlane plane_ref clutter_locations <- liftM (map (parent . asLocationTyped _nullary _multiposition)) $ dbGetContents plane_ref let terrainIsClear (Position (x,y)) = all terrainPredicate $ concat [[gridAt terrain (x',y') | x' <- [x-terrain_clear..x+terrain_clear]] | y' <- [y-terrain_clear..y+terrain_clear]] let clutterIsClear here = not $ any (\p -> distanceBetweenChessboard here p <= object_clear) clutter_locations let m_result = find (\p -> terrainIsClear p && clutterIsClear p) xys case m_result of Just result -> do logDB log_plane DEBUG "Found clear site." return $ Just result Nothing -> pickRandomClearSite_withTimeout (fmap (subtract 1) timeout) (search_radius + 1) object_clear (max 0 $ terrain_clear - 1) (Position (start_x,start_y)) terrainPredicate plane_ref terrainAt :: (DBReadable db) => PlaneRef -> Position -> db TerrainPatch terrainAt plane_ref (Position (x,y)) = do terrain <- liftM plane_terrain $ dbGetPlane plane_ref return $ gridAt terrain (x,y) setTerrainAt :: PlaneRef -> Position -> TerrainPatch -> DB () setTerrainAt plane_ref (Position pos) patch = dbModPlane (\p -> p { plane_terrain = specificReplaceGrid pos patch $ plane_terrain p }) plane_ref -- | Lists all of the entities that are on a specific spot, not including nested entities. -- Typically this is zero or one creatures, and zero or more tools. whatIsOccupying :: (DBReadable db,GenericReference a) => PlaneRef -> Position -> db [a] whatIsOccupying plane_ref position = liftM (mapMaybe fromLocation . filter ((== 0) . (distanceBetweenChessboard position) . parent) . map (asLocationTyped _nullary _multiposition)) $ dbGetContents plane_ref -- | Answers True iff a creature may walk or swim or drop objects at the position. -- Lava is considered passable, but trees are not. isTerrainPassable :: (DBReadable db) => PlaneRef -> CreatureRef -> Position -> db Bool isTerrainPassable plane_ref creature_ref position = do (critters :: [Either BuildingRef CreatureRef]) <- liftM (filter (=/= creature_ref)) $ whatIsOccupying plane_ref position terrain <- terrainAt plane_ref position return $ not (terrain `elem` [RockFace,Forest,DeepForest]) && null critters getBiome :: (DBReadable db) => PlaneRef -> db Biome getBiome = liftM plane_biome . dbGetPlane