floors can be rudimentaly built

ideas/general.md

@@ -26,7 +26,7 @@ of account data.
 
 ## View
 
-Cabinet perspective
+Isometric perspective
 
 ## Mechanics
 

src/Floorplan.hs

@@ -0,0 +1,250 @@
+module Floorplan where
+
+import Data.Matrix (Matrix(..))
+import qualified Data.Matrix as M
+import Data.Foldable (find)
+import Data.Maybe (fromMaybe)
+
+import System.Random
+
+import Debug.Trace
+
+data TileState
+  = Wall
+  | Wind
+  | Door
+  | Hall
+  | Offi
+  | Toil
+  | Kitc
+  | Elev
+  | Unde
+  deriving (Eq)
+
+instance Show TileState where
+  show Wall = "#"
+  show Wind = "~"
+  show Door = "+"
+  show Hall = "_"
+  show Offi = "."
+  show Toil = "o"
+  show Kitc = "k"
+  show Elev = "x"
+  show Unde = " "
+
+data FloorConfig = FloorConfig
+  { elevator    :: (Int, Int)
+  , facilities  :: [(Int, Int)]
+  , size        :: (Int, Int)
+  } deriving (Show)
+
+data Boundaries = Boundaries
+  { matmin :: (Int, Int)
+  , matmax :: (Int, Int)
+  } deriving (Show)
+
+buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
+buildHallFloorIO fc = do
+  rand <- newStdGen
+  return $ buildHallFloor fc rand
+
+buildHallFloor :: FloorConfig -> StdGen -> Matrix TileState
+buildHallFloor fc gen =
+  let empty         = emptyFloor fc
+      (g1, withElv) = buildElevator fc (placeHalls gen fc empty)
+      (g2, withIW)  = buildInnerWalls g1 withElv
+      withOW        = buildOuterWalls withIW
+      closed        = closeOffices withOW
+  in  closed
+
+emptyFloor :: FloorConfig -> Matrix TileState
+emptyFloor fc =
+  let (rows, cols) = size fc
+  in  M.matrix rows cols (const Unde)
+
+buildElevator
+  :: FloorConfig
+  -> (StdGen, Matrix TileState)
+  -> (StdGen, Matrix TileState)
+buildElevator fc (gen, emptyFloor) =
+  let (row, col) = elevator fc
+      boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
+      buildShaft = foldl
+        (\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
+        (foldl (\acc coord -> M.setElem Wall coord acc) emptyFloor (boxCoord 2))
+        (boxCoord 5)
+      elvDoor = M.setElem Door (row + 2, col) buildShaft
+  in  (gen, foldl (\acc coord -> M.setElem Elev coord acc) elvDoor (boxCoord 1))
+
+placeHalls
+  :: StdGen
+  -> FloorConfig
+  -> Matrix TileState
+  -> (StdGen, Matrix TileState)
+placeHalls rng fc input =
+  doHalls rng
+   [(Boundaries (1,1) (nrows input, ncols input))]
+   (elevator fc) 5 input
+  where
+    elPos = elevator fc
+    doHalls rand bounds cross wmax mat =
+      let (rnd, gen) = next rand
+      in  foldl (\(agen, amat) b ->
+            let (row, g1)   = randomR (fst (matmin b), fst (matmax b)) agen
+                (col, g2)   = randomR (snd (matmin b), snd (matmax b)) g1
+                (nw, g3)    = randomR (2, wmax) g2
+                (nbs, nmat) = buildHall cross nw b amat
+            in
+              if hallRatio nmat < 0.5 && wmax - 1 > 2
+              then doHalls g3 nbs (row, col) (wmax -1) nmat
+              else (g3, nmat)
+            ) (rand, mat) bounds
+
+boundSize :: Boundaries -> Int
+boundSize (Boundaries min max) =
+  (fst max - fst min) * (snd max - snd min)
+
+buildHall
+  :: (Int, Int)
+  -> Int
+  -> Boundaries
+  -> Matrix TileState
+  -> ([Boundaries], Matrix TileState)
+buildHall coord@(row, col) width bounds mat =
+  let vertHalls = foldl (\acc c -> M.mapCol
+        (\r cur -> if r >= fst (matmin bounds) && r <= fst (matmax bounds)
+          then replaceTile cur Hall
+          else cur
+          ) c acc)
+        mat
+        [col - (width `div` 2) .. col + (width `div` 2)]
+      horzHalls = foldl (\acc r -> M.mapRow
+        (\c cur -> if c >= snd (matmin bounds) && c <= snd (matmax bounds)
+          then replaceTile cur Hall
+          else cur
+          ) r acc)
+        vertHalls
+        [row - (width `div` 2) .. row + (width `div` 2)]
+  in  ( [ Boundaries (matmin bounds) coord
+        , Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds))
+        , Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col)
+        , Boundaries coord (matmax bounds)
+        ]
+      , horzHalls
+      )
+
+replaceTile :: TileState -> TileState -> TileState
+replaceTile cur new
+  | cur == Unde = new
+  | otherwise   = cur
+
+hallRatio :: Matrix TileState -> Double
+hallRatio mat =
+  let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 mat
+  in  fromIntegral hs / fromIntegral (nrows mat * ncols mat)
+
+buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
+buildInnerWalls rng input =
+  let floodSearchReplace
+        :: StdGen
+        -> (Int, Int)
+        -> Matrix TileState
+        -> (StdGen, Matrix TileState)
+      floodSearchReplace gn coord@(row, col) mat
+        | mat M.! coord == Unde =
+          let maxRow = doRow row
+              doRow r
+                | M.safeGet (r + 1) col mat == Just Unde = doRow (r + 1)
+                | otherwise = r
+              maxCol = doCol col
+              doCol c
+                | M.safeGet row (c + 1) mat == Just Unde = doCol (c + 1)
+                | otherwise = c
+              (cr, g1) = randomR (row, maxRow) gn
+              (cc, g2) = randomR (col, maxCol) g1
+              (nngen, nnmat) = doCross
+                g2
+                (cr, cc)
+                (Boundaries coord (maxRow, maxCol))
+                mat
+              doCross
+                :: StdGen
+                -> (Int, Int)
+                -> Boundaries
+                -> Matrix TileState
+                -> (StdGen, Matrix TileState)
+              doCross gen coord@(xr, xc) b imat =
+                let nbs = map (\(min, max) -> Boundaries min max) bounds
+                    bounds =
+                      [ (matmin b, coord)
+                      , ((fst (matmin b), col), (row, snd (matmax b)))
+                      , ((row, snd (matmin b)), (fst (matmax b), col))
+                      , (coord, matmax b)
+                      ]
+                    (ngen, crosses) = foldl
+                      (\(agen, acc) (minb, maxb) ->
+                        let (fc, g1) = randomR (fst minb, fst maxb) agen
+                            (fr, g2) = randomR (snd minb, snd maxb) g1
+                        in  (g2, acc ++ [(fc, fr)])
+                        ) (gen, []) bounds
+                    horz = M.mapRow (\icol cur ->
+                      if icol >= snd (matmin b) && icol <= snd (matmax b)
+                      then replaceTile cur Wall
+                      else cur
+                      ) xr imat
+                    vert = M.mapCol (\irow cur ->
+                      if irow >= fst (matmin b) && irow <= fst (matmax b)
+                      then replaceTile cur Wall
+                      else cur
+                      ) xc horz
+                    omat = foldl
+                      (\acc coords ->
+                        M.setElem (replaceTile (acc M.! coords) Offi) coords acc
+                        ) vert btups
+                    btups = (,)
+                      <$> [fst (matmin b) .. fst (matmax b)]
+                      <*> [snd (matmin b) .. snd (matmax b)]
+                in if trace ("bs: " ++ show (boundSize b)) (boundSize b) >= 16
+                   then foldl
+                     (\(agen, amat) (cr, nb) -> doCross agen cr nb amat)
+                     (ngen, omat)
+                     (zip crosses nbs)
+                   else trace
+                     ("built cross at " ++ show coord ++ " within " ++ show b)
+                     (gen, omat)
+          in  (nngen, nnmat)
+        | otherwise = (gn, mat)
+      tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
+  in  foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
+        (rng, input) (tups input)
+
+closeOffices :: Matrix TileState -> Matrix TileState
+closeOffices input =
+  let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
+      isNeighbor (row, col) =
+        let subm = M.submatrix (row -1) (row + 1) (col - 1) (col + 1) input
+        in  any (== Hall) (M.toList subm)
+  in  foldl (\acc coord ->
+        if input M.! coord == Offi && isNeighbor coord
+        then M.setElem Wall coord acc
+        else acc
+        ) input (tups input)
+
+buildOuterWalls :: Matrix TileState -> Matrix TileState
+buildOuterWalls input =
+  let horz :: Matrix TileState
+      horz =
+        foldl
+        (\amat r -> M.mapRow (\_ _ -> Wall) r amat)
+        input
+        [ 1
+        , nrows input
+        ]
+      vert =
+        foldl
+        (\amat c -> M.mapCol (\_ _ -> Wall) c amat)
+        horz
+        [ 1
+        , ncols horz
+        ]
+  in  vert

src/Types/UserData.hs

@@ -47,6 +47,7 @@ data Entity f = Entity
   { pos    :: Component f 'Field (V2 Float)
   , vel    :: Component f 'Field (V2 Float)
   , rot    :: Component f 'Field Direction
+  , player :: Component f 'Unique Bool
   }
   deriving (Generic)
 

tracer-game.cabal

@@ -20,6 +20,7 @@ executable tracer-game
   other-modules:       Types
                      , Types.UserData
                      , StateMachine
+                     , Floorplan
                      , Init
   default-extensions:  OverloadedStrings
                      , DeriveGeneric
@@ -35,5 +36,7 @@ executable tracer-game
                      , containers
                      , ecstasy
                      , linear
+                     , matrix
+                     , random
   hs-source-dirs:      src
   default-language:    Haskell2010