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

parent 02641ea4
......@@ -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
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
......
{-# 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 }
......@@ -36,6 +36,7 @@ module Roguestar.Lib.DB
dbVerify,
whereIs,
getContents,
getAncestors,
move,
ro, atomic,
logDB,
......@@ -485,6 +486,15 @@ whereIs item = fromMaybe (error "whereIs: has no location") . HD.lookupParent (t
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.
--
......
......@@ -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
......
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
{-# LANGUAGE FlexibleContexts #-}
module Roguestar.Lib.Model.Classes
module Roguestar.Lib.Graph.Classes
(HasPlane(..),
HasSquare(..),
HasMonsters(..),
comonsters)
HasMonster(..),
comonsters,
position,
planeReference,
monsterReference)
where
import Control.Arrow
import Roguestar.Lib.Model.Graph
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 x -> Plane x
plane :: a -> Plane
class HasMonsters a where
monsters :: a x -> Set.Set (Monster x)
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
......@@ -22,7 +37,7 @@ instance HasPlane Square where
plane = square_to_plane
instance HasPlane Monster where
plane = monster_to_square >>> square_to_plane
plane = plane . square
instance HasMonsters Plane where
monsters = plane_to_monsters
......@@ -30,7 +45,28 @@ instance HasMonsters Plane where
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 :: (Eq (Monster x)) => Monster x -> Set.Set (Monster x)
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
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
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
module Roguestar.Lib.Model.Tests
module Roguestar.Lib.Graph.Tests
(testcases)
where
import Roguestar.Lib.Model.Graph
import Roguestar.Lib.Model.Classes
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
......@@ -13,40 +14,36 @@ testcases = TestLabel "Roguestar.Lib.Model.Tests" $ TestList [
testMonsterToPlane,
testCoMonsters]
data ID =
Equestria
| Nirn
| Twilight
| Ysolda
| Zathras
deriving (Eq, Ord, Show)
equestria :: Plane ID
equestria :: Plane
equestria = Plane {
plane_to_uid = Equestria,
plane_to_monsters = Set.fromList [twilight, ysolda, zathras] }
plane_to_reference = References.PlaneRef 0,
plane_to_monsters = Set.fromList [twilight, picard, zathras],
plane_to_buildings = Set.fromList [] }
twilight :: Monster ID
twilight :: Monster
twilight = Monster {
monster_to_uid = Twilight,
monster_to_square = Square equestria }
monster_to_data = error "undefined twilight",
monster_to_reference = References.MonsterRef 1,
monster_to_square = Square equestria (error "No Position") }
ysolda :: Monster ID
ysolda = Monster {
monster_to_uid = Ysolda,
monster_to_square = Square equestria }
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 ID
zathras :: Monster
zathras = Monster {
monster_to_uid = Zathras,
monster_to_square = Square equestria }
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 ysolda)
testMonsterToPlane = TestCase $ assertEqual "testMonsterToPlane" equestria (plane picard)
testCoMonsters :: Test
testCoMonsters = TestCase $ assertEqual "testCoMonsters" (Set.fromList [twilight, ysolda]) (comonsters zathras)
testCoMonsters = TestCase $ assertEqual "testCoMonsters" (Set.fromList [twilight, picard]) (comonsters zathras)
module Roguestar.Lib.Model.Graph
(Monster(..),
Plane(..),
Square(..))
where
import qualified Data.Set as Set
data Monster a = Monster {
monster_to_uid :: a,
monster_to_square :: Square a }
deriving (Show)
data Square a = Square {
square_to_plane :: Plane a }
deriving (Show)
data Plane a = Plane {
plane_to_uid :: a,
plane_to_monsters :: Set.Set (Monster a) }
deriving (Show)
class HasGraphUID a where
toUID :: a x -> x
instance HasGraphUID Monster where
toUID = monster_to_uid
instance HasGraphUID Plane where
toUID = plane_to_uid
eqByUID :: (HasGraphUID a, Eq x) => a x -> a x -> Bool
eqByUID a b = toUID a == toUID b
instance (Eq a) => Eq (Monster a) where
(==) = eqByUID
instance (Eq a) => Eq (Plane a) where
(==) = eqByUID
ordByUID :: (HasGraphUID a, Ord x) => a x -> a x -> Ordering
ordByUID a b = compare (toUID a) (toUID b)
instance (Ord a) => Ord (Monster a) where
compare = ordByUID
instance (Ord a) => Ord (Plane a) where
compare = ordByUID
module Roguestar.Lib.Model.GraphUIDs
()
where
class HasGraphUID a where
toUID :: a x -> x
instance HasGraphUID Monster where
toUID = monster_to_uid
instance HasGraphUID Plane where
toUID = plane_to_uid
eqByUID :: (HasGraphUID a, Eq x) => a x -> a x -> Bool
eqByUID a b = toUID a == toUID b
--Deprecated
module Roguestar.Lib.Tests
(TestResult(..),
TestCase,
test,
runAllTests,
sampleTestCase)
where
data TestResult = Passed String | Failed String deriving Show
type TestCase = IO TestResult
-- |
-- Sample test case that always passes.
--
sampleTestCase :: IO TestResult
sampleTestCase = do return (Passed "sampleTestCase")
-- |
-- True if the TestResult is Passed, False otherwise
--
testResultToBool :: TestResult -> Bool
testResultToBool (Passed _) = True
testResultToBool (Failed _) = False
-- |
-- Simple way to generate a TestResult based on a boolean test result.
--
test :: String -> Bool -> TestCase
test str True = return $ Passed str
test str False = return $ Failed str
-- |
-- Runs every specified test case, returning True iff all tests pass.
-- Results from the tests are printed.
--
runAllTests :: [TestCase] -> IO Bool
runAllTests [] = do return True
runAllTests (testCase:testCases) = do testResult <- testCase
putStrLn (show testResult)
testResults <- runAllTests testCases
return (testResults && testResultToBool testResult)
......@@ -6,8 +6,8 @@ import Data.Text as T
import Control.Monad.Writer.Lazy as W
import Roguestar.Lib.Roguestar
import Data.Maybe
import Data.List as List
import Control.Concurrent
import System.IO
import Roguestar.Lib.DB
import Roguestar.Lib.Data.PlayerState
import Control.Monad.Reader.Class
......@@ -17,34 +17,39 @@ import Roguestar.Lib.Utility.SiteCriteria
import Roguestar.Lib.Random as Random
import qualified Test.HUnit.Base as HUnit
import qualified Test.HUnit.Text as HUnitText
import qualified Roguestar.Lib.Model.Tests as ModelTests
import qualified Roguestar.Lib.Graph.Tests as GraphTests
import qualified Roguestar.Lib.Core.Tests as CoreTests
type UnitTest = WriterT (T.Text,All) IO ()
import qualified Roguestar.Lib.Utility.HierarchicalDatabase as HDatabaseTests
runTests :: IO (T.Text,Bool)
runTests =
do ((),(t,All b)) <- runWriterT $ sequence_ unit_tests
counts <- HUnitText.runTestTT testcases
return (t,b && HUnit.errors counts > 0 || HUnit.failures counts > 0)
do (counts, text) <- captureTestResults testcases
return (text, HUnit.errors counts == 0 && HUnit.failures counts == 0)
data TestResult = TestResult {
test_result_text :: [T.Text] }
unit_tests :: [UnitTest]
unit_tests = [testPickRandomClearSite]
pathOf :: HUnit.State -> String
pathOf (HUnit.State { HUnit.path = p }) = List.concat $ List.map (nodeToString) $ List.reverse p
where nodeToString (HUnit.ListItem i) = "[" ++ show i ++ "]"
nodeToString (HUnit.Label s) = "/" ++ s
assert :: Bool -> T.Text -> UnitTest
assert ok test_name =
do let message = test_name `T.append` (if ok then ": ok." else ": FAILED.") `T.append` "\n"
tell (message, All ok)
liftIO $ hPutStr stderr $ T.unpack message
captureTestResults :: HUnit.Test -> IO (HUnit.Counts, T.Text)
captureTestResults test =
do (counts, test_result) <- HUnit.performTest report_start report_problem report_problem (TestResult []) test
return (counts, T.concat $ List.intersperse "\n\n" $ List.reverse $ test_result_text test_result)
where report_start state test_result = return $ test_result { test_result_text = (T.pack $ "\n" ++ pathOf state) : test_result_text test_result }
report_problem msg state test_result = return $ test_result { test_result_text = (T.pack $ pathOf state ++ ": " ++ msg) : test_result_text test_result }
-- Generate N random planes and run tests against them.
runWithRandomPlanes :: Int -> T.Text -> (PlaneRef -> DB Bool) -> UnitTest
runWithRandomPlanes n test_name db_action = forM_ [1..n] $ \x ->
do b <- liftIO $ runDB (runWithRandomPlane_ db_action) initial_db
assert (either (const False) fst b) (test_name `T.append` "#" `T.append` T.pack (show x))
runWithRandomPlanes :: Int -> String -> (PlaneRef -> DB HUnit.Assertion) -> HUnit.Test
runWithRandomPlanes n test_name db_action = HUnit.TestList $ (flip Prelude.map) [1..n] $ \x -> HUnit.TestLabel (test_name ++ "#" ++ show x) $ HUnit.TestCase $
liftIO $ do result <- runDB (runWithRandomPlane_ db_action) initial_db
case result of
(Right (assertion, _)) -> assertion
(Left (err)) -> HUnit.assertString (show err)
runWithRandomPlane_ :: (PlaneRef -> DB Bool) -> DB Bool
runWithRandomPlane_ :: (PlaneRef -> DB HUnit.Assertion) -> DB HUnit.Assertion
runWithRandomPlane_ dbAction =
do let biome = Random.weightedSet [(4,TemperateClearing),(1,TemperateForest)]
plane_ref <- dbNewPlane "testPlane" (TerrainGenerationData 3 biome []) TheUniverse
......@@ -52,11 +57,13 @@ runWithRandomPlane_ dbAction =
{-- UNIT TESTS BEGIN HERE --}
testcases :: HUnit.Test
testcases = HUnit.TestList [
testcases = HUnit.TestLabel "root" $ HUnit.TestList [
HUnit.TestLabel "session" $ HUnit.TestList $ [testSessionAliveBeforeTimeout, testSessionExpiredAfterTimeout],
HUnit.TestLabel "database" $ HUnit.TestList $ [testSetPlayerState, testLocal],
HUnit.TestLabel "Roguestar.Lib.Model" $ ModelTests.testcases,
HUnit.TestLabel "Roguestar.Lib.Core" $ CoreTests.testcases]
HUnit.TestLabel "clear-site" $ testPickRandomClearSite,
HUnit.TestLabel "Roguestar.Lib.Graph" $ GraphTests.testcases,
HUnit.TestLabel "Roguestar.Lib.Core" $ CoreTests.testcases,
HUnit.TestLabel "Roguestar.Lib.Utility.HierarchicalDatabase" $ HDatabaseTests.testcases]
testSessionAliveBeforeTimeout :: HUnit.Test
testSessionAliveBeforeTimeout = HUnit.TestCase $
......@@ -98,7 +105,7 @@ testLocal = HUnit.TestCase $
Left _ -> HUnit.assertFailure "testLocal (failed in monad)"
Right (pstate,_) -> HUnit.assertEqual "testLocal" pstate (SpeciesSelectionState Nothing)
testPickRandomClearSite :: UnitTest
testPickRandomClearSite :: HUnit.Test
testPickRandomClearSite = runWithRandomPlanes 10 "testPickRandomClearSite" $ \plane_ref ->
do Position (x,y) <- pickRandomSite (-1000,1000) (-1000,1000) 50 (areaClearForObjectPlacement 1) plane_ref
t1 <- terrainAt plane_ref $ Position (x-1,y-1)
......@@ -110,4 +117,5 @@ testPickRandomClearSite = runWithRandomPlanes 10 "testPickRandomClearSite" $ \pl
t7 <- terrainAt plane_ref $ Position (x-1,y+1)
t8 <- terrainAt plane_ref $ Position (x,y+1)
t9 <- terrainAt plane_ref $ Position (x+1,y+1)
return $ Prelude.all (not . (`elem` difficult_terrains)) [t1,t2,t3,t4,t5,t6,t7,t8,t9]
return $ HUnit.assertBool "Unacceptable terrain obstruction." (Prelude.all (not . (`elem` difficult_terrains)) [t1,t2,t3,t4,t5,t6,t7,t8,t9])
-- Services
-- Utilities
module Roguestar.Lib.Utility.HierarchicalDatabase
(HierarchicalDatabase,
HierarchicalRelation(..),
......@@ -12,14 +12,14 @@ module Roguestar.Lib.Utility.HierarchicalDatabase
childrenOf,
Roguestar.Lib.Utility.HierarchicalDatabase.toList,
Roguestar.Lib.Utility.HierarchicalDatabase.fromList,
insidenessTests)
testcases)
where
import Prelude hiding (lookup)
import qualified Data.Map as Map
import qualified Data.List as List
import Roguestar.Lib.Tests
import Data.Maybe as Maybe
import qualified Test.HUnit as HUnit
-- | A record that can be a component of a 'HierarchicalDatabase'.
class HierarchicalRelation a where
......@@ -40,7 +40,8 @@ instance (Show a) => Show (HierarchicalDatabase a) where
show imap = show $ toList imap
instance (HierarchicalRelation a,Read a) => Read (HierarchicalDatabase a) where
readsPrec n = \v -> Prelude.map (\(x,y) -> (fromList x,y)) (readsPrec n v)
readsPrec n v = Prelude.map foo (readsPrec n v)
where foo (x,y) = (fromList x,y)
empty :: HierarchicalDatabase a
empty = HierarchicalDatabase (Map.empty) (Map.empty)
......@@ -135,34 +136,25 @@ example1 = fromList $ List.map ExampleRelation
(4,(-6),False),
(4,14,False)]
testParent :: TestCase
testParent = if (parentOf 0 example1) == (Just 2)
then return (Passed "testParent")
else return (Failed "testParent")
testParent :: HUnit.Test
testParent = HUnit.TestCase $ HUnit.assertEqual "testParent" (Just 2) (parentOf 0 example1)
testChildren :: TestCase
testChildren = if (length $ childrenOf 1 example1) == 5
then return (Passed "testChildren")
else return (Failed "testChildren")
testChildCount :: HUnit.Test
testChildCount = HUnit.TestCase $
HUnit.assertEqual "testChildCount" 5 (length $ childrenOf 1 example1)
testUserData :: TestCase
testUserData :: HUnit.Test
testUserData = let child_records = lookupChildren 1 example1
in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
then return (Passed "testUserDatas")
else return (Failed "testUserDatas")
in HUnit.TestCase $ HUnit.assertBool "testUserData" (all (\(ExampleRelation (_,_,b)) -> b) child_records)
testChildrenCorrect :: TestCase
testChildrenCorrect = let the_children = childrenOf 4 example1
in if (all even the_children)
then return (Passed "testChildrenCorrect")
else return (Failed "testChildrenCorrect")
testChildrenEven :: HUnit.Test
testChildrenEven = let the_children = childrenOf 4 example1 -- The example data is contrived so that all of the children of "4" have even numbered IDs.
in HUnit.TestCase $ HUnit.assertBool "testChildrenEven" (all even the_children)
testDelete :: TestCase
testDelete :: HUnit.Test
testDelete = let deleted = delete 0 $ delete (-6) $ example1
in if ((length $ childrenOf 4 deleted) == 2 &&
(isNothing $ parentOf 0 deleted))
then return (Passed "testDelete")
else return (Failed "testDelete")
in HUnit.TestCase $ HUnit.assertBool "testDelete" ((length $ childrenOf 4 deleted) == 2 &&
(isNothing $ parentOf 0 deleted))
insidenessTests :: [TestCase]
insidenessTests = [testParent,testChildren,testUserData,testChildrenCorrect,testDelete]
testcases :: HUnit.Test
testcases = HUnit.TestLabel "HierarchicalDatabase" $ HUnit.TestList [testParent,testChildCount,testUserData,testChildrenEven,testDelete]
......@@ -2,14 +2,12 @@
--Data
module Roguestar.Lib.Utility.RayCasting
(castRays,
castRay,
gridRayCasterTests)
castRay)
where
import Data.Set as Set
import Data.List as List
import Data.Ratio
import Roguestar.Lib.Tests
-- |
-- When casting large numbers of rays from the same point, castRays will try to do this in
......@@ -124,33 +122,3 @@ incrementRay ray@(Ray {ray_origin=(ax,ay), ray_delta=(dx,dy)}) =
--
rayToPoints :: Ray -> [(Float,Float)]
rayToPoints ray = List.map ray_origin $ iterate (incrementRay) ray
sampleDensityFunction :: (Integer,Integer) -> Integer
sampleDensityFunction (x,y) = (abs x + abs y)
gridRayCasterTests :: [TestCase]
gridRayCasterTests = [easyRayTest,hardRayTest,tooHardRayTest,stressLazyRayTest]
easyRayTest :: TestCase
easyRayTest = (if castRay (4,5) (-3,-1) 100 sampleDensityFunction
then return (Passed "easyRayTest")
else return (Failed "easyRayTest"))
hardRayTest :: TestCase
hardRayTest = (if castRay (10,0) (0,10) 5 sampleDensityFunction
then return (Passed "hardRayTest")
else return (Failed "hardRayTest"))
tooHardRayTest :: TestCase
tooHardRayTest = (if castRay (10,0) (0,10) 4 sampleDensityFunction
then return (Failed "tooHardRayTest")
else return (Passed "tooHardRayTest"))
-- |
-- This test should evaluate quickly, even though the ray is very long, because the ray
-- will be opaqued early the casting of the ray.
--
stressLazyRayTest :: TestCase
stressLazyRayTest = (if castRay (-1,0) (1,2500000) 2 sampleDensityFunction
then return (Failed "stressLazyRayTest")
else return (Passed "stressLazyRayTest"))
......@@ -64,7 +64,8 @@ makeGlobals :: IO Aeson.Value