public
Created

Haskell Shadowcasting

  • Download Gist
FOV.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
{-# 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.