Create a gist now

Instantly share code, notes, and snippets.

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