Rogue-like game level generator

Levelgen.hs

import qualified Data.Set as Set
import           Data.Set   (Set)

import qualified Data.Map as Map
import           Data.Map   (Map)

import           Data.List

import           System.IO
import           System.Directory

data Place item = Place
    { land     :: Landscape
    , contains :: item
    }

data Landscape
    = Tile
    | Rock
    | Planks
    | Door
    | Unknown
    | Grass

    deriving (Read, Show, Enum)

class Drawable a where
    draw :: a -> String

instance Drawable Landscape where
    draw landscape = case landscape of
        Tile    -> "." -- \x1b[32m.\x1b[0m" -- \x1b[32m.\x1b[0m" -- color gets fucked when exporting for now
        Rock    -> "#" -- \x1b[34m#\x1b[0m"
        Planks  -> "="
        Door    -> "D" -- \x1b[34mD\x1b[0m"
        Grass   -> ","
        Unknown -> " "

instance Drawable (Place item) where
    draw = draw . land

type ScreenBuffer = Map (Int, Int) String

blit :: ScreenBuffer -> IO ()
blit = mapM_ (putStrLn . concatMap snd) . groupBy (\((a, _), _) ((b, _), _) -> a == b) . Map.toList

screenOf :: Drawable a => a -> Map (Int, Int) String
screenOf c = Map.fromList 
    [ ((x, y), draw c)
        | x <- [0.. 25]
        , y <- [0.. 80]]

updateScreen :: String -> Int -> Int -> String
updateScreen script x y = "\x1b[" ++ show x ++ ";" ++ show y ++ "H" ++ script

placeRoom :: Drawable a => a -> (Int, Int, Int, Int) -> ScreenBuffer -> ScreenBuffer
placeRoom flr (l, u, r, d) = blitWith

    [ x `xx` y $ draw flr
        | x <- [l.. r]
        , y <- [u.. d]
    ]

data Direction = H | V

blitWith :: [((Int, Int), String)] -> ScreenBuffer -> ScreenBuffer
blitWith = Map.union . Map.fromList

placeWall :: Drawable a => a -> Direction -> (Int, Int, Int) -> ScreenBuffer -> ScreenBuffer
placeWall wall H (l, u, d) = blitWith

    [ l `xx` y $ draw wall
        | y <- [u.. d]
    ]

placeWall wall V (u, l, r) = blitWith

    [ x `xx` u $ draw wall
        | x <- [l.. r]
    ]

makeRoom :: (Drawable a) => a -> a -> (Int, Int, Int, Int) -> ScreenBuffer -> ScreenBuffer
makeRoom wall flr (l, u, r, d) =

    placeWall wall V (u, l, r) .
    placeWall wall V (d, l, r) .
    placeWall wall H (r, u, d) .
    placeWall wall H (l, u, d) .

    placeRoom flr (l, u, r, d)

place :: Drawable a => a -> (Int, Int) -> ScreenBuffer -> ScreenBuffer
place a (x, y) = Map.insert (x, y) $ draw a

xx :: Int -> Int -> String -> ((Int, Int), String)
xx x y c = ((x, y), c)

(|>) :: x -> (x -> y) -> y
(|>) = flip ($)

maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
    [(x, "")] -> Just x
    _         -> Nothing

store :: String -> ScreenBuffer -> IO ()
store name buf =
    writeFile name $ show buf

retrieve :: String -> IO (Maybe ScreenBuffer)
retrieve name = do
    exists <- doesFileExist name

    if exists
     then do
        content <- readFile name

        return $ maybeRead content

     else 
        return Nothing

toPlainText :: ScreenBuffer -> String
toPlainText = unlines . map (concatMap snd) . groupBy (\((a, _), _) ((b, _), _) -> a == b) . Map.toList

editor :: String -> [ScreenBuffer] -> IO ()
editor msg screen = do
    let list = Map.toList $ head screen

    let ws = map (snd . fst) list
    let hs = map (fst . fst) list

    putStr $ 30 `replicate` '\n'

    putStr "==== "
    putStr $ show (maximum ws) ++ " x " ++ show (maximum hs)
    putStrLn $ 24 `replicate` '='

    blit $ head screen

    putStrLn msg
    putStr "> "

    input <- getLine

    case words input of

        "crop" : "to" : wh -> do

            let wh' = maybeRead $ concat wh

            case wh' of
                Just (w, h) -> do
                    let new = head screen `Map.intersection` (Map.empty |> makeRoom Unknown Unknown (0, 0, w, h))

                    editor "Image cropped." $ new : screen

                Nothing ->
                    editor "Usage: crop to <coords: (w: Int, h: Int)>" screen

        "enlarge" : "to" : wh -> do

            let wh' = maybeRead $ concat wh

            case wh' of
                Just (w, h) -> do
                    let new = head screen `Map.union` (Map.empty |> makeRoom Unknown Unknown (0, 0, w, h))

                    editor "Enlarged your... image." $ new : screen

                Nothing ->
                    editor "Usage: enlarge to <coords: (w: Int, h: Int)>" screen

        export : name | export `elem` ["print", "export", "dump"] -> do
            let exported = toPlainText $ head screen

            writeFile (concat name) exported

            editor ("Exported to " ++ concat name ++ ".") screen

        help : [] | help `elem` ["help", "halp", "?", ":?"] -> do
            let lesson = unlines
                    [ "-"
                    , "help               - bring this info"
                    , "-"
                    , "load filename      - load file from file"
                    , "save filename      - save to file"
                    , "-"
                    , "materials          - list all available materials"
                    , "-"
                    , "undo               - undoes previous action (loading could be undone, too)"
                    , "-"
                    , "quit               - who knows what it does?"
                    , "-"
                    , "export filename    - prints image as is to txt file"
                    , "-"
                    , "crop    (w, h)     - decrease size of the image (up-left corner stays as it is)"
                    , "enlarge (w, h)     - increase size of the image (up-left corner stays as it is)"
                    , "-"
                    , "make room wall floor (l, u, r, d)"
                    , "                   - make a room from given coords, wall and floor materials"
                    , "-"
                    , ":wq                - save to last.map & exit"
                    , "-"
                    , "last               - load from last.map"
                    , "-"
                    , "place block (x, y) - place a block at given site"
                    , "-"
                    , "    TRY: make room Rock Grass (5, 5, 10, 10)"
                    , "-"
                    , "(press enter to remove this)"
                    ]

            editor lesson screen

        last : [] | last `elem` ["last", "before", "continue", "restore"] -> do

            top' <- retrieve "last.map"

            case top' of
                Just top -> editor "Read from last.map." (top : screen)

                Nothing  -> editor "File last.map seems to be corrupted - I cannot read it, sorry." screen

        load : name' | load `elem` ["load", ":r", ":load", "open", "read"] -> do

            let name = concat name'

            top' <- retrieve name

            case top' of
                Just top -> editor ("Read from " ++ name ++ ".") (top : screen)

                Nothing  -> editor ("File " ++ name ++ " seems to be corrupted - I cannot read it, sorry.") screen

        save : name' | save `elem` ["save", ":w", "store", "write"] -> do

            let name = concat name'

            name `store` head screen

            editor ("Saved to " ++ name ++ ".") screen

        blocks : [] | blocks `elem` ["blocks", "materials"] ->
            editor (show [Tile ..]) screen

        "make" : "room" : wall : flr : coords -> do

            let h = head screen

            let h' = do
                w  <- maybeRead   wall          :: Maybe Landscape
                f  <- maybeRead   flr           :: Maybe Landscape
                cs <- maybeRead $ concat coords :: Maybe (Int, Int, Int, Int)

                return $ h |> makeRoom w f cs

            case h' of 
                Just hd -> (hd : screen) |> editor msg
                Nothing -> editor "Usage: make room <wall> <floor> <coords>" screen

        undo : [] | undo `elem` ["undo", "back", "oops", "shit"] ->

            if length screen == 1
             then editor "Cannot be undone - initial state." screen
             else editor "Undone." $ tail screen

        "place" : item : coords -> do

            let h : _ = screen

            let h' = do
                i  <- maybeRead   item          :: Maybe Landscape
                cs <- maybeRead $ concat coords :: Maybe (Int, Int)

                return $ h |> place i cs

            case h' of 
                Just hd -> (hd : screen) |> editor msg
                Nothing -> editor "Usage: place <item> <coords>" screen

        quit : [] | quit `elem` ["q", "quit", "exit", "die", ":q"] ->

            putStrLn "Bye!"

        ":wq" : [] -> do
            "last.map" `store` head screen

            putStrLn "Saved to last.map. Bye!"

        [] -> editor "" screen

        _ -> editor "What?" screen



main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    editor "Welcome to roguelike editor!" [screenOf Unknown]