diff options
Diffstat (limited to 'src/Xanthous')
| -rw-r--r-- | src/Xanthous/Data.hs | 173 | ||||
| -rw-r--r-- | src/Xanthous/Generators.hs | 29 | ||||
| -rw-r--r-- | src/Xanthous/Generators/CaveAutomata.hs | 31 | ||||
| -rw-r--r-- | src/Xanthous/Generators/Dungeon.hs | 192 | ||||
| -rw-r--r-- | src/Xanthous/Generators/Util.hs | 7 | ||||
| -rw-r--r-- | src/Xanthous/Orphans.hs | 33 | ||||
| -rw-r--r-- | src/Xanthous/Random.hs | 23 | ||||
| -rw-r--r-- | src/Xanthous/Util.hs | 9 | ||||
| -rw-r--r-- | src/Xanthous/Util/Graph.hs | 33 | ||||
| -rw-r--r-- | src/Xanthous/Util/Graphics.hs | 36 | ||||
| -rw-r--r-- | src/Xanthous/Util/Optparse.hs | 21 |
11 files changed, 505 insertions, 82 deletions
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index dfad2cffd392..8a8a62d0ee08 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoTypeSynonymInstances #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoTypeSynonymInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} -------------------------------------------------------------------------------- -- | Common data types for Xanthous -------------------------------------------------------------------------------- module Xanthous.Data - ( -- * - Position'(..) + ( Opposite(..) + + -- * + , Position'(..) , Position , x , y + -- ** , Positioned(..) , _Positioned , position @@ -30,6 +34,18 @@ module Xanthous.Data , stepTowards , isUnit + -- * Boxes + , Box(..) + , topLeftCorner + , bottomRightCorner + , setBottomRightCorner + , dimensions + , inBox + , boxIntersects + , boxCenter + , boxEdge + , module Linear.V2 + -- * , Per(..) , invertRate @@ -49,12 +65,16 @@ module Xanthous.Data -- * , Direction(..) - , opposite , move , asPosition , directionOf -- * + , Corner(..) + , Edge(..) + , cornerEdges + + -- * , Neighbors(..) , edges , neighborDirections @@ -65,6 +85,9 @@ module Xanthous.Data ) where -------------------------------------------------------------------------------- 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.Generic import Data.Group @@ -74,11 +97,18 @@ import Data.Aeson.Generic.DerivingVia import Data.Aeson ( 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.Util.Graphics -------------------------------------------------------------------------------- +-- | opposite ∘ opposite ≡ id +class Opposite x where + opposite :: x -> x + +-------------------------------------------------------------------------------- + -- fromScalar ∘ scalar ≡ id class Scalar a where scalar :: a -> Double @@ -109,7 +139,10 @@ data Position' a where deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] (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 @@ -236,16 +269,16 @@ instance Arbitrary Direction where arbitrary = genericArbitrary shrink = genericShrink -opposite :: Direction -> Direction -opposite Up = Down -opposite Down = Up -opposite Left = Right -opposite Right = Left -opposite UpLeft = DownRight -opposite UpRight = DownLeft -opposite DownLeft = UpRight -opposite DownRight = UpLeft -opposite Here = Here +instance Opposite Direction where + opposite Up = Down + opposite Down = Up + opposite Left = Right + opposite Right = Left + opposite UpLeft = DownRight + opposite UpRight = DownLeft + opposite DownLeft = UpRight + opposite DownRight = UpLeft + opposite Here = Here move :: Direction -> Position -> Position 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 { _topLeft , _top @@ -307,7 +374,7 @@ data Neighbors a = Neighbors } deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) deriving anyclass (NFData) -makeLenses ''Neighbors +makeFieldsNoPrefix ''Neighbors instance Applicative Neighbors where pure α = Neighbors @@ -403,3 +470,57 @@ newtype Hitpoints = Hitpoints Word via 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] diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 490e50ea60a8..592bf73c0007 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -25,6 +25,7 @@ import qualified Options.Applicative as Opt import Control.Monad.Random -------------------------------------------------------------------------------- import qualified Xanthous.Generators.CaveAutomata as CaveAutomata +import qualified Xanthous.Generators.Dungeon as Dungeon import Xanthous.Generators.Util import Xanthous.Generators.LevelContents import Xanthous.Data (Dimensions, Position'(Position), Position) @@ -35,14 +36,18 @@ import Xanthous.Entities.Item (Item) import Xanthous.Entities.Creature (Creature) -------------------------------------------------------------------------------- -data Generator = CaveAutomata +data Generator + = CaveAutomata + | Dungeon deriving stock (Show, Eq) data SGenerator (gen :: Generator) where SCaveAutomata :: SGenerator 'CaveAutomata + SDungeon :: SGenerator 'Dungeon type family Params (gen :: Generator) :: Type where Params 'CaveAutomata = CaveAutomata.Params + Params 'Dungeon = Dungeon.Params generate :: RandomGen g @@ -52,6 +57,7 @@ generate -> g -> Cells generate SCaveAutomata = CaveAutomata.generate +generate SDungeon = Dungeon.generate data GeneratorInput where 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 parseGeneratorInput :: Opt.Parser GeneratorInput -parseGeneratorInput = Opt.subparser $ - Opt.command "cave" (Opt.info - (GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams) - (Opt.progDesc "cellular-automata based cave generator")) +parseGeneratorInput = Opt.subparser + $ generatorCommand SCaveAutomata + "cave" + "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 arr = diff --git a/src/Xanthous/Generators/CaveAutomata.hs b/src/Xanthous/Generators/CaveAutomata.hs index e885f4ed1aad..5a7c081d03e9 100644 --- a/src/Xanthous/Generators/CaveAutomata.hs +++ b/src/Xanthous/Generators/CaveAutomata.hs @@ -2,23 +2,25 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} - +-------------------------------------------------------------------------------- module Xanthous.Generators.CaveAutomata ( Params(..) , defaultParams , parseParams , generate ) where - -import Xanthous.Prelude -import Control.Monad.Random (RandomGen, runRandT) -import Data.Array.ST -import Data.Array.Unboxed +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Control.Monad.Random (RandomGen, runRandT) +import Data.Array.ST +import Data.Array.Unboxed import qualified Options.Applicative as Opt - -import Xanthous.Util (between) -import Xanthous.Data (Dimensions, width, height) -import Xanthous.Generators.Util +-------------------------------------------------------------------------------- +import Xanthous.Util (between) +import Xanthous.Util.Optparse +import Xanthous.Data (Dimensions, width, height) +import Xanthous.Generators.Util +-------------------------------------------------------------------------------- data Params = Params { _aliveStartChance :: Double @@ -70,13 +72,6 @@ parseParams = Params <> Opt.metavar "STEPS" ) where - readWithGuard predicate errmsg = do - res <- Opt.auto - unless (predicate res) - $ Opt.readerError - $ errmsg res - pure res - parseChance = readWithGuard (between 0 1) $ \res -> "Chance must be in the range [0,1], got: " <> show res @@ -85,7 +80,7 @@ parseParams = Params (between 0 8) $ \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 = runSTUArray $ fmap fst diff --git a/src/Xanthous/Generators/Dungeon.hs b/src/Xanthous/Generators/Dungeon.hs new file mode 100644 index 000000000000..fdc510bb79ec --- /dev/null +++ b/src/Xanthous/Generators/Dungeon.hs @@ -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) diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs index 2c041149d900..13f248a045d8 100644 --- a/src/Xanthous/Generators/Util.hs +++ b/src/Xanthous/Generators/Util.hs @@ -7,6 +7,7 @@ module Xanthous.Generators.Util , Cells , CellM , randInitialize + , initializeEmpty , numAliveNeighborsM , numAliveNeighbors , 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 dims aliveChance = do - res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False + res <- initializeEmpty dims for_ [0..dims ^. width] $ \i -> for_ [0..dims ^. height] $ \j -> do val <- (>= aliveChance) <$> getRandomR (0, 1) lift $ writeArray res (i, j) val pure res +initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) +initializeEmpty dims = + lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False + numAliveNeighborsM :: forall a i j m . (MArray a Bool m, Ix (i, j), Integral i, Integral j) diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index 6a860e1c49f1..b7a4a3212629 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -1,7 +1,9 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UndecidableInstances, PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} -------------------------------------------------------------------------------- module Xanthous.Orphans @@ -13,21 +15,23 @@ import Xanthous.Prelude hiding (elements, (.=)) import Data.Aeson import Data.Aeson.Types (typeMismatch) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Text.Arbitrary () import Graphics.Vty.Attributes import Brick.Widgets.Edit import Data.Text.Zipper.Generic (GenericTextZipper) import Brick.Widgets.Core (getName) import System.Random (StdGen) import Test.QuickCheck +import "quickcheck-instances" Test.QuickCheck.Instances () import Text.Megaparsec (errorBundlePretty) import Text.Megaparsec.Pos import Text.Mustache import Text.Mustache.Type ( showKey ) import Control.Monad.State +import Linear -------------------------------------------------------------------------------- import Xanthous.Util.JSON +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- instance forall s a. ( Cons s s a a @@ -130,18 +134,6 @@ instance Function Template where parseTemplatePartial txt = 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 _ (TextBlock txt) = txt ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" @@ -169,12 +161,6 @@ instance FromJSON Template where $ either (fail . errorBundlePretty) pure . 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 Template @@ -353,3 +339,8 @@ instance CoArbitrary StdGen where deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) => 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) diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs index bbf176f71d6e..3cb0b068d3d7 100644 --- a/src/Xanthous/Random.hs +++ b/src/Xanthous/Random.hs @@ -8,17 +8,19 @@ module Xanthous.Random , Weighted(..) , evenlyWeighted , weightedBy + , subRand ) where -------------------------------------------------------------------------------- import Xanthous.Prelude -------------------------------------------------------------------------------- -import Data.List.NonEmpty (NonEmpty) -import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) -import Data.Random.Shuffle.Weighted -import Data.Random.Distribution -import Data.Random.Distribution.Uniform -import Data.Random.Distribution.Uniform.Exclusive -import Data.Random.Sample +import Data.List.NonEmpty (NonEmpty(..)) +import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) +import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) +import Data.Random.Shuffle.Weighted +import Data.Random.Distribution +import Data.Random.Distribution.Uniform +import Data.Random.Distribution.Uniform.Exclusive +import Data.Random.Sample import qualified Data.Random.Source as DRS -------------------------------------------------------------------------------- @@ -58,6 +60,10 @@ instance Choose (NonEmpty a) where type RandomResult (NonEmpty a) = a 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)) evenlyWeighted :: [a] -> Weighted Int [] a @@ -76,3 +82,6 @@ instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighte sample $ fromMaybe (error "unreachable") . headMay <$> weightedSample 1 (toList ws) + +subRand :: MonadRandom m => Rand StdGen a -> m a +subRand sub = evalRand sub . mkStdGen <$> getRandom diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs index 93155af3fd59..524ad4819dac 100644 --- a/src/Xanthous/Util.hs +++ b/src/Xanthous/Util.hs @@ -29,6 +29,9 @@ module Xanthous.Util , maximum1 , minimum1 + -- * Combinators + , times, times_ + -- * Type-level programming utils , KnownBool(..) ) where @@ -228,6 +231,12 @@ maximum1 = getMax . foldMap1 Max minimum1 :: (Ord a, Foldable1 f) => f a -> a 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 diff --git a/src/Xanthous/Util/Graph.hs b/src/Xanthous/Util/Graph.hs new file mode 100644 index 000000000000..8e5c04f4bfa9 --- /dev/null +++ b/src/Xanthous/Util/Graph.hs @@ -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₂) diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs index e8269e72d6c8..bd6a0906a6d5 100644 --- a/src/Xanthous/Util/Graphics.hs +++ b/src/Xanthous/Util/Graphics.hs @@ -4,16 +4,26 @@ module Xanthous.Util.Graphics ( circle , filledCircle , line + , straightLine + , delaunay ) where -------------------------------------------------------------------------------- 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.NonEmpty (NonEmpty) import Data.Ix (range, Ix) import Data.Word (Word8) 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 Codec.Picture (imagePixels) +import Linear.V2 -------------------------------------------------------------------------------- @@ -24,7 +34,7 @@ circle :: (Num i, Integral i, Ix i) circle (ox, oy) radius = pointsFromRaster (ox + radius) (oy + radius) $ stroke 1 JoinRound (CapRound, CapRound) - $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy)) + $ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy)) $ fromIntegral radius filledCircle :: (Num i, Integral i, Ix i) @@ -34,7 +44,7 @@ filledCircle :: (Num i, Integral i, Ix i) filledCircle (ox, oy) radius = pointsFromRaster (ox + radius) (oy + radius) $ fill - $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy)) + $ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy)) $ fromIntegral radius -- 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 then (yTemp + ystep, tempError - δx) 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) diff --git a/src/Xanthous/Util/Optparse.hs b/src/Xanthous/Util/Optparse.hs new file mode 100644 index 000000000000..dfa65372351d --- /dev/null +++ b/src/Xanthous/Util/Optparse.hs @@ -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 |