From e77c8b23c148ffaa5991da18c981e61db2a5e55c Mon Sep 17 00:00:00 2001
From: Kelly Rauchenberger <fefferburbia@gmail.com>
Date: Mon, 1 Apr 2013 23:01:59 -0400
Subject: Initial commit

Haskell version now has most of the functionality from the C++ version, except for color, and
overworld generation is REALLY slow.
---
 Fallen/Map.hs           | 67 +++++++++++++++++++++++++++++++++++++++++++++++++
 Fallen/Map/Dungeon.hs   |  0
 Fallen/Map/Overworld.hs | 59 +++++++++++++++++++++++++++++++++++++++++++
 Fallen/Point.hs         | 58 ++++++++++++++++++++++++++++++++++++++++++
 Fallen/Tiles.hs         | 30 ++++++++++++++++++++++
 Fallen/Util.hs          |  8 ++++++
 Main.hs                 | 48 +++++++++++++++++++++++++++++++++++
 README.md               |  4 +--
 8 files changed, 272 insertions(+), 2 deletions(-)
 create mode 100644 Fallen/Map.hs
 create mode 100644 Fallen/Map/Dungeon.hs
 create mode 100644 Fallen/Map/Overworld.hs
 create mode 100644 Fallen/Point.hs
 create mode 100644 Fallen/Tiles.hs
 create mode 100644 Fallen/Util.hs
 create mode 100644 Main.hs

diff --git a/Fallen/Map.hs b/Fallen/Map.hs
new file mode 100644
index 0000000..96c6467
--- /dev/null
+++ b/Fallen/Map.hs
@@ -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
diff --git a/Fallen/Map/Dungeon.hs b/Fallen/Map/Dungeon.hs
new file mode 100644
index 0000000..e69de29
diff --git a/Fallen/Map/Overworld.hs b/Fallen/Map/Overworld.hs
new file mode 100644
index 0000000..308aad0
--- /dev/null
+++ b/Fallen/Map/Overworld.hs
@@ -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
diff --git a/Fallen/Point.hs b/Fallen/Point.hs
new file mode 100644
index 0000000..321f3b0
--- /dev/null
+++ b/Fallen/Point.hs
@@ -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
diff --git a/Fallen/Tiles.hs b/Fallen/Tiles.hs
new file mode 100644
index 0000000..e64a650
--- /dev/null
+++ b/Fallen/Tiles.hs
@@ -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
diff --git a/Fallen/Util.hs b/Fallen/Util.hs
new file mode 100644
index 0000000..dd01fff
--- /dev/null
+++ b/Fallen/Util.hs
@@ -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
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..4908c59
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,48 @@
+module Main where
+  import Fallen.Point
+  import Fallen.Tiles
+  import Fallen.Map
+  import Fallen.Map.Overworld
+  import System.Random
+  import UI.HSCurses.Curses
+  
+  -- main :: ()
+  main = do
+    rg <- getStdGen
+    let (m,rg') = initOverworld rg
+    initCurses
+    keypad stdScr True
+    echo False
+    cursSet CursorInvisible
+    startColor
+    mainLoop (75,75) m rg'
+    endWin
+  
+  mainLoop player m rg = do
+    render player m
+    input <- getCh
+    case input of
+      KeyLeft -> moveIfPassable player m rg West
+      KeyRight -> moveIfPassable player m rg East
+      KeyUp -> moveIfPassable player m rg North
+      KeyDown -> moveIfPassable player m rg South
+      _ -> putStrLn "endgame"
+  
+  moveIfPassable player m rg dir = do
+    let p' = stepInDirection player dir
+    let t' = getTileAtPos m p'
+    if t' `elem` passableTiles
+      then mainLoop p' m rg
+      else mainLoop player m rg
+  
+  -- render :: Point -> Map -> Window -> ()
+  render (px,py) m = do
+    (h,w) <- scrSize
+    let viewportX = px - quot w 2
+    let viewportY = py - quot h 2
+    let viewport = [(x,y) | y <- [viewportY..viewportY+h-1], x <- [viewportX..viewportX+w-1]]
+    let drawch = drawTile . getTileAtPos m
+    let viewport_ = map (\p@(x,y) -> (p, drawch p)) viewport
+    mapM_ (\((x,y),ch) -> mvAddCh (y-viewportY) (x-viewportX) ch) viewport_
+    mvAddCh (py-viewportY) (px-viewportX) (toEnum $ fromEnum '@')
+    refresh
\ No newline at end of file
diff --git a/README.md b/README.md
index 0bfd78c..ff1a6a0 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,4 @@
-fallen-hs
+The Fallen
 =========
 
-An experimental roguelike written in Haskell
\ No newline at end of file
+An experimental roguelike written in Haskell
-- 
cgit 1.4.1