Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Haskell Shadowcasting
{-# LANGUAGE TupleSections #-}
module RL.FOV where
import Control.Monad
import Control.Monad.ST
import Data.Array.IArray
import Data.Array.MArray
import Data.Array.ST
import Data.Array.Unboxed
import RL.Types
slopeStart :: (Row, Col) -> Double
slopeStart (r, c) = (fromIntegral c - 0.5) / (fromIntegral r + 0.5)
slopeEnd :: (Row, Col) -> Double
slopeEnd (r, c) = (fromIntegral c + 0.5) / (fromIntegral r - 0.5)
slope :: (Row, Col) -> Double
slope (r, c) = fromIntegral c / fromIntegral r
type ScanLines = [[(Row, Col)]]
scanLines :: ScanLines
scanLines = map (\x -> map (x,) [x, (x-1) .. 0]) [1..]
scanEnd :: (Row, Col) -> ScanLines -> ScanLines
scanEnd n = map (filter ((> slopeEnd n) . slopeEnd))
scanStart :: (Row, Col) -> ScanLines -> ScanLines
scanStart n = map (filter ((< slopeStart n) . slopeStart))
data Dir8 = N8 | NE8 | E8 | SE8 | S8 | SW8 | W8 | NW8 deriving (Eq, Enum)
rotate :: Dir8 -> (Row, Col) -> (Row, Col)
rotate N8 (x, y) = (-x, y)
rotate NE8 (x, y) = (-y, x)
rotate E8 (x, y) = (y, x)
rotate SE8 pos = pos
rotate S8 (x, y) = (x, -y)
rotate SW8 (x, y) = (y, -x)
rotate W8 (x, y) = (-y, -x)
rotate NW8 (x, y) = (-x, -y)
translate :: (Row, Col) -> (Row, Col) -> (Row, Col)
translate (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
transform :: Dir8 -> (Row, Col) -> (Row, Col) -> (Row, Col)
transform dir off pos = translate (rotate dir pos) off
data Octant = Oct Int Dir8 (Row, Col)
scan :: Octant -> UArray (Row, Col) Bool -> STUArray s (Row, Col) Bool -> ScanLines -> ST s ()
scan _ _ _ ([] : lines) = return ()
scan oct@(Oct dist dir off) opacity visible scanLines@((top:_) : _) = go scanLines
where
go ([] : lines) = scan oct opacity visible lines
go ((pos@(r,c) : line) : lines)
| r > dist = return ()
| not (bounds opacity `inRange` toArray (r, 0)) = return ()
| not (bounds opacity `inRange` toArray pos) = go (line : lines)
| not (isOpaque pos) = makeVisible pos >> go (line : lines)
| otherwise = do
makeVisible pos
when (not (pos == top)) $ scan oct opacity visible (scanEnd pos lines)
let (wall, line') = span isOpaque line
mapM_ makeVisible wall
case line' of
[] -> return ()
((r', c'):_) -> go $ scanStart (r', c'+1) (line' : lines)
toArray = transform dir off
makeVisible p = writeArray visible (toArray p) True
isOpaque p = opacity ! toArray p
shadowCast :: (Row, Col) -> UArray (Row, Col) Bool -> UArray (Row, Col) Bool
shadowCast start opacity = runSTUArray $ do
visible <- newArray (bounds opacity) False
forM_ [N8 .. NW8] $ \dir -> do
scan (Oct 100 dir start) opacity visible scanLines
return visible
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.