6 files changed, 222 insertions, 0 deletions

@@ -0,0 +1,67 @@
+module Fallen.Map
+( Map,
+  emptyMap,
+  dimension,
+  inBounds,
+  getTileAtPos,
+  findTileInMap,
+  updateMap,
+  legalMoves,
+  fillMapRect
+) where
+  import Fallen.Tiles
+  import Fallen.Point
+  import Data.List
+  import Fallen.Util
+  import Data.Maybe
+  
+  data Map = Map {
+    dimension :: (Int, Int),
+    mapdata :: [(Point, Tile)],
+    background :: Tile
+    }
+  
+  -- emptyMap :: Int -> Int -> Tile -> Map
+  emptyMap w h t = Map { dimension=(w,h), mapdata=[], background=t }
+  
+  -- inBounds :: Map -> Point -> Bool
+  inBounds m (x,y) = let (w,h) = dimension m in (x >= 0) && (x < w) && (y >= 0) && (y < h)
+  
+  -- getTileAtPos :: Map -> Point -> Tile
+  --getTileAtPos m p = if (inBounds m p)
+  --  then mapdata m p
+  --  else background m
+  getTileAtPos m p = fromMaybe (background m) $ lookup p $ mapdata m
+  
+  -- findTileInMap :: Map -> Tile -> [Point]
+--  findTileInMap m t = filter (\p -> t == mapdata m p) rawPoints where
+--    (w,h) = dimension m
+--    rawPoints = [(x,y) | x <- [0..w-1], y <- [0..h-1]]
+  findTileInMap m t = map fst $ filter ((== t) . snd) $ mapdata m
+  
+  -- updateMap updates the tiles at the given position in the map
+  -- if the passed point already exists in the internal array, it is overwritten with the new point
+  -- if the passed tile is the background tile, it removes the tile pair from the internal array
+  -- updateMap :: Point -> Tile -> Map -> Map
+  updateMap p t (Map d xs bg) = if t == bg
+    then Map d (filter ((/= p) . fst) xs) bg
+    else case lookup p xs of
+      Just _ -> Map d (map (\(p1,t1) -> if p1 == p then (p,t) else (p1,t1)) xs) bg
+      Nothing -> Map d ((p,t):xs) bg
+--  updateMap p t (Map d xs bg) = Map d (redirect p t xs) bg where
+--    redirect p t xs = (\p2 -> if p == p2 then t else xs p2)
+  
+  -- legalMoves :: Map -> Point -> [Tile] -> [Direction]
+  legalMoves m p ts = map fst $ filter legal $ map tileDir directions where
+    tileDir d = (d, getTileAtPos m $ stepInDirection p d)
+    legal (_,t) = t `elem` ts
+   
+  -- fillMapRect :: Int -> Int -> Int -> Int -> Tile -> Map -> Map
+  fillMapRect x y w h t (Map d xs bg) = if bg == t
+          then Map d (filter outBounds xs) bg 
+          else Map d (filter outBounds xs ++ [((px,py), t) | px <- [x..x+w-1], py <- [y..y+h-1]]) bg where
+                  outBounds ((px,py),_) = (px < x) || (px >= (x+w)) || (py < y) || (py >= (y+h))
+--  fillMapRect x y w h t (Map d xs bg) = Map d redirectInBounds bg where
+--    redirectInBounds = (\p -> if (inBounds p) then t else xs p)
+--    inBounds (px,py) = (px >= x) && (px < (x+w)) && (py >= y) && (py < (y+h))
+  
\ No newline at end of file
@@ -0,0 +1,59 @@
+module Fallen.Map.Overworld
+( initOverworld
+) where
+  import Fallen.Map
+  import Fallen.Tiles
+  import System.Random
+  import Fallen.Util
+  import Fallen.Point
+  
+  -- initOverworld : generate the overworld
+  initOverworld rg = do
+    let m = emptyMap 150 150 Forest -- create map
+    let m' = fillMapRect 0 0 150 150 Grass m -- fill with grass
+    let (tr,rg1) = randomR (1,50) rg :: (Int,StdGen)
+    let (lr,rg2) = randomR (1,50) rg1 :: (Int,StdGen)
+    let (rr,rg3) = randomR (1,50) rg2 :: (Int,StdGen)
+    let (br,rg4) = randomR (1,50) rg3 :: (Int,StdGen)
+    let (m'',rg5) = roughen 150 tr lr rr br rg4 m' -- add surrounding forest
+    let (clumps,rg6) = randomR (30,60) rg5 :: (Int,StdGen)
+    let (m2,rg7) = drawClumps clumps rg6 m''
+    (m2,rg7)
+  
+  -- roughen : create the rough forest edges of the overworld
+  roughen 0 _ _ _ _ rg m = (m,rg)
+  roughen w tr lr rr br rg m = do
+          let m' = fillMapRect (w-1) 0 1 tr Forest m
+          let m'' = fillMapRect 0 (w-1) lr 1 Forest m'
+          let m2 = fillMapRect (150-rr-1) (w-1) rr 1 Forest m''
+          let m2' = fillMapRect (w-1) (150-br-1) 1 br Forest m2
+          let (str,rg1) = randomR (-2,2) rg :: (Int,StdGen)
+          let (slr,rg2) = randomR (-2,2) rg1 :: (Int,StdGen)
+          let (srr,rg3) = randomR (-2,2) rg2 :: (Int,StdGen)
+          let (sbr,rg4) = randomR (-2,2) rg3 :: (Int,StdGen)
+          roughen (w-1) (bound tr str) (bound lr slr) (bound rr srr) (bound br sbr) rg4 m2' where
+      bound r s
+        | r + s < 1 = 1
+        | r + s > 50 = 50
+        | otherwise = r + s
+  
+  -- drawClumps : add in clumps of rocks, water, and trees
+  clumpTypes = [Rock, Water, Forest]
+  clumpOver = [Rock, Water, Forest, Grass]
+  drawClumps 0 rg m = (m,rg)
+  drawClumps num rg m = do
+    let (area,rg1) = randomR (1,300) rg :: (Int,StdGen)
+    let (clumpType,rg2) = randomSetElement rg1 clumpTypes
+    let (startPoint,rg3) = randomPoint 0 0 149 149 rg2
+    let (m',rg4) = drawClump area clumpType startPoint m rg3
+    drawClumps (num-1) rg4 m'
+  drawClump 0 clumpType p m rg = (updateMap p clumpType m,rg)
+  drawClump area clumpType p m rg = do
+    let m' = updateMap p clumpType m
+    let legalDirs = legalMoves m' p clumpOver
+    if null legalDirs
+      then (m',rg)
+      else do
+        let (nextDir,rg1) = randomSetElement rg legalDirs
+        let nextPoint = stepInDirection p nextDir
+        drawClump (area-1) clumpType nextPoint m' rg1
\ No newline at end of file
@@ -0,0 +1,58 @@
+module Fallen.Point
+( Point,
+  Direction(North, South, East, West),
+  directions,
+  distance,
+  stepInDirection,
+  opposite,
+  randomPoint,
+  dirToPoint
+) where
+  import System.Random
+  
+  type Point = (Int, Int)
+  data Direction = North | South | East | West deriving (Show)
+  
+  -- directions :: [Direction]
+  directions = [North, South, East, West]
+  
+  -- distance :: Point -> Point -> Int
+  distance (x1, y1) (x2, y2) = ceiling . sqrt . fromIntegral $ (x1-x2)^2 + (y1-y2)^2
+  
+  -- stepInDirection :: Point -> Direction -> Point
+  stepInDirection (x, y) dir = case dir of
+    North -> (x, y-1)
+    South -> (x, y+1)
+    East -> (x+1, y)
+    West -> (x-1, y)
+  
+  -- opposite :: Direction -> Direction
+  opposite dir = case dir of
+    North -> South
+    South -> North
+    East -> West
+    West -> East
+  
+  -- randomPoint :: Int -> Int -> Int -> Int -> IO Point
+  randomPoint minX minY maxX maxY rg = do
+    let (x,rg1) = randomR (minX, maxX) rg :: (Int,StdGen)
+    let (y,rg2) = randomR (minY, maxY) rg1  :: (Int,StdGen)
+    ((x,y),rg2)
+  
+  -- dirToPoint :: Point -> Point -> [Direction]
+  dirToPoint p1 p2 = horizDirToPoint p1 p2 ++ vertDirToPoint p1 p2 where
+    horizDirToPoint (x1,y1) (x2,y2) = case compare x1 x2 of
+      LT -> [East]
+      EQ -> []
+      GT -> [West]
+    vertDirToPoint (x1,y1) (x2,y2) = case compare y1 y2 of
+      LT -> [North]
+      EQ -> []
+      GT -> [South]
+  
+  instance Eq Direction where
+    North == North = True
+    South == South = True
+    East == East = True
+    West == West = True
+    _ == _ = False
@@ -0,0 +1,30 @@
+module Fallen.Tiles
+( Tile(Grass, Earth, Passage, Floor, Forest, Rock, Water),
+  drawTile,
+  passableTiles
+) where
+  import UI.HSCurses.CursesHelper
+  
+  data Tile = Grass | Earth | Passage | Floor | Forest | Rock | Water deriving (Show)
+  
+  instance Eq Tile where
+    Grass == Grass = True
+    Earth == Earth = True
+    Passage == Passage = True
+    Floor == Floor = True
+    Forest == Forest = True
+    Rock == Rock = True
+    Water == Water = True
+    _ == _ = False
+  
+  drawCharWithColor ch color = toEnum $ fromEnum ch
+    
+  drawTile Grass = drawCharWithColor '.' GreenF
+  drawTile Earth = drawCharWithColor ' ' BlackF
+  drawTile Passage = drawCharWithColor '.' GreyF
+  drawTile Floor = drawCharWithColor '.' GreyF
+  drawTile Forest = drawCharWithColor '~' GreenF
+  drawTile Rock = drawCharWithColor '*' GreyF
+  drawTile Water = drawCharWithColor '~' BlueF
+  
+  passableTiles = [Grass, Passage, Floor]
\ No newline at end of file
@@ -0,0 +1,8 @@
+module Fallen.Util
+( randomSetElement
+) where
+  import System.Random
+  
+  randomSetElement rg set = do
+    let (index,rg') = randomR (0,length set - 1) rg :: (Int,StdGen)
+    (set !! index, rg')
\ No newline at end of file