about summary refs log tree commit diff
path: root/users/aspen/xanthous/src/Xanthous/Entities/Environment.hs
blob: b45a91eabed2c6ff8bcadd8a36832470da8d452b (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Environment
  (
    -- * Walls
    Wall(..)

    -- * Doors
  , Door(..)
  , open
  , closed
  , locked
  , unlockedDoor

    -- * Messages
  , GroundMessage(..)

    -- * Stairs
  , Staircase(..)
  ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Test.QuickCheck
import Brick (str)
import Brick.Widgets.Border.Style (unicode)
import Brick.Types (Edges(..))
import Data.Aeson
import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
import Xanthous.Entities.Draw.Util
import Xanthous.Data
import Xanthous.Data.Entities
import Xanthous.Game.State
import Xanthous.Util.QuickCheck
--------------------------------------------------------------------------------

data Wall = Wall
  deriving stock (Show, Eq, Ord, Generic, Enum)
  deriving anyclass (NFData, CoArbitrary, Function)

instance ToJSON Wall where
  toJSON = const $ String "Wall"

instance FromJSON Wall where
  parseJSON = withText "Wall" $ \case
    "Wall" -> pure Wall
    _      -> fail "Invalid Wall: expected Wall"

instance Brain Wall where step = brainVia Brainless

instance Entity Wall where
  entityAttributes _ = defaultEntityAttributes
    & blocksVision .~ True
    & blocksObject .~ True
  description _ = "a wall"
  entityChar _ = "┼"

instance Arbitrary Wall where
  arbitrary = pure Wall

wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity)
          => Neighbors mono -> Edges Bool
wallEdges neighs = any (entityIs @Wall) <$> edges neighs

instance Draw Wall where
  drawWithNeighbors neighs _wall =
    str . pure . borderFromEdges unicode $ wallEdges neighs

data Door = Door
  { _open   :: Bool
  , _locked :: Bool
  }
  deriving stock (Show, Eq, Ord, Generic)
  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary Door
makeLenses ''Door

instance Draw Door where
  drawWithNeighbors neighs door
    = str . pure . ($ door ^. open) $ case wallEdges neighs of
        Edges True  False  False False -> vertDoor
        Edges False True   False False -> vertDoor
        Edges True  True   False False -> vertDoor
        Edges False False  True  False -> horizDoor
        Edges False False  False True  -> horizDoor
        Edges False False  True  True  -> horizDoor
        _                              -> allsidesDoor
    where
      horizDoor True = '␣'
      horizDoor False = 'ᚔ'
      vertDoor True = '['
      vertDoor False = 'ǂ'
      allsidesDoor True = '+'
      allsidesDoor False = '▥'

instance Brain Door where step = brainVia Brainless

instance Entity Door where
  entityAttributes door = defaultEntityAttributes
    & blocksVision .~ not (door ^. open)
  description door | door ^. open = "an open door"
                   | otherwise    = "a closed door"
  entityChar _ = "d"
  entityCollision door | door ^. open = Nothing
                       | otherwise = Just Stop

closed :: Lens' Door Bool
closed = open . involuted not

-- | A closed, unlocked door
unlockedDoor :: Door
unlockedDoor = Door
  { _open = False
  , _locked = False
  }

--------------------------------------------------------------------------------

newtype GroundMessage = GroundMessage Text
  deriving stock (Show, Eq, Ord, Generic)
  deriving anyclass (NFData, CoArbitrary, Function)
  deriving Arbitrary via GenericArbitrary GroundMessage
  deriving (ToJSON, FromJSON)
       via WithOptions '[ 'TagSingleConstructors 'True
                        , 'SumEnc 'ObjWithSingleField
                        ]
           GroundMessage
  deriving Draw
       via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
           GroundMessage
instance Brain GroundMessage where step = brainVia Brainless

instance Entity GroundMessage where
  description = const "a message on the ground. Press r. to read it."
  entityChar = const "≈"
  entityCollision = const Nothing

--------------------------------------------------------------------------------

data Staircase = UpStaircase | DownStaircase
  deriving stock (Show, Eq, Ord, Generic)
  deriving anyclass (NFData, CoArbitrary, Function)
  deriving Arbitrary via GenericArbitrary Staircase
  deriving (ToJSON, FromJSON)
       via WithOptions '[ 'TagSingleConstructors 'True
                        , 'SumEnc 'ObjWithSingleField
                        ]
           Staircase
instance Brain Staircase where step = brainVia Brainless

instance Draw Staircase where
  draw UpStaircase = str "<"
  draw DownStaircase = str ">"

instance Entity Staircase where
  description UpStaircase = "a staircase leading upwards"
  description DownStaircase = "a staircase leading downwards"
  entityChar UpStaircase = "<"
  entityChar DownStaircase = ">"
  entityCollision = const Nothing