├── .gitignore ├── LICENSE ├── README.md ├── manifest.yaml ├── package.yaml ├── rogue.cabal ├── src ├── Game.hs ├── Game │ └── TH.hs ├── Main.hs ├── Slack.hs └── Utils.hs ├── stack.yaml └── stack.yaml.lock /.gitignore: -------------------------------------------------------------------------------- 1 | shell.nix 2 | .hie/ 3 | .stack-work/ 4 | *.json 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2021 Hack Club 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | _⚠️ GitHub & Heroku have turned off their integration while investigating a [breach](https://github.blog/2022-04-15-security-alert-stolen-oauth-user-tokens/), so changes will not automatically deploy after pushing to `main`. If you have access to do so, please [push your changes to the `main` branch of the Heroku git remote](https://devcenter.heroku.com/articles/git) once your PR is merged. Otherwise, please mention it in the PR and assign [@cosmicoptima](https://github.com/cosmicoptima) for review._ 2 | 3 | _While wandering through a forest, you find the entrance to the..._ 4 | 5 | ![dungeon of the slack](https://cloud-9adijwjyk-hack-club-bot.vercel.app/0untitled_artwork_4.png) 6 | 7 | ## Dungeon of the Slack 8 | 9 | ...is a rogue-like dungeon arcade game built into the Hack Club Slack. 10 | 11 | members of the slack can join #slacking-in-the-dungeon to try it themselves. 12 | 13 | You can start a game in that channel by running `/rogue-start` 14 | 15 | The leaderboard will be posted at the end of each game. 16 | 17 | ## contribution 18 | 19 | The whole app is open source. See https://contribute.hackclub.com/#new-here for details on how to get started. 20 | 21 | ### colophon 22 | 23 | the app was built by @celeste 24 | 25 | thanks to [kenney](https://kenney.nl/assets/micro-roguelike) for the tileset 26 | 27 | the README art was contributed by @MaxWofford 28 | -------------------------------------------------------------------------------- /manifest.yaml: -------------------------------------------------------------------------------- 1 | display_information: 2 | name: dungeon of the slackers 3 | description: "HACK and slash your way in #dungeon-of-the-slack" 4 | background_color: "#363636" 5 | long_description: "what a dark dungeon. you wonder how far you'll make it...\r 6 | 7 | \r 8 | 9 | Head to #dungeon-of-the-slack and start a game with /rogue-start.\r 10 | 11 | \r 12 | 13 | Fully open-source! You can read the code/contribute at github.com/hackclub/rogue." 14 | features: 15 | bot_user: 16 | display_name: dungeon of the slackers 17 | always_online: true 18 | slash_commands: 19 | - command: /rogue-start 20 | description: start a new game 21 | should_escape: false 22 | oauth_config: 23 | scopes: 24 | bot: 25 | - channels:read 26 | - chat:write 27 | - groups:read 28 | - reactions:read 29 | - reactions:write 30 | - users:read 31 | - commands 32 | settings: 33 | event_subscriptions: 34 | bot_events: 35 | - member_joined_channel 36 | - reaction_added 37 | interactivity: 38 | is_enabled: true 39 | org_deploy_enabled: false 40 | socket_mode_enabled: true 41 | token_rotation_enabled: false 42 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: rogue 2 | ghc-options: -O2 -Wall -fno-warn-orphans 3 | dependencies: 4 | - base >= 4.14 && < 5 5 | - relude 6 | 7 | - websockets 8 | - wreq 9 | - wuss 10 | 11 | - aeson 12 | - aeson-pretty 13 | - apecs 14 | - astar 15 | - base64 16 | - containers 17 | - data-default 18 | - directory 19 | - fixed-vector 20 | - lens 21 | - megaparsec 22 | - MonadRandom 23 | - split 24 | - template-haskell 25 | - time 26 | - unliftio 27 | - vector 28 | executable: 29 | main: Main.hs 30 | source-dirs: src 31 | -------------------------------------------------------------------------------- /rogue.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.6. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: rogue 8 | version: 0.0.0 9 | license: MIT 10 | license-file: LICENSE 11 | build-type: Simple 12 | 13 | executable rogue 14 | main-is: Main.hs 15 | other-modules: 16 | Game 17 | Game.TH 18 | Slack 19 | Utils 20 | Paths_rogue 21 | hs-source-dirs: 22 | src 23 | ghc-options: -O2 -Wall -fno-warn-orphans 24 | build-depends: 25 | MonadRandom 26 | , aeson 27 | , aeson-pretty 28 | , apecs 29 | , astar 30 | , base >=4.14 && <5 31 | , base64 32 | , containers 33 | , data-default 34 | , directory 35 | , fixed-vector 36 | , lens 37 | , megaparsec 38 | , relude 39 | , split 40 | , template-haskell 41 | , time 42 | , unliftio 43 | , vector 44 | , websockets 45 | , wreq 46 | , wuss 47 | default-language: Haskell2010 48 | -------------------------------------------------------------------------------- /src/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NoImplicitPrelude #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | {-# LANGUAGE StrictData #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | 16 | module Game 17 | ( RogueM 18 | , TileGrid 19 | , Leaderboard(..) 20 | , LeaderboardEntry(..) 21 | , withLeaderboard 22 | , Command(..) 23 | , Message(..) 24 | , Tile(..) 25 | , Portal(..) 26 | , represent 27 | , populateWorld 28 | , leaderboardText 29 | , getLeaderboardInfo 30 | , step 31 | , runRogue 32 | ) where 33 | 34 | import Apecs hiding ( System ) 35 | import Apecs.Core hiding ( System ) 36 | import Apecs.Util 37 | import Relude hiding ( Map 38 | , Set 39 | , get 40 | , modify 41 | ) 42 | 43 | import Game.TH 44 | import Utils 45 | 46 | import qualified Control.Lens as L 47 | import Control.Monad.Random hiding ( fromList ) 48 | import Data.Default 49 | import Data.Graph.AStar 50 | import Data.List ( (!!) 51 | , union 52 | ) 53 | import Data.Time ( UTCTime 54 | , diffUTCTime 55 | , getCurrentTime 56 | , secondsToNominalDiffTime 57 | ) 58 | import qualified Data.Vector.Fixed as FVec 59 | import qualified Data.Vector.Unboxed as Vec 60 | 61 | 62 | -- components 63 | ------------- 64 | 65 | -- globals 66 | 67 | defComponent "Message" 68 | [("unMessage", mkType ''[] [''Text])] 69 | ''Global 70 | 71 | instance Semigroup Message where 72 | x <> y = Message $ unMessage x <> unMessage y 73 | instance Monoid Message where 74 | mempty = Message [] 75 | 76 | withMessage :: ([Text] -> [Text]) -> Message -> Message 77 | withMessage f = Message . f . unMessage 78 | 79 | data GameStage = Intro | MainGame | GameOver 80 | defComponent "InGameStage" 81 | [("_unGameStage", mkType ''GameStage [])] 82 | ''Global 83 | 84 | instance Semigroup InGameStage where 85 | InGameStage GameOver <> _ = InGameStage GameOver 86 | _ <> InGameStage GameOver = InGameStage GameOver 87 | InGameStage MainGame <> _ = InGameStage MainGame 88 | _ <> InGameStage MainGame = InGameStage MainGame 89 | _ <> _ = InGameStage Intro 90 | instance Monoid InGameStage where 91 | mempty = InGameStage Intro 92 | 93 | defComponent "TurnsElapsed" 94 | [("unTurnsElapsed", mkType ''Int [])] 95 | ''Global 96 | 97 | instance Semigroup TurnsElapsed where 98 | TurnsElapsed x <> TurnsElapsed y = TurnsElapsed (x + y) 99 | instance Monoid TurnsElapsed where 100 | mempty = TurnsElapsed 0 101 | 102 | withTurnsElapsed :: (Int -> Int) -> TurnsElapsed -> TurnsElapsed 103 | withTurnsElapsed f = TurnsElapsed . f . unTurnsElapsed 104 | 105 | defComponent "SecsElapsed" 106 | [("unSecsElapsed", mkType ''Int [])] 107 | ''Global 108 | 109 | instance Semigroup SecsElapsed where 110 | SecsElapsed x <> SecsElapsed y = SecsElapsed (x + y) 111 | instance Monoid SecsElapsed where 112 | mempty = SecsElapsed 0 113 | 114 | withSecsElapsed :: (Int -> Int) -> SecsElapsed -> SecsElapsed 115 | withSecsElapsed f = SecsElapsed . f . unSecsElapsed 116 | 117 | defComponent "Depth" 118 | [("unDepth", mkType ''Int [])] 119 | ''Global 120 | 121 | instance Semigroup Depth where 122 | Depth x <> Depth y = Depth (x + y) 123 | instance Monoid Depth where 124 | mempty = Depth 0 125 | 126 | withDepth :: (Int -> Int) -> Depth -> Depth 127 | withDepth f = Depth . f . unDepth 128 | 129 | -- abilities 130 | 131 | defComponent "CanMove" [] ''Map 132 | defComponent "HasHealth" 133 | [("unHealth", mkType ''Int [])] 134 | ''Map 135 | defComponent "HasLocation" 136 | [ ("posX", mkType ''Int []) 137 | , ("posY", mkType ''Int []) 138 | ] 139 | ''Map 140 | 141 | withHealth :: (Int -> Int) -> HasHealth -> HasHealth 142 | withHealth f = HasHealth . f . unHealth 143 | 144 | deriving instance Eq HasLocation 145 | 146 | -- terrain 147 | 148 | defComponent "IsDoor" [] ''Map 149 | defComponent "IsWall" [] ''Map 150 | 151 | -- objects 152 | 153 | data Portal = Blue | Orange deriving Eq 154 | defComponent "IsFire" [] ''Map 155 | defComponent "IsPortal" 156 | [("portalType", mkType ''Portal [])] 157 | ''Map 158 | defComponent "IsPotion" 159 | [("unPotion", mkType ''Int [])] 160 | ''Map 161 | 162 | -- staircase 163 | 164 | defComponent "IsStaircase" [] ''Map 165 | 166 | -- alive 167 | 168 | defComponent "IsEvil" [] ''Map 169 | defComponent "IsPlayer" [] ''Unique 170 | 171 | 172 | -- world 173 | -------- 174 | 175 | makeWorld "World" componentNames 176 | 177 | -- TODO rename the other RogueM, whose name is less fitting 178 | type RandIOM = RandT StdGen IO 179 | type RogueM = SystemT World RandIOM 180 | 181 | 182 | -- utilities 183 | ------------ 184 | 185 | -- component polymorphism 186 | 187 | type Gettable a = (Get World RandIOM a, Get World RogueM a) 188 | type Settable a = Set World RandIOM a 189 | type Memberable a = (Members World RandIOM a, Members World RogueM a) 190 | data ComponentBox = forall a . (Gettable a, Settable a, Memberable a) => C a 191 | data ProxyBox = forall a . (Gettable a, Settable a, Memberable a) => P ( Proxy 192 | a 193 | ) 194 | 195 | existsBoxed :: Entity -> ProxyBox -> RogueM Bool 196 | existsBoxed e (P (_ :: Proxy c)) = exists e (Proxy :: Proxy c) 197 | 198 | 199 | setBoxed :: Entity -> ComponentBox -> RogueM () 200 | setBoxed e (C c) = set e c 201 | 202 | mkEntity :: [ComponentBox] -> RogueM Entity 203 | mkEntity = (nextEntity >>=) . mkEntity' 204 | where 205 | mkEntity' (s : ss) e = setBoxed e s >> mkEntity' ss e 206 | mkEntity' [] e = pure e 207 | 208 | mkEntity_ :: [ComponentBox] -> RogueM () 209 | mkEntity_ = void . mkEntity 210 | 211 | 212 | -- members 213 | 214 | members :: Memberable c => Proxy c -> RogueM [Entity] 215 | members (_ :: Proxy c) = do 216 | storage :: Storage c <- getStore 217 | memberVec <- lift $ explMembers storage 218 | (pure . map Entity . Vec.toList) memberVec 219 | 220 | 221 | -- deletion 222 | 223 | mkDelete localComponentNames 224 | 225 | 226 | -- map 227 | 228 | type EntityGrid = Matrix (Maybe Entity) 229 | type TileGrid = Matrix (Maybe Tile) 230 | 231 | emptyMapE :: EntityGrid 232 | emptyMapE = (Matrix . FVec.replicate . FVec.replicate) Nothing 233 | 234 | emptyMapT :: TileGrid 235 | emptyMapT = (Matrix . FVec.replicate . FVec.replicate) Nothing 236 | 237 | maxCoord :: Int 238 | maxCoord = matrixSize - 1 239 | 240 | 241 | -- message 242 | 243 | appendMessage :: Text -> RogueM () 244 | appendMessage text = modify global $ withMessage (text :) 245 | 246 | 247 | -- location 248 | 249 | fromLocation :: HasLocation -> (Int, Int) 250 | fromLocation (HasLocation x y) = (x, y) 251 | 252 | entityExistsAt :: Int -> Int -> RogueM Bool 253 | entityExistsAt x y = 254 | cfold (\found comp -> found || fromLocation comp == (x, y)) False 255 | 256 | findEntityAt :: Gettable c => Int -> Int -> Proxy c -> RogueM (Maybe Entity) 257 | findEntityAt x y (_ :: Proxy c) = 258 | members (Proxy :: Proxy (HasLocation, c)) 259 | >>= mapM get 260 | <&> listToMaybe 261 | . mapMaybe 262 | (\(entity, HasLocation x' y') -> 263 | if x == x' && y == y' then Just entity else Nothing 264 | ) 265 | 266 | entityWithExistsAt :: Gettable c => Int -> Int -> Proxy c -> RogueM Bool 267 | entityWithExistsAt x y p = findEntityAt x y p <&> isJust 268 | 269 | wallExistsAt :: Int -> Int -> RogueM Bool 270 | wallExistsAt x y = 271 | cfold (\found (comp, IsWall) -> found || fromLocation comp == (x, y)) False 272 | 273 | randomCoord :: RogueM (Int, Int) 274 | randomCoord = do 275 | x <- lift $ getRandomR (0, maxCoord) 276 | y <- lift $ getRandomR (0, maxCoord) 277 | pure (x, y) 278 | 279 | randomCoordNoEdge :: RogueM (Int, Int) 280 | randomCoordNoEdge = do 281 | x <- lift $ getRandomR (1, maxCoord - 1) 282 | y <- lift $ getRandomR (1, maxCoord - 1) 283 | pure (x, y) 284 | 285 | mkEntityOnEmpty :: [ComponentBox] -> RogueM Entity 286 | mkEntityOnEmpty ss = do 287 | (x, y) <- randomCoord 288 | entityExistsAt x y >>= \occupied -> if occupied 289 | then mkEntityOnEmpty ss 290 | else mkEntity $ C (HasLocation x y) : ss 291 | 292 | mkEntityOnEmpty_ :: [ComponentBox] -> RogueM () 293 | mkEntityOnEmpty_ ss = do 294 | (x, y) <- randomCoord 295 | entityExistsAt x y >>= \occupied -> if occupied 296 | then mkEntityOnEmpty_ ss 297 | else mkEntity_ $ C (HasLocation x y) : ss 298 | 299 | 300 | -- difficulty 301 | ------------- 302 | 303 | getDifficulty :: RogueM Double 304 | getDifficulty = get global <&> \(SecsElapsed secs, Depth depth) -> 305 | (fromIntegral secs * (fromIntegral depth + 2)) ** 0.7 + 100 306 | 307 | 308 | -- comp gen 309 | ----------- 310 | 311 | randomItemComponents :: RogueM [ComponentBox] 312 | randomItemComponents = do 313 | regenAmount <- lift $ getRandomR (3, 7) 314 | difficulty <- getDifficulty 315 | randomIO <&> \n -> 316 | if n > (difficulty / 300) then [C $ IsPotion regenAmount] else [C IsFire] 317 | 318 | 319 | -- commands 320 | ----------- 321 | 322 | newtype Leaderboard = Leaderboard 323 | { unLeaderboard :: [LeaderboardEntry] 324 | } deriving Eq 325 | 326 | data LeaderboardEntry = LeaderboardEntry 327 | { leName :: Text 328 | , leTime :: UTCTime 329 | , leDepth :: Int 330 | , leSecs :: Int 331 | } 332 | deriving Eq 333 | 334 | withLeaderboard 335 | :: ([LeaderboardEntry] -> [LeaderboardEntry]) -> Leaderboard -> Leaderboard 336 | withLeaderboard f (Leaderboard entries) = Leaderboard (f entries) 337 | 338 | -- `IncrementTimer` is not really a command, 339 | -- but indicates that most systems shouldn't run 340 | data Command = IncrementTimer 341 | | DisplayLeaderboard Leaderboard 342 | | Noop 343 | | Move (Int, Int) 344 | | Drink 345 | | Die 346 | deriving Eq 347 | 348 | 349 | -- initialization 350 | ----------------- 351 | 352 | mkWalls :: RogueM () 353 | mkWalls = mkWalls' 25 where 354 | mkWalls' :: Int -> RogueM () 355 | mkWalls' 0 = return () 356 | mkWalls' n = do 357 | (x, y) <- randomCoordNoEdge 358 | 359 | let 360 | pos1 = if even n then posX else posY 361 | dim1 = if even n then x else y 362 | pos2 = if even n then posY else posX 363 | dim2 = if even n then y else x 364 | 365 | adjEntityLocs :: RogueM [HasLocation] 366 | adjEntityLocs = cfold 367 | (\ls loc -> if abs (pos2 loc - dim2) < 3 && pos1 loc - dim1 == 0 368 | then loc : ls 369 | else ls 370 | ) 371 | [] 372 | 373 | constrainWalls isMin = 374 | (\case 375 | [] -> pure $ if isMin then Just 0 else Just (matrixSize - 1) 376 | (e, loc) : _ -> 377 | existsBoxed e (P (Proxy :: Proxy IsDoor)) 378 | ||^ existsBoxed e (P (Proxy :: Proxy IsPlayer)) 379 | >>= \blocked -> pure $ if blocked 380 | then Nothing 381 | else (Just . (if isMin then safeInc else safeDec) . pos1) 382 | loc 383 | ) 384 | . (if isMin then reverse else id) 385 | . sortOn (pos1 . snd) 386 | . filter ((if isMin then (>=) else (<=)) dim1 . pos1 . snd) 387 | . filter ((== dim2) . pos2 . snd) 388 | <=< mapM get 389 | 390 | safeInc n' = if n' == matrixSize - 1 then n' else succ n' 391 | safeDec n' = if n' == 0 then n' else pred n' 392 | 393 | entities <- members (Proxy :: Proxy HasLocation) 394 | dimRanges <- sequence 395 | [ constrainWalls isMin entities | isMin <- [True, False] ] 396 | 397 | valid <- null <$> adjEntityLocs 398 | if valid 399 | then case dimRanges of 400 | [Just min', Just max'] -> do 401 | newWalls <- sequence $ if even n 402 | then 403 | [ mkEntity [C (HasLocation x' y), C IsWall] 404 | | x' <- [min' .. max'] 405 | ] 406 | else 407 | [ mkEntity [C (HasLocation x y'), C IsWall] 408 | | y' <- [min' .. max'] 409 | ] 410 | doorPos <- lift $ getRandomR (0, length newWalls - 1) 411 | set (newWalls !! doorPos) (Not :: Not IsWall, IsDoor) 412 | mkWalls' (n + 1) 413 | _ -> mkWalls' (n - 1) 414 | else mkWalls' (n - 1) 415 | 416 | populateWorld :: Maybe Entity -> RogueM () 417 | populateWorld existingPlayer = do 418 | (staircase, player) <- populateWorld' 419 | HasLocation sx sy <- get staircase 420 | HasLocation px py <- get player 421 | 422 | minPathLength <- getDifficulty <&> round . (/ 20) 423 | maxPathLength <- getDifficulty <&> round . (/ 10) 424 | 425 | pathfind (px, py) (sx, sy) >>= \case 426 | Nothing -> tryAgain 427 | Just path -> unless 428 | (length path > minPathLength && length path < maxPathLength) 429 | tryAgain 430 | 431 | -- i'm evil and horrible 432 | entities <- members (Proxy :: Proxy HasLocation) 433 | forM_ entities 434 | $ (\entity -> 435 | represent entity >>= \repr -> when (repr == ErrorTile) (delete entity) 436 | ) 437 | where 438 | populateWorld' = do 439 | difficulty <- getDifficulty 440 | enemyCount <- (+ floor (difficulty / 120)) <$> lift (getRandomR (1, 4)) 441 | itemCount <- (+ floor (difficulty / 100)) <$> lift (getRandomR (1, 4)) 442 | 443 | mkWalls 444 | replicateM_ enemyCount 445 | $ mkEntityOnEmpty_ [C CanMove, C (HasHealth 3), C IsEvil] 446 | replicateM_ itemCount $ randomItemComponents >>= mkEntityOnEmpty_ 447 | forM_ [C (IsPortal Blue), C (IsPortal Orange)] $ mkEntityOnEmpty_ . (: []) 448 | staircase <- mkEntityOnEmpty [C IsStaircase] 449 | player <- case existingPlayer of 450 | Just player -> pure player 451 | Nothing -> mkEntityOnEmpty [C CanMove, C (HasHealth 10), C IsPlayer] 452 | 453 | pure (staircase, player) 454 | 455 | tryAgain = do 456 | cmapM_ $ \(HasLocation _ _, Not :: Not IsPlayer, entity) -> delete entity 457 | populateWorld existingPlayer 458 | 459 | 460 | -- movement 461 | ----------- 462 | 463 | getNeighbors :: (Int, Int) -> RogueM (HashSet (Int, Int)) 464 | getNeighbors (x, y) = 465 | fmap fromList 466 | . filterM (fmap not . uncurry wallExistsAt) 467 | . filter 468 | (\(x', y') -> x' >= 0 && x' < matrixSize && y' >= 0 && y' < matrixSize) 469 | $ [(x, y - 1), (x + 1, y), (x, y + 1), (x - 1, y)] 470 | 471 | portalReplace :: (Int, Int) -> RogueM (Int, Int) 472 | portalReplace (x, y) = do 473 | portalHere <- cfold 474 | (\acc (HasLocation x' y', IsPortal p) -> 475 | if (x, y) == (x', y') then Just p else acc 476 | ) 477 | Nothing 478 | case portalHere of 479 | Just Blue -> 480 | cfold 481 | (\acc (HasLocation x' y', IsPortal p) -> 482 | if p == Orange then Just (x', y') else acc 483 | ) 484 | Nothing 485 | <&> fromMaybe (x, y) 486 | Just Orange -> 487 | cfold 488 | (\acc (HasLocation x' y', IsPortal p) -> 489 | if p == Blue then Just (x', y') else acc 490 | ) 491 | Nothing 492 | <&> fromMaybe (x, y) 493 | Nothing -> pure (x, y) 494 | 495 | getNeighborsPortal :: (Int, Int) -> RogueM (HashSet (Int, Int)) 496 | getNeighborsPortal = 497 | getNeighbors >=> mapM portalReplace . toList >=> pure . fromList 498 | 499 | -- TODO account for portals in pathfinding 500 | pathfind :: (Int, Int) -> (Int, Int) -> RogueM (Maybe [(Int, Int)]) 501 | pathfind begin dest = aStarM getNeighbors 502 | (\_ _ -> pure (1 :: Int)) 503 | (const $ pure 1) 504 | (pure . (== dest)) 505 | (pure begin) 506 | 507 | -- also handles combat 508 | moveTo :: Entity -> Int -> Int -> RogueM () 509 | moveTo entity destX destY = do 510 | HasLocation curX curY <- get entity 511 | getNeighbors (curX, curY) 512 | >>= flip when attackOrMove 513 | . ((destX, destY) `elem`) 514 | . toList 515 | where 516 | attackOrMove = do 517 | (destX', destY') <- portalReplace (destX, destY) 518 | findEntityAt destX destY (Proxy :: Proxy HasHealth) >>= maybe 519 | (set entity $ HasLocation destX' destY') 520 | (flip modify $ withHealth pred) 521 | 522 | 523 | -- tiles 524 | -------- 525 | 526 | data Tile = WallTile 527 | | DoorTile 528 | | EvilTile 529 | | FireTile 530 | | PotionTile 531 | | PortalTile Portal 532 | | StaircaseTile 533 | | PlayerTile 534 | | ErrorTile 535 | deriving Eq 536 | 537 | 538 | -- systems 539 | ---------- 540 | 541 | data System = System 542 | { qualifier :: [ProxyBox] 543 | , action :: Command -> Entity -> RogueM () 544 | , transRepr :: Entity -> Tile -> RogueM Tile 545 | , transName :: Entity -> Text -> RogueM Text 546 | , forbidIncTimer :: Bool 547 | } 548 | 549 | instance Default System where 550 | def = System { qualifier = [] 551 | , action = \_ _ -> pure () 552 | , transRepr = const pure 553 | , transName = const pure 554 | , forbidIncTimer = True 555 | } 556 | 557 | qualified :: Entity -> [ProxyBox] -> RogueM Bool 558 | qualified = allM . existsBoxed 559 | 560 | 561 | trivialRender :: ProxyBox -> Tile -> Text -> System 562 | trivialRender comp tile name' = def { qualifier = [comp] 563 | , transRepr = \_ _ -> pure tile 564 | , transName = \_ _ -> pure name' 565 | } 566 | 567 | moveEvil :: System 568 | moveEvil = def 569 | { qualifier = [$(pb "HasLocation"), $(pb "CanMove"), $(pb "IsEvil")] 570 | , action = \_ e -> do 571 | HasLocation evilX evilY <- get e 572 | playerLoc <- cfold (\_ (loc, IsPlayer) -> Just loc) Nothing 573 | case playerLoc of 574 | Just (HasLocation playerX playerY) -> do 575 | path <- pathfind (evilX, evilY) (playerX, playerY) 576 | maybe (pure ()) (uncurry $ moveTo e) 577 | . (listToMaybe =<<) 578 | $ path 579 | Nothing -> pure () 580 | } 581 | 582 | -- TODO perhaps generalize? 583 | drinkPotion :: System 584 | drinkPotion = def 585 | { qualifier = [$(pb "IsPlayer")] 586 | , action = \c e -> case c of 587 | Drink -> get e >>= \(HasLocation x y) -> 588 | findEntityAt x y (Proxy :: Proxy IsPotion) >>= maybe 589 | (pure ()) 590 | (\e' -> do 591 | get e' >>= modify e . withHealth . (+) . unPotion 592 | delete e' 593 | appendMessage "you feel rejuvenated..." 594 | ) 595 | _ -> pure () 596 | } 597 | 598 | spreadFire :: System 599 | spreadFire = def 600 | { qualifier = [$(pb "IsFire")] 601 | , action = \_ e -> do 602 | neighbors <- get e >>= getNeighborsPortal . fromLocation 603 | forM_ neighbors $ \(x, y) -> do 604 | spreadTo <- (lift getRandom :: RogueM Double) <&> (< 0.05) 605 | fireAt <- cfold 606 | (\found (HasLocation x' y', IsFire) -> found || (x, y) == (x', y')) 607 | False 608 | when (spreadTo && not fireAt) $ mkEntity_ [C (HasLocation x y), C IsFire] 609 | } 610 | 611 | takeFireDamage :: System 612 | takeFireDamage = def 613 | { qualifier = [$(pb "HasHealth")] 614 | , action = \_ e -> do 615 | HasLocation x y <- get e 616 | onFire <- cfold 617 | (\found (HasLocation fireX fireY, IsFire) -> 618 | found || (fireX, fireY) == (x, y) 619 | ) 620 | False 621 | when onFire $ do 622 | modify e (withHealth pred) 623 | name e >>= appendMessage . (<> " burns...") 624 | } 625 | 626 | descendStaircase :: System 627 | descendStaircase = def 628 | { qualifier = [$(pb "HasLocation"), $(pb "IsPlayer")] 629 | , action = \_ e -> get e >>= \(HasLocation x y) -> 630 | whenM (entityWithExistsAt x y (Proxy :: Proxy IsStaircase)) $ do 631 | modify global $ withDepth succ 632 | cmapM_ $ \(HasLocation _ _, entity, Not :: Not IsPlayer) -> delete entity 633 | populateWorld (Just e) 634 | } 635 | 636 | systems :: [System] 637 | systems = 638 | [ -- rendering and naming 639 | trivialRender $(pb "IsWall") WallTile "a wall" 640 | , trivialRender $(pb "IsDoor") DoorTile "a door" 641 | , trivialRender $(pb "IsEvil") EvilTile "a rat" 642 | , trivialRender $(pb "IsFire") FireTile "fire" 643 | , trivialRender $(pb "IsPotion") PotionTile "a potion" 644 | , def { qualifier = [$(pb "IsPortal")] 645 | , transRepr = \e _ -> get e <&> PortalTile . portalType 646 | , transName = \_ _ -> pure "a portal" 647 | } 648 | , trivialRender $(pb "IsStaircase") StaircaseTile "a staircase" 649 | , trivialRender $(pb "IsPlayer") PlayerTile "the player" 650 | -- active 651 | , def 652 | { qualifier = [$(pb "HasHealth"), $(pb "IsPlayer")] 653 | , action = \c e -> case c of 654 | Die -> set e $ HasHealth 0 655 | _ -> pure () 656 | } 657 | , def 658 | { qualifier = [$(pb "HasLocation"), $(pb "CanMove"), $(pb "IsPlayer")] 659 | , action = \c e -> case c of 660 | Move (x, y) -> do 661 | HasLocation x' y' <- get e 662 | moveTo e (x + x') (y + y') 663 | _ -> pure () 664 | } 665 | , moveEvil 666 | , drinkPotion 667 | -- passive 668 | , spreadFire 669 | , takeFireDamage 670 | , def 671 | { qualifier = [$(pb "HasHealth")] 672 | , action = \_ e -> get e >>= \(HasHealth x) -> when (x <= 0) $ do 673 | name e >>= appendMessage . (<> " has died!") 674 | whenM (exists e (Proxy :: Proxy IsPlayer)) $ do 675 | get global >>= \(Depth n) -> 676 | appendMessage ("you survived to depth " <> show n <> ".") 677 | set global $ InGameStage GameOver 678 | delete e 679 | } 680 | -- message 681 | , def 682 | { qualifier = [$(pb "HasHealth"), $(pb "IsPlayer")] 683 | , action = \_ e -> get e >>= \(HasHealth hp, Depth d) -> appendMessage 684 | ("you have " <> show hp <> " hp (depth " <> show d <> ")") 685 | } 686 | -- descension 687 | , descendStaircase 688 | ] 689 | 690 | 691 | -- global systems 692 | ----------------- 693 | 694 | clearMessage :: Command -> RogueM () 695 | clearMessage command = case command of 696 | IncrementTimer -> pure () 697 | _ -> set global $ Message ["..."] 698 | 699 | displayIntro :: Command -> RogueM () 700 | displayIntro _ = get global >>= \case 701 | (InGameStage Intro, TurnsElapsed 2) -> do 702 | appendMessage "you enter the dungeon..." 703 | populateWorld Nothing 704 | set global $ InGameStage MainGame 705 | (InGameStage Intro, _) -> set global $ Message [introMessage] 706 | _ -> pure () 707 | where 708 | introMessage 709 | = "welcome to dungeon of the slack\n\n\ 710 | \react with :tw_arrow_up::tw_arrow_right::tw_arrow_down::tw_arrow_left: to move\n\ 711 | \react with :tw_hourglass: to wait\n\ 712 | \react with :tw_tea: to drink a potion\n\ 713 | \react with :tw_skull: to die instantly\n\n\ 714 | \move quickly; you will find that the dungeon becomes less forgiving as time progresses" 715 | 716 | incrementTurns :: Command -> RogueM () 717 | incrementTurns command = 718 | unless (command == IncrementTimer) $ modify global $ withTurnsElapsed succ 719 | 720 | globalSystemsPre :: [Command -> RogueM ()] 721 | globalSystemsPre = [clearMessage, displayIntro, incrementTurns] 722 | 723 | 724 | displayLeaderboard :: Command -> RogueM () 725 | displayLeaderboard = \case 726 | DisplayLeaderboard leaderboard -> do 727 | displayed <- liftIO (leaderboardText leaderboard) 728 | appendMessage displayed 729 | _ -> pure () 730 | 731 | incrementSecs :: Command -> RogueM () 732 | incrementSecs = \case 733 | IncrementTimer -> get global >>= \case 734 | InGameStage MainGame -> modify global $ withSecsElapsed succ 735 | _ -> pure () 736 | _ -> pure () 737 | 738 | displaySecs :: Command -> RogueM () 739 | displaySecs _ = do 740 | (InGameStage stage, SecsElapsed secs) <- get global 741 | case stage of 742 | MainGame -> modify global . withMessage $ L.set 743 | (L.ix 0) 744 | ((<> " seconds...") . show $ secs) 745 | _ -> pure () 746 | 747 | reverseMessage :: Command -> RogueM () 748 | reverseMessage command = case command of 749 | IncrementTimer -> pure () 750 | _ -> modify global $ withMessage reverse 751 | 752 | globalSystemsPost :: [Command -> RogueM ()] 753 | globalSystemsPost = 754 | [displayLeaderboard, reverseMessage, incrementSecs, displaySecs] 755 | 756 | 757 | -- run 758 | ------- 759 | 760 | build :: (System -> Entity -> a -> RogueM a) -> a -> Entity -> RogueM a 761 | build f d entity = foldl' 762 | (>=>) 763 | (const $ pure d) 764 | (map (\s -> whenQualified s . (entity &) . f $ s) systems) 765 | entity 766 | where 767 | whenQualified system m tile = qualified entity (qualifier system) 768 | >>= \qual -> (if qual then m else pure) tile 769 | 770 | represent :: Entity -> RogueM Tile 771 | represent = build transRepr ErrorTile 772 | 773 | name :: Entity -> RogueM Text 774 | name = build transName "something" 775 | 776 | 777 | -- lmfao 778 | compareEntities :: Entity -> Entity -> RogueM Ordering 779 | compareEntities e1 e2 = do 780 | e1player <- exists e1 (Proxy :: Proxy IsPlayer) 781 | e2player <- exists e2 (Proxy :: Proxy IsPlayer) 782 | e1evil <- exists e1 (Proxy :: Proxy IsEvil) 783 | e2evil <- exists e2 (Proxy :: Proxy IsEvil) 784 | e1staircase <- exists e1 (Proxy :: Proxy IsStaircase) 785 | e2staircase <- exists e2 (Proxy :: Proxy IsStaircase) 786 | 787 | case (e1player, e2player, e1evil, e2evil, e1staircase, e2staircase) of 788 | (True, False, _, _, _, _) -> pure GT 789 | (False, True, _, _, _, _) -> pure LT 790 | (_, _, True, False, _, _) -> pure GT 791 | (_, _, False, True, _, _) -> pure LT 792 | (_, _, _, _, True, False) -> pure GT 793 | (_, _, _, _, False, True) -> pure LT 794 | _ -> pure EQ 795 | 796 | getGrid :: RogueM TileGrid 797 | getGrid = get global >>= \case 798 | InGameStage Intro -> pure $ compose 799 | [ mset x y (Just ErrorTile) 800 | | x <- [0 .. matrixSize] 801 | , y <- [0 .. matrixSize] 802 | ] 803 | emptyMapT 804 | InGameStage _ -> 805 | members (Proxy :: Proxy HasLocation) 806 | >>= mapM get 807 | >>= foldlM go emptyMapE 808 | >>= mapM (maybe (pure Nothing) (represent >=> pure . Just)) 809 | where 810 | go grid (entity, entityLoc) = do 811 | comparison <- case mget (posX entityLoc) (posY entityLoc) grid of 812 | Just existingEntity -> compareEntities entity existingEntity 813 | Nothing -> pure GT 814 | case comparison of 815 | LT -> pure grid 816 | _ -> pure $ mset (posX entityLoc) (posY entityLoc) (Just entity) grid 817 | 818 | executeStep :: Command -> RogueM () 819 | executeStep command = do 820 | forM_ globalSystemsPre (\f -> f command) 821 | SecsElapsed secs <- get global 822 | let realTimeStep = secs >= 180 && even secs 823 | forM_ 824 | systems 825 | (\s -> 826 | unless (forbidIncTimer s && command == IncrementTimer && not realTimeStep) 827 | $ do 828 | members' <- mapM (\(P (_ :: p)) -> members (Proxy :: p)) 829 | (qualifier s) 830 | mapM_ 831 | (\e -> whenM (qualified e (qualifier s)) $ action s command e) 832 | (foldl' union [] members') 833 | ) 834 | forM_ globalSystemsPost (\f -> f command) 835 | 836 | leaderboardText :: Leaderboard -> IO Text 837 | leaderboardText (Leaderboard entries) = do 838 | currentTime <- liftIO getCurrentTime 839 | let oneWeek = secondsToNominalDiffTime 604800 840 | pure 841 | $ "leaderboard:\n" 842 | <> ( unlines 843 | . map displayEntry 844 | . take 10 845 | . sortOn (\e -> Down (leDepth e, leSecs e)) 846 | . filter ((< oneWeek) . diffUTCTime currentTime . leTime) 847 | ) 848 | entries 849 | where 850 | displayEntry LeaderboardEntry {..} = 851 | leName <> ": depth " <> show leDepth <> ", " <> show leSecs <> " secs" 852 | 853 | getLeaderboardInfo :: RogueM (Int, Int) 854 | getLeaderboardInfo = do 855 | (Depth depth, SecsElapsed secs) <- get global 856 | pure (depth, secs) 857 | 858 | step 859 | :: Command 860 | -> (TileGrid -> RogueM a) 861 | -> (Message -> RogueM b) 862 | -> RogueM (a, b, Bool) 863 | step command renderGrid renderMessage = do 864 | executeStep command 865 | grid <- getGrid >>= renderGrid 866 | message <- get global >>= renderMessage 867 | gameOver <- get global >>= \case 868 | InGameStage GameOver -> pure True 869 | _ -> pure False 870 | pure (grid, message, gameOver) 871 | 872 | runRogue :: RogueM a -> IO a 873 | runRogue f = do 874 | rng <- newStdGen 875 | world <- initWorld 876 | runRandT (runSystem f world) rng <&> fst 877 | -------------------------------------------------------------------------------- /src/Game/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | -- legally this has to be in a different module 6 | 7 | module Game.TH 8 | ( defComponent 9 | , mkType 10 | , localComponentNames 11 | , componentNames 12 | , mkDelete 13 | , mkListComponents 14 | , pb 15 | ) where 16 | 17 | import Apecs 18 | import Relude hiding ( Type ) 19 | 20 | import Language.Haskell.TH 21 | 22 | 23 | defComponent :: Text -> [(Text, Type)] -> Name -> Q [Dec] 24 | defComponent name args storage = do 25 | instance' <- [d| 26 | instance Component $component where 27 | type Storage $component = $storage' $component 28 | |] 29 | return (data' : instance') 30 | where 31 | mkName' = mkName . toString 32 | 33 | name' = mkName' name 34 | data' = DataD [] name' [] Nothing [RecC name' (noBang args)] [] 35 | component = conT name' 36 | storage' = conT storage 37 | 38 | noBang = map (\(n, t) -> (mkName' n, Bang NoSourceUnpackedness NoSourceStrictness, t)) 39 | 40 | mkType :: Name -> [Name] -> Type 41 | mkType = mkType' . ConT where 42 | mkType' type' [] = type' 43 | mkType' type' (a : as) = mkType' (AppT type' $ ConT a) as 44 | 45 | 46 | localComponentNames :: [Name] 47 | localComponentNames = 48 | [ mkName "CanMove" 49 | , mkName "HasHealth" 50 | , mkName "HasLocation" 51 | , mkName "IsDoor" 52 | , mkName "IsWall" 53 | , mkName "IsFire" 54 | , mkName "IsPortal" 55 | , mkName "IsPotion" 56 | , mkName "IsStaircase" 57 | , mkName "IsEvil" 58 | , mkName "IsPlayer" 59 | ] 60 | 61 | componentNames :: [Name] 62 | componentNames = 63 | [ mkName "Message" 64 | , mkName "InGameStage" 65 | , mkName "TurnsElapsed" 66 | , mkName "SecsElapsed" 67 | , mkName "Depth" 68 | ] 69 | <> localComponentNames 70 | 71 | mkDelete :: [Name] -> Q [Dec] 72 | mkDelete compNames = (: []) <$> do 73 | let comps = map conT compNames 74 | stmts = map (\c -> noBindS 75 | [e| 76 | whenM (exists entity (Proxy :: Proxy $c)) $ 77 | destroy entity (Proxy :: Proxy $c) 78 | |] 79 | ) comps 80 | funD (mkName "delete") 81 | [clause [varP $ mkName "entity"] (normalB $ doE stmts) []] 82 | 83 | -- FOR DEBUGGING 84 | mkListComponents :: Q [Dec] 85 | mkListComponents = (: []) <$> do 86 | let comps = map (\c -> (conT c, (litE . stringL . nameBase) c)) localComponentNames 87 | stmts = map (\(ct, cn) -> noBindS 88 | [e| 89 | whenM (exists entity (Proxy :: Proxy $ct)) $ 90 | liftIO $ putStrLn ("Component " <> $cn) 91 | |] 92 | ) comps 93 | funD (mkName "listComponents") [clause [varP $ mkName "entity"] (normalB $ doE stmts) []] 94 | 95 | 96 | pb :: String -> Q Exp 97 | pb name = appE (conE $ mkName "P") $ sigE 98 | (conE $ mkName "Proxy") 99 | (appT (conT $ mkName "Proxy") (conT $ mkName name)) 100 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Main 9 | ( main 10 | ) where 11 | 12 | import Relude 13 | 14 | import Game 15 | import Slack 16 | import Utils 17 | 18 | import Data.Aeson ( FromJSON 19 | , ToJSON 20 | , decodeStrict 21 | , encodeFile 22 | ) 23 | import System.Directory ( doesFileExist ) 24 | 25 | import Network.Wreq.Session ( Session ) 26 | import qualified Network.Wreq.Session as S 27 | 28 | import UnliftIO.Async 29 | import UnliftIO.Concurrent ( threadDelay ) 30 | 31 | import Control.Concurrent.Chan 32 | import Data.List.Split ( chunksOf ) 33 | import qualified Data.Map as Map 34 | import Data.Maybe ( fromJust ) 35 | import Data.Time ( getCurrentTime ) 36 | import System.Environment ( lookupEnv ) 37 | 38 | 39 | data Context = Context 40 | { ctxSession :: Session 41 | , ctxAPIToken :: Text 42 | , ctxWSToken :: Text 43 | , ctxChannelID :: Text 44 | , ctxLeaderboardFile :: Text 45 | } 46 | 47 | type AppM = ReaderT Context IO 48 | type GameM = ReaderT Context RogueM 49 | 50 | 51 | deriving instance Generic LeaderboardEntry 52 | deriving instance Generic Leaderboard 53 | 54 | instance FromJSON LeaderboardEntry 55 | instance ToJSON LeaderboardEntry 56 | 57 | instance FromJSON Leaderboard 58 | instance ToJSON Leaderboard 59 | 60 | 61 | -- user id hardcoded for convenience. sorry! 62 | rogueUserId :: Text 63 | rogueUserId = "U02MTTW1XND" 64 | 65 | addReacts :: Text -> GameM () 66 | addReacts timestamp = do 67 | Context { ctxSession = session, ctxAPIToken = token, ctxChannelID = channelID } <- 68 | ask 69 | void . liftIO . async $ mapM_ 70 | (reactToMessage session token channelID timestamp) 71 | [ "tw_hourglass" 72 | , "tw_arrow_up" 73 | , "tw_arrow_right" 74 | , "tw_arrow_down" 75 | , "tw_arrow_left" 76 | , "tw_tea" 77 | , "tw_skull" 78 | ] 79 | 80 | fromReact :: Text -> Command 81 | fromReact = \case 82 | "tw_hourglass" -> Noop 83 | "tw_arrow_up" -> Move (0, -1) 84 | "tw_arrow_right" -> Move (1, 0) 85 | "tw_arrow_down" -> Move (0, 1) 86 | "tw_arrow_left" -> Move (-1, 0) 87 | "tw_tea" -> Drink 88 | "tw_skull" -> Die 89 | _ -> Noop 90 | 91 | -- renderGrid is a mess! i'm quite aware 92 | renderGrid :: TileGrid -> RogueM Text 93 | renderGrid es = 94 | mapM fromCoord coordMatrix <&> fromString . concat . intercalate ["\n"] . m2l 95 | where 96 | coordMatrix = (l2m . chunksOf matrixSize) 97 | [ (x, y) | y <- [0 .. matrixSize - 1], x <- [0 .. matrixSize - 1] ] 98 | 99 | fromCoord (x, y) = fromEntityRepr (vertical (x, y)) (mget x y es) 100 | 101 | fromEntityRepr vertical' = pure . \case 102 | Just WallTile -> 103 | if vertical' then ":rogue__wall_vert:" else ":rogue__wall_horiz:" 104 | Just DoorTile -> 105 | if vertical' then ":rogue__door_vert:" else ":rogue__door_horiz:" 106 | Just EvilTile -> ":rogue__rat:" 107 | Just FireTile -> ":rogue__fire:" 108 | Just PotionTile -> ":rogue__potion:" 109 | Just (PortalTile Blue ) -> ":rogue__portal_out:" 110 | Just (PortalTile Orange) -> ":rogue__portal_in:" 111 | Just StaircaseTile -> ":rogue__staircase:" 112 | Just PlayerTile -> ":rogue__player:" 113 | Just ErrorTile -> ":rogue__default:" 114 | Nothing -> ":rogue__blank:" 115 | 116 | isWallOrDoor' = (== WallTile) ||$ (== DoorTile) 117 | isWallOrDoor x' y' = maybe False isWallOrDoor' $ mget x' y' es 118 | isSomething x' y' = isJust $ mget x' y' es 119 | safeInc a = if a < matrixSize - 1 then a + 1 else a 120 | safeDec a = if a > 0 then a - 1 else a 121 | vertical (x, y) = a && b && not (c && d) where 122 | [a, b, c, d] = 123 | [ isSomething x (safeDec y) 124 | , isSomething x (safeInc y) 125 | , isWallOrDoor (safeDec x) y 126 | , isWallOrDoor (safeInc x) y 127 | ] 128 | 129 | stepAndSend :: Maybe Text -> Text -> Command -> GameM (Text, Bool) 130 | stepAndSend edit user cmd = do 131 | Context { ctxSession = session, ctxAPIToken = token, ctxChannelID = channelID } <- 132 | ask 133 | 134 | (renderedGrid, message, gameOver) <- lift $ step 135 | cmd 136 | renderGrid 137 | (pure . (("(<@" <> user <> ">'s game)\n\n") <>) . unlines . unMessage) 138 | let text = message <> "\n" <> renderedGrid 139 | 140 | case edit of 141 | Nothing -> do 142 | timestamp <- 143 | liftIO $ sendMessage session token channelID text <&> fromJust 144 | addReacts timestamp 145 | return (timestamp, gameOver) 146 | Just timestamp -> do 147 | void . liftIO . async $ editMessage session token channelID timestamp text 148 | 149 | return (timestamp, gameOver) 150 | 151 | 152 | data Event = CommandEvent Text Command 153 | | NewGameEvent Text 154 | | NewMemberEvent Text 155 | 156 | handleMsg :: Chan Event -> Text -> EventHandler IO 157 | handleMsg channel channelID msg = do 158 | putStrLn $ "Message from socket: " <> show msg 159 | case msg of 160 | MemberJoin c u -> do 161 | when (c == channelID) (writeChan channel (NewMemberEvent u)) 162 | return BasicRes 163 | 164 | ReactionAdd e m u -> do 165 | unless (u == rogueUserId) 166 | (writeChan channel $ CommandEvent m (fromReact e)) 167 | return BasicRes 168 | 169 | SlashCommand _ u -> do 170 | writeChan channel $ NewGameEvent u 171 | return $ SlashCommandRes "starting a new game..." False 172 | 173 | _ -> do 174 | putStrLn $ "Can't handle event: " <> show msg 175 | return NoRes 176 | 177 | 178 | getLeaderboard :: Text -> IO Leaderboard 179 | getLeaderboard (toString -> path) = doesFileExist path >>= \case 180 | True -> 181 | readFileBS path 182 | >>= maybe (die "Failed to read leaderboard file...") pure 183 | . decodeStrict 184 | False -> pure (Leaderboard []) 185 | 186 | 187 | initializeGame :: Text -> GameM Text 188 | initializeGame user = stepAndSend Nothing user Noop <&> fst 189 | 190 | runGame :: Chan Command -> Text -> Text -> GameM () 191 | runGame channel timestamp user = do 192 | void . liftIO . async . forever $ do 193 | threadDelay 1000000 194 | writeChan channel IncrementTimer 195 | 196 | let gameLoop = do 197 | cmd <- liftIO $ readChan channel 198 | (_, gameOver) <- stepAndSend (Just timestamp) user cmd 199 | if gameOver then endGame timestamp user else gameLoop 200 | gameLoop 201 | 202 | endGame :: Text -> Text -> GameM () 203 | endGame timestamp user = do 204 | context <- ask 205 | 206 | let leaderboardPath = ctxLeaderboardFile context 207 | leaderboard <- liftIO (getLeaderboard leaderboardPath) 208 | 209 | void $ stepAndSend (Just timestamp) user (DisplayLeaderboard leaderboard) 210 | 211 | (depth, secs) <- lift getLeaderboardInfo 212 | currentTime <- liftIO getCurrentTime 213 | userName <- liftIO 214 | $ getUserName (ctxSession context) (ctxAPIToken context) user 215 | let newLeaderboard = withLeaderboard 216 | (<> [ LeaderboardEntry { leName = userName 217 | , leTime = currentTime 218 | , leDepth = depth 219 | , leSecs = secs 220 | } 221 | ] 222 | ) 223 | leaderboard 224 | liftIO $ encodeFile (toString leaderboardPath) newLeaderboard 225 | 226 | 227 | app :: AppM () 228 | app = do 229 | channel <- liftIO newChan 230 | gameChannels <- liftIO $ newIORef Map.empty 231 | 232 | context <- ask 233 | wsThread <- liftIO . async $ wsConnect 234 | (ctxSession context) 235 | (ctxWSToken context) 236 | (handleMsg channel (ctxChannelID context)) 237 | 238 | void . forever $ do 239 | event <- liftIO $ readChan channel 240 | case event of 241 | CommandEvent timestamp cmd -> do 242 | gameChannelMay <- liftIO (readIORef gameChannels) 243 | <&> Map.lookup timestamp 244 | case gameChannelMay of 245 | Just gameChannel -> liftIO . writeChan gameChannel $ cmd 246 | Nothing -> putStrLn "Message does not correspond to any game" 247 | 248 | NewGameEvent user -> do 249 | let 250 | createGame = do 251 | gameChannel <- liftIO newChan 252 | timestamp <- initializeGame user 253 | liftIO $ modifyIORef gameChannels (Map.insert timestamp gameChannel) 254 | runGame gameChannel timestamp user 255 | 256 | void . liftIO . async . runRogue . runReaderT createGame $ context 257 | 258 | NewMemberEvent user -> void . liftIO $ do 259 | leaderboardText' <- 260 | getLeaderboard (ctxLeaderboardFile context) 261 | >>= liftIO 262 | . leaderboardText 263 | sendMessage 264 | (ctxSession context) 265 | (ctxAPIToken context) 266 | (ctxChannelID context) 267 | ( "hello <@" 268 | <> user 269 | <> ">\n\n\ 270 | \i am a small game about dungeon descension; i bear similarities to arcade and roguelike games\n\n\ 271 | \type the command `/rlnewgame` and a new game will await you\n\ 272 | \alternatively, you may explore my recesses: https://github.com/hackclub/rogue\n\n" 273 | <> leaderboardText' 274 | ) 275 | 276 | cancel wsThread 277 | 278 | main :: IO () 279 | main = do 280 | let envVarNames = 281 | [ "SLACK_API_TOKEN" 282 | , "SLACK_WS_TOKEN" 283 | , "RL_CHANNEL_NAME" 284 | , "LEADERBOARD_FILE" 285 | ] 286 | envVars <- mapM lookupEnv envVarNames 287 | 288 | case map (fmap fromString) envVars of 289 | [Just at, Just wst, Just cn, Just lf] -> do 290 | session <- S.newSession 291 | channelID <- getChannelID session at cn 292 | let context = Context { ctxSession = session 293 | , ctxAPIToken = at 294 | , ctxWSToken = wst 295 | , ctxChannelID = channelID 296 | , ctxLeaderboardFile = lf 297 | } 298 | runReaderT app context 299 | _ -> 300 | void 301 | . die 302 | $ "Can't find some of the following environment variables: " 303 | <> intercalate ", " envVarNames 304 | -------------------------------------------------------------------------------- /src/Slack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE StrictData #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | 9 | module Slack 10 | ( wsConnect 11 | , EventHandler 12 | , SocketEventContent(..) 13 | , SocketEventResContent(..) 14 | , getChannelID 15 | , sendMessage 16 | , editMessage 17 | , reactToMessage 18 | , getUserName 19 | ) where 20 | 21 | import Relude hiding ( get 22 | , head 23 | , many 24 | ) 25 | 26 | import Control.Lens hiding ( (.=) ) 27 | import Data.Aeson 28 | import Data.Aeson.Encode.Pretty 29 | import Text.Megaparsec hiding ( token ) 30 | import Text.Megaparsec.Char 31 | 32 | import Network.Wreq 33 | import qualified Network.Wreq.Session as S 34 | import Network.Wreq.Session ( Session ) 35 | 36 | import Network.WebSockets hiding ( Message ) 37 | import Wuss 38 | 39 | 40 | -- WebSocket connection 41 | ----------------------- 42 | 43 | 44 | data GetURLResponse = GetURLResponse 45 | { ok :: Bool 46 | , error' :: Maybe Text 47 | , url :: Maybe Text 48 | } 49 | deriving Generic 50 | instance FromJSON GetURLResponse 51 | 52 | 53 | type Parser = Parsec Void Text 54 | 55 | data URL = URL 56 | { host :: Text 57 | , path :: Text 58 | } 59 | 60 | -- this is of course inflexible, 61 | -- but it only has to handle what slack responds with 62 | parseURL :: Parser URL 63 | parseURL = do 64 | _ <- string "wss://" 65 | host' <- takeWhileP Nothing (/= '/') 66 | path' <- many anySingle 67 | 68 | return URL { host = host', path = fromString path' } 69 | 70 | 71 | data SocketEvent = SocketEvent 72 | { inEnvId :: Maybe Text 73 | , content :: SocketEventContent 74 | } 75 | deriving Show 76 | data SocketEventContent = 77 | Hello 78 | | MemberJoin { channelJoined :: Text, userJoined :: Text } 79 | | ReactionAdd { reactionName :: Text, reactionMessage :: Text, reactionUser :: Text } 80 | | SlashCommand { scText :: Text, scUser :: Text } 81 | | Disconnect 82 | | Unknown { unknownType :: Text, unknownFull :: Text } 83 | deriving Show 84 | 85 | instance FromJSON SocketEvent where 86 | parseJSON = withObject "SlackMessage" $ \v -> do 87 | typeName :: Text <- v .: "type" 88 | smContent <- 89 | (case typeName of 90 | "hello" -> return Hello 91 | "events_api" -> do 92 | event <- (v .: "payload") >>= (.: "event") 93 | eventType :: Text <- event .: "type" 94 | case eventType of 95 | "member_joined_channel" -> do 96 | channel <- event .: "channel" 97 | user <- event .: "user" 98 | return $ MemberJoin channel user 99 | "reaction_added" -> do 100 | name <- event .: "reaction" 101 | msg <- event .: "item" >>= (.: "ts") 102 | user <- event .: "user" 103 | return $ ReactionAdd name msg user 104 | _ -> return $ Unknown eventType (decodeUtf8 . encodePretty $ v) 105 | "slash_commands" -> do 106 | text <- (v .: "payload") >>= (.: "text") 107 | user <- (v .: "payload") >>= (.: "user_id") 108 | return $ SlashCommand { scText = text, scUser = user } 109 | "disconnect" -> return Disconnect 110 | _ -> do 111 | type' <- v .: "type" 112 | let content' = (decodeUtf8 . encodePretty) v 113 | return $ Unknown type' content' 114 | ) 115 | 116 | envId' :: Maybe Text <- v .:? "envelope_id" 117 | return $ SocketEvent envId' smContent 118 | 119 | 120 | data SocketEventRes = SocketEventRes 121 | { outEnvId :: Text 122 | , resContent :: SocketEventResContent 123 | } 124 | data SocketEventResContent = SlashCommandRes 125 | { scrText :: Text 126 | , scrInChannel :: Bool 127 | } 128 | | BasicRes 129 | | NoRes 130 | 131 | instance ToJSON SocketEventRes where 132 | toJSON om = 133 | object 134 | $ ("envelope_id" .= outEnvId om) 135 | : (case resContent om of 136 | SlashCommandRes _ _ -> 137 | [ "payload" .= object 138 | [ "text" .= (scrText . resContent) om 139 | , "response_type" 140 | .= (if (scrInChannel . resContent) om 141 | then "in_channel" 142 | else "ephemeral" :: Text 143 | ) 144 | ] 145 | ] 146 | _ -> [] 147 | ) 148 | 149 | 150 | type EventHandler m = SocketEventContent -> m SocketEventResContent 151 | 152 | wsClient :: EventHandler IO -> Connection -> IO () 153 | wsClient handleMsg conn = do 154 | putStrLn "Connected!" 155 | let msgLoop = do 156 | msgRaw <- receiveData conn 157 | let msg = decode msgRaw 158 | let isDisconnect = case msg of 159 | Just (content -> Disconnect) -> True 160 | _ -> False 161 | unless isDisconnect $ do 162 | liftIO 163 | . maybe 164 | (putTextLn $ "Failed to parse JSON: " <> decodeUtf8 msgRaw) 165 | (\se -> 166 | maybe (return ()) (socketLoop se) . inEnvId $ (se :: SocketEvent) 167 | ) 168 | $ msg 169 | msgLoop 170 | msgLoop 171 | where 172 | socketLoop se id_ = do 173 | res <- handleMsg (content se) 174 | case res of 175 | NoRes -> return () 176 | _ -> liftIO $ sendTextData 177 | conn 178 | (encode SocketEventRes { outEnvId = id_, resContent = res }) 179 | 180 | 181 | wsConnect :: Session -> Text -> EventHandler IO -> IO () 182 | wsConnect session wsToken handle = forever $ do 183 | getURLRes <- liftIO $ asJSON =<< S.postWith 184 | (defaults & header "Authorization" .~ ["Bearer " <> encodeUtf8 wsToken]) 185 | session 186 | "https://slack.com/api/apps.connections.open" 187 | ([] :: [FormParam]) 188 | 189 | case url (getURLRes ^. responseBody) of 190 | Just url' -> case runParser parseURL "" url' of 191 | Left e -> void . die . ("Failed to parse URI: " <>) . show $ e 192 | Right u -> runSecureClient (toString . host $ u) 193 | 443 194 | (toString . path $ u) 195 | (wsClient handle) 196 | Nothing -> 197 | void 198 | . die 199 | . toString 200 | . ("Failed to get WebSocket URI with: " <>) 201 | . fromMaybe "(no error)" 202 | . error' 203 | . (^. responseBody) 204 | $ getURLRes 205 | 206 | 207 | -- HTTP requests 208 | ---------------- 209 | 210 | 211 | newtype ChannelList = ChannelList { channels :: [Channel] } 212 | instance FromJSON ChannelList where 213 | parseJSON = 214 | withObject "ChannelList" $ (return . ChannelList) <=< (.: "channels") 215 | 216 | data Channel = Channel 217 | { chanName :: Text 218 | , chanId :: Text 219 | } 220 | instance FromJSON Channel where 221 | parseJSON = withObject "Channel" $ \v -> do 222 | chanName' <- v .: "name" 223 | chanId' <- v .: "id" 224 | return $ Channel { chanName = chanName', chanId = chanId' } 225 | 226 | getChannelID :: Session -> Text -> Text -> IO Text 227 | getChannelID session token name = do 228 | chanListRes <- S.getWith 229 | ( defaults 230 | & header "Authorization" 231 | .~ ["Bearer " <> encodeUtf8 token] 232 | & param "limit" 233 | .~ ["1000"] 234 | & param "types" 235 | .~ ["public_channel", "private_channel"] 236 | ) 237 | session 238 | "https://slack.com/api/conversations.list" 239 | case eitherDecode (chanListRes ^. responseBody) of 240 | Left e -> 241 | die 242 | $ "Failed to parse JSON for conversation list: " 243 | <> e 244 | <> "\n" 245 | <> decodeUtf8 (chanListRes ^. responseBody) 246 | Right cl -> 247 | return . chanId . head' . filter ((== name) . chanName) . channels $ cl 248 | where 249 | -- TODO getChannelID should return IO (Maybe Text) and be total 250 | head' = \case 251 | c : _ -> c 252 | [] -> error $ "Couldn't find channel with name: " <> name 253 | 254 | 255 | newtype SendMsgRes = SendMsgRes 256 | { 257 | msgTimestamp :: Maybe Text 258 | } 259 | deriving Show 260 | instance FromJSON SendMsgRes where 261 | parseJSON = withObject "SendMsgRes" $ (.: "ts") >=> return . SendMsgRes 262 | 263 | -- returns timestamp 264 | sendMessage :: Session -> Text -> Text -> Text -> IO (Maybe Text) 265 | sendMessage session token channelId text = do 266 | res <- S.postWith 267 | (defaults & header "Authorization" .~ ["Bearer " <> encodeUtf8 token]) 268 | session 269 | "https://slack.com/api/chat.postMessage" 270 | (object [("channel", String channelId), ("text", String text)]) 271 | 272 | case eitherDecode (res ^. responseBody) of 273 | Left e -> die $ e <> "\n" <> (decodeUtf8 . view responseBody) res 274 | Right (SendMsgRes s) -> return s 275 | 276 | editMessage :: Session -> Text -> Text -> Text -> Text -> IO () 277 | editMessage session token channelId timestamp' text = void $ S.postWith 278 | (defaults & header "Authorization" .~ ["Bearer " <> encodeUtf8 token]) 279 | session 280 | "https://slack.com/api/chat.update" 281 | (object 282 | [ ("channel", String channelId) 283 | , ("ts" , String timestamp') 284 | , ("text" , String text) 285 | ] 286 | ) 287 | 288 | reactToMessage :: Session -> Text -> Text -> Text -> Text -> IO () 289 | reactToMessage session token channelId timestamp' emoji = void $ S.post 290 | session 291 | "https://slack.com/api/reactions.add" 292 | [ "token" := token 293 | , "channel" := channelId 294 | , "timestamp" := timestamp' 295 | , "name" := emoji 296 | ] 297 | 298 | 299 | newtype UserInfo = UserInfo 300 | { userDisplayName :: Text } 301 | deriving Show 302 | 303 | instance FromJSON UserInfo where 304 | parseJSON = 305 | withObject "UserInfo" 306 | $ (.: "user") 307 | >=> (.: "profile") 308 | >=> (.: "display_name") 309 | >=> return 310 | . UserInfo 311 | 312 | getUserName :: Session -> Text -> Text -> IO Text 313 | getUserName session token userId = do 314 | res <- S.getWith 315 | ( defaults 316 | & header "Authorization" 317 | .~ ["Bearer " <> encodeUtf8 token] 318 | & param "user" 319 | .~ [userId] 320 | ) 321 | session 322 | "https://slack.com/api/users.info" 323 | case eitherDecode (res ^. responseBody) of 324 | Left e -> die $ e <> "\n" <> (decodeUtf8 . view responseBody) res 325 | Right u -> pure . userDisplayName $ u 326 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Utils where 5 | 6 | import Relude 7 | import Relude.Unsafe ( (!!) ) 8 | 9 | import Control.Lens hiding ( Context ) 10 | import Control.Monad.Random 11 | import Data.List.Split ( chunksOf ) 12 | import qualified Data.Vector.Fixed as Vec 13 | import Data.Vector.Fixed.Boxed ( Vec ) 14 | 15 | 16 | compose :: [a -> a] -> a -> a 17 | compose = flip $ foldl' (&) 18 | 19 | replace :: Eq a => a -> a -> [a] -> [a] 20 | replace x y = map (\o -> if o == x then y else o) 21 | 22 | replace' :: Eq a => (a -> Bool) -> (a -> a) -> [a] -> [a] 23 | replace' b f xs = (maybe id (\x -> replace x (f x)) . find b $ xs) xs 24 | 25 | (&&$), (||$) :: (a -> Bool) -> (a -> Bool) -> a -> Bool 26 | (&&$) f g x = f x && g x 27 | (||$) f g x = f x || g x 28 | 29 | 30 | -- random 31 | --------- 32 | 33 | type RandM = Rand StdGen 34 | type RandT' m = RandT StdGen m 35 | 36 | randomChoice :: Monad m => [a] -> RandT' m a 37 | randomChoice xs = getRandomR (0, length xs - 1) <&> (xs !!) 38 | 39 | 40 | -- matrix 41 | --------- 42 | 43 | matrixSize :: Int 44 | matrixSize = 14 45 | 46 | -- yes i know hardcoding the dims here is bad 47 | newtype Matrix a = Matrix { fromMatrix :: Vec 14 (Vec 14 a) } 48 | 49 | instance Functor Matrix where 50 | fmap f = Matrix . (Vec.map . Vec.map) f . fromMatrix 51 | 52 | instance Foldable Matrix where 53 | foldr f d = foldr f d . concat . m2l 54 | 55 | instance Traversable Matrix where 56 | traverse m = fmap (l2m . chunksOf matrixSize) . traverse m . concat . m2l 57 | 58 | -- maybe this should be some typeclass instance 59 | m2l :: Matrix a -> [[a]] 60 | m2l = Vec.toList . Vec.map Vec.toList . fromMatrix 61 | 62 | l2m :: [[a]] -> Matrix a 63 | l2m = Matrix . Vec.fromList . map Vec.fromList 64 | 65 | mget :: Int -> Int -> Matrix a -> a 66 | mget x y = (!! x) . (!! y) . m2l 67 | 68 | mset :: Int -> Int -> a -> Matrix a -> Matrix a 69 | mset x y e = l2m . over (ix y) (& ix x .~ e) . m2l 70 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 2 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml 3 | packages: [.] 4 | extra-deps: [astar-0.3.0.0] 5 | nix: 6 | shell-file: shell.nix 7 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: astar-0.3.0.0@sha256:8bf6350542e9db9451490e8993560ee843dc48a61d46a206985430f9b62461c8,967 9 | pantry-tree: 10 | sha256: c4176cc3fc9ad39f2a9fc7eb4346c87b6e60b70ba23d8e2adbdfc81fe544b808 11 | size: 213 12 | original: 13 | hackage: astar-0.3.0.0 14 | snapshots: 15 | - completed: 16 | sha256: e66e70a7f998036025e8f40abc89b8eeb79c88f57727020cba1b54f375aa7ca0 17 | size: 586292 18 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml 19 | original: 20 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/17.yaml 21 | --------------------------------------------------------------------------------