├── .gitignore ├── Setup.hs ├── CHANGELOG.md ├── src ├── Items.hs ├── Main.hs ├── Board.hs └── Rogalik.hs ├── README.md ├── rogalik.cabal └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | *.hi 3 | *.o 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for rogalik 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /src/Items.hs: -------------------------------------------------------------------------------- 1 | module Items where 2 | 3 | data Weapon 4 | = Sword 5 | | Axe 6 | deriving (Show) 7 | 8 | data Item 9 | = GoldItem Int 10 | | WeaponItem Weapon 11 | deriving (Show) 12 | 13 | itemChar :: Item -> Char 14 | itemChar (GoldItem _) = '*' 15 | itemChar (WeaponItem _) = '/' 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Rogalik 2 | 3 | **WARNING! It's unfinished!** But it draws a bunch of rooms. And you can walk in them. Which is cool I guess. 4 | 5 | ![rogalik](https://upload.wikimedia.org/wikipedia/commons/7/73/Rogalik.jpg) 6 | 7 | ## Quick Start 8 | 9 | ```console 10 | $ cabal v2-run 11 | ``` 12 | -------------------------------------------------------------------------------- /rogalik.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | -- Initial package description 'rogalik.cabal' generated by 'cabal init'. 3 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 4 | 5 | name: rogalik 6 | version: 0.1.0.0 7 | -- synopsis: 8 | -- description: 9 | -- bug-reports: 10 | -- license: 11 | license-file: LICENSE 12 | author: rexim 13 | maintainer: reximkut@gmail.com 14 | -- copyright: 15 | -- category: 16 | build-type: Simple 17 | extra-source-files: CHANGELOG.md, README.md 18 | 19 | executable rogalik 20 | main-is: Main.hs 21 | other-modules: Board 22 | , Items 23 | , Rogalik 24 | -- other-extensions: 25 | build-depends: base >=4.12 && <4.13 26 | , random >=1.1 && < 1.2 27 | , array >= 0.5 && < 0.6 28 | , containers >= 0.6 && < 0.7 29 | , transformers >= 0.5 && < 0.6 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2021 Alexey Kutepov 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Text.Printf 4 | import System.IO 5 | import Control.Monad 6 | import Control.Monad.Trans.State 7 | import Control.Monad.Trans.Class 8 | import Data.Foldable 9 | 10 | import Rogalik 11 | 12 | -- TODO: random level generation based on RNG 13 | -- TODO: enemies 14 | -- TODO: floors 15 | -- TODO: potions 16 | -- ... 17 | 18 | printRogalik :: StateT Rogalik IO () 19 | printRogalik = do 20 | rogalik <- get 21 | lift $ putStrLn $ unlines $ renderRogalik rogalik 22 | 23 | unlessM :: Monad m => m Bool -> m () -> m () 24 | unlessM conditionM body = do 25 | condition <- conditionM 26 | unless condition body 27 | 28 | handleCommands :: String -> StateT Rogalik IO () 29 | handleCommands commands = 30 | for_ commands $ \command -> 31 | case command of 32 | 's' -> rogalikMove D 33 | 'w' -> rogalikMove U 34 | 'a' -> rogalikMove L 35 | 'd' -> rogalikMove R 36 | 'q' -> quitRogalik 37 | _ -> lift $ printf "Unknown command: %c\n" command 38 | 39 | gameLoop :: StateT Rogalik IO () 40 | gameLoop = 41 | unlessM (rogalikQuit <$> get) $ do 42 | lift $ putStr "> " 43 | lift $ hFlush stdout 44 | line <- lift $ getLine 45 | handleCommands line 46 | printRogalik 47 | gameLoop 48 | 49 | main :: IO () 50 | main = 51 | evalStateT 52 | (do generateRogalik 53 | printRogalik 54 | gameLoop) $ 55 | emptyRogalik 20 20 56 | -------------------------------------------------------------------------------- /src/Board.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | module Board where 3 | 4 | import Data.Ix 5 | import Data.Array 6 | import Data.List 7 | import Data.Function 8 | 9 | data Point = Point 10 | { cellRow :: Int 11 | , cellCol :: Int 12 | } deriving (Eq, Ord, Ix, Show) 13 | 14 | liftPoint2 :: (Int -> Int -> Int) -> Point -> Point -> Point 15 | liftPoint2 op (Point row1 col1) (Point row2 col2) = Point (row1 `op` row2) (col1 `op` col2) 16 | 17 | (^+^) :: Point -> Point -> Point 18 | (^+^) = liftPoint2 (+) 19 | 20 | (^-^) :: Point -> Point -> Point 21 | (^-^) = liftPoint2 (-) 22 | 23 | data Rect = Rect 24 | { rectPoint1 :: Point 25 | , rectPoint2 :: Point 26 | } deriving (Show) 27 | 28 | boardRect :: Board a -> Rect 29 | boardRect board = uncurry Rect $ bounds $ boardArray board 30 | 31 | shrinkRect :: Int -> Rect -> Rect 32 | shrinkRect s (Rect cell1 cell2) = Rect (cell1 ^+^ Point s s) (cell2 ^-^ Point s s) 33 | 34 | clampRect :: Rect -> Point -> Point 35 | clampRect (Rect (Point row1 col1) (Point row2 col2)) (Point row col) = 36 | Point (clamp row row1 row2) (clamp col col1 col2) 37 | where 38 | clamp x l h = min (max x l) h 39 | 40 | data Board a = Board 41 | { boardArray :: Array Point a 42 | } deriving (Show, Functor) 43 | 44 | (^!^) :: Board a -> Point -> a 45 | (^!^) board cell = boardArray board ! wrapPoint board cell 46 | 47 | wrapPoint :: Board a -> Point -> Point 48 | wrapPoint board cell = liftPoint2 mod (cell ^-^ offset) size ^+^ offset 49 | where (offset, t) = bounds $ boardArray board 50 | size = t ^-^ offset 51 | 52 | mkBoard :: Int -> Int -> a -> Board a 53 | mkBoard width height a = 54 | Board $ array cellRange $ zip (range cellRange) (cycle [a]) 55 | where 56 | cellRange = (Point 1 1, Point height width) 57 | 58 | boardToLists :: Board a -> [[a]] 59 | boardToLists (Board pixels) = 60 | map (map snd) $ groupBy ((==) `on` (cellRow . fst)) $ assocs pixels 61 | 62 | fillPoint :: Point -> a -> Board a -> Board a 63 | fillPoint cell = fillRect (Rect cell cell) 64 | 65 | fillRect :: Rect -> a -> Board a -> Board a 66 | fillRect (Rect cell1 cell2) a board = board {boardArray = pixels // patch} 67 | where pixels = boardArray board 68 | patch = zip (map (wrapPoint board) $ range (cell1, cell2)) (cycle [a]) 69 | 70 | fillBoard :: a -> Board a -> Board a 71 | fillBoard a board = fillRect (boardRect board) a board 72 | -------------------------------------------------------------------------------- /src/Rogalik.hs: -------------------------------------------------------------------------------- 1 | module Rogalik where 2 | 3 | import Data.Array 4 | import Data.Foldable 5 | import qualified Data.Map as M 6 | import Data.Functor.Identity 7 | import System.Random 8 | import Control.Monad 9 | 10 | import Board 11 | import Items 12 | import Control.Monad.Trans.State 13 | import Control.Monad.Trans.Class 14 | 15 | data Dir 16 | = L 17 | | R 18 | | U 19 | | D 20 | deriving (Eq, Ord, Enum, Show) 21 | 22 | dirV2 :: Dir -> Point 23 | dirV2 L = Point 0 (-1) 24 | dirV2 R = Point 0 1 25 | dirV2 U = Point (-1) 0 26 | dirV2 D = Point 1 0 27 | 28 | data Room = Room 29 | { roomRect :: Rect 30 | , roomItems :: M.Map Point Item 31 | } deriving (Show) 32 | 33 | mkRoom :: Rect -> Room 34 | mkRoom rect = Room {roomRect = rect, roomItems = M.empty} 35 | 36 | addItem :: Point -> Item -> Room -> Room 37 | addItem cell item room = room {roomItems = M.insert cell item items} 38 | where 39 | items = roomItems room 40 | 41 | displayRoom :: Monad m => Room -> StateT (Board Char) m () 42 | displayRoom room = do 43 | modify $ fillRect (roomRect room) '.' 44 | let roomPos = rectPoint1 $ roomRect room 45 | for_ (M.toList $ roomItems room) $ \(itemPos, item) -> 46 | modify $ fillPoint (roomPos ^+^ itemPos) (itemChar item) 47 | 48 | data Player = Player 49 | { playerPos :: Point 50 | , playerGold :: Int 51 | , playerWeapons :: [Weapon] 52 | } deriving (Show) 53 | 54 | data Cell 55 | = Empty 56 | | Floor 57 | | VertWall 58 | | HorzWall 59 | | Passage 60 | | Door 61 | deriving (Show) 62 | 63 | cellToChar :: Cell -> Char 64 | cellToChar Empty = ' ' 65 | cellToChar Floor = '.' 66 | cellToChar VertWall = '|' 67 | cellToChar HorzWall = '-' 68 | cellToChar Passage = '#' 69 | cellToChar Door = '+' 70 | 71 | cellWalkable :: Cell -> Bool 72 | cellWalkable Empty = False 73 | cellWalkable Floor = True 74 | cellWalkable VertWall = False 75 | cellWalkable HorzWall = False 76 | cellWalkable Passage = True 77 | cellWalkable Door = True 78 | 79 | data Generator = Generator 80 | { generatorBoard :: Board Cell 81 | , generatorPos :: Point 82 | , generatorDir :: Dir 83 | } deriving (Show) 84 | 85 | mkGenerator :: Int -> Int -> Generator 86 | mkGenerator width height = 87 | Generator 88 | { generatorBoard = mkBoard width height Empty 89 | , generatorPos = Point 0 0 90 | , generatorDir = R 91 | } 92 | 93 | pickOne :: [a] -> IO a 94 | pickOne [] = error "pickOne: empty list" 95 | pickOne xs = do 96 | let n = length xs 97 | index <- randomRIO (0, n - 1) 98 | return $ xs !! index 99 | 100 | dirToChar :: Dir -> Char 101 | dirToChar L = '<' 102 | dirToChar R = '>' 103 | dirToChar U = '^' 104 | dirToChar D = 'v' 105 | 106 | renderGenerator :: Generator -> [String] 107 | renderGenerator generator = 108 | boardToLists $ 109 | runIdentity $ 110 | execStateT 111 | (do modify $ 112 | fillPoint 113 | (generatorPos generator) 114 | (dirToChar $ generatorDir generator)) $ 115 | cellToChar <$> generatorBoard generator 116 | 117 | generatorInit :: StateT Generator IO () 118 | generatorInit = do 119 | board <- generatorBoard <$> get 120 | pos <- lift $ pickOne $ indices $ boardArray board 121 | dir <- lift $ pickOne $ enumFrom $ toEnum 0 122 | modify $ \generator -> generator {generatorPos = pos, generatorDir = dir} 123 | 124 | generatorPassage :: Dir -> Int -> StateT Generator IO () 125 | generatorPassage = undefined 126 | 127 | generatorStep :: StateT Generator IO () 128 | generatorStep = undefined 129 | 130 | generatorGo :: StateT Generator IO () 131 | generatorGo = do 132 | generatorInit 133 | generatorPassage L 5 134 | 135 | data Rogalik = Rogalik 136 | { rogalikBoard :: Board Cell 137 | , rogalikPlayerPos :: Point 138 | , rogalikQuit :: Bool 139 | } deriving (Show) 140 | 141 | rogalikUpdateBoard :: Monad m => StateT (Board Cell) m () -> StateT Rogalik m () 142 | rogalikUpdateBoard boardState = StateT $ \rogalik -> do 143 | board' <- execStateT boardState $ rogalikBoard rogalik 144 | return ((), rogalik { rogalikBoard = board' }) 145 | 146 | quitRogalik :: Monad m => StateT Rogalik m () 147 | quitRogalik = modify (\rogalik -> rogalik {rogalikQuit = True}) 148 | 149 | emptyRogalik :: Int -> Int -> Rogalik 150 | emptyRogalik width height = 151 | Rogalik 152 | { rogalikBoard = board 153 | , rogalikPlayerPos = (fst $ bounds $ boardArray board) ^+^ Point 1 1 154 | , rogalikQuit = False 155 | } 156 | where 157 | board = mkBoard width height Empty 158 | 159 | generateRoomRect :: Monad m => Rect -> StateT Rogalik m () 160 | generateRoomRect rect@(Rect (Point row1 col1) (Point row2 col2)) = rogalikUpdateBoard $ do 161 | modify $ fillRect (Rect (Point row1 col1) (Point row2 col1)) VertWall 162 | modify $ fillRect (Rect (Point row1 col2) (Point row2 col2)) VertWall 163 | modify $ fillRect (Rect (Point row1 col1) (Point row1 col2)) HorzWall 164 | modify $ fillRect (Rect (Point row2 col1) (Point row2 col2)) HorzWall 165 | modify $ fillRect (shrinkRect 1 rect) Floor 166 | 167 | generateRoomAt :: Monad m => Point -> Int -> Int -> StateT Rogalik m () 168 | generateRoomAt pos rows cols = generateRoomRect (Rect pos (pos ^+^ Point (rows - 1) (cols - 1))) 169 | 170 | randomPoint :: Rect -> IO Point 171 | randomPoint (Rect (Point row1 col1) (Point row2 col2)) = do 172 | row <- randomRIO (row1, row2) 173 | col <- randomRIO (col1, col2) 174 | return $ Point row col 175 | 176 | generateRooms :: StateT Rogalik IO () 177 | generateRooms = 178 | replicateM_ 2 $ do 179 | board <- rogalikBoard <$> get 180 | cell <- lift $ randomPoint $ boardRect board 181 | w <- lift $ randomRIO (3, 7) 182 | h <- lift $ randomRIO (3, 7) 183 | generateRoomAt cell w h 184 | 185 | placePlayer :: StateT Rogalik IO () 186 | placePlayer = do 187 | board <- rogalikBoard <$> get 188 | let walkables = filter (cellWalkable . snd) $ assocs $ boardArray board 189 | let n = length walkables 190 | when (n == 0) $ error "Could not find any walkable cells for the player" 191 | i <- lift $ randomRIO (0, n - 1) 192 | modify $ \rogalik -> rogalik {rogalikPlayerPos = fst (walkables !! i)} 193 | 194 | generateRogalik :: StateT Rogalik IO () 195 | generateRogalik = do 196 | generateRooms 197 | placePlayer 198 | 199 | rogalikMove :: Monad m => Dir -> StateT Rogalik m () 200 | rogalikMove dir = modify $ \rogalik -> 201 | let playerPos' = rogalikPlayerPos rogalik ^+^ dirV2 dir 202 | board = rogalikBoard rogalik 203 | in if cellWalkable $ board ^!^ playerPos' 204 | then rogalik {rogalikPlayerPos = playerPos'} 205 | else rogalik 206 | 207 | renderRogalik :: Rogalik -> [String] 208 | renderRogalik rogalik = 209 | boardToLists $ 210 | runIdentity $ 211 | execStateT (do modify $ fillPoint (rogalikPlayerPos rogalik) '@') $ 212 | cellToChar <$> rogalikBoard rogalik 213 | --------------------------------------------------------------------------------