Add items and inventory

Add a new "Item" entity, which pulls from the previously-existent
ItemType raw, and add a "PickUp" command which takes the (currently
*only*) item off the ground and puts it into the inventory.

package.yaml

@@ -33,6 +33,7 @@ dependencies:
 - filepath
 - generic-arbitrary
 - generic-monoid
+- generic-lens
 - groups
 - lens
 - megaparsec

src/Main.hs

@@ -8,7 +8,7 @@ import           System.Random
 import           Xanthous.Game (getInitialState)
 import           Xanthous.App (makeApp)
 import           Xanthous.Generators
-  ( GeneratorInput(..)
+  ( GeneratorInput
   , parseGeneratorInput
   , generateFromInput
   , showCells

src/Xanthous/App.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ViewPatterns #-}
 module Xanthous.App (makeApp) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -7,17 +8,16 @@ import           Graphics.Vty.Attributes (defAttr)
 import           Graphics.Vty.Input.Events (Event(EvKey))
 import           Control.Monad.State (get)
 import           Control.Monad.State.Class (modify)
-import           Control.Monad.Random (getRandom)
+import           Data.Aeson (object)
+import qualified Data.Aeson as A
 --------------------------------------------------------------------------------
 import           Xanthous.Command
 import           Xanthous.Data
                  ( move
-                 , Position(..)
                  , Dimensions'(Dimensions)
-                 , Dimensions
+                 , positioned
-                 , positionFromPair
                  )
-import           Xanthous.Data.EntityMap (EntityMap)
+import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game
 import           Xanthous.Game.Draw (drawGame)
 import           Xanthous.Monad
@@ -25,12 +25,13 @@ import           Xanthous.Resource (Name)
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.Creature (Creature)
 import qualified Xanthous.Entities.Creature as Creature
+import qualified Xanthous.Entities.Character as Character
 import           Xanthous.Entities.RawTypes (EntityRaw(..))
 import           Xanthous.Entities.Raws (raw)
 import           Xanthous.Entities
+import           Xanthous.Entities.Item (Item)
 import           Xanthous.Generators
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
-import           Xanthous.Generators.LevelContents
 --------------------------------------------------------------------------------
 
 type App = Brick.App GameState () Name
@@ -56,11 +57,12 @@ testGormlak =
 startEvent :: AppM ()
 startEvent = do
   say_ ["welcome"]
-  (level, charPos) <-
+  level <-
     generateLevel SCaveAutomata CaveAutomata.defaultParams
     $ Dimensions 80 80
-  entities <>= level
+  entities <>= (SomeEntity <$> level ^. levelWalls)
-  characterPosition .= charPos
+  entities <>= (SomeEntity <$> level ^. levelItems)
+  characterPosition .= level ^. levelCharacterPosition
   modify updateCharacterVision
   -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
 
@@ -84,21 +86,23 @@ handleCommand (Move dir) = do
     Just Stop -> pure ()
   continue
 
+handleCommand PickUp = do
+  pos <- use characterPosition
+  ents <- uses entities $ EntityMap.atPositionWithIDs pos
+  let items = flip foldMap ents $ \(eid, view positioned -> se) ->
+        case downcastEntity @Item se of
+          Just item -> [(eid, item)]
+          Nothing   -> []
+  case items of
+    [] -> say_ ["items", "nothingToPickUp"]
+    [(itemID, item)] -> do
+      character %= Character.pickUpItem item
+      entities . at itemID .= Nothing
+      say ["items", "pickUp"] $ object [ "item" A..= item ]
+    _ -> undefined
+  continue
+
 handleCommand PreviousMessage = do
   messageHistory %= popMessage
   continue
 
---------------------------------------------------------------------------------
-
-generateLevel
-  :: SGenerator gen
-  -> Params gen
-  -> Dimensions
-  -> AppM (EntityMap SomeEntity, Position)
-generateLevel g ps dims = do
-  gen <- use randomGen
-  let cells = generate g ps dims gen
-  _ <- getRandom @_ @Int -- perturb the generator, so we don't get the same level twice
-  charPos <- positionFromPair <$> chooseCharacterPosition cells
-  let level = SomeEntity <$> cellsToWalls cells
-  pure (level, charPos)

src/Xanthous/Command.hs

@@ -9,10 +9,11 @@ data Command
   = Quit
   | Move Direction
   | PreviousMessage
-  -- | PickUp
+  | PickUp
 
 commandFromKey :: Key -> [Modifier] -> Maybe Command
 commandFromKey (KChar 'q') [] = Just Quit
+
 commandFromKey (KChar 'h') [] = Just $ Move Left
 commandFromKey (KChar 'j') [] = Just $ Move Down
 commandFromKey (KChar 'k') [] = Just $ Move Up
@@ -24,4 +25,6 @@ commandFromKey (KChar 'n') [] = Just $ Move DownRight
 
 commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
 
+commandFromKey (KChar ',') [] = Just PickUp
+
 commandFromKey _ _ = Nothing

src/Xanthous/Data/EntityMap/Graphics.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE ViewPatterns #-}
 --------------------------------------------------------------------------------
-module Xanthous.Data.EntityMap.Graphics where
+module Xanthous.Data.EntityMap.Graphics
+  ( visiblePositions
+  , visibleEntities
+  ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 --------------------------------------------------------------------------------
@@ -11,6 +14,10 @@ import Xanthous.Entities
 import Xanthous.Util.Graphics (circle, line)
 --------------------------------------------------------------------------------
 
+visiblePositions :: Position -> Word -> EntityMap SomeEntity -> Set Position
+visiblePositions pos radius = setFromList . positions . visibleEntities pos radius
+
+
 -- | Given a point and a radius of vision, returns a list of all entities that
 -- are *visible* (eg, not blocked by an entity that obscures vision) from that
 -- point

src/Xanthous/Entities.hs

@@ -7,26 +7,33 @@ module Xanthous.Entities
   ( Draw(..)
   , DrawCharacter(..)
   , DrawStyledCharacter(..)
+  , DrawRawChar(..)
   , Entity(..)
   , SomeEntity(..)
   , downcastEntity
   , entityIs
+  , _SomeEntity
 
   , Color(..)
   , KnownColor(..)
 
   , EntityChar(..)
+  , HasChar(..)
   ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude
+import           Xanthous.Prelude hiding ((.=))
 --------------------------------------------------------------------------------
 import           Brick
 import           Data.Typeable
 import qualified Graphics.Vty.Attributes as Vty
 import qualified Graphics.Vty.Image as Vty
 import           Data.Aeson
+import           Data.Generics.Product.Fields
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
 --------------------------------------------------------------------------------
 import           Xanthous.Data
+import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
 class (Show a, Eq a, Draw a) => Entity a where
@@ -58,6 +65,10 @@ downcastEntity (SomeEntity e) = cast e
 
 entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool
 entityIs = isJust . downcastEntity @a
+
+_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
+_SomeEntity = prism' SomeEntity downcastEntity
+
 --------------------------------------------------------------------------------
 
 class Draw a where
@@ -109,13 +120,33 @@ instance
             , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
             , Vty.attrURL = Vty.Default
             }
+
 --------------------------------------------------------------------------------
+
+class HasChar s a | s -> a where
+  char :: Lens' s a
+  {-# MINIMAL char #-}
+
+newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
+
+instance
+  forall rawField a raw.
+  ( HasField rawField a a raw raw
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawChar rawField a) where
+  draw (DrawRawChar e) = draw $ e ^. field @rawField . char
+
+--------------------------------------------------------------------------------
+
 data EntityChar = EntityChar
   { _char :: Char
   , _style :: Vty.Attr
   }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary EntityChar where
+  arbitrary = genericArbitrary
 
 instance FromJSON EntityChar where
   parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
@@ -132,7 +163,16 @@ instance FromJSON EntityChar where
     pure EntityChar {..}
   parseJSON _ = fail "Invalid type, expected string or object"
 
+instance ToJSON EntityChar where
+  toJSON (EntityChar chr styl)
+    | styl == Vty.defAttr = String $ chr <| Empty
+    | otherwise = object
+      [ "char" .= chr
+      , "style" .= object
+        [ "foreground" .= Vty.attrForeColor styl
+        , "background" .= Vty.attrBackColor styl
+        ]
+      ]
+
 instance Draw EntityChar where
   draw EntityChar{..} = raw $ Vty.string _style [_char]
-
---------------------------------------------------------------------------------

src/Xanthous/Entities/Arbitrary.hs

@@ -14,6 +14,6 @@ import           Xanthous.Entities.Environment
 
 instance Arbitrary SomeEntity where
   arbitrary = Gen.oneof
-    [ pure $ SomeEntity Character
+    [ SomeEntity <$> arbitrary @Character
     , pure $ SomeEntity Wall
     ]

src/Xanthous/Entities/Character.hs

@@ -1,23 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Character
   ( Character(..)
   , mkCharacter
+  , pickUpItem
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 import Test.QuickCheck
+import Test.QuickCheck.Instances.Vector ()
+import Test.QuickCheck.Arbitrary.Generic
 import Brick
 --------------------------------------------------------------------------------
 import Xanthous.Entities
+import Xanthous.Entities.Item
 --------------------------------------------------------------------------------
 
 data Character = Character
-  deriving stock (Show, Eq, Ord, Generic)
+  { _inventory :: !(Vector Item)
+  }
+  deriving stock (Show, Eq, Generic)
   deriving anyclass (CoArbitrary, Function)
+makeLenses ''Character
 
 scrollOffset :: Int
 scrollOffset = 5
 
--- deriving Draw via (DrawCharacter "@" Character)
 instance Draw Character where
   draw _ = visibleRegion rloc rreg $ str "@"
     where
@@ -28,7 +35,13 @@ instance Entity Character where
   blocksVision _ = False
 
 instance Arbitrary Character where
-  arbitrary = pure Character
+  arbitrary = genericArbitrary
 
 mkCharacter :: Character
 mkCharacter = Character
+  { _inventory = mempty
+  }
+
+pickUpItem :: Item -> Character -> Character
+pickUpItem item = inventory %~ (item <|)
+

src/Xanthous/Entities/Creature.hs

@@ -1,28 +1,33 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
--- |
+--------------------------------------------------------------------------------
-
+module Xanthous.Entities.Creature
-module Xanthous.Entities.Creature where
+  ( Creature(..)
-
+  , creatureType
-import Data.Word
+  , hitpoints
-
+  , newWithType
+  , damage
+  ) where
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Data.Word
+--------------------------------------------------------------------------------
 import Xanthous.Entities.RawTypes hiding (Creature)
-import Xanthous.Entities (Draw(..), Entity(..))
+import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
+--------------------------------------------------------------------------------
 
 data Creature = Creature
   { _creatureType :: CreatureType
   , _hitpoints :: Word16
   }
   deriving stock (Eq, Show, Generic)
+  deriving Draw via DrawRawChar "_creatureType" Creature
 makeLenses ''Creature
 
 instance Entity Creature where
   blocksVision _ = False
 
-instance Draw Creature where
-  draw = draw .view (creatureType . char)
-
 newWithType :: CreatureType -> Creature
 newWithType _creatureType =
   let _hitpoints = _creatureType ^. maxHitpoints

src/Xanthous/Entities/Item.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Entities.Item
+  ( Item(..)
+  , itemType
+  , newWithType
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Data.Aeson (ToJSON, FromJSON)
+import Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+import Xanthous.Entities.RawTypes hiding (Item)
+import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
+--------------------------------------------------------------------------------
+
+data Item = Item
+  { _itemType :: ItemType
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (CoArbitrary, Function)
+  deriving Draw via DrawRawChar "_itemType" Item
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Item
+makeLenses ''Item
+
+instance Arbitrary Item where
+  arbitrary = Item <$> arbitrary
+
+instance Entity Item where
+  blocksVision _ = False
+
+newWithType :: ItemType -> Item
+newWithType = Item

src/Xanthous/Entities/RawTypes.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Entities.RawTypes
   ( CreatureType(..)
   , ItemType(..)
@@ -9,19 +9,20 @@ module Xanthous.Entities.RawTypes
   , HasName(..)
   , HasDescription(..)
   , HasLongDescription(..)
-  , HasChar(..)
   , HasMaxHitpoints(..)
   , HasFriendly(..)
   , _Creature
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
 import Data.Aeson.Generic.DerivingVia
-import Data.Aeson (FromJSON)
+import Data.Aeson (ToJSON, FromJSON)
 import Data.Word
-
+--------------------------------------------------------------------------------
-import Xanthous.Entities (EntityChar)
+import Xanthous.Entities (EntityChar, HasChar(..))
-
+--------------------------------------------------------------------------------
 data CreatureType = CreatureType
   { _name :: Text
   , _description :: Text
@@ -35,7 +36,7 @@ data CreatureType = CreatureType
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        CreatureType
 makeFieldsNoPrefix ''CreatureType
-
+--------------------------------------------------------------------------------
 data ItemType = ItemType
   { _name :: Text
   , _description :: Text
@@ -43,12 +44,15 @@ data ItemType = ItemType
   , _char :: EntityChar
   }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData)
+  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving (FromJSON)
+  deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        ItemType
 makeFieldsNoPrefix ''ItemType
 
+instance Arbitrary ItemType where
+  arbitrary = genericArbitrary
+
 data EntityRaw
   = Creature CreatureType
   | Item ItemType

src/Xanthous/Entities/Raws.hs

@@ -1,17 +1,23 @@
 {-# LANGUAGE TemplateHaskell #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Entities.Raws
   ( raws
   , raw
+  , RawType(..)
+  , rawsWithType
+  , entityFromRaw
   ) where
-
+--------------------------------------------------------------------------------
 import           Data.FileEmbed
 import qualified Data.Yaml as Yaml
 import           Xanthous.Prelude
 import           System.FilePath.Posix
-
+--------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes
-
+import           Xanthous.Entities
+import qualified Xanthous.Entities.Creature as Creature
+import qualified Xanthous.Entities.Item as Item
+--------------------------------------------------------------------------------
 rawRaws :: [(FilePath, ByteString)]
 rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
 
@@ -26,3 +32,27 @@ raws
 
 raw :: Text -> Maybe EntityRaw
 raw n = raws ^. at n
+
+class RawType (a :: Type) where
+  _RawType :: Prism' EntityRaw a
+
+instance RawType CreatureType where
+  _RawType = prism' Creature $ \case
+    Creature c -> Just c
+    _ -> Nothing
+
+instance RawType ItemType where
+  _RawType = prism' Item $ \case
+    Item i -> Just i
+    _ -> Nothing
+
+rawsWithType :: forall a. RawType a => HashMap Text a
+rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws
+
+--------------------------------------------------------------------------------
+
+entityFromRaw :: EntityRaw -> SomeEntity
+entityFromRaw (Creature creatureType)
+  = SomeEntity $ Creature.newWithType creatureType
+entityFromRaw (Item itemType)
+  = SomeEntity $ Item.newWithType itemType

src/Xanthous/Entities/Raws/noodles.yaml

@@ -0,0 +1,8 @@
+Item:
+  name: noodles
+  description: a big bowl o' noodles
+  longDescription: You know exactly what kind of noodles
+  char:
+    char: 'n'
+    style:
+      foreground: yellow

src/Xanthous/Game.hs

@@ -5,7 +5,7 @@
 module Xanthous.Game
   ( GameState(..)
   , entities
-  , revealedEntities
+  , revealedPositions
   , messageHistory
   , randomGen
 
@@ -35,7 +35,6 @@ import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 import           Control.Monad.State.Class
 --------------------------------------------------------------------------------
-import           Xanthous.Util (appendVia)
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.EntityMap.Graphics
@@ -43,6 +42,7 @@ import           Xanthous.Data (Positioned, Position(..), positioned, position)
 import           Xanthous.Entities (SomeEntity(..), downcastEntity, entityIs)
 import           Xanthous.Entities.Character
 import           Xanthous.Entities.Creature
+import           Xanthous.Entities.Item
 import           Xanthous.Entities.Arbitrary ()
 import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
@@ -71,12 +71,11 @@ hideMessage NoMessageHistory = NoMessageHistory
 hideMessage (MessageHistory msgs _) = MessageHistory msgs False
 
 data GameState = GameState
-  { _entities          :: EntityMap SomeEntity
+  { _entities          :: !(EntityMap SomeEntity)
-    -- | A subset of the overall set of entities
+  , _revealedPositions :: !(Set Position)
-  , _revealedEntities  :: EntityMap SomeEntity
+  , _characterEntityID :: !EntityID
-  , _characterEntityID :: EntityID
+  , _messageHistory    :: !MessageHistory
-  , _messageHistory    :: MessageHistory
+  , _randomGen         :: !StdGen
-  , _randomGen         :: StdGen
   }
   deriving stock (Show)
 makeLenses ''GameState
@@ -84,7 +83,7 @@ makeLenses ''GameState
 instance Eq GameState where
   (==) = (==) `on` \gs ->
     ( gs ^. entities
-    , gs ^. revealedEntities
+    , gs ^. revealedPositions
     , gs ^. characterEntityID
     , gs ^. messageHistory
     )
@@ -96,11 +95,7 @@ instance Arbitrary GameState where
     _messageHistory <- arbitrary
     (_characterEntityID, _entities) <- arbitrary <&>
       EntityMap.insertAtReturningID charPos (SomeEntity char)
-    revealedPositions <- sublistOf $ EntityMap.positions _entities
+    _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
-    let _revealedEntities = mempty &~ do
-          for_ revealedPositions $ \pos -> do
-            let ents = _entities ^. EntityMap.atPosition pos
-            EntityMap.atPosition pos <>= ents
     _randomGen <- mkStdGen <$> arbitrary
     pure $ GameState {..}
 
@@ -114,7 +109,7 @@ getInitialState = do
           (SomeEntity char)
           mempty
       _messageHistory = NoMessageHistory
-      _revealedEntities = _entities
+      _revealedPositions = mempty
   pure GameState {..}
 
 positionedCharacter :: Lens' GameState (Positioned Character)
@@ -151,8 +146,8 @@ visionRadius = 12 -- TODO make this dynamic
 updateCharacterVision :: GameState -> GameState
 updateCharacterVision game =
   let charPos = game ^. characterPosition
-      visible = visibleEntities charPos visionRadius $ game ^. entities
+      visible = visiblePositions charPos visionRadius $ game ^. entities
-  in game & revealedEntities %~ appendVia EntityMap.Deduplicate visible
+  in game & revealedPositions <>~ visible
 
 
 --------------------------------------------------------------------------------
@@ -169,4 +164,5 @@ collisionAt pos = do
   pure $
     if | null ents -> Nothing
        | any (entityIs @Creature) ents -> pure Combat
+       | all (entityIs @Item) ents -> Nothing
        | otherwise -> pure Stop

src/Xanthous/Game/Draw.hs

@@ -17,7 +17,7 @@ import Xanthous.Entities
 import Xanthous.Game
   ( GameState(..)
   , entities
-  , revealedEntities
+  , revealedPositions
   , characterPosition
   , MessageHistory(..)
   , messageHistory
@@ -37,28 +37,34 @@ drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
 --   (MessageHistory (lastMessage :| _) True) -> txt lastMessage
 
 drawEntities
-  :: EntityMap SomeEntity -- ^ visible entities
+  :: Set Position
+    -- ^ Positions the character has seen
+    -- FIXME: this will break down as soon as creatures can walk around on their
+    -- own, since we don't want to render things walking around when the
+    -- character can't see them
   -> EntityMap SomeEntity -- ^ all entities
   -> Widget Name
-drawEntities em allEnts
+drawEntities visiblePositions allEnts
   = vBox rows
   where
-    entityPositions = EntityMap.positions em
+    entityPositions = EntityMap.positions allEnts
     maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
     maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
     rows = mkRow <$> [0..maxY]
     mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
-    renderEntityAt pos =
+    renderEntityAt pos
-      let neighbors = EntityMap.neighbors pos allEnts
+      | pos `member` visiblePositions
-      in maybe (str " ") (drawWithNeighbors neighbors)
+      = let neighbors = EntityMap.neighbors pos allEnts
-         $ em ^? atPosition pos . folded
+        in maybe (str " ") (drawWithNeighbors neighbors)
+           $ allEnts ^? atPosition pos . folded
+      | otherwise = str " "
 
 drawMap :: GameState -> Widget Name
 drawMap game
   = viewport MapViewport Both
   . showCursor Character (game ^. characterPosition . loc)
   $ drawEntities
-    (game ^. revealedEntities)
+    (game ^. revealedPositions)
     (game ^. entities)
 
 drawGame :: GameState -> [Widget Name]

src/Xanthous/Generators.hs

@@ -1,18 +1,35 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE TemplateHaskell #-}
 --------------------------------------------------------------------------------
-module Xanthous.Generators where
+module Xanthous.Generators
+  ( generate
+  , SGenerator(..)
+  , GeneratorInput
+  , generateFromInput
+  , parseGeneratorInput
+  , showCells
+  , Level(..)
+  , levelWalls
+  , levelItems
+  , levelCharacterPosition
+  , generateLevel
+  ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude
+import           Xanthous.Prelude hiding (Level)
 import           Data.Array.Unboxed
 import           System.Random (RandomGen)
 import qualified Options.Applicative as Opt
+import           Control.Monad.Random
 --------------------------------------------------------------------------------
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
 import           Xanthous.Generators.Util
+import           Xanthous.Generators.LevelContents
 import           Xanthous.Data (Dimensions, Position(Position))
 import           Xanthous.Data.EntityMap (EntityMap)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities.Environment
+import           Xanthous.Entities.Item
 --------------------------------------------------------------------------------
 
 data Generator = CaveAutomata
@@ -68,3 +85,21 @@ cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
         in EntityMap.insertAt (Position x' y') Wall em
     maybeInsertWall em _ = em
     surroundedOnAllSides pos = numAliveNeighbors cells pos == 8
+
+--------------------------------------------------------------------------------
+
+data Level = Level
+  { _levelWalls :: EntityMap Wall
+  , _levelItems :: EntityMap Item
+  , _levelCharacterPosition :: Position
+  }
+makeLenses ''Level
+
+generateLevel :: MonadRandom m => SGenerator gen -> Params gen -> Dimensions -> m Level
+generateLevel gen ps dims = do
+  rand <- mkStdGen <$> getRandom
+  let cells = generate gen ps dims rand
+      _levelWalls = cellsToWalls cells
+  _levelItems <- randomItems cells
+  _levelCharacterPosition <- chooseCharacterPosition cells
+  pure Level {..}

src/Xanthous/Generators/LevelContents.hs

@@ -1,21 +1,45 @@
 --------------------------------------------------------------------------------
 module Xanthous.Generators.LevelContents
   ( chooseCharacterPosition
+  , randomItems
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude
+import           Xanthous.Prelude
 --------------------------------------------------------------------------------
-import Control.Monad.Random
+import           Control.Monad.Random
-import Data.Array.IArray (amap)
+import           Data.Array.IArray (amap, bounds, rangeSize)
 --------------------------------------------------------------------------------
-import Xanthous.Generators.Util
+import           Xanthous.Generators.Util
-import Xanthous.Random
+import           Xanthous.Random
+import           Xanthous.Data (Position, positionFromPair)
+import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
+import           Xanthous.Entities.Item (Item(..))
+import           Xanthous.Entities.Raws
+import           Xanthous.Entities.RawTypes
+import qualified Xanthous.Entities.Item as Item
 --------------------------------------------------------------------------------
 
-chooseCharacterPosition :: MonadRandom m => Cells -> m (Word, Word)
+chooseCharacterPosition :: MonadRandom m => Cells -> m Position
-chooseCharacterPosition cells = choose $ impureNonNull candidates
+chooseCharacterPosition = randomPosition
+
+randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
+randomItems cells = do
+  let len = rangeSize $ bounds cells
+  (numItems :: Int) <- floor . (* fromIntegral len)
+                     <$> getRandomR @_ @Float (0.0004, 0.001)
+  items <- for [0..numItems] $ const do
+    pos <- randomPosition cells
+    itemType <- fmap (fromMaybe (error "no item raws!"))
+               . choose . ChooseElement
+               $ rawsWithType @ItemType
+    let item = Item.newWithType itemType
+    pure (pos, item)
+  pure $ _EntityMap # items
+
+randomPosition :: MonadRandom m => Cells -> m Position
+randomPosition cells = fmap positionFromPair . choose $ impureNonNull candidates
   where
-    -- cells ends up with true = wall, we want true = can put a character here
+    -- cells ends up with true = wall, we want true = can put an item here
     placeableCells = amap not cells
 
     -- find the largest contiguous region of cells in the cave.

src/Xanthous/Orphans.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
@@ -15,6 +16,7 @@ import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Text.Arbitrary ()
 import           Graphics.Vty.Attributes
 import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
 import           Text.Megaparsec (errorBundlePretty)
 import           Text.Megaparsec.Pos
 import           Text.Mustache
@@ -157,15 +159,15 @@ deriving anyclass instance NFData Template
 
 instance FromJSON Color where
   parseJSON = withText "Color" $ \case
-    "black" -> pure black
+    "black"   -> pure black
-    "red" -> pure red
+    "red"     -> pure red
-    "green" -> pure green
+    "green"   -> pure green
-    "yellow" -> pure yellow
+    "yellow"  -> pure yellow
-    "blue" -> pure blue
+    "blue"    -> pure blue
     "magenta" -> pure magenta
-    "cyan" -> pure cyan
+    "cyan"    -> pure cyan
-    "white" -> pure white
+    "white"   -> pure white
-    _       -> fail "Invalid color"
+    _         -> fail "Invalid color"
 
 instance ToJSON Color where
   toJSON color
@@ -180,6 +182,44 @@ instance ToJSON Color where
     | otherwise = error "unimplemented"
 
 instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
-  parseJSON Null = pure Default
+  parseJSON Null                   = pure Default
-  parseJSON x    = SetTo <$> parseJSON x
+  parseJSON (String "keepCurrent") = pure KeepCurrent
+  parseJSON x                      = SetTo <$> parseJSON x
 
+instance ToJSON a => ToJSON (MaybeDefault a) where
+  toJSON Default     = Null
+  toJSON KeepCurrent = String "keepCurrent"
+  toJSON (SetTo x)   = toJSON x
+
+--------------------------------------------------------------------------------
+
+instance Arbitrary Color where
+  arbitrary = genericArbitrary
+
+deriving anyclass instance CoArbitrary Color
+deriving anyclass instance Function Color
+
+instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where
+  arbitrary = oneof [ pure Default
+                    , pure KeepCurrent
+                    , SetTo <$> arbitrary
+                    ]
+
+instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
+  coarbitrary Default = variant @Int 1
+  coarbitrary KeepCurrent = variant @Int 2
+  coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x
+
+instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
+  function = functionShow
+
+instance Arbitrary Attr where
+  arbitrary = do
+    attrStyle <- arbitrary
+    attrForeColor <- arbitrary
+    attrBackColor <- arbitrary
+    attrURL <- arbitrary
+    pure Attr {..}
+
+deriving anyclass instance CoArbitrary Attr
+deriving anyclass instance Function Attr

src/Xanthous/messages.yaml

@@ -1 +1,4 @@
 welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
+items:
+  pickUp: You pick up the {{item.itemType.name}}
+  nothingToPickUp: There's nothing here to pick up

xanthous.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 86b7d3047b95fc65f4c6489a21e8c89883981c8c5bd552b5ea83aaf70de8a7cf
+-- hash: 78a45f3d5eb8c2993c219fd4214f61e9842177fa4d97667aeaedbfe3d0842165
 
 name:           xanthous
 version:        0.1.0.0
@@ -41,6 +41,7 @@ library
       Xanthous.Entities.Creature
       Xanthous.Entities.Draw.Util
       Xanthous.Entities.Environment
+      Xanthous.Entities.Item
       Xanthous.Entities.Raws
       Xanthous.Entities.RawTypes
       Xanthous.Game
@@ -79,6 +80,7 @@ library
     , file-embed
     , filepath
     , generic-arbitrary
+    , generic-lens
     , generic-monoid
     , groups
     , lens
@@ -111,6 +113,7 @@ executable xanthous
       Xanthous.Entities.Creature
       Xanthous.Entities.Draw.Util
       Xanthous.Entities.Environment
+      Xanthous.Entities.Item
       Xanthous.Entities.Raws
       Xanthous.Entities.RawTypes
       Xanthous.Game
@@ -148,6 +151,7 @@ executable xanthous
     , file-embed
     , filepath
     , generic-arbitrary
+    , generic-lens
     , generic-monoid
     , groups
     , lens
@@ -200,6 +204,7 @@ test-suite test
     , file-embed
     , filepath
     , generic-arbitrary
+    , generic-lens
     , generic-monoid
     , groups
     , lens