BorderMap.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Brick.BorderMap
    ( BorderMap
    , Edges(..)
    , eTopL, eBottomL, eRightL, eLeftL
    , empty, clear, emptyCoordinates, singleton
    , insertH, insertV, insert
    , unsafeUnion
    , coordinates, bounds
    , values
    , lookupRow, lookupCol, lookupH, lookupV, lookup
    , setCoordinates, crop, expand
    , translate
    ) where

import Brick.Types.Common (Edges(..), Location(..), eTopL, eBottomL, eRightL, eLeftL, origin)
#if !(MIN_VERSION_base(4,18,0))
import Control.Applicative (liftA2)
#endif
import Data.IMap (IMap, Run(Run))
import GHC.Generics
import Control.DeepSeq
import Prelude hiding (lookup)
import qualified Data.IMap as IM

-- | Internal use only.
neighbors :: Edges a -> Edges (a, a)
neighbors (Edges vt vb vl vr) = Edges horiz horiz vert vert where
    horiz = (vl, vr)
    vert  = (vt, vb)

-- Invariant: corner values are present on all the edges incident on that
-- corner. Widthless or heightless rectangles replicate the IMaps exactly on
-- the two coincident edges.
--
-- Practically speaking, this means for lookup you can look on any edge that
-- could contain the key you care about, while for insertion you must insert on
-- every edge that could contain the keys being inserted.

-- | A @BorderMap a@ is like a @Map Location a@, except that there is a
-- rectangle, and only 'Location's on the border of this rectangle are
-- retained. The 'BorderMap' can be queried for the position and size of the
-- rectangle. There are also efficient bulk query and bulk update operations
-- for adjacent positions on the border.
data BorderMap a = BorderMap
    { _coordinates :: Edges Int
    , _values :: Edges (IMap a)
    } deriving (Eq, Ord, Show, Functor, Read, Generic, NFData)

-- | Given a rectangle (specified as the coordinates of the top, left, bottom,
-- and right sides), initialize an empty 'BorderMap'.
emptyCoordinates :: Edges Int -> BorderMap a
emptyCoordinates cs = BorderMap { _coordinates = cs, _values = pure IM.empty }

-- | An empty 'BorderMap' that tracks the same points as the input.
clear :: BorderMap a -> BorderMap b
clear = emptyCoordinates . coordinates

-- | An empty 'BorderMap' that does not track any points.
empty :: BorderMap a
empty = emptyCoordinates Edges
    { eTop = 0
    , eBottom = -1
    , eLeft = 0
    , eRight = -1
    }

-- | A 'BorderMap' that tracks only the given the point (and initially maps it
-- to the given value).
singleton :: Location -> a -> BorderMap a
singleton l v = translate l . insert origin v . emptyCoordinates $ pure 0

{-# INLINE coordinates #-}
-- | The positions of the edges of the rectangle whose border is retained in a
-- 'BorderMap'. For example, if @coordinates m = e@, then the top border
-- contains the 'Location's on row @eTop e@ and between columns @eLeft e@ to
-- @eRight e@ inclusive.
coordinates :: BorderMap a -> Edges Int
coordinates = _coordinates

-- | A complementary way to query the edges of the rectangle whose border is
-- retained in a 'BorderMap'. For example, if @bounds m = b@, then a
-- 'Location'\'s column must be between @fst (eTop b)@ and @snd (eTop b)@ to be
-- retained. See also 'coordinates', which is in most cases a more natural
-- border query.
bounds :: BorderMap a -> Edges (Int, Int)
bounds = neighbors . coordinates

{-# INLINE values #-}
-- | Maps giving the values along each edge. Corner values are replicated in
-- all relevant edges.
values :: BorderMap a -> Edges (IMap a)
values = _values

-- | Bulk insertion of horizontally-adjacent values. The 'Location' gives the
-- start point, and the 'Run' extends in the "larger columns" direction.
insertH :: Location -> Run a -> BorderMap a -> BorderMap a
insertH = insertDirAgnostic (Edges insertPar insertPar insertPerp insertPerp) . swapLoc
    where
    swapLoc (Location (col, row)) = Location (row, col)

-- | Bulk insertion of vertically-adjacent values. The 'Location' gives the
-- start point, and the 'Run' extends in the "larger rows" direction.
insertV :: Location -> Run a -> BorderMap a -> BorderMap a
insertV = insertDirAgnostic (Edges insertPerp insertPerp insertPar insertPar)

insertDirAgnostic
    :: Edges (Location -> Run a -> Int -> (Int, Int) -> IMap a -> IMap a)
    -> Location -> Run a -> BorderMap a -> BorderMap a
insertDirAgnostic insertions l r m =
    m { _values = insertions <*> pure l <*> pure r <*> coordinates m <*> bounds m <*> _values m }

insertPar, insertPerp :: Location -> Run a -> Int -> (Int, Int) -> IMap a -> IMap a
insertPar (Location (kPar, kPerp)) r herePar (loPerp, hiPerp)
    | kPar == herePar && loPerp <= kPerp + IM.len r - 1 && kPerp <= hiPerp
        = IM.insert beg r { IM.len = end - beg + 1 }
    | otherwise = id
    where
    beg = max kPerp loPerp
    end = min (kPerp + IM.len r - 1) hiPerp
insertPerp (Location (kPar, kPerp)) r herePerp (loPar, hiPar)
    | loPar <= kPar && kPar <= hiPar && kPerp <= herePerp && herePerp <= kPerp + IM.len r - 1
        = IM.insert kPar r { IM.len = 1 }
    | otherwise = id

-- | Insert a single value at the given location.
insert :: Location -> a -> BorderMap a -> BorderMap a
insert l = insertV l . Run 1

-- | Look up all values on a given row. The 'IMap' returned maps columns to
-- values.
lookupRow :: Int -> BorderMap a -> IMap a
lookupRow row m
    | row == eTop    (coordinates m) = eTop    (_values m)
    | row == eBottom (coordinates m) = eBottom (_values m)
    | otherwise = IM.fromList
        $  [(eLeft   (coordinates m), Run 1 a) | Just a <- [IM.lookup row (eLeft   (_values m))]]
        ++ [(eRight  (coordinates m), Run 1 a) | Just a <- [IM.lookup row (eRight  (_values m))]]

-- | Look up all values on a given column. The 'IMap' returned maps rows to
-- values.
lookupCol :: Int -> BorderMap a -> IMap a
lookupCol col m
    | col == eLeft   (coordinates m) = eLeft   (_values m)
    | col == eRight  (coordinates m) = eRight  (_values m)
    | otherwise = IM.fromList
        $  [(eTop    (coordinates m), Run 1 a) | Just a <- [IM.lookup col (eTop    (_values m))]]
        ++ [(eBottom (coordinates m), Run 1 a) | Just a <- [IM.lookup col (eBottom (_values m))]]

-- | Bulk lookup of horizontally-adjacent values. The 'Location' gives the
-- starting point, and the 'Run' extends in the "larger columns" direction. The
-- 'IMap' returned maps columns to values.
lookupH :: Location -> Run ignored -> BorderMap a -> IMap a
lookupH (Location (col, row)) r = IM.restrict col r . lookupRow row

-- | Bulk lookup of vertically-adjacent values. The 'Location' gives the
-- starting point, and the 'Run' extends in the "larger rows" direction. The
-- 'IMap' returned maps rows to values.
lookupV :: Location -> Run ignored -> BorderMap a -> IMap a
lookupV (Location (col, row)) r = IM.restrict row r . lookupCol col

-- | Look up a single position.
lookup :: Location -> BorderMap a -> Maybe a
lookup (Location (col, row)) = IM.lookup row . lookupCol col

-- | Set the rectangle being tracked by this 'BorderMap', throwing away any
-- values that do not lie on this new rectangle.
setCoordinates :: Edges Int -> BorderMap a -> BorderMap a
setCoordinates coordinates' m = BorderMap
    { _values = values'
    , _coordinates = coordinates'
    }
    where
    bounds' = neighbors coordinates'
    values' = gc
        <$> _coordinates m
        <*> coordinates'
        <*> bounds'
        <*> _values m
        <*> Edges { eTop = lookupRow, eBottom = lookupRow, eLeft = lookupCol, eRight = lookupCol }
    gc oldPar newPar (loPerp, hiPerp) imPar lookupPerp
        | oldPar == newPar = IM.restrict loPerp (Run (hiPerp-loPerp+1) ()) imPar
        | otherwise = lookupPerp newPar m

-- | Ensure that the rectangle being tracked by this 'BorderMap' extends no
-- farther than the given one.
crop :: Edges Int -> BorderMap a -> BorderMap a
crop cs m = setCoordinates (shrink <*> cs <*> coordinates m) m where
    shrink = Edges
        { eTop    = max
        , eBottom = min
        , eLeft   = max
        , eRight  = min
        }

-- | Ensure that the rectangle being tracked by this 'BorderMap' extends at
-- least as far as the given one.
expand :: Edges Int -> BorderMap a -> BorderMap a
expand cs m = setCoordinates (grow <*> cs <*> coordinates m) m where
    grow = Edges
        { eTop    = min
        , eBottom = max
        , eLeft   = min
        , eRight  = max
        }

-- | Move a 'BorderMap' by adding the given 'Location' to all keys in the map.
translate :: Location -> BorderMap a -> BorderMap a
-- fast path: do nothing for (0,0)
translate (Location (0, 0)) m = m
translate (Location (c, r)) m = BorderMap
    { _coordinates = liftA2 (+)          cOffsets (_coordinates m)
    , _values      = liftA2 IM.addToKeys vOffsets (_values      m)
    }
    where
    cOffsets = Edges { eTop = r, eBottom = r, eLeft = c, eRight = c }
    vOffsets = Edges { eTop = c, eBottom = c, eLeft = r, eRight = r }

-- | Assumes the two 'BorderMap's are tracking the same rectangles, but have
-- disjoint keys. This property is not checked.
unsafeUnion :: BorderMap a -> BorderMap a -> BorderMap a
unsafeUnion m m' = m { _values = liftA2 IM.unsafeUnion (_values m) (_values m') }