{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
module Imj.Game.Hamazed.World.Space
( Space
, Material(..)
, mkEmptySpace
, mkDeterministicallyFilledSpace
, mkRandomlyFilledSpace
, RandomParameters(..)
, Strategy(..)
, location
, scopedLocation
, Boundaries(..)
, renderSpace
, createRandomNonCollidingPosSpeed
, module Imj.Graphics.Render
) where
import Imj.Prelude
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Reader.Class(MonadReader)
import System.Console.Terminal.Size( Window(..) )
import Data.Graph( Graph
, graphFromEdges
, components )
import Data.List(length, group, concat, mapAccumL)
import Data.Maybe(mapMaybe)
import Data.Matrix( getElem
, fromLists
, getMatrixAsVector
, Matrix
, nrows, ncols )
import Data.Vector(Vector, slice, (!))
import Foreign.C.Types( CInt(..) )
import Imj.Game.Hamazed.Color
import Imj.Game.Hamazed.World.Space.Types
import Imj.Geo.Discrete
import Imj.Graphics.Render
import Imj.Physics.Discrete
import Imj.Util
createRandomNonCollidingPosSpeed :: Space -> IO PosSpeed
createRandomNonCollidingPosSpeed space = do
pos <- randomNonCollidingPos space
dx <- randomSpeed
dy <- randomSpeed
return $ fst
$ mirrorSpeedAndMoveToPrecollisionIfNeeded (`location` space)
$ PosSpeed pos (Coords (Coord dx) (Coord dy))
oneRandom :: Int -> Int -> IO Int
oneRandom a b = do
r <- randomRsIO a b
return $ head $ take 1 r
randomSpeed :: IO Int
randomSpeed = oneRandom (-1) 1
randomNonCollidingPos :: Space -> IO (Coords Pos)
randomNonCollidingPos space@(Space _ worldSize _) = do
coords <- randomCoords worldSize
case getMaterial coords space of
Wall -> randomNonCollidingPos space
Air -> return coords
randomInt :: Int -> IO Int
randomInt sz =
oneRandom 0 (sz-1)
randomCoords :: Size -> IO (Coords Pos)
randomCoords (Size rs cs) = do
r <- randomCoord $ fromIntegral rs
c <- randomCoord $ fromIntegral cs
return $ Coords r c
randomCoord :: Coord a -> IO (Coord a)
randomCoord (Coord sz) = Coord <$> randomInt sz
forEachRowPure :: Matrix CInt -> Size -> (Coord Row -> (Coord Col -> Material) -> b) -> [b]
forEachRowPure mat (Size nRows nColumns) f =
let rowIndexes = [0..fromIntegral $ nRows-1]
internalRowLength = nInternalColumns
rowLength = internalRowLength - 2
nInternalColumns = nColumns + 2
matAsOneVector = flatten mat
in map (\rowIdx -> do
let internalRowIdx = succ rowIdx
startInternalIdx = fromIntegral internalRowIdx * fromIntegral nInternalColumns :: Int
startIdx = succ startInternalIdx
row = slice startIdx (fromIntegral rowLength) matAsOneVector
f rowIdx (\c -> mapInt $ row ! fromIntegral c)) rowIndexes
mapMaterial :: Material -> CInt
mapMaterial Air = 0
mapMaterial Wall = 1
mapInt :: CInt -> Material
mapInt 0 = Air
mapInt 1 = Wall
mapInt _ = error "mapInt arg out of bounds"
mkEmptySpace :: Size -> Space
mkEmptySpace s =
let air = mapMaterial Air
in mkSpaceFromInnerMat s [[air]]
mkDeterministicallyFilledSpace :: Size -> Space
mkDeterministicallyFilledSpace s@(Size heightEmptySpace widthEmptySpace) =
let wall = mapMaterial Wall
air = mapMaterial Air
w = fromIntegral widthEmptySpace
h = fromIntegral heightEmptySpace
middleRow = replicate w air
collisionRow = replicate 2 air ++ replicate (w-4) wall ++ replicate 2 air
ncolls = 8 :: Int
nEmpty = h - ncolls
n1 = quot nEmpty 2
n2 = nEmpty - n1
l = replicate n1 middleRow ++ replicate ncolls collisionRow ++ replicate n2 middleRow
in mkSpaceFromInnerMat s l
mkRandomlyFilledSpace :: RandomParameters -> Size -> IO Space
mkRandomlyFilledSpace (RandomParameters blockSize strategy) s = do
smallWorldMat <- mkSmallWorld s blockSize strategy
let innerMat = replicateElements blockSize $ map (replicateElements blockSize) smallWorldMat
return $ mkSpaceFromInnerMat s innerMat
mkSmallWorld :: Size
-> Int
-> Strategy
-> IO [[CInt]]
mkSmallWorld s@(Size heightEmptySpace widthEmptySpace) multFactor strategy = do
let nCols = quot widthEmptySpace $ fromIntegral multFactor
nRows = quot heightEmptySpace $ fromIntegral multFactor
mkRandomRow _ = take (fromIntegral nCols) <$> rands
smallMat <- mapM mkRandomRow [0..nRows-1]
let mat = fromLists smallMat
graph = graphOfIndex (mapMaterial Air) mat
case strategy of
StrictlyOneComponent -> case components graph of
[_] -> return smallMat
_ -> mkSmallWorld s multFactor strategy
graphOfIndex :: CInt -> Matrix CInt -> Graph
graphOfIndex matchIdx mat =
let sz@(nRows,nCols) = size mat
coords = [Coords (Coord r) (Coord c) | c <-[0..nCols-1], r <- [0..nRows-1], mat `at` (r, c) == matchIdx]
edges = map (\c -> (c, c, connectedNeighbours matchIdx c mat sz)) coords
(graph, _, _) = graphFromEdges edges
in graph
size :: Matrix a -> (Int, Int)
size mat = (nrows mat, ncols mat)
flatten :: Matrix a -> Vector a
flatten = getMatrixAsVector
at :: Matrix a -> (Int, Int) -> a
at mat (i, j) = getElem (succ i) (succ j) mat
connectedNeighbours :: CInt -> Coords Pos -> Matrix CInt -> (Int, Int) -> [Coords Pos]
connectedNeighbours matchIdx coords mat (nRows,nCols) =
let neighbours = [translateInDir LEFT coords, translateInDir Down coords]
in mapMaybe (\other@(Coords (Coord r) (Coord c)) ->
if r < 0 || c < 0 || r >= nRows || c >= nCols || mat `at` (r, c) /= matchIdx
then
Nothing
else
Just other) neighbours
mkSpaceFromInnerMat :: Size -> [[CInt]] -> Space
mkSpaceFromInnerMat s innerMatMaybeSmaller =
let innerMat = extend s innerMatMaybeSmaller
mat = fromLists $ addBorder s innerMat
in Space mat s $ matToRenderGroups mat s
extend :: Size -> [[a]] -> [[a]]
extend (Size rs cs) mat =
extend' (fromIntegral rs) $ map (extend' $ fromIntegral cs) mat
extend' :: Int -> [a] -> [a]
extend' _ [] = error "extend empty list not supported"
extend' sz l@(_:_) =
let len = length l
addsTotal = sz - assert (len <= sz) len
addsLeft = quot addsTotal 2
addsRight = addsTotal - addsLeft
in replicate addsLeft (head l) ++ l ++ replicate addsRight (last l)
rands :: IO [CInt]
rands = randomRsIO 0 1
addBorder :: Size -> [[CInt]] -> [[CInt]]
addBorder (Size _ widthEmptySpace) l =
let nCols = fromIntegral widthEmptySpace + 2 * borderSize
wall = mapMaterial Wall
wallRow = replicate nCols wall
encloseIn b e = b ++ e ++ b
in encloseIn (replicate borderSize wallRow) $ map (encloseIn $ replicate borderSize wall) l
borderSize :: Int
borderSize = 1
matToRenderGroups :: Matrix CInt -> Size -> [RenderGroup]
matToRenderGroups mat s@(Size _ cs) =
concat $
forEachRowPure mat s $
\row accessMaterial ->
snd $ mapAccumL
(\col listMaterials@(material:_) ->
let count = length listMaterials
materialColor = case material of
Wall -> wallColors
Air -> airColors
materialChar = case material of
Wall -> 'Z'
Air -> ' '
in (col + fromIntegral count,
RenderGroup (Coords row col) materialColor materialChar count))
(Coord 0) $ group $ map accessMaterial [0..fromIntegral $ pred cs]
getInnerMaterial :: Coords Pos -> Space -> Material
getInnerMaterial (Coords (Coord r) (Coord c)) (Space mat _ _) =
mapInt $ mat `at` (r+borderSize, c+borderSize)
getMaterial :: Coords Pos -> Space -> Material
getMaterial coords@(Coords r c) space@(Space _ (Size rs cs) _)
| r < 0 || c < 0 = Wall
| r > fromIntegral(rs-1) || c > fromIntegral(cs-1) = Wall
| otherwise = getInnerMaterial coords space
materialToLocation :: Material -> Location
materialToLocation m = case m of
Wall -> OutsideWorld
Air -> InsideWorld
location :: Coords Pos -> Space -> Location
location c s = materialToLocation $ getMaterial c s
strictLocation :: Coords Pos -> Space -> Location
strictLocation coords@(Coords r c) space@(Space _ (Size rs cs) _)
| r < 0 || c < 0 || r > fromIntegral(rs-1) || c > fromIntegral(cs-1) = InsideWorld
| otherwise = materialToLocation $ getInnerMaterial coords space
{-# INLINABLE renderSpace #-}
renderSpace :: (Draw e, MonadReader e m, MonadIO m)
=> Space
-> Coords Pos
-> m (Coords Pos)
renderSpace (Space _ _ renderedWorld) upperLeft = do
let worldCoords = move borderSize Down $ move borderSize RIGHT upperLeft
mapM_ (renderGroup worldCoords) renderedWorld
return worldCoords
{-# INLINABLE renderGroup #-}
renderGroup :: (Draw e, MonadReader e m, MonadIO m)
=> Coords Pos
-> RenderGroup
-> m ()
renderGroup worldCoords (RenderGroup pos colors char count) =
drawChars count char (sumCoords pos worldCoords) colors
scopedLocation :: Space
-> Maybe (Window Int)
-> Coords Pos
-> Boundaries
-> Coords Pos
-> Location
scopedLocation space@(Space _ sz _) mayTermWindow wcc =
let worldLocation = (`location` space)
worldLocationExcludingBorders = (`strictLocation` space)
(Window h w) = fromMaybe (Window {height = 150, width = 400}) mayTermWindow
terminalLocation coordsInWorld =
let (Coords (Coord r) (Coord c)) = sumCoords coordsInWorld wcc
in if r >= 0 && r < h && c >= 0 && c < w
then
InsideWorld
else
OutsideWorld
productLocations l l' = case l of
InsideWorld -> l'
OutsideWorld -> OutsideWorld
in \case
WorldFrame -> worldLocation
TerminalWindow -> (\coo-> if containsWithOuterBorder coo sz
then
OutsideWorld
else
terminalLocation coo)
Both -> (\coo-> productLocations (terminalLocation coo) (worldLocationExcludingBorders coo))