Add dungeon level generation
Add a dungeon level generator, which: 1. generates an infinite sequence of rectangular rooms within the dimensions of the level 2. removes any duplicates from that sequence 3. Generates a graph from the delaunay triangulation of the centerpoints of those rooms 4. Generates the minimum-spanning-tree of that delaunay triangulation, with weights given by line length in points 5. Adds back a subset (default 10-15%) of edges from the delaunay triangulation to the graph 6. Uses the resulting graph to draw corridors between the rooms, using a random point on the near edge of each room to pick the points of the corridors
This commit is contained in:
		
							parent
							
								
									6f427fe4d6
								
							
						
					
					
						commit
						e76567b9e7
					
				
					 20 changed files with 680 additions and 103 deletions
				
			
		
							
								
								
									
										13
									
								
								build/hgeometry-fix-haddock.patch
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										13
									
								
								build/hgeometry-fix-haddock.patch
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,13 @@ | ||||||
|  | diff --git a/src/Data/Geometry/PlanarSubdivision/Merge.hs b/src/Data/Geometry/PlanarSubdivision/Merge.hs
 | ||||||
|  | index 1136114..3f4e7bb 100644
 | ||||||
|  | --- a/src/Data/Geometry/PlanarSubdivision/Merge.hs
 | ||||||
|  | +++ b/src/Data/Geometry/PlanarSubdivision/Merge.hs
 | ||||||
|  | @@ -153,7 +153,7 @@ mergeWith' mergeFaces p1 p2 = PlanarSubdivision cs vd rd rf
 | ||||||
|  |          -- we have to shift the number of the *Arcs*. Since every dart | ||||||
|  |          -- consists of two arcs, we have to shift by numDarts / 2 | ||||||
|  |          -- Furthermore, we take numFaces - 1 since we want the first | ||||||
|  | -        -- *internal* face of p2 (the one with FaceId 1) to correspond with the first free
 | ||||||
|  | +        -- /internal/ face of p2 (the one with FaceId 1) to correspond with the first free
 | ||||||
|  |          -- position (at index numFaces) | ||||||
|  | 
 | ||||||
|  |      cs = p1^.components <> p2'^.components | ||||||
|  | @ -1,7 +1,32 @@ | ||||||
| { nixpkgs ? import ./nixpkgs.nix {} }: | { nixpkgs ? import ./nixpkgs.nix {} }: | ||||||
| let inherit (nixpkgs) pkgs; | let inherit (nixpkgs) pkgs; | ||||||
| in self: super: rec { | in self: super: with pkgs.haskell.lib; rec { | ||||||
|   generic-arbitrary = pkgs.haskell.lib.appendPatch |   generic-arbitrary = appendPatch | ||||||
|     super.generic-arbitrary |     super.generic-arbitrary | ||||||
|     [ ./build/generic-arbitrary-export-garbitrary.patch ]; |     [ ./build/generic-arbitrary-export-garbitrary.patch ]; | ||||||
|  | 
 | ||||||
|  |   hgeometry = | ||||||
|  |     appendPatch | ||||||
|  |       (self.callHackageDirect { | ||||||
|  |         pkg = "hgeometry"; | ||||||
|  |         ver = "0.9.0.0"; | ||||||
|  |         sha256 = "02hyvbqm57lr47w90vdgl71cfbd6lvwpqdid9fcnmxkdjbq4kv6b"; | ||||||
|  |       } {}) [ ./build/hgeometry-fix-haddock.patch ]; | ||||||
|  | 
 | ||||||
|  |   hgeometry-combinatorial = | ||||||
|  |     self.callHackageDirect { | ||||||
|  |       pkg = "hgeometry-combinatorial"; | ||||||
|  |       ver = "0.9.0.0"; | ||||||
|  |       sha256 = "12k41wd9fd1y3jd5djwcpwg2s1cva87wh14i0m1yn49zax9wl740"; | ||||||
|  |     } {}; | ||||||
|  | 
 | ||||||
|  |   vinyl = pkgs.haskell.lib.overrideSrc | ||||||
|  |     (pkgs.haskell.lib.markUnbroken super.vinyl) | ||||||
|  |     rec { | ||||||
|  |       src = nixpkgs.fetchzip { | ||||||
|  |         url = "mirror://hackage/vinyl-${version}/vinyl-${version}.tar.gz"; | ||||||
|  |         sha256 = "190ffrmm76fh8fi9afkcda2vldf89y7dxj10434h28mbpq55kgsx"; | ||||||
|  |       }; | ||||||
|  |       version = "0.12.0"; | ||||||
|  |     }; | ||||||
| } | } | ||||||
|  |  | ||||||
|  | @ -30,14 +30,19 @@ dependencies: | ||||||
| - containers | - containers | ||||||
| - data-default | - data-default | ||||||
| - deepseq | - deepseq | ||||||
|  | - fgl | ||||||
|  | - fgl-arbitrary | ||||||
| - file-embed | - file-embed | ||||||
| - filepath | - filepath | ||||||
| - generic-arbitrary | - generic-arbitrary | ||||||
| - generic-monoid | - generic-monoid | ||||||
| - generic-lens | - generic-lens | ||||||
| - groups | - groups | ||||||
|  | - hgeometry | ||||||
|  | - hgeometry-combinatorial | ||||||
| - JuicyPixels | - JuicyPixels | ||||||
| - lens | - lens | ||||||
|  | - linear | ||||||
| - megaparsec | - megaparsec | ||||||
| - MonadRandom | - MonadRandom | ||||||
| - mtl | - mtl | ||||||
|  | @ -49,6 +54,7 @@ dependencies: | ||||||
| - raw-strings-qq | - raw-strings-qq | ||||||
| - reflection | - reflection | ||||||
| - Rasterific | - Rasterific | ||||||
|  | - streams | ||||||
| - stache | - stache | ||||||
| - semigroupoids | - semigroupoids | ||||||
| - tomland | - tomland | ||||||
|  |  | ||||||
|  | @ -18,11 +18,7 @@ let | ||||||
|       overrides = (self: super: { |       overrides = (self: super: { | ||||||
|         ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; |         ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; | ||||||
|         ghcWithPackages = self.ghc.withPackages; |         ghcWithPackages = self.ghc.withPackages; | ||||||
|         # eww https://github.com/NixOS/nixpkgs/issues/16394 |       } // (import ./haskell-overlay.nix { inherit nixpkgs; }) self super); | ||||||
|         generic-arbitrary = pkgs.haskell.lib.appendPatch |  | ||||||
|           super.generic-arbitrary |  | ||||||
|           [ ./build/generic-arbitrary-export-garbitrary.patch ]; |  | ||||||
|       }); |  | ||||||
|     } |     } | ||||||
|     else packageSet |     else packageSet | ||||||
|   ); |   ); | ||||||
|  |  | ||||||
							
								
								
									
										25
									
								
								src/Main.hs
									
										
									
									
									
								
							
							
						
						
									
										25
									
								
								src/Main.hs
									
										
									
									
									
								
							|  | @ -47,19 +47,22 @@ parseRunParams = RunParams | ||||||
| data Command | data Command | ||||||
|   = Run RunParams |   = Run RunParams | ||||||
|   | Load FilePath |   | Load FilePath | ||||||
|   | Generate GeneratorInput Dimensions |   | Generate GeneratorInput Dimensions (Maybe Int) | ||||||
| 
 | 
 | ||||||
| parseDimensions :: Opt.Parser Dimensions | parseDimensions :: Opt.Parser Dimensions | ||||||
| parseDimensions = Dimensions | parseDimensions = Dimensions | ||||||
|   <$> Opt.option Opt.auto |   <$> Opt.option Opt.auto | ||||||
|        ( Opt.short 'w' |        ( Opt.short 'w' | ||||||
|        <> Opt.long "width" |        <> Opt.long "width" | ||||||
|  |        <> Opt.metavar "TILES" | ||||||
|        ) |        ) | ||||||
|   <*> Opt.option Opt.auto |   <*> Opt.option Opt.auto | ||||||
|        ( Opt.short 'h' |        ( Opt.short 'h' | ||||||
|        <> Opt.long "height" |        <> Opt.long "height" | ||||||
|  |        <> Opt.metavar "TILES" | ||||||
|        ) |        ) | ||||||
| 
 | 
 | ||||||
|  | 
 | ||||||
| parseCommand :: Opt.Parser Command | parseCommand :: Opt.Parser Command | ||||||
| parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser | parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser | ||||||
|   $ Opt.command "run" |   $ Opt.command "run" | ||||||
|  | @ -75,6 +78,8 @@ parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser | ||||||
|        (Generate |        (Generate | ||||||
|         <$> parseGeneratorInput |         <$> parseGeneratorInput | ||||||
|         <*> parseDimensions |         <*> parseDimensions | ||||||
|  |         <*> optional | ||||||
|  |             (Opt.option Opt.auto (Opt.long "seed")) | ||||||
|         <**> Opt.helper |         <**> Opt.helper | ||||||
|        ) |        ) | ||||||
|        (Opt.progDesc "Generate a sample level")) |        (Opt.progDesc "Generate a sample level")) | ||||||
|  | @ -91,6 +96,9 @@ runGame :: RunParams -> IO () | ||||||
| runGame rparams = do | runGame rparams = do | ||||||
|   app <- makeApp |   app <- makeApp | ||||||
|   gameSeed <- maybe getRandom pure $ seed rparams |   gameSeed <- maybe getRandom pure $ seed rparams | ||||||
|  |   when (isNothing $ seed rparams) | ||||||
|  |     . putStrLn | ||||||
|  |     $ "Seed: " <> tshow gameSeed | ||||||
|   let initialState = Game.initialStateFromSeed gameSeed &~ do |   let initialState = Game.initialStateFromSeed gameSeed &~ do | ||||||
|         for_ (characterName rparams) $ \cn -> |         for_ (characterName rparams) $ \cn -> | ||||||
|           Game.character . Character.characterName ?= cn |           Game.character . Character.characterName ?= cn | ||||||
|  | @ -112,11 +120,16 @@ loadGame saveFile = do | ||||||
|   pure () |   pure () | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
| runGenerate :: GeneratorInput -> Dimensions -> IO () | runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO () | ||||||
| runGenerate input dims = do | runGenerate input dims mSeed = do | ||||||
|   randGen <- getStdGen |   putStrLn "Generating..." | ||||||
|   let res = generateFromInput input dims randGen |   genSeed <- maybe getRandom pure mSeed | ||||||
|  |   let randGen = mkStdGen genSeed | ||||||
|  |       res = generateFromInput input dims randGen | ||||||
|       rs = regions $ amap not res |       rs = regions $ amap not res | ||||||
|  |   when (isNothing mSeed) | ||||||
|  |     . putStrLn | ||||||
|  |     $ "Seed: " <> tshow genSeed | ||||||
|   putStr "num regions: " |   putStr "num regions: " | ||||||
|   print $ length rs |   print $ length rs | ||||||
|   putStr "region lengths: " |   putStr "region lengths: " | ||||||
|  | @ -128,7 +141,7 @@ runGenerate input dims = do | ||||||
| runCommand :: Command -> IO () | runCommand :: Command -> IO () | ||||||
| runCommand (Run runParams) = runGame runParams | runCommand (Run runParams) = runGame runParams | ||||||
| runCommand (Load saveFile) = loadGame saveFile | runCommand (Load saveFile) = loadGame saveFile | ||||||
| runCommand (Generate input dims) = runGenerate input dims | runCommand (Generate input dims mSeed) = runGenerate input dims mSeed | ||||||
| 
 | 
 | ||||||
| main :: IO () | main :: IO () | ||||||
| main = runCommand =<< Opt.execParser optParser | main = runCommand =<< Opt.execParser optParser | ||||||
|  |  | ||||||
|  | @ -1,23 +1,27 @@ | ||||||
| {-# LANGUAGE PartialTypeSignatures #-} | {-# LANGUAGE PartialTypeSignatures  #-} | ||||||
| {-# LANGUAGE StandaloneDeriving #-} | {-# LANGUAGE StandaloneDeriving     #-} | ||||||
| {-# LANGUAGE ViewPatterns      #-} | {-# LANGUAGE ViewPatterns           #-} | ||||||
| {-# LANGUAGE RoleAnnotations   #-} | {-# LANGUAGE RoleAnnotations        #-} | ||||||
| {-# LANGUAGE RecordWildCards   #-} | {-# LANGUAGE RecordWildCards        #-} | ||||||
| {-# LANGUAGE DeriveTraversable #-} | {-# LANGUAGE DeriveTraversable      #-} | ||||||
| {-# LANGUAGE DeriveFoldable    #-} | {-# LANGUAGE DeriveFoldable         #-} | ||||||
| {-# LANGUAGE DeriveFunctor     #-} | {-# LANGUAGE DeriveFunctor          #-} | ||||||
| {-# LANGUAGE TemplateHaskell   #-} | {-# LANGUAGE TemplateHaskell        #-} | ||||||
| {-# LANGUAGE NoTypeSynonymInstances   #-} | {-# LANGUAGE NoTypeSynonymInstances #-} | ||||||
|  | {-# LANGUAGE DuplicateRecordFields  #-} | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| -- | Common data types for Xanthous | -- | Common data types for Xanthous | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| module Xanthous.Data | module Xanthous.Data | ||||||
|   ( -- * |   ( Opposite(..) | ||||||
|     Position'(..) | 
 | ||||||
|  |     -- * | ||||||
|  |   , Position'(..) | ||||||
|   , Position |   , Position | ||||||
|   , x |   , x | ||||||
|   , y |   , y | ||||||
| 
 | 
 | ||||||
|  |     -- ** | ||||||
|   , Positioned(..) |   , Positioned(..) | ||||||
|   , _Positioned |   , _Positioned | ||||||
|   , position |   , position | ||||||
|  | @ -30,6 +34,18 @@ module Xanthous.Data | ||||||
|   , stepTowards |   , stepTowards | ||||||
|   , isUnit |   , isUnit | ||||||
| 
 | 
 | ||||||
|  |     -- * Boxes | ||||||
|  |   , Box(..) | ||||||
|  |   , topLeftCorner | ||||||
|  |   , bottomRightCorner | ||||||
|  |   , setBottomRightCorner | ||||||
|  |   , dimensions | ||||||
|  |   , inBox | ||||||
|  |   , boxIntersects | ||||||
|  |   , boxCenter | ||||||
|  |   , boxEdge | ||||||
|  |   , module Linear.V2 | ||||||
|  | 
 | ||||||
|     -- * |     -- * | ||||||
|   , Per(..) |   , Per(..) | ||||||
|   , invertRate |   , invertRate | ||||||
|  | @ -49,11 +65,15 @@ module Xanthous.Data | ||||||
| 
 | 
 | ||||||
|     -- * |     -- * | ||||||
|   , Direction(..) |   , Direction(..) | ||||||
|   , opposite |  | ||||||
|   , move |   , move | ||||||
|   , asPosition |   , asPosition | ||||||
|   , directionOf |   , directionOf | ||||||
| 
 | 
 | ||||||
|  |     -- * | ||||||
|  |   , Corner(..) | ||||||
|  |   , Edge(..) | ||||||
|  |   , cornerEdges | ||||||
|  | 
 | ||||||
|     -- * |     -- * | ||||||
|   , Neighbors(..) |   , Neighbors(..) | ||||||
|   , edges |   , edges | ||||||
|  | @ -65,6 +85,9 @@ module Xanthous.Data | ||||||
|   ) where |   ) where | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Prelude hiding (Left, Down, Right, (.=)) | import           Xanthous.Prelude hiding (Left, Down, Right, (.=)) | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import           Linear.V2 hiding (_x, _y) | ||||||
|  | import qualified Linear.V2 as L | ||||||
| import           Test.QuickCheck (Arbitrary, CoArbitrary, Function) | import           Test.QuickCheck (Arbitrary, CoArbitrary, Function) | ||||||
| import           Test.QuickCheck.Arbitrary.Generic | import           Test.QuickCheck.Arbitrary.Generic | ||||||
| import           Data.Group | import           Data.Group | ||||||
|  | @ -74,11 +97,18 @@ import           Data.Aeson.Generic.DerivingVia | ||||||
| import           Data.Aeson | import           Data.Aeson | ||||||
|                  ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) |                  ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Util (EqEqProp(..), EqProp) | import           Xanthous.Util (EqEqProp(..), EqProp, between) | ||||||
|  | import           Xanthous.Util.QuickCheck (GenericArbitrary(..)) | ||||||
| import           Xanthous.Orphans () | import           Xanthous.Orphans () | ||||||
| import           Xanthous.Util.Graphics | import           Xanthous.Util.Graphics | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
|  | -- | opposite ∘ opposite ≡ id | ||||||
|  | class Opposite x where | ||||||
|  |   opposite :: x -> x | ||||||
|  | 
 | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
| -- fromScalar ∘ scalar ≡ id | -- fromScalar ∘ scalar ≡ id | ||||||
| class Scalar a where | class Scalar a where | ||||||
|   scalar :: a -> Double |   scalar :: a -> Double | ||||||
|  | @ -109,7 +139,10 @@ data Position' a where | ||||||
|   deriving (ToJSON, FromJSON) |   deriving (ToJSON, FromJSON) | ||||||
|        via WithOptions '[ FieldLabelModifier '[Drop 1] ] |        via WithOptions '[ FieldLabelModifier '[Drop 1] ] | ||||||
|                        (Position' a) |                        (Position' a) | ||||||
| makeLenses ''Position' | 
 | ||||||
|  | x, y :: Lens' (Position' a) a | ||||||
|  | x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy) | ||||||
|  | y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy) | ||||||
| 
 | 
 | ||||||
| type Position = Position' Int | type Position = Position' Int | ||||||
| 
 | 
 | ||||||
|  | @ -236,16 +269,16 @@ instance Arbitrary Direction where | ||||||
|   arbitrary = genericArbitrary |   arbitrary = genericArbitrary | ||||||
|   shrink = genericShrink |   shrink = genericShrink | ||||||
| 
 | 
 | ||||||
| opposite :: Direction -> Direction | instance Opposite Direction where | ||||||
| opposite Up        = Down |   opposite Up        = Down | ||||||
| opposite Down      = Up |   opposite Down      = Up | ||||||
| opposite Left      = Right |   opposite Left      = Right | ||||||
| opposite Right     = Left |   opposite Right     = Left | ||||||
| opposite UpLeft    = DownRight |   opposite UpLeft    = DownRight | ||||||
| opposite UpRight   = DownLeft |   opposite UpRight   = DownLeft | ||||||
| opposite DownLeft  = UpRight |   opposite DownLeft  = UpRight | ||||||
| opposite DownRight = UpLeft |   opposite DownRight = UpLeft | ||||||
| opposite Here      = Here |   opposite Here      = Here | ||||||
| 
 | 
 | ||||||
| move :: Direction -> Position -> Position | move :: Direction -> Position -> Position | ||||||
| move Up        = y -~ 1 | move Up        = y -~ 1 | ||||||
|  | @ -295,6 +328,40 @@ stepTowards (view _Position -> p₁) (view _Position -> p₂) | ||||||
| 
 | 
 | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
|  | data Corner | ||||||
|  |   = TopLeft | ||||||
|  |   | TopRight | ||||||
|  |   | BottomLeft | ||||||
|  |   | BottomRight | ||||||
|  |   deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) | ||||||
|  | 
 | ||||||
|  | instance Opposite Corner where | ||||||
|  |   opposite TopLeft = BottomRight | ||||||
|  |   opposite TopRight = BottomLeft | ||||||
|  |   opposite BottomLeft = TopRight | ||||||
|  |   opposite BottomRight = TopLeft | ||||||
|  | 
 | ||||||
|  | data Edge | ||||||
|  |   = TopEdge | ||||||
|  |   | LeftEdge | ||||||
|  |   | RightEdge | ||||||
|  |   | BottomEdge | ||||||
|  |   deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) | ||||||
|  | 
 | ||||||
|  | instance Opposite Edge where | ||||||
|  |   opposite TopEdge = BottomEdge | ||||||
|  |   opposite BottomEdge = TopEdge | ||||||
|  |   opposite LeftEdge = RightEdge | ||||||
|  |   opposite RightEdge = LeftEdge | ||||||
|  | 
 | ||||||
|  | cornerEdges :: Corner -> (Edge, Edge) | ||||||
|  | cornerEdges TopLeft = (TopEdge, LeftEdge) | ||||||
|  | cornerEdges TopRight = (TopEdge, RightEdge) | ||||||
|  | cornerEdges BottomLeft = (BottomEdge, LeftEdge) | ||||||
|  | cornerEdges BottomRight = (BottomEdge, RightEdge) | ||||||
|  | 
 | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
| data Neighbors a = Neighbors | data Neighbors a = Neighbors | ||||||
|   { _topLeft |   { _topLeft | ||||||
|   , _top |   , _top | ||||||
|  | @ -307,7 +374,7 @@ data Neighbors a = Neighbors | ||||||
|   } |   } | ||||||
|   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) |   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) | ||||||
|   deriving anyclass (NFData) |   deriving anyclass (NFData) | ||||||
| makeLenses ''Neighbors | makeFieldsNoPrefix ''Neighbors | ||||||
| 
 | 
 | ||||||
| instance Applicative Neighbors where | instance Applicative Neighbors where | ||||||
|   pure α = Neighbors |   pure α = Neighbors | ||||||
|  | @ -403,3 +470,57 @@ newtype Hitpoints = Hitpoints Word | ||||||
|        via Word |        via Word | ||||||
|   deriving (Semigroup, Monoid) via Sum Word |   deriving (Semigroup, Monoid) via Sum Word | ||||||
| 
 | 
 | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | data Box a = Box | ||||||
|  |   { _topLeftCorner :: V2 a | ||||||
|  |   , _dimensions    :: V2 a | ||||||
|  |   } | ||||||
|  |   deriving stock (Show, Eq, Ord, Functor, Generic) | ||||||
|  |   deriving Arbitrary via GenericArbitrary (Box a) | ||||||
|  | makeFieldsNoPrefix ''Box | ||||||
|  | 
 | ||||||
|  | bottomRightCorner :: Num a => Box a -> V2 a | ||||||
|  | bottomRightCorner box = | ||||||
|  |   V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x) | ||||||
|  |      (box ^. topLeftCorner . L._y + box ^. dimensions . L._y) | ||||||
|  | 
 | ||||||
|  | setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a | ||||||
|  | setBottomRightCorner box br@(V2 brx bry) | ||||||
|  |   | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y | ||||||
|  |   = box & topLeftCorner .~ br | ||||||
|  |         & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx) | ||||||
|  |         & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry) | ||||||
|  |   | otherwise | ||||||
|  |   = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x)) | ||||||
|  |         & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y)) | ||||||
|  | 
 | ||||||
|  | inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool | ||||||
|  | inBox box pt = flip all [L._x, L._y] $ \component -> | ||||||
|  |   between (box ^. topLeftCorner . component) | ||||||
|  |           (box ^. to bottomRightCorner . component) | ||||||
|  |           (pt ^. component) | ||||||
|  | 
 | ||||||
|  | boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool | ||||||
|  | boxIntersects box₁ box₂ | ||||||
|  |   = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂] | ||||||
|  | 
 | ||||||
|  | boxCenter :: (Fractional a) => Box a -> V2 a | ||||||
|  | boxCenter box = V2 cx cy | ||||||
|  |  where | ||||||
|  |    cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2) | ||||||
|  |    cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2) | ||||||
|  | 
 | ||||||
|  | boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a] | ||||||
|  | boxEdge box LeftEdge = | ||||||
|  |   V2 (box ^. topLeftCorner . L._x) | ||||||
|  |   <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y] | ||||||
|  | boxEdge box RightEdge = | ||||||
|  |   V2 (box ^. to bottomRightCorner . L._x) | ||||||
|  |   <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y] | ||||||
|  | boxEdge box TopEdge = | ||||||
|  |   flip V2 (box ^. topLeftCorner . L._y) | ||||||
|  |   <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] | ||||||
|  | boxEdge box BottomEdge = | ||||||
|  |   flip V2 (box ^. to bottomRightCorner . L._y) | ||||||
|  |   <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] | ||||||
|  |  | ||||||
|  | @ -25,6 +25,7 @@ import qualified Options.Applicative as Opt | ||||||
| import           Control.Monad.Random | import           Control.Monad.Random | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import qualified Xanthous.Generators.CaveAutomata as CaveAutomata | import qualified Xanthous.Generators.CaveAutomata as CaveAutomata | ||||||
|  | import qualified Xanthous.Generators.Dungeon as Dungeon | ||||||
| import           Xanthous.Generators.Util | import           Xanthous.Generators.Util | ||||||
| import           Xanthous.Generators.LevelContents | import           Xanthous.Generators.LevelContents | ||||||
| import           Xanthous.Data (Dimensions, Position'(Position), Position) | import           Xanthous.Data (Dimensions, Position'(Position), Position) | ||||||
|  | @ -35,14 +36,18 @@ import           Xanthous.Entities.Item (Item) | ||||||
| import           Xanthous.Entities.Creature (Creature) | import           Xanthous.Entities.Creature (Creature) | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| data Generator = CaveAutomata | data Generator | ||||||
|  |   = CaveAutomata | ||||||
|  |   | Dungeon | ||||||
|   deriving stock (Show, Eq) |   deriving stock (Show, Eq) | ||||||
| 
 | 
 | ||||||
| data SGenerator (gen :: Generator) where | data SGenerator (gen :: Generator) where | ||||||
|   SCaveAutomata :: SGenerator 'CaveAutomata |   SCaveAutomata :: SGenerator 'CaveAutomata | ||||||
|  |   SDungeon :: SGenerator 'Dungeon | ||||||
| 
 | 
 | ||||||
| type family Params (gen :: Generator) :: Type where | type family Params (gen :: Generator) :: Type where | ||||||
|   Params 'CaveAutomata = CaveAutomata.Params |   Params 'CaveAutomata = CaveAutomata.Params | ||||||
|  |   Params 'Dungeon = Dungeon.Params | ||||||
| 
 | 
 | ||||||
| generate | generate | ||||||
|   :: RandomGen g |   :: RandomGen g | ||||||
|  | @ -52,6 +57,7 @@ generate | ||||||
|   -> g |   -> g | ||||||
|   -> Cells |   -> Cells | ||||||
| generate SCaveAutomata = CaveAutomata.generate | generate SCaveAutomata = CaveAutomata.generate | ||||||
|  | generate SDungeon = Dungeon.generate | ||||||
| 
 | 
 | ||||||
| data GeneratorInput where | data GeneratorInput where | ||||||
|   GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput |   GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput | ||||||
|  | @ -60,10 +66,23 @@ generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells | ||||||
| generateFromInput (GeneratorInput sg ps) = generate sg ps | generateFromInput (GeneratorInput sg ps) = generate sg ps | ||||||
| 
 | 
 | ||||||
| parseGeneratorInput :: Opt.Parser GeneratorInput | parseGeneratorInput :: Opt.Parser GeneratorInput | ||||||
| parseGeneratorInput = Opt.subparser $ | parseGeneratorInput = Opt.subparser | ||||||
|   Opt.command "cave" (Opt.info |   $ generatorCommand SCaveAutomata | ||||||
|                       (GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams) |       "cave" | ||||||
|                       (Opt.progDesc "cellular-automata based cave generator")) |       "Cellular-automata based cave generator" | ||||||
|  |       CaveAutomata.parseParams | ||||||
|  |   <> generatorCommand SDungeon | ||||||
|  |       "dungeon" | ||||||
|  |       "Classic dungeon map generator" | ||||||
|  |       Dungeon.parseParams | ||||||
|  |   where | ||||||
|  |     generatorCommand sgen name desc parseParams = | ||||||
|  |       Opt.command name | ||||||
|  |         (Opt.info | ||||||
|  |           (GeneratorInput <$> pure sgen <*> parseParams) | ||||||
|  |           (Opt.progDesc desc) | ||||||
|  |         ) | ||||||
|  | 
 | ||||||
| 
 | 
 | ||||||
| showCells :: Cells -> Text | showCells :: Cells -> Text | ||||||
| showCells arr = | showCells arr = | ||||||
|  |  | ||||||
|  | @ -2,23 +2,25 @@ | ||||||
| {-# LANGUAGE ViewPatterns #-} | {-# LANGUAGE ViewPatterns #-} | ||||||
| {-# LANGUAGE RecordWildCards #-} | {-# LANGUAGE RecordWildCards #-} | ||||||
| {-# LANGUAGE TemplateHaskell #-} | {-# LANGUAGE TemplateHaskell #-} | ||||||
| 
 | -------------------------------------------------------------------------------- | ||||||
| module Xanthous.Generators.CaveAutomata | module Xanthous.Generators.CaveAutomata | ||||||
|   ( Params(..) |   ( Params(..) | ||||||
|   , defaultParams |   , defaultParams | ||||||
|   , parseParams |   , parseParams | ||||||
|   , generate |   , generate | ||||||
|   ) where |   ) where | ||||||
| 
 | -------------------------------------------------------------------------------- | ||||||
| import Xanthous.Prelude | import           Xanthous.Prelude | ||||||
| import Control.Monad.Random (RandomGen, runRandT) | import           Control.Monad.Random (RandomGen, runRandT) | ||||||
| import Data.Array.ST | import           Data.Array.ST | ||||||
| import Data.Array.Unboxed | import           Data.Array.Unboxed | ||||||
| import qualified Options.Applicative as Opt | import qualified Options.Applicative as Opt | ||||||
| 
 | -------------------------------------------------------------------------------- | ||||||
| import Xanthous.Util (between) | import           Xanthous.Util (between) | ||||||
| import Xanthous.Data (Dimensions, width, height) | import           Xanthous.Util.Optparse | ||||||
| import Xanthous.Generators.Util | import           Xanthous.Data (Dimensions, width, height) | ||||||
|  | import           Xanthous.Generators.Util | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| data Params = Params | data Params = Params | ||||||
|   { _aliveStartChance :: Double |   { _aliveStartChance :: Double | ||||||
|  | @ -70,13 +72,6 @@ parseParams = Params | ||||||
|       <> Opt.metavar "STEPS" |       <> Opt.metavar "STEPS" | ||||||
|       ) |       ) | ||||||
|   where |   where | ||||||
|     readWithGuard predicate errmsg = do |  | ||||||
|       res <- Opt.auto |  | ||||||
|       unless (predicate res) |  | ||||||
|         $ Opt.readerError |  | ||||||
|         $ errmsg res |  | ||||||
|       pure res |  | ||||||
| 
 |  | ||||||
|     parseChance = readWithGuard |     parseChance = readWithGuard | ||||||
|       (between 0 1) |       (between 0 1) | ||||||
|       $ \res -> "Chance must be in the range [0,1], got: " <> show res |       $ \res -> "Chance must be in the range [0,1], got: " <> show res | ||||||
|  | @ -85,7 +80,7 @@ parseParams = Params | ||||||
|       (between 0 8) |       (between 0 8) | ||||||
|       $ \res -> "Neighbors must be in the range [0,8], got: " <> show res |       $ \res -> "Neighbors must be in the range [0,8], got: " <> show res | ||||||
| 
 | 
 | ||||||
| generate :: RandomGen g => Params -> Dimensions -> g -> UArray (Word, Word) Bool | generate :: RandomGen g => Params -> Dimensions -> g -> Cells | ||||||
| generate params dims gen | generate params dims gen | ||||||
|   = runSTUArray |   = runSTUArray | ||||||
|   $ fmap fst |   $ fmap fst | ||||||
|  |  | ||||||
							
								
								
									
										192
									
								
								src/Xanthous/Generators/Dungeon.hs
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										192
									
								
								src/Xanthous/Generators/Dungeon.hs
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,192 @@ | ||||||
|  | {-# LANGUAGE ViewPatterns #-} | ||||||
|  | {-# LANGUAGE TemplateHaskell #-} | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | module Xanthous.Generators.Dungeon | ||||||
|  |   ( Params(..) | ||||||
|  |   , defaultParams | ||||||
|  |   , parseParams | ||||||
|  |   , generate | ||||||
|  |   ) where | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import           Xanthous.Prelude hiding ((:>)) | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import           Control.Monad.Random | ||||||
|  | import           Data.Array.ST | ||||||
|  | import           Data.Array.IArray (amap) | ||||||
|  | import           Data.Stream.Infinite (Stream(..)) | ||||||
|  | import qualified Data.Stream.Infinite as Stream | ||||||
|  | import qualified Data.Graph.Inductive.Graph as Graph | ||||||
|  | import           Data.Graph.Inductive.PatriciaTree | ||||||
|  | import qualified Data.List.NonEmpty as NE | ||||||
|  | import           Data.Maybe (fromJust) | ||||||
|  | import           Linear.V2 | ||||||
|  | import           Linear.Metric | ||||||
|  | import qualified Options.Applicative as Opt | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import           Xanthous.Random | ||||||
|  | import           Xanthous.Data hiding (x, y, _x, _y, edges) | ||||||
|  | import           Xanthous.Generators.Util | ||||||
|  | import           Xanthous.Util.Graphics (delaunay, straightLine) | ||||||
|  | import           Xanthous.Util.Graph (mstSubGraph) | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | data Params = Params | ||||||
|  |   { _numRoomsRange :: (Word, Word) | ||||||
|  |   , _roomDimensionRange :: (Word, Word) | ||||||
|  |   , _connectednessRatioRange :: (Double, Double) | ||||||
|  |   } | ||||||
|  |   deriving stock (Show, Eq, Ord, Generic) | ||||||
|  | makeLenses ''Params | ||||||
|  | 
 | ||||||
|  | defaultParams :: Params | ||||||
|  | defaultParams = Params | ||||||
|  |   { _numRoomsRange = (6, 8) | ||||||
|  |   , _roomDimensionRange = (3, 12) | ||||||
|  |   , _connectednessRatioRange = (0.1, 0.15) | ||||||
|  |   } | ||||||
|  | 
 | ||||||
|  | parseParams :: Opt.Parser Params | ||||||
|  | parseParams = Params | ||||||
|  |   <$> parseRange | ||||||
|  |         "num-rooms" | ||||||
|  |         "number of rooms to generate in the dungeon" | ||||||
|  |         "ROOMS" | ||||||
|  |         (defaultParams ^. numRoomsRange) | ||||||
|  |   <*> parseRange | ||||||
|  |         "room-size" | ||||||
|  |         "size in tiles of one of the sides of a room" | ||||||
|  |         "TILES" | ||||||
|  |         (defaultParams ^. roomDimensionRange) | ||||||
|  |   <*> parseRange | ||||||
|  |         "connectedness-ratio" | ||||||
|  |         ( "ratio of edges from the delaunay triangulation to re-add to the " | ||||||
|  |         <> "minimum-spanning-tree") | ||||||
|  |         "RATIO" | ||||||
|  |         (defaultParams ^. connectednessRatioRange) | ||||||
|  |   <**> Opt.helper | ||||||
|  |   where | ||||||
|  |     parseRange name desc metavar (defMin, defMax) = | ||||||
|  |       (,) | ||||||
|  |       <$> Opt.option Opt.auto | ||||||
|  |           ( Opt.long ("min-" <> name) | ||||||
|  |           <> Opt.value defMin | ||||||
|  |           <> Opt.showDefault | ||||||
|  |           <> Opt.help ("Minimum " <> desc) | ||||||
|  |           <> Opt.metavar metavar | ||||||
|  |           ) | ||||||
|  |       <*> Opt.option Opt.auto | ||||||
|  |           ( Opt.long ("max-" <> name) | ||||||
|  |           <> Opt.value defMax | ||||||
|  |           <> Opt.showDefault | ||||||
|  |           <> Opt.help ("Maximum " <> desc) | ||||||
|  |           <> Opt.metavar metavar | ||||||
|  |           ) | ||||||
|  | 
 | ||||||
|  | generate :: RandomGen g => Params -> Dimensions -> g -> Cells | ||||||
|  | generate params dims gen | ||||||
|  |   = amap not | ||||||
|  |   $ runSTUArray | ||||||
|  |   $ fmap fst | ||||||
|  |   $ flip runRandT gen | ||||||
|  |   $ generate' params dims | ||||||
|  | 
 | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) | ||||||
|  | generate' params dims = do | ||||||
|  |   cells <- initializeEmpty dims | ||||||
|  |   rooms <- genRooms params dims | ||||||
|  |   for_ rooms $ fillRoom cells | ||||||
|  | 
 | ||||||
|  |   let fullRoomGraph = delaunayRoomGraph rooms | ||||||
|  |       mst = mstSubGraph fullRoomGraph | ||||||
|  |       mstEdges = Graph.edges mst | ||||||
|  |       nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges) | ||||||
|  |                     $ Graph.labEdges fullRoomGraph | ||||||
|  | 
 | ||||||
|  |   reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges)) | ||||||
|  |                      <$> getRandomR (params ^. connectednessRatioRange) | ||||||
|  |   let reintroEdges = take reintroEdgeCount nonMSTEdges | ||||||
|  |       corridorGraph = Graph.insEdges reintroEdges mst | ||||||
|  | 
 | ||||||
|  |   corridors <- traverse | ||||||
|  |               ( uncurry corridorBetween | ||||||
|  |               . over both (fromJust . Graph.lab corridorGraph) | ||||||
|  |               ) $ Graph.edges corridorGraph | ||||||
|  | 
 | ||||||
|  |   for_ (join corridors) $ \pt -> lift $ writeArray cells pt True | ||||||
|  | 
 | ||||||
|  |   pure cells | ||||||
|  | 
 | ||||||
|  | type Room = Box Word | ||||||
|  | 
 | ||||||
|  | genRooms :: MonadRandom m => Params -> Dimensions -> m [Room] | ||||||
|  | genRooms params dims = do | ||||||
|  |   numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange) | ||||||
|  |   subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do | ||||||
|  |     roomWidth <- getRandomR $ params ^. roomDimensionRange | ||||||
|  |     roomHeight <- getRandomR $ params ^. roomDimensionRange | ||||||
|  |     xPos <- getRandomR (0, dims ^. width - roomWidth) | ||||||
|  |     yPos <- getRandomR (0, dims ^. height - roomHeight) | ||||||
|  |     pure Box | ||||||
|  |       { _topLeftCorner = V2 xPos yPos | ||||||
|  |       , _dimensions = V2 roomWidth roomHeight | ||||||
|  |       } | ||||||
|  |   where | ||||||
|  |     removeIntersecting seen (room :> rooms) | ||||||
|  |       | any (boxIntersects room) seen | ||||||
|  |       = removeIntersecting seen rooms | ||||||
|  |       | otherwise | ||||||
|  |       = room :> removeIntersecting (room : seen) rooms | ||||||
|  |     streamRepeat x = x :> streamRepeat x | ||||||
|  |     infinitely = sequence . streamRepeat | ||||||
|  | 
 | ||||||
|  | delaunayRoomGraph :: [Room] -> Gr Room Double | ||||||
|  | delaunayRoomGraph rooms = | ||||||
|  |   Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty | ||||||
|  |   where | ||||||
|  |     edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂)) | ||||||
|  |           . over (mapped . both) snd | ||||||
|  |           . delaunay @Double | ||||||
|  |           . NE.fromList | ||||||
|  |           . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p)) | ||||||
|  |           $ nodes | ||||||
|  |     nodes = zip [0..] rooms | ||||||
|  |     roomDist = distance `on` (boxCenter . fmap fromIntegral) | ||||||
|  | 
 | ||||||
|  | fillRoom :: MCells s -> Room -> CellM g s () | ||||||
|  | fillRoom cells room = | ||||||
|  |   let V2 posx posy = room ^. topLeftCorner | ||||||
|  |       V2 dimx dimy = room ^. dimensions | ||||||
|  |   in for_ [posx .. posx + dimx] $ \x -> | ||||||
|  |        for_ [posy .. posy + dimy] $ \y -> | ||||||
|  |          lift $ writeArray cells (x, y) True | ||||||
|  | 
 | ||||||
|  | corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)] | ||||||
|  | corridorBetween originRoom destinationRoom | ||||||
|  |   = straightLine <$> origin <*> destination | ||||||
|  |   where | ||||||
|  |     origin = choose . NE.fromList . map toTuple =<< originEdge | ||||||
|  |     destination = choose . NE.fromList . map toTuple =<< destinationEdge | ||||||
|  |     originEdge = pickEdge originRoom originCorner | ||||||
|  |     destinationEdge = pickEdge destinationRoom destinationCorner | ||||||
|  |     pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner | ||||||
|  |     originCorner = | ||||||
|  |       case ( compare (originRoom ^. topLeftCorner . _x) | ||||||
|  |                      (destinationRoom ^. topLeftCorner . _x) | ||||||
|  |            , compare (originRoom ^. topLeftCorner . _y) | ||||||
|  |                      (destinationRoom ^. topLeftCorner . _y) | ||||||
|  |            ) of | ||||||
|  |         (LT, LT) -> BottomRight | ||||||
|  |         (LT, GT) -> TopRight | ||||||
|  |         (GT, LT) -> BottomLeft | ||||||
|  |         (GT, GT) -> TopLeft | ||||||
|  | 
 | ||||||
|  |         (EQ, LT) -> BottomLeft | ||||||
|  |         (EQ, GT) -> TopRight | ||||||
|  |         (GT, EQ) -> TopLeft | ||||||
|  |         (LT, EQ) -> BottomRight | ||||||
|  |         (EQ, EQ) -> TopLeft -- should never happen | ||||||
|  | 
 | ||||||
|  |     destinationCorner = opposite originCorner | ||||||
|  |     toTuple (V2 x y) = (x, y) | ||||||
|  | @ -7,6 +7,7 @@ module Xanthous.Generators.Util | ||||||
|   , Cells |   , Cells | ||||||
|   , CellM |   , CellM | ||||||
|   , randInitialize |   , randInitialize | ||||||
|  |   , initializeEmpty | ||||||
|   , numAliveNeighborsM |   , numAliveNeighborsM | ||||||
|   , numAliveNeighbors |   , numAliveNeighbors | ||||||
|   , fillOuterEdgesM |   , fillOuterEdgesM | ||||||
|  | @ -39,13 +40,17 @@ type CellM g s a = RandT g (ST s) a | ||||||
| 
 | 
 | ||||||
| randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) | randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) | ||||||
| randInitialize dims aliveChance = do | randInitialize dims aliveChance = do | ||||||
|   res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False |   res <- initializeEmpty dims | ||||||
|   for_ [0..dims ^. width] $ \i -> |   for_ [0..dims ^. width] $ \i -> | ||||||
|     for_ [0..dims ^. height] $ \j -> do |     for_ [0..dims ^. height] $ \j -> do | ||||||
|       val <- (>= aliveChance) <$> getRandomR (0, 1) |       val <- (>= aliveChance) <$> getRandomR (0, 1) | ||||||
|       lift $ writeArray res (i, j) val |       lift $ writeArray res (i, j) val | ||||||
|   pure res |   pure res | ||||||
| 
 | 
 | ||||||
|  | initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) | ||||||
|  | initializeEmpty dims = | ||||||
|  |   lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False | ||||||
|  | 
 | ||||||
| numAliveNeighborsM | numAliveNeighborsM | ||||||
|   :: forall a i j m |   :: forall a i j m | ||||||
|   . (MArray a Bool m, Ix (i, j), Integral i, Integral j) |   . (MArray a Bool m, Ix (i, j), Integral i, Integral j) | ||||||
|  |  | ||||||
|  | @ -1,7 +1,9 @@ | ||||||
| {-# LANGUAGE RecordWildCards #-} | {-# LANGUAGE RecordWildCards #-} | ||||||
| {-# LANGUAGE StandaloneDeriving #-} | {-# LANGUAGE StandaloneDeriving #-} | ||||||
| {-# LANGUAGE ViewPatterns #-} | {-# LANGUAGE ViewPatterns #-} | ||||||
| {-# LANGUAGE UndecidableInstances, PatternSynonyms #-} | {-# LANGUAGE UndecidableInstances #-} | ||||||
|  | {-# LANGUAGE PatternSynonyms #-} | ||||||
|  | {-# LANGUAGE PackageImports #-} | ||||||
| {-# OPTIONS_GHC -Wno-orphans #-} | {-# OPTIONS_GHC -Wno-orphans #-} | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| module Xanthous.Orphans | module Xanthous.Orphans | ||||||
|  | @ -13,21 +15,23 @@ import           Xanthous.Prelude hiding (elements, (.=)) | ||||||
| import           Data.Aeson | import           Data.Aeson | ||||||
| import           Data.Aeson.Types (typeMismatch) | import           Data.Aeson.Types (typeMismatch) | ||||||
| import           Data.List.NonEmpty (NonEmpty(..)) | import           Data.List.NonEmpty (NonEmpty(..)) | ||||||
| import qualified Data.List.NonEmpty as NonEmpty |  | ||||||
| import           Data.Text.Arbitrary () |  | ||||||
| import           Graphics.Vty.Attributes | import           Graphics.Vty.Attributes | ||||||
| import           Brick.Widgets.Edit | import           Brick.Widgets.Edit | ||||||
| import           Data.Text.Zipper.Generic (GenericTextZipper) | import           Data.Text.Zipper.Generic (GenericTextZipper) | ||||||
| import           Brick.Widgets.Core (getName) | import           Brick.Widgets.Core (getName) | ||||||
| import           System.Random (StdGen) | import           System.Random (StdGen) | ||||||
| import           Test.QuickCheck | import           Test.QuickCheck | ||||||
|  | import           "quickcheck-instances" Test.QuickCheck.Instances () | ||||||
| import           Text.Megaparsec (errorBundlePretty) | import           Text.Megaparsec (errorBundlePretty) | ||||||
| import           Text.Megaparsec.Pos | import           Text.Megaparsec.Pos | ||||||
| import           Text.Mustache | import           Text.Mustache | ||||||
| import           Text.Mustache.Type ( showKey ) | import           Text.Mustache.Type ( showKey ) | ||||||
| import           Control.Monad.State | import           Control.Monad.State | ||||||
|  | import           Linear | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Util.JSON | import           Xanthous.Util.JSON | ||||||
|  | import           Xanthous.Util.QuickCheck | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| instance forall s a. | instance forall s a. | ||||||
|   ( Cons s s a a |   ( Cons s s a a | ||||||
|  | @ -130,18 +134,6 @@ instance Function Template where | ||||||
|       parseTemplatePartial txt |       parseTemplatePartial txt | ||||||
|         = compileMustacheText "template" txt ^?! _Right |         = compileMustacheText "template" txt ^?! _Right | ||||||
| 
 | 
 | ||||||
| instance Arbitrary a => Arbitrary (NonEmpty a) where |  | ||||||
|   arbitrary = do |  | ||||||
|     x <- arbitrary |  | ||||||
|     xs <- arbitrary |  | ||||||
|     pure $ x :| xs |  | ||||||
| 
 |  | ||||||
| instance CoArbitrary a => CoArbitrary (NonEmpty a) where |  | ||||||
|   coarbitrary = coarbitrary . toList |  | ||||||
| 
 |  | ||||||
| instance Function a => Function (NonEmpty a) where |  | ||||||
|   function = functionMap toList NonEmpty.fromList |  | ||||||
| 
 |  | ||||||
| ppNode :: Map PName [Node] -> Node -> Text | ppNode :: Map PName [Node] -> Node -> Text | ||||||
| ppNode _ (TextBlock txt) = txt | ppNode _ (TextBlock txt) = txt | ||||||
| ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" | ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" | ||||||
|  | @ -169,12 +161,6 @@ instance FromJSON Template where | ||||||
|     $ either (fail . errorBundlePretty) pure |     $ either (fail . errorBundlePretty) pure | ||||||
|     . compileMustacheText "template" |     . compileMustacheText "template" | ||||||
| 
 | 
 | ||||||
| instance CoArbitrary Text where |  | ||||||
|   coarbitrary = coarbitrary . unpack |  | ||||||
| 
 |  | ||||||
| instance Function Text where |  | ||||||
|   function = functionMap unpack pack |  | ||||||
| 
 |  | ||||||
| deriving anyclass instance NFData Node | deriving anyclass instance NFData Node | ||||||
| deriving anyclass instance NFData Template | deriving anyclass instance NFData Template | ||||||
| 
 | 
 | ||||||
|  | @ -353,3 +339,8 @@ instance CoArbitrary StdGen where | ||||||
| deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) | deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) | ||||||
|             => CoArbitrary (StateT s m a) |             => CoArbitrary (StateT s m a) | ||||||
| 
 | 
 | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a) | ||||||
|  | instance CoArbitrary a => CoArbitrary (V2 a) | ||||||
|  | instance Function a => Function (V2 a) | ||||||
|  |  | ||||||
|  | @ -8,17 +8,19 @@ module Xanthous.Random | ||||||
|   , Weighted(..) |   , Weighted(..) | ||||||
|   , evenlyWeighted |   , evenlyWeighted | ||||||
|   , weightedBy |   , weightedBy | ||||||
|  |   , subRand | ||||||
|   ) where |   ) where | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import Xanthous.Prelude | import Xanthous.Prelude | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import Data.List.NonEmpty (NonEmpty) | import           Data.List.NonEmpty (NonEmpty(..)) | ||||||
| import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) | import           Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) | ||||||
| import Data.Random.Shuffle.Weighted | import           Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) | ||||||
| import Data.Random.Distribution | import           Data.Random.Shuffle.Weighted | ||||||
| import Data.Random.Distribution.Uniform | import           Data.Random.Distribution | ||||||
| import Data.Random.Distribution.Uniform.Exclusive | import           Data.Random.Distribution.Uniform | ||||||
| import Data.Random.Sample | import           Data.Random.Distribution.Uniform.Exclusive | ||||||
|  | import           Data.Random.Sample | ||||||
| import qualified Data.Random.Source as DRS | import qualified Data.Random.Source as DRS | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
|  | @ -58,6 +60,10 @@ instance Choose (NonEmpty a) where | ||||||
|   type RandomResult (NonEmpty a) = a |   type RandomResult (NonEmpty a) = a | ||||||
|   choose = choose . fromNonEmpty @[_] |   choose = choose . fromNonEmpty @[_] | ||||||
| 
 | 
 | ||||||
|  | instance Choose (a, a) where | ||||||
|  |   type RandomResult (a, a) = a | ||||||
|  |   choose (x, y) = choose (x :| [y]) | ||||||
|  | 
 | ||||||
| newtype Weighted w t a = Weighted (t (w, a)) | newtype Weighted w t a = Weighted (t (w, a)) | ||||||
| 
 | 
 | ||||||
| evenlyWeighted :: [a] -> Weighted Int [] a | evenlyWeighted :: [a] -> Weighted Int [] a | ||||||
|  | @ -76,3 +82,6 @@ instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighte | ||||||
|     sample |     sample | ||||||
|     $ fromMaybe (error "unreachable") . headMay |     $ fromMaybe (error "unreachable") . headMay | ||||||
|     <$> weightedSample 1 (toList ws) |     <$> weightedSample 1 (toList ws) | ||||||
|  | 
 | ||||||
|  | subRand :: MonadRandom m => Rand StdGen a -> m a | ||||||
|  | subRand sub = evalRand sub . mkStdGen <$> getRandom | ||||||
|  |  | ||||||
|  | @ -29,6 +29,9 @@ module Xanthous.Util | ||||||
|   , maximum1 |   , maximum1 | ||||||
|   , minimum1 |   , minimum1 | ||||||
| 
 | 
 | ||||||
|  |     -- * Combinators | ||||||
|  |   , times, times_ | ||||||
|  | 
 | ||||||
|     -- * Type-level programming utils |     -- * Type-level programming utils | ||||||
|   , KnownBool(..) |   , KnownBool(..) | ||||||
|   ) where |   ) where | ||||||
|  | @ -228,6 +231,12 @@ maximum1 = getMax . foldMap1 Max | ||||||
| minimum1 :: (Ord a, Foldable1 f) => f a -> a | minimum1 :: (Ord a, Foldable1 f) => f a -> a | ||||||
| minimum1 = getMin . foldMap1 Min | minimum1 = getMin . foldMap1 Min | ||||||
| 
 | 
 | ||||||
|  | times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b] | ||||||
|  | times n f = traverse f [1..n] | ||||||
|  | 
 | ||||||
|  | times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a] | ||||||
|  | times_ n fa = times n (const fa) | ||||||
|  | 
 | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| -- | This class gives a boolean associated with a type-level bool, a'la | -- | This class gives a boolean associated with a type-level bool, a'la | ||||||
|  |  | ||||||
							
								
								
									
										33
									
								
								src/Xanthous/Util/Graph.hs
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										33
									
								
								src/Xanthous/Util/Graph.hs
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,33 @@ | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | module Xanthous.Util.Graph where | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import           Xanthous.Prelude | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import           Data.Graph.Inductive.Query.MST (msTree) | ||||||
|  | import qualified Data.Graph.Inductive.Graph as Graph | ||||||
|  | import           Data.Graph.Inductive.Graph | ||||||
|  | import           Data.Graph.Inductive.Basic (undir) | ||||||
|  | import           Data.Set (isSubsetOf) | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | mstSubGraph | ||||||
|  |   :: forall gr node edge. (DynGraph gr, Real edge, Show edge) | ||||||
|  |   => gr node edge -> gr node edge | ||||||
|  | mstSubGraph graph = insEdges mstEdges . insNodes (labNodes graph) $ Graph.empty | ||||||
|  |   where | ||||||
|  |     mstEdges = ordNub $ do | ||||||
|  |       LP path <- msTree $ undir graph | ||||||
|  |       case path of | ||||||
|  |         [] -> [] | ||||||
|  |         [_] -> [] | ||||||
|  |         ((n₂, edgeWeight) : (n₁, _) : _) -> | ||||||
|  |           pure (n₁, n₂, edgeWeight) | ||||||
|  | 
 | ||||||
|  | isSubGraphOf | ||||||
|  |   :: (Graph gr1, Graph gr2, Ord node, Ord edge) | ||||||
|  |   => gr1 node edge | ||||||
|  |   -> gr2 node edge | ||||||
|  |   -> Bool | ||||||
|  | isSubGraphOf graph₁ graph₂ | ||||||
|  |   = setFromList (labNodes graph₁) `isSubsetOf` setFromList (labNodes graph₂) | ||||||
|  |   && setFromList (labEdges graph₁) `isSubsetOf` setFromList (labEdges graph₂) | ||||||
|  | @ -4,16 +4,26 @@ module Xanthous.Util.Graphics | ||||||
|   ( circle |   ( circle | ||||||
|   , filledCircle |   , filledCircle | ||||||
|   , line |   , line | ||||||
|  |   , straightLine | ||||||
|  |   , delaunay | ||||||
|   ) where |   ) where | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| import           Xanthous.Prelude | import           Xanthous.Prelude | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer | ||||||
|  |               as Geometry | ||||||
|  | import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry | ||||||
|  | import           Codec.Picture (imagePixels) | ||||||
|  | import qualified Data.Geometry.Point as Geometry | ||||||
|  | import           Data.Ext ((:+)(..)) | ||||||
| import           Data.List (unfoldr) | import           Data.List (unfoldr) | ||||||
|  | import           Data.List.NonEmpty (NonEmpty) | ||||||
| import           Data.Ix (range, Ix) | import           Data.Ix (range, Ix) | ||||||
| import           Data.Word (Word8) | import           Data.Word (Word8) | ||||||
| import qualified Graphics.Rasterific as Raster | import qualified Graphics.Rasterific as Raster | ||||||
| import           Graphics.Rasterific hiding (circle, line) | import           Graphics.Rasterific hiding (circle, line, V2(..)) | ||||||
| import           Graphics.Rasterific.Texture (uniformTexture) | import           Graphics.Rasterific.Texture (uniformTexture) | ||||||
| import           Codec.Picture (imagePixels) | import           Linear.V2 | ||||||
| -------------------------------------------------------------------------------- | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
|  | @ -24,7 +34,7 @@ circle :: (Num i, Integral i, Ix i) | ||||||
| circle (ox, oy) radius | circle (ox, oy) radius | ||||||
|   = pointsFromRaster (ox + radius) (oy + radius) |   = pointsFromRaster (ox + radius) (oy + radius) | ||||||
|   $ stroke 1 JoinRound (CapRound, CapRound) |   $ stroke 1 JoinRound (CapRound, CapRound) | ||||||
|   $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy)) |   $ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy)) | ||||||
|   $ fromIntegral radius |   $ fromIntegral radius | ||||||
| 
 | 
 | ||||||
| filledCircle :: (Num i, Integral i, Ix i) | filledCircle :: (Num i, Integral i, Ix i) | ||||||
|  | @ -34,7 +44,7 @@ filledCircle :: (Num i, Integral i, Ix i) | ||||||
| filledCircle (ox, oy) radius | filledCircle (ox, oy) radius | ||||||
|   = pointsFromRaster (ox + radius) (oy + radius) |   = pointsFromRaster (ox + radius) (oy + radius) | ||||||
|   $ fill |   $ fill | ||||||
|   $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy)) |   $ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy)) | ||||||
|   $ fromIntegral radius |   $ fromIntegral radius | ||||||
| 
 | 
 | ||||||
| -- showCells . fromPoints . NE.fromList $ filledCircle (15, 15) 7 | -- showCells . fromPoints . NE.fromList $ filledCircle (15, 15) 7 | ||||||
|  | @ -83,3 +93,21 @@ line pa@(xa, ya) pb@(xb, yb) | ||||||
|         (newY, newError) = if (2 * tempError) >= δx |         (newY, newError) = if (2 * tempError) >= δx | ||||||
|                            then (yTemp + ystep, tempError - δx) |                            then (yTemp + ystep, tempError - δx) | ||||||
|                            else (yTemp, tempError) |                            else (yTemp, tempError) | ||||||
|  | 
 | ||||||
|  | straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)] | ||||||
|  | straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb | ||||||
|  |   where midpoint = (xa, yb) | ||||||
|  | 
 | ||||||
|  | 
 | ||||||
|  | delaunay | ||||||
|  |   :: (Ord n, Fractional n) | ||||||
|  |   => NonEmpty (V2 n, p) | ||||||
|  |   -> [((V2 n, p), (V2 n, p))] | ||||||
|  | delaunay | ||||||
|  |   = map (over both fromPoint) | ||||||
|  |   . Geometry.triangulationEdges | ||||||
|  |   . Geometry.delaunayTriangulation | ||||||
|  |   . map toPoint | ||||||
|  |   where | ||||||
|  |     toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid | ||||||
|  |     fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid) | ||||||
|  |  | ||||||
							
								
								
									
										21
									
								
								src/Xanthous/Util/Optparse.hs
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										21
									
								
								src/Xanthous/Util/Optparse.hs
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,21 @@ | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | module Xanthous.Util.Optparse | ||||||
|  |   ( readWithGuard | ||||||
|  |   ) where | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import Xanthous.Prelude | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import qualified Options.Applicative as Opt | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | readWithGuard | ||||||
|  |   :: Read b | ||||||
|  |   => (b -> Bool) | ||||||
|  |   -> (b -> String) | ||||||
|  |   -> Opt.ReadM b | ||||||
|  | readWithGuard predicate errmsg = do | ||||||
|  |   res <- Opt.auto | ||||||
|  |   unless (predicate res) | ||||||
|  |     $ Opt.readerError | ||||||
|  |     $ errmsg res | ||||||
|  |   pure res | ||||||
|  | @ -9,6 +9,7 @@ import qualified Xanthous.Generators.UtilSpec | ||||||
| import qualified Xanthous.MessageSpec | import qualified Xanthous.MessageSpec | ||||||
| import qualified Xanthous.OrphansSpec | import qualified Xanthous.OrphansSpec | ||||||
| import qualified Xanthous.Util.GraphicsSpec | import qualified Xanthous.Util.GraphicsSpec | ||||||
|  | import qualified Xanthous.Util.GraphSpec | ||||||
| import qualified Xanthous.Util.InflectionSpec | import qualified Xanthous.Util.InflectionSpec | ||||||
| import qualified Xanthous.UtilSpec | import qualified Xanthous.UtilSpec | ||||||
| 
 | 
 | ||||||
|  | @ -28,5 +29,6 @@ test = testGroup "Xanthous" | ||||||
|   , Xanthous.DataSpec.test |   , Xanthous.DataSpec.test | ||||||
|   , Xanthous.UtilSpec.test |   , Xanthous.UtilSpec.test | ||||||
|   , Xanthous.Util.GraphicsSpec.test |   , Xanthous.Util.GraphicsSpec.test | ||||||
|  |   , Xanthous.Util.GraphSpec.test | ||||||
|   , Xanthous.Util.InflectionSpec.test |   , Xanthous.Util.InflectionSpec.test | ||||||
|   ] |   ] | ||||||
|  |  | ||||||
|  | @ -1,10 +1,10 @@ | ||||||
| -- | | -------------------------------------------------------------------------------- | ||||||
| 
 |  | ||||||
| module Xanthous.DataSpec (main, test) where | module Xanthous.DataSpec (main, test) where | ||||||
| 
 | -------------------------------------------------------------------------------- | ||||||
| import Test.Prelude hiding (Right, Left, Down) | import Test.Prelude hiding (Right, Left, Down) | ||||||
| import Xanthous.Data | import Xanthous.Data | ||||||
| import Data.Group | import Data.Group | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| main :: IO () | main :: IO () | ||||||
| main = defaultMain test | main = defaultMain test | ||||||
|  | @ -35,11 +35,12 @@ test = testGroup "Xanthous.Data" | ||||||
|           (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13" |           (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13" | ||||||
|       ] |       ] | ||||||
|     ] |     ] | ||||||
|  | 
 | ||||||
|   , testGroup "Direction" |   , testGroup "Direction" | ||||||
|     [ testProperty "opposite is involutive" $ \(dir :: Direction) -> |     [ testProperty "opposite is involutive" $ \(dir :: Direction) -> | ||||||
|         opposite (opposite dir) == dir |         opposite (opposite dir) == dir | ||||||
|     , testProperty "opposite provides inverse" $ \dir -> |     , testProperty "opposite provides inverse" $ \dir -> | ||||||
|         invert (asPosition dir) == asPosition (opposite dir) |         invert (asPosition dir) === asPosition (opposite dir) | ||||||
|     , testProperty "asPosition isUnit" $ \dir -> |     , testProperty "asPosition isUnit" $ \dir -> | ||||||
|         dir /= Here ==> isUnit (asPosition dir) |         dir /= Here ==> isUnit (asPosition dir) | ||||||
|     , testGroup "Move" |     , testGroup "Move" | ||||||
|  | @ -53,4 +54,29 @@ test = testGroup "Xanthous.Data" | ||||||
|       , testCase "DownRight" $ move DownRight mempty @?= Position 1 1 |       , testCase "DownRight" $ move DownRight mempty @?= Position 1 1 | ||||||
|       ] |       ] | ||||||
|     ] |     ] | ||||||
|  | 
 | ||||||
|  |   , testGroup "Corner" | ||||||
|  |     [ testGroup "instance Opposite" | ||||||
|  |       [ testProperty "involutive" $ \corner -> | ||||||
|  |           opposite (opposite corner) === corner | ||||||
|  |       ] | ||||||
|  |     ] | ||||||
|  | 
 | ||||||
|  |   , testGroup "Edge" | ||||||
|  |     [ testGroup "instance Opposite" | ||||||
|  |       [ testProperty "involutive" $ \edge -> | ||||||
|  |           opposite (opposite edge) === edge | ||||||
|  |       ] | ||||||
|  |     ] | ||||||
|  | 
 | ||||||
|  |   , testGroup "Box" | ||||||
|  |     [ testGroup "boxIntersects" | ||||||
|  |       [ testProperty "True" $ \dims -> | ||||||
|  |           boxIntersects (Box @Word (V2 1 1) (V2 2 2)) | ||||||
|  |                         (Box (V2 2 2) dims) | ||||||
|  |       , testProperty "False" $ \dims -> | ||||||
|  |           not $ boxIntersects (Box @Word (V2 1 1) (V2 2 2)) | ||||||
|  |                             (Box (V2 4 2) dims) | ||||||
|  |       ] | ||||||
|  |     ] | ||||||
|   ] |   ] | ||||||
|  |  | ||||||
							
								
								
									
										39
									
								
								test/Xanthous/Util/GraphSpec.hs
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										39
									
								
								test/Xanthous/Util/GraphSpec.hs
									
										
									
									
									
										Normal file
									
								
							|  | @ -0,0 +1,39 @@ | ||||||
|  | module Xanthous.Util.GraphSpec (main, test) where | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import Test.Prelude | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | import Xanthous.Util.Graph | ||||||
|  | import Data.Graph.Inductive.Basic | ||||||
|  | import Data.Graph.Inductive.Graph (labNodes, size, order) | ||||||
|  | import Data.Graph.Inductive.PatriciaTree | ||||||
|  | import Data.Graph.Inductive.Arbitrary | ||||||
|  | -------------------------------------------------------------------------------- | ||||||
|  | 
 | ||||||
|  | main :: IO () | ||||||
|  | main = defaultMain test | ||||||
|  | 
 | ||||||
|  | test :: TestTree | ||||||
|  | test = testGroup "Xanthous.Util.Graph" | ||||||
|  |   [ testGroup "mstSubGraph" | ||||||
|  |     [ testProperty "always produces a subgraph" | ||||||
|  |         $ \(CG _ (graph :: Gr Int Int)) -> | ||||||
|  |           let msg = mstSubGraph $ undir graph | ||||||
|  |           in counterexample (show msg) | ||||||
|  |             $ msg `isSubGraphOf` undir graph | ||||||
|  |     , testProperty "returns a graph with the same nodes" | ||||||
|  |         $ \(CG _ (graph :: Gr Int Int)) -> | ||||||
|  |           let msg = mstSubGraph graph | ||||||
|  |           in counterexample (show msg) | ||||||
|  |             $ labNodes msg === labNodes graph | ||||||
|  |     , testProperty "has nodes - 1 edges" | ||||||
|  |         $ \(CG _ (graph :: Gr Int Int)) -> | ||||||
|  |           order graph > 1 ==> | ||||||
|  |           let msg = mstSubGraph graph | ||||||
|  |           in counterexample (show msg) | ||||||
|  |             $ size msg === order graph - 1 | ||||||
|  |     , testProperty "always produces a simple graph" | ||||||
|  |         $ \(CG _ (graph :: Gr Int Int)) -> | ||||||
|  |           let msg = mstSubGraph graph | ||||||
|  |           in counterexample (show msg) $ isSimple msg | ||||||
|  |     ] | ||||||
|  |   ] | ||||||
|  | @ -4,7 +4,7 @@ cabal-version: 1.12 | ||||||
| -- | -- | ||||||
| -- see: https://github.com/sol/hpack | -- see: https://github.com/sol/hpack | ||||||
| -- | -- | ||||||
| -- hash: 2d93180ab419496ded42f750d00a5b3f6c6994a9af86a8694bb585a1f52919d4 | -- hash: 497414a98a626a63a6c5022688b33d0021c1580c7c262fbc1152599289df7935 | ||||||
| 
 | 
 | ||||||
| name:           xanthous | name:           xanthous | ||||||
| version:        0.1.0.0 | version:        0.1.0.0 | ||||||
|  | @ -54,6 +54,7 @@ library | ||||||
|       Xanthous.Game.State |       Xanthous.Game.State | ||||||
|       Xanthous.Generators |       Xanthous.Generators | ||||||
|       Xanthous.Generators.CaveAutomata |       Xanthous.Generators.CaveAutomata | ||||||
|  |       Xanthous.Generators.Dungeon | ||||||
|       Xanthous.Generators.LevelContents |       Xanthous.Generators.LevelContents | ||||||
|       Xanthous.Generators.Util |       Xanthous.Generators.Util | ||||||
|       Xanthous.Messages |       Xanthous.Messages | ||||||
|  | @ -63,9 +64,11 @@ library | ||||||
|       Xanthous.Random |       Xanthous.Random | ||||||
|       Xanthous.Resource |       Xanthous.Resource | ||||||
|       Xanthous.Util |       Xanthous.Util | ||||||
|  |       Xanthous.Util.Graph | ||||||
|       Xanthous.Util.Graphics |       Xanthous.Util.Graphics | ||||||
|       Xanthous.Util.Inflection |       Xanthous.Util.Inflection | ||||||
|       Xanthous.Util.JSON |       Xanthous.Util.JSON | ||||||
|  |       Xanthous.Util.Optparse | ||||||
|       Xanthous.Util.QuickCheck |       Xanthous.Util.QuickCheck | ||||||
|   other-modules: |   other-modules: | ||||||
|       Paths_xanthous |       Paths_xanthous | ||||||
|  | @ -74,8 +77,10 @@ library | ||||||
|   default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators |   default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators | ||||||
|   ghc-options: -Wall |   ghc-options: -Wall | ||||||
|   build-depends: |   build-depends: | ||||||
|       MonadRandom |       JuicyPixels | ||||||
|  |     , MonadRandom | ||||||
|     , QuickCheck |     , QuickCheck | ||||||
|  |     , Rasterific | ||||||
|     , aeson |     , aeson | ||||||
|     , array |     , array | ||||||
|     , base |     , base | ||||||
|  | @ -87,13 +92,18 @@ library | ||||||
|     , containers |     , containers | ||||||
|     , data-default |     , data-default | ||||||
|     , deepseq |     , deepseq | ||||||
|  |     , fgl | ||||||
|  |     , fgl-arbitrary | ||||||
|     , file-embed |     , file-embed | ||||||
|     , filepath |     , filepath | ||||||
|     , generic-arbitrary |     , generic-arbitrary | ||||||
|     , generic-lens |     , generic-lens | ||||||
|     , generic-monoid |     , generic-monoid | ||||||
|     , groups |     , groups | ||||||
|  |     , hgeometry | ||||||
|  |     , hgeometry-combinatorial | ||||||
|     , lens |     , lens | ||||||
|  |     , linear | ||||||
|     , megaparsec |     , megaparsec | ||||||
|     , mtl |     , mtl | ||||||
|     , optparse-applicative |     , optparse-applicative | ||||||
|  | @ -105,7 +115,9 @@ library | ||||||
|     , random-source |     , random-source | ||||||
|     , raw-strings-qq |     , raw-strings-qq | ||||||
|     , reflection |     , reflection | ||||||
|  |     , semigroupoids | ||||||
|     , stache |     , stache | ||||||
|  |     , streams | ||||||
|     , text-zipper |     , text-zipper | ||||||
|     , tomland |     , tomland | ||||||
|     , vector |     , vector | ||||||
|  | @ -142,6 +154,7 @@ executable xanthous | ||||||
|       Xanthous.Game.State |       Xanthous.Game.State | ||||||
|       Xanthous.Generators |       Xanthous.Generators | ||||||
|       Xanthous.Generators.CaveAutomata |       Xanthous.Generators.CaveAutomata | ||||||
|  |       Xanthous.Generators.Dungeon | ||||||
|       Xanthous.Generators.LevelContents |       Xanthous.Generators.LevelContents | ||||||
|       Xanthous.Generators.Util |       Xanthous.Generators.Util | ||||||
|       Xanthous.Messages |       Xanthous.Messages | ||||||
|  | @ -151,9 +164,11 @@ executable xanthous | ||||||
|       Xanthous.Random |       Xanthous.Random | ||||||
|       Xanthous.Resource |       Xanthous.Resource | ||||||
|       Xanthous.Util |       Xanthous.Util | ||||||
|  |       Xanthous.Util.Graph | ||||||
|       Xanthous.Util.Graphics |       Xanthous.Util.Graphics | ||||||
|       Xanthous.Util.Inflection |       Xanthous.Util.Inflection | ||||||
|       Xanthous.Util.JSON |       Xanthous.Util.JSON | ||||||
|  |       Xanthous.Util.Optparse | ||||||
|       Xanthous.Util.QuickCheck |       Xanthous.Util.QuickCheck | ||||||
|       Paths_xanthous |       Paths_xanthous | ||||||
|   hs-source-dirs: |   hs-source-dirs: | ||||||
|  | @ -161,8 +176,10 @@ executable xanthous | ||||||
|   default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators |   default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators | ||||||
|   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 |   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 | ||||||
|   build-depends: |   build-depends: | ||||||
|       MonadRandom |       JuicyPixels | ||||||
|  |     , MonadRandom | ||||||
|     , QuickCheck |     , QuickCheck | ||||||
|  |     , Rasterific | ||||||
|     , aeson |     , aeson | ||||||
|     , array |     , array | ||||||
|     , base |     , base | ||||||
|  | @ -174,13 +191,18 @@ executable xanthous | ||||||
|     , containers |     , containers | ||||||
|     , data-default |     , data-default | ||||||
|     , deepseq |     , deepseq | ||||||
|  |     , fgl | ||||||
|  |     , fgl-arbitrary | ||||||
|     , file-embed |     , file-embed | ||||||
|     , filepath |     , filepath | ||||||
|     , generic-arbitrary |     , generic-arbitrary | ||||||
|     , generic-lens |     , generic-lens | ||||||
|     , generic-monoid |     , generic-monoid | ||||||
|     , groups |     , groups | ||||||
|  |     , hgeometry | ||||||
|  |     , hgeometry-combinatorial | ||||||
|     , lens |     , lens | ||||||
|  |     , linear | ||||||
|     , megaparsec |     , megaparsec | ||||||
|     , mtl |     , mtl | ||||||
|     , optparse-applicative |     , optparse-applicative | ||||||
|  | @ -192,7 +214,9 @@ executable xanthous | ||||||
|     , random-source |     , random-source | ||||||
|     , raw-strings-qq |     , raw-strings-qq | ||||||
|     , reflection |     , reflection | ||||||
|  |     , semigroupoids | ||||||
|     , stache |     , stache | ||||||
|  |     , streams | ||||||
|     , text-zipper |     , text-zipper | ||||||
|     , tomland |     , tomland | ||||||
|     , vector |     , vector | ||||||
|  | @ -217,6 +241,7 @@ test-suite test | ||||||
|       Xanthous.MessageSpec |       Xanthous.MessageSpec | ||||||
|       Xanthous.OrphansSpec |       Xanthous.OrphansSpec | ||||||
|       Xanthous.Util.GraphicsSpec |       Xanthous.Util.GraphicsSpec | ||||||
|  |       Xanthous.Util.GraphSpec | ||||||
|       Xanthous.Util.InflectionSpec |       Xanthous.Util.InflectionSpec | ||||||
|       Xanthous.UtilSpec |       Xanthous.UtilSpec | ||||||
|       Paths_xanthous |       Paths_xanthous | ||||||
|  | @ -225,8 +250,10 @@ test-suite test | ||||||
|   default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators |   default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators | ||||||
|   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0 |   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0 | ||||||
|   build-depends: |   build-depends: | ||||||
|       MonadRandom |       JuicyPixels | ||||||
|  |     , MonadRandom | ||||||
|     , QuickCheck |     , QuickCheck | ||||||
|  |     , Rasterific | ||||||
|     , aeson |     , aeson | ||||||
|     , array |     , array | ||||||
|     , base |     , base | ||||||
|  | @ -238,14 +265,19 @@ test-suite test | ||||||
|     , containers |     , containers | ||||||
|     , data-default |     , data-default | ||||||
|     , deepseq |     , deepseq | ||||||
|  |     , fgl | ||||||
|  |     , fgl-arbitrary | ||||||
|     , file-embed |     , file-embed | ||||||
|     , filepath |     , filepath | ||||||
|     , generic-arbitrary |     , generic-arbitrary | ||||||
|     , generic-lens |     , generic-lens | ||||||
|     , generic-monoid |     , generic-monoid | ||||||
|     , groups |     , groups | ||||||
|  |     , hgeometry | ||||||
|  |     , hgeometry-combinatorial | ||||||
|     , lens |     , lens | ||||||
|     , lens-properties |     , lens-properties | ||||||
|  |     , linear | ||||||
|     , megaparsec |     , megaparsec | ||||||
|     , mtl |     , mtl | ||||||
|     , optparse-applicative |     , optparse-applicative | ||||||
|  | @ -257,7 +289,9 @@ test-suite test | ||||||
|     , random-source |     , random-source | ||||||
|     , raw-strings-qq |     , raw-strings-qq | ||||||
|     , reflection |     , reflection | ||||||
|  |     , semigroupoids | ||||||
|     , stache |     , stache | ||||||
|  |     , streams | ||||||
|     , tasty |     , tasty | ||||||
|     , tasty-hunit |     , tasty-hunit | ||||||
|     , tasty-quickcheck |     , tasty-quickcheck | ||||||
|  |  | ||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue