scroll-1.20150313: Level/Border.hs

{-# LANGUAGE RankNTypes #-}

module Level.Border (border, isBoundry, addBorder, addCap, joinCap, checkBounded) where

import qualified Data.Vector as V
import Data.Vector ((!))
import qualified Data.Vector.Mutable as MV
import Control.Monad.ST
import Control.Monad
import Data.Monoid
import Data.Char
import Control.Applicative

import Types

addBorder :: Level -> V.Vector (V.Vector Char)
addBorder = padForCap . erodeLeftEdge . V.modify transform
	. V.fromList . map V.fromList 
	. trimTrailingEmptyLines
	. padSameWidth . map deTab

border :: Char
border = '|'

cap :: Char
cap = '_'

isBorder :: Char -> Bool
isBorder c = c == border

isCap :: Char -> Bool
isCap c = c == cap

isBoundry :: Char -> Bool
isBoundry c = isBorder c || isCap c

deTab :: String -> String
deTab = concatMap go
  where
	go '\t' = replicate 8 ' '
	go c = [c]

padSameWidth :: [String] -> [String]
padSameWidth l = map pad l
  where
	width = maximum (map length l)
	pad s = let w = length s
		in s ++ replicate (width - w) ' '

-- Trailing empty lines break the border generation, so remove.
trimTrailingEmptyLines :: [String] -> [String]
trimTrailingEmptyLines = reverse . dropWhile (all isSpace) . reverse

type Transform = forall s. MV.MVector s (V.Vector Char) -> ST s ()

transform :: Transform
transform v = sequence_ $ map (\a -> a v)
	[ constrict
	, outsideBorder
	, widenHalls
	, openPasses
	, erodeEdge
	]

constrict :: Transform
constrict v
	| MV.length v == 0 = return ()
	| otherwise = do
		l1 <- MV.read v 0
		-- When constricting, leave at least the center fifth free.
		-- This keeps centered headers from being constricted to
		-- much.
		let maxconstrict = V.length l1 - 1
		loop 0 maxconstrict
  where
	loop y maxconstrict
		| y >= MV.length v = return ()
		| otherwise = do
			l <- MV.read v y
			let l' = V.modify (go maxconstrict) l
			MV.write v y l'
			loop (y + 1) maxconstrict
	
	go maxconstrict lv = do
		loopy id maxconstrict lv 0
		loopy (\n -> MV.length lv - 1 - n) maxconstrict lv 0
	
	loopy f maxconstrict lv n
		| n <= maxconstrict = do
			let x = f n
			c <- MV.read lv x
			if isSpace c
				then do
					MV.write lv x '|'
					loopy f maxconstrict lv (n + 1)
				else return ()
		| otherwise = return ()

-- Constrict over-does it for blank lines. Widen them back out,
-- to be as wide as the line below them. Note that we work from
-- the bottom up, so that multiple blank lines all open as wide
-- as the text below.
--
-- If the whole level ends with a blank line or lines, they're also
-- windened into halls, based on the first non-blank line above.
widenHalls :: Transform
widenHalls v = do
	forM_ (reverse [0..MV.length v - 2]) $ \y -> do
		lv <- MV.read v y
		when (isHall lv) $ do
			below <- MV.read v (y + 1)
			MV.write v y $ hallAbove below

hallAbove :: V.Vector Char -> V.Vector Char
hallAbove = V.map (\c -> if isBorder c then c else ' ')

-- Note that lines that are somehow all border are treated as halls,
-- which is good, since otherwise there would be no way through!
isHall :: V.Vector Char -> Bool
isHall = V.all isSpace . deBorderLeft . V.reverse . deBorderLeft

deBorderLeft :: V.Vector Char -> V.Vector Char
deBorderLeft = V.dropWhile isBorder

deBorderRight :: V.Vector Char -> V.Vector Char
deBorderRight = V.reverse . deBorderLeft . V.reverse

-- Often there will be a long line, like this one.||||
-- that is followed by a shorter line.||||||||||||||||
--
-- This can happen at the end of a||||||||
-- paragraph, but also||||||||||||||||||||
-- sometimes in the middle of one.||||||||
--
-- In this case, the border goes too far in and makes the game
-- too hard, so open up a pass.
--
-- We'll only do it if the shorter line is at least 3 letters
-- shorter than the longer.
openPasses :: Transform
openPasses v = forM_ [0..MV.length v - 2] $ \y -> do
	lv <- MV.read v y
	below <- MV.read v (y + 1)
	let belowc = countborder below
	let delta = countborder lv - belowc
	when (delta >= 3) $ do
		let lv' = V.concat
			[ deBorderRight lv
			, V.replicate (delta - 1) ' '
			, V.replicate (belowc + 1) border
			]
		MV.write v y lv'
  where
	countborder = V.length . V.takeWhile isBorder . V.reverse

outsideBorder :: Transform
outsideBorder v = forM_ [0..MV.length v - 1] $ \y -> do
	lv <- MV.read v y
	let lv' = V.cons border $ V.snoc lv border
	MV.write v y lv'

erodeEdge :: Transform
erodeEdge v = do
	looplines v erodeRight
	looplines v addArt

-- inefficient
erodeLeftEdge :: V.Vector (V.Vector Char) -> V.Vector (V.Vector Char)
erodeLeftEdge = V.map (V.reverse) . V.modify erodeEdge . V.map (V.reverse) 

data Area = Area
	{ areaAbove :: V.Vector Char
	, areaHere :: V.Vector Char
	, areaBelow :: V.Vector Char
	}
	deriving (Show)

type AreaTransformer = forall s. Area -> Int -> MV.MVector s Char -> ST s ()

looplines
	:: forall s. MV.MVector s (V.Vector Char)
	-> AreaTransformer
	-> ST s ()
looplines v f = forM_ [0..MV.length v - 1] $ \y -> do
	area <- Area
		<$> saferead (pred y)
		<*> MV.read v y
		<*> saferead (succ y)
	MV.write v y $ V.modify (f area (V.length (areaHere area) - 1))
		(areaHere area)
  where
	saferead y
		| y >= 0 && y <= MV.length v - 1 = MV.read v y
		-- use a dummy, all blank line at top and bottom
		| otherwise = V.map (\_ -> ' ') <$> MV.read v 0

-- The border can be eroded away, as long as there is other border inside
-- it, both on its line, and above and below it.
--
-- Or, the lines above or below may have whitespace, which continues
-- till the end of the line.
--
--         |     |       |         |
--         || -> |       |||||| -> |
--         |     |       |||||     |||||
erodeRight :: AreaTransformer
erodeRight area x mv
	| x < 2 = return ()
	| bordering (areaHere area) && bwhite (areaAbove area) && bwhite (areaBelow area) = do
		MV.write mv x ' '
		erodeRight area (x-1) mv
	| otherwise = return ()
  where
	bordering vec = isBorder (vec ! pred x)
	bwhite vec = bordering vec || V.all isSpace (V.drop x vec)

-- After erosion is finished, go back through and find corners in
-- the border, inserting some additional ascii art.
--
--      |     |,    ||    ||
--      || -> ||    |  -> |`
addArt :: AreaTransformer
addArt area x mv
	| x < 2 = return ()
	| isBorder (areaHere area ! x) = return () 
	| isSpace (areaHere area ! pred x) = addArt area (pred x) mv
	| isBorder (areaAbove area ! x) = MV.write mv x '`'
	| isBorder (areaBelow area ! x) = MV.write mv x ','
	| otherwise = return ()

padForCap :: V.Vector (V.Vector Char) -> V.Vector (V.Vector Char)
padForCap = V.map pad
  where
	pad l = V.replicate 2 ' ' <> l <> V.replicate 2 ' '

addCap :: forall s. MV.MVector s (MV.MVector s Char) -> ST s ()
addCap v = do
	len <- MV.length <$> MV.read v 0
	let mid = replicate (len - 6) '_'
	let a ... b = a ++ mid ++ b
	let cap1 = vec $ "  _"..."_  "
	let cap2 = vec $ "=(_"..."_)="

	MV.write v 0 =<< cap1
	MV.write v 1 =<< cap2
	above <- V.freeze =<< MV.read v (end - 2)
	c <- cap1
	joinCap above c
	MV.write v (end-1) c
	MV.write v end =<< cap2
  where
	vec = V.thaw . V.fromList
	end = MV.length v - 1

-- Updates the line that joins the cap to the bottom of the scroll,
-- drawing border symbols to match the line just above.
--
--       | lorem ipsum dolor ||||||||||||||| 
--   ____|___________________|||||||||||||||_______
-- =(______________________________________________)=
--
-- Also inserts some spaces in the line, as both ascii art and to let
-- the player get into the scroll endcap area. (But, they can only
-- get there if a message is displayed.) That is how the game is won!
--
-- This needs to be called each time the scroll is rolled up more.
joinCap :: forall s. V.Vector Char -> MV.MVector s Char -> ST s ()
joinCap above v = forM_ [2..V.length above - 3] $ \x ->
	MV.write v x (joiner x)
  where
	leftborder = findborder above
	rightborder = V.length above - 1 - findborder (V.reverse above)
	findborder = V.length . V.takeWhile (not . isBorder)
	dashy x = x == leftborder + 1 || x == rightborder -1 || x `mod` 5 == 0 || pred x `mod` 5 == 0
	joiner x = 
		if isBorder (above ! x) || x == leftborder || x == rightborder
			then border
			else if dashy x || x < leftborder || x > rightborder
				then cap
				else ' '

-- Check that the specified posixition has border to the left and right,
-- and is not itself embedded in a border, and is empty.
checkBounded :: World -> Pos -> ST RealWorld Bool
checkBounded w (x,y) = do
	l <- MV.read w y
	if x >= MV.length l
		then return False
		else do
			c <- MV.read l x
			if not (isSpace c)
				then return False
				else do
					let len = MV.length l - 1
					ok <- searchBoundry x l succ len
					if ok
						then searchBoundry x l pred len
						else return False

searchBoundry :: forall s. Int -> MV.MVector s Char -> (Int -> Int) -> Int -> ST s Bool
searchBoundry x l f len =
	let x' = f x
	in if x' <= len && x' >= 0
		then do
			c <- MV.read l x'
			if isBoundry c
				then return True
				else searchBoundry x' l f len
		else return False