2015-05-11 02:57:53 +03:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Main where
|
|
|
|
|
2015-06-08 05:27:20 +03:00
|
|
|
import Graphics.Vty
|
2015-05-11 02:57:53 +03:00
|
|
|
|
|
|
|
import Data.Array
|
|
|
|
import Data.Default (def)
|
|
|
|
|
|
|
|
import Control.Applicative
|
|
|
|
import Control.Monad
|
2015-06-21 01:02:54 +03:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
2015-05-11 02:57:53 +03:00
|
|
|
|
|
|
|
import System.Random
|
|
|
|
import System.Exit
|
|
|
|
|
2015-06-08 04:37:36 +03:00
|
|
|
import Brick.Main
|
|
|
|
import Brick.Render
|
|
|
|
import Brick.Border
|
|
|
|
import Brick.Core
|
|
|
|
import Brick.Center
|
2015-05-11 02:57:53 +03:00
|
|
|
|
|
|
|
data Player = Player
|
|
|
|
{ playerCoord :: Coord
|
|
|
|
} deriving (Show,Eq)
|
|
|
|
|
|
|
|
data World = World
|
|
|
|
{ player :: Player
|
|
|
|
, level :: Level
|
|
|
|
}
|
|
|
|
deriving (Show,Eq)
|
|
|
|
|
|
|
|
data Level = Level
|
|
|
|
{ levelStart :: Coord
|
|
|
|
, levelEnd :: Coord
|
|
|
|
, levelGeo :: Geo
|
|
|
|
-- building the geo image is expensive. Cache it. Though VTY should go
|
|
|
|
-- through greater lengths to avoid the need to cache images.
|
|
|
|
, levelGeoImage :: Image
|
|
|
|
}
|
|
|
|
deriving (Show,Eq)
|
|
|
|
|
|
|
|
data LevelPiece
|
|
|
|
= EmptySpace
|
|
|
|
| Rock
|
|
|
|
deriving (Show, Eq)
|
|
|
|
|
|
|
|
type Geo = Array Coord LevelPiece
|
|
|
|
type Coord = (Int, Int)
|
|
|
|
|
|
|
|
main :: IO ()
|
|
|
|
main = do
|
|
|
|
level0 <- mkLevel 1
|
|
|
|
let world0 = World (Player (levelStart level0)) level0
|
|
|
|
app = def { appDraw = updateDisplay
|
|
|
|
, appHandleEvent = processEvent
|
|
|
|
, appChooseCursor = neverShowCursor
|
|
|
|
}
|
|
|
|
defaultMain app world0
|
|
|
|
|
|
|
|
-- |Generate a level randomly using the specified difficulty. Higher
|
|
|
|
-- difficulty means the level will have more rooms and cover a larger area.
|
|
|
|
mkLevel :: Int -> IO Level
|
|
|
|
mkLevel difficulty = do
|
|
|
|
let size = 80 * difficulty
|
|
|
|
[levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)
|
|
|
|
let randomP = (,) <$> randomRIO (2, levelWidth-3) <*> randomRIO (2, levelHeight-3)
|
|
|
|
start <- randomP
|
|
|
|
end <- randomP
|
|
|
|
-- first the base geography: all rocks
|
|
|
|
let baseGeo = array ((0,0), (levelWidth-1, levelHeight-1))
|
|
|
|
[((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]
|
|
|
|
-- next the empty spaces that make the rooms
|
|
|
|
-- for this we generate a number of center points
|
|
|
|
centers <- replicateM (2 ^ difficulty + difficulty) randomP
|
|
|
|
-- generate rooms for all those points, plus the start and end
|
|
|
|
geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)
|
|
|
|
return $ Level start end geo (buildGeoImage geo)
|
|
|
|
|
|
|
|
-- |Add a room to a geography and return a new geography. Adds a
|
|
|
|
-- randomly-sized room centered at the specified coordinates.
|
|
|
|
addRoom :: Int
|
|
|
|
-> Int
|
|
|
|
-- ^The width and height of the geographical area
|
|
|
|
-> Geo
|
|
|
|
-- ^The geographical area to which a new room should be added
|
|
|
|
-> Coord
|
|
|
|
-- ^The desired center of the new room.
|
|
|
|
-> IO Geo
|
|
|
|
addRoom levelWidth levelHeight geo (centerX, centerY) = do
|
|
|
|
size <- randomRIO (5,15)
|
|
|
|
let xMin = max 1 (centerX - size)
|
|
|
|
xMax = min (levelWidth - 1) (centerX + size)
|
|
|
|
yMin = max 1 (centerY - size)
|
|
|
|
yMax = min (levelHeight - 1) (centerY + size)
|
|
|
|
let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]
|
|
|
|
return (geo // room)
|
|
|
|
|
|
|
|
pieceA, dumpA :: Attr
|
|
|
|
pieceA = defAttr `withForeColor` blue `withBackColor` green
|
|
|
|
dumpA = defAttr `withStyle` reverseVideo
|
|
|
|
|
2015-06-21 01:02:54 +03:00
|
|
|
processEvent :: Event -> World -> EventM World
|
2015-05-11 02:57:53 +03:00
|
|
|
processEvent k world = do
|
|
|
|
case k of
|
2015-06-21 01:02:54 +03:00
|
|
|
EvKey KEsc [] -> liftIO exitSuccess
|
2015-05-11 02:57:53 +03:00
|
|
|
EvKey KLeft [] -> return $ movePlayer world (-1) 0
|
|
|
|
EvKey KRight [] -> return $ movePlayer world 1 0
|
|
|
|
EvKey KUp [] -> return $ movePlayer world 0 (-1)
|
|
|
|
EvKey KDown [] -> return $ movePlayer world 0 1
|
|
|
|
_ -> return world
|
|
|
|
|
|
|
|
movePlayer :: World -> Int -> Int -> World
|
|
|
|
movePlayer world dx dy = do
|
|
|
|
let Player (x, y) = player world
|
|
|
|
x' = x + dx
|
|
|
|
y' = y + dy
|
|
|
|
case levelGeo (level world) ! (x',y') of
|
|
|
|
EmptySpace -> world { player = Player (x',y') }
|
|
|
|
_ -> world
|
|
|
|
|
2015-06-08 04:37:36 +03:00
|
|
|
updateDisplay :: World -> [Render]
|
2015-05-11 03:17:47 +03:00
|
|
|
updateDisplay world = [ info, playerLayer, geoLayer ]
|
2015-05-11 02:57:53 +03:00
|
|
|
where
|
2015-06-08 04:37:36 +03:00
|
|
|
info = vBox [ (hCenter $ txt "Move with the arrows keys. Press ESC to exit.", High)
|
2015-06-08 05:40:49 +03:00
|
|
|
, (hBorder, High)
|
2015-05-11 02:57:53 +03:00
|
|
|
]
|
2015-05-11 03:17:47 +03:00
|
|
|
(px, py) = playerCoord $ player world
|
|
|
|
playerLoc = Location (px, py)
|
2015-05-11 02:57:53 +03:00
|
|
|
theLevel = level world
|
2015-06-08 06:38:07 +03:00
|
|
|
playerLayer = center $ raw (char pieceA '@')
|
2015-06-08 04:37:36 +03:00
|
|
|
geoLayer = centerAbout playerLoc $ raw $ levelGeoImage theLevel
|
2015-05-11 02:57:53 +03:00
|
|
|
|
|
|
|
imageForGeo :: LevelPiece -> Image
|
|
|
|
imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '
|
|
|
|
imageForGeo Rock = char defAttr 'X'
|
|
|
|
|
|
|
|
buildGeoImage :: Geo -> Image
|
|
|
|
buildGeoImage geo =
|
|
|
|
let (geoWidth, geoHeight) = snd $ bounds geo
|
|
|
|
in vertCat [ geoRow
|
|
|
|
| y <- [0..geoHeight-1]
|
|
|
|
, let geoRow = horizCat [ i
|
|
|
|
| x <- [0..geoWidth-1]
|
|
|
|
, let i = imageForGeo (geo ! (x,y))
|
|
|
|
]
|
|
|
|
]
|
|
|
|
|
|
|
|
playerX :: Player -> Int
|
|
|
|
playerX = fst . playerCoord
|
|
|
|
|
|
|
|
playerY :: Player -> Int
|
|
|
|
playerY = snd . playerCoord
|