Permalink
Browse files

Enhanced graph model (specifically) and unit test model (broadly).

  • Loading branch information...
1 parent 02641ea commit 6ef7291ce094da6befe523f1293e4fa09d10f2ab @clanehin committed Jan 5, 2014
View
@@ -25,4 +25,4 @@ check: clean
cabal-dev build
depends:
- cabal-dev install -j cipher-aes MaybeT MonadCatchIO-transformers aeson data-lens-template data-memocombinators hastache hslogger mwc-random snap-core snap-server snap streams system-uuid data-lens-template snap streams
+ cabal-dev install-deps -j
@@ -1,12 +0,0 @@
-module Roguestar.Lib.Core.Entities
- (getAncestors)
- where
-
-import Roguestar.Lib.Data.LocationData
-import Roguestar.Lib.DB
-
-getAncestors :: Reference a -> DB_BaseType -> [Location]
-getAncestors reference _ | reference =:= the_universe = []
-getAncestors reference db = location : getAncestors reference' db
- where reference' = parentReference location
- location = whereIs reference db
@@ -38,7 +38,6 @@ import qualified Data.ByteString.Char8 as B
import Roguestar.Lib.Data.BuildingData
import Roguestar.Lib.Logging
import Control.Monad.Maybe
-import Roguestar.Lib.Core.Entities
dbNewPlane :: (LocationConstructor l, ReferenceTypeOf l ~ Plane) => B.ByteString -> TerrainGenerationData -> l -> DB PlaneRef
dbNewPlane name tg_data l =
@@ -9,7 +9,6 @@ import Roguestar.Lib.Data.MonsterData
import Roguestar.Lib.Data.TerrainData
import Roguestar.Lib.Data.ToolData
import Roguestar.Lib.DB
-import Roguestar.Lib.Core.Entities
import Roguestar.Lib.Core.Plane
import Test.HUnit
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Roguestar.Lib.Core2.Realization
+ (realizePlane,
+ realizeMonster,
+ realizeSquare)
+ where
+
+--
+-- This module extracts information from the database and builds a navigable object graph.
+--
+-- See Roguestar.Lib.DB to see the database implementation we are pulling from.
+-- See Roguestar.Lib.Graph to see the graph model we are realizing.
+--
+
+import Prelude hiding (getContents)
+import qualified Roguestar.Lib.Data.PlaneData as PlaneData
+import Roguestar.Lib.DB
+import Roguestar.Lib.Graph
+import Data.Maybe (mapMaybe, fromMaybe)
+import qualified Data.Set as Set
+
+realizePlane :: DB_BaseType -> PlaneRef -> Plane
+realizePlane db plane_ref = Plane {
+ plane_to_reference = plane_ref,
+ plane_to_data = getPlane plane_ref db,
+ plane_to_monsters = Set.fromList $ map (realizeMonster db . asChild) $ mapMaybe fromLocation $ getContents plane_ref db,
+ plane_to_buildings = Set.empty }
+
+realizeMonster :: DB_BaseType -> MonsterRef -> Monster
+realizeMonster db monster_ref = Monster {
+ monster_to_reference = monster_ref,
+ monster_to_data = getMonster monster_ref db,
+ monster_to_square = realizeSquare db plane_ref p }
+ where (p :: Position, Parent plane_ref :: Parent PlaneData.Plane) = fromMaybe (error "realizeMonster: doesn't have a planar position") $ fromLocation $ whereIs monster_ref db
+
+realizeSquare :: DB_BaseType -> PlaneRef -> Position -> Square
+realizeSquare db plane_ref p = Square {
+ square_to_plane = realizePlane db plane_ref,
+ square_to_position = p }
+
View
@@ -36,6 +36,7 @@ module Roguestar.Lib.DB
dbVerify,
whereIs,
getContents,
+ getAncestors,
move,
ro, atomic,
logDB,
@@ -486,6 +487,15 @@ getContents :: Reference t -> DB_BaseType -> [Location]
getContents item = HD.lookupChildren (toUID item) . db_hierarchy
-- |
+-- Returns locations of all ancestors, starting with the parent and proceeding in order to the root.
+--
+getAncestors :: Reference a -> DB_BaseType -> [Location]
+getAncestors reference _ | reference =:= the_universe = []
+getAncestors reference db = location : getAncestors reference' db
+ where reference' = parentReference location
+ location = whereIs reference db
+
+-- |
-- Gets the time of an object.
--
-- The "time" of an object is when its next turn is scheduled.
@@ -160,7 +160,10 @@ instance LocationDetail Facing where
fromLocation (IsSubsequent {}) = Nothing
fromLocation (IsBeneath {}) = Nothing
+-- | A convenience type to indicate that a reference is the parent component of a parent-child location record pair.
newtype Parent a = Parent { asParent :: Reference a }
+
+-- | A convenience type to indicate that a reference is the child component of a parent-child location record pair.
newtype Child a = Child { asChild :: Reference a }
instance ReferenceType a => LocationDetail (Parent a) where
View
@@ -0,0 +1,10 @@
+module Roguestar.Lib.Graph
+ (module Roguestar.Lib.Graph.Graph,
+ module Roguestar.Lib.Graph.Classes,
+ module Roguestar.Lib.Graph.Location)
+ where
+
+import Roguestar.Lib.Graph.Graph
+import Roguestar.Lib.Graph.Classes
+import Roguestar.Lib.Graph.Location
+
@@ -0,0 +1,72 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Roguestar.Lib.Graph.Classes
+ (HasPlane(..),
+ HasSquare(..),
+ HasMonsters(..),
+ HasMonster(..),
+ comonsters,
+ position,
+ planeReference,
+ monsterReference)
+ where
+
+import qualified Roguestar.Lib.Data.ReferenceTypes as References
+import Roguestar.Lib.Position
+import Roguestar.Lib.Graph.Graph
+import qualified Data.Set as Set
+
+class HasPlane a where
+ plane :: a -> Plane
+
+class HasMonsters a where
+ monsters :: a -> Set.Set (Monster)
+
+class HasMonster a where
+ monster :: a -> Monster
+
+class HasBuildings a where
+ buildings :: a -> Set.Set (Building)
+
+class HasSquare a where
+ square :: a -> Square
+
+instance HasPlane Plane where
+ plane = id
+
+instance HasPlane Square where
+ plane = square_to_plane
+
+instance HasPlane Monster where
+ plane = plane . square
+
+instance HasMonsters Plane where
+ monsters = plane_to_monsters
+
+instance HasMonsters Monster where
+ monsters m = Set.singleton m
+
+instance HasMonster Monster where
+ monster = id
+
+instance HasSquare Square where
+ square = id
+
+instance HasSquare Monster where
+ square = monster_to_square
+
+instance HasBuildings Plane where
+ buildings = plane_to_buildings
+
+-- | Monsters, other than this monster, on the same plane as this monster.
+comonsters :: Monster -> Set.Set Monster
+comonsters m = Set.filter (/= m) $ monsters $ plane m
+
+position :: (HasSquare a) => a -> Position
+position = square_to_position . square
+
+planeReference :: (HasPlane a) => a -> References.PlaneRef
+planeReference = plane_to_reference . plane
+
+monsterReference :: (HasMonster a) => a -> References.MonsterRef
+monsterReference = monster_to_reference . monster
+
@@ -0,0 +1,59 @@
+module Roguestar.Lib.Graph.Graph
+ (Monster(..),
+ Plane(..),
+ Square(..),
+ Building(..))
+ where
+
+import qualified Data.Set as Set
+import qualified Roguestar.Lib.Data.ReferenceTypes as References
+import qualified Roguestar.Lib.Data.MonsterData as MonsterData
+import qualified Roguestar.Lib.Data.PlaneData as PlaneData
+import Roguestar.Lib.Position
+
+data Monster = Monster {
+ monster_to_reference :: References.MonsterRef,
+ monster_to_data :: MonsterData.Monster,
+ monster_to_square :: Square }
+
+data Square = Square {
+ square_to_plane :: Plane,
+ square_to_position :: Position }
+
+data Plane = Plane {
+ plane_to_reference :: References.PlaneRef,
+ plane_to_data :: PlaneData.Plane,
+ plane_to_monsters :: Set.Set Monster,
+ plane_to_buildings :: Set.Set Building }
+
+data Building = Building {
+ building_to_reference :: References.BuildingRef,
+ building_to_position :: Set.Set Square }
+
+instance Eq Monster where
+ a == b = monster_to_reference a == monster_to_reference b
+
+instance Eq Plane where
+ a == b = plane_to_reference a == plane_to_reference b
+
+instance Eq Building where
+ a == b = building_to_reference a == building_to_reference b
+
+instance Ord Monster where
+ compare a b = compare (monster_to_reference a) (monster_to_reference b)
+
+instance Ord Plane where
+ compare a b = compare (plane_to_reference a) (plane_to_reference b)
+
+instance Ord Building where
+ compare a b = compare (building_to_reference a) (building_to_reference b)
+
+instance Show Monster where
+ show = show . monster_to_reference
+
+instance Show Plane where
+ show = show . plane_to_reference
+
+instance Show Building where
+ show = show . building_to_reference
+
@@ -0,0 +1,14 @@
+module Roguestar.Lib.Graph.Location
+ (standing)
+ where
+
+import Roguestar.Lib.Data.FacingData
+import Roguestar.Lib.Data.LocationData
+import Roguestar.Lib.Graph.Classes
+
+standing :: (HasSquare a) => Facing -> a -> Standing
+standing face x = Standing (planeReference $ plane $ square x)
+ (position $ square x)
+ face
+
+
@@ -0,0 +1,49 @@
+module Roguestar.Lib.Graph.Tests
+ (testcases)
+ where
+
+import qualified Roguestar.Lib.Data.ReferenceTypes as References
+import Roguestar.Lib.Graph.Graph
+import Roguestar.Lib.Graph.Classes
+import qualified Data.Set as Set
+import Test.HUnit
+
+testcases :: Test
+testcases = TestLabel "Roguestar.Lib.Model.Tests" $ TestList [
+ testPlaneToSelf,
+ testMonsterToPlane,
+ testCoMonsters]
+
+equestria :: Plane
+equestria = Plane {
+ plane_to_reference = References.PlaneRef 0,
+ plane_to_monsters = Set.fromList [twilight, picard, zathras],
+ plane_to_buildings = Set.fromList [] }
+
+twilight :: Monster
+twilight = Monster {
+ monster_to_data = error "undefined twilight",
+ monster_to_reference = References.MonsterRef 1,
+ monster_to_square = Square equestria (error "No Position") }
+
+picard :: Monster
+picard = Monster {
+ monster_to_data = error "undefined picard",
+ monster_to_reference = References.MonsterRef 2,
+ monster_to_square = Square equestria (error "No Position") }
+
+zathras :: Monster
+zathras = Monster {
+ monster_to_data = error "undefined zathras",
+ monster_to_reference = References.MonsterRef 3,
+ monster_to_square = Square equestria (error "No Position") }
+
+testPlaneToSelf :: Test
+testPlaneToSelf = TestCase $ assertEqual "testPlaneToSelf" equestria (plane equestria)
+
+testMonsterToPlane :: Test
+testMonsterToPlane = TestCase $ assertEqual "testMonsterToPlane" equestria (plane picard)
+
+testCoMonsters :: Test
+testCoMonsters = TestCase $ assertEqual "testCoMonsters" (Set.fromList [twilight, picard]) (comonsters zathras)
+
@@ -1,36 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module Roguestar.Lib.Model.Classes
- (HasPlane(..),
- HasMonsters(..),
- comonsters)
- where
-
-import Control.Arrow
-import Roguestar.Lib.Model.Graph
-import qualified Data.Set as Set
-
-class HasPlane a where
- plane :: a x -> Plane x
-
-class HasMonsters a where
- monsters :: a x -> Set.Set (Monster x)
-
-instance HasPlane Plane where
- plane = id
-
-instance HasPlane Square where
- plane = square_to_plane
-
-instance HasPlane Monster where
- plane = monster_to_square >>> square_to_plane
-
-instance HasMonsters Plane where
- monsters = plane_to_monsters
-
-instance HasMonsters Monster where
- monsters m = Set.singleton m
-
--- | Monsters, other than this monster, on the same plane as this monster.
-comonsters :: (Eq (Monster x)) => Monster x -> Set.Set (Monster x)
-comonsters m = Set.filter (/= m) $ monsters $ plane m
-
Oops, something went wrong.

0 comments on commit 6ef7291

Please sign in to comment.