Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Haskell Shadowcasting

View FOV.hs
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
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.