module Rainbox.Box.Primitives
(
Background(..)
, Align
, Vert
, Horiz
, center
, top
, bottom
, left
, right
, Bar(..)
, Rod(..)
, barToBox
, barsToBox
, Nibble
, unNibble
, Spaces
, numSpaces
, spcBackground
, BoxP(..)
, Box
, unBox
, Height(..)
, height
, Width(..)
, HasWidth(..)
, blank
, chunks
, catH
, catV
, viewH
, viewV
, split
) where
import qualified Data.Foldable as F
import System.Console.Rainbow.Types
import Data.Monoid
import qualified Data.Text as X
import Data.String
import System.Console.Rainbow.Colors
data Background = Background
{ boxBackground8 :: Color8
, boxBackground256 :: Color256
} deriving (Eq, Show)
data Spaces = Spaces
{ numSpaces :: Int
, spcBackground :: Background
} deriving (Eq, Show)
instance HasWidth Spaces where
width = numSpaces
newtype Nibble = Nibble { unNibble :: Either Spaces Chunk }
deriving (Eq, Show)
instance IsString Nibble where
fromString = Nibble . Right . fromString
instance HasWidth Nibble where
width = either width width . unNibble
newtype Bar = Bar { unBar :: [Chunk] }
deriving (Eq, Show)
barToBox :: Bar -> Box
barToBox = chunks . unBar
barsToBox :: Background -> Align Horiz -> [Bar] -> Box
barsToBox bk ah = catV bk ah . map barToBox
instance IsString Bar where
fromString = Bar . (:[]) . fromString
instance Monoid Bar where
mempty = Bar []
mappend (Bar l) (Bar r) = Bar $ l ++ r
newtype Box = Box { unBox :: BoxP }
deriving (Eq, Show)
newtype Rod = Rod { unRod :: [Nibble] }
deriving (Eq, Show)
instance IsString Rod where
fromString = Rod . (:[]) . fromString
instance HasWidth Rod where
width = sum . map width . unRod
data BoxP
= NoHeight Int
| WithHeight [Rod]
deriving (Eq, Show)
instance HasWidth BoxP where
width b = case b of
NoHeight w -> w
WithHeight ns -> sum . map width $ ns
instance IsString Box where
fromString = Box . WithHeight . (:[]) . fromString
newtype Height = Height { unHeight :: Int }
deriving (Eq, Ord, Show)
height :: Box -> Int
height b = case unBox b of
NoHeight _ -> 0
WithHeight rs -> length rs
newtype Width = Width { unWidth :: Int }
deriving (Eq, Ord, Show)
class HasWidth a where
width :: a -> Int
instance HasWidth Bar where
width = sum . map (sum . map X.length . text) . unBar
instance HasWidth Box where
width b = case unBox b of
NoHeight i -> i
WithHeight rs -> case rs of
[] -> error "cols: error"
x:_ -> width x
instance HasWidth Chunk where
width = sum . map X.length . text
blank
:: Background
-> Height
-> Width
-> Box
blank bk r c
| unHeight r < 1 = Box $ NoHeight (max 0 (unWidth c))
| otherwise = Box . WithHeight $ replicate (unHeight r) row
where
row | unWidth c < 1 = Rod []
| otherwise = Rod [ blanks bk (unWidth c) ]
chunks :: [Chunk] -> Box
chunks = Box . WithHeight . (:[]) . Rod . map (Nibble . Right)
data Align a = Center | NonCenter a
deriving (Eq, Show)
data Vert = ATop | ABottom
deriving (Eq, Show)
data Horiz = ALeft | ARight
deriving (Eq, Show)
center :: Align a
center = Center
top :: Align Vert
top = NonCenter ATop
bottom :: Align Vert
bottom = NonCenter ABottom
left :: Align Horiz
left = NonCenter ALeft
right :: Align Horiz
right = NonCenter ARight
catH :: Background -> Align Vert -> [Box] -> Box
catH bk al bs
| null bs = Box $ NoHeight 0
| hght == 0 = Box . NoHeight . sum . map width $ bs
| otherwise = Box . WithHeight . mergeHoriz . map (pad . unBox) $ bs
where
pad = padHoriz bk al hght
hght = F.maximum . (0:) . map height $ bs
catV :: Background -> Align Horiz -> [Box] -> Box
catV bk al bs
| null bs = Box $ NoHeight 0
| otherwise = Box . foldr f (NoHeight w)
. concat . map (flatten . unBox) $ bs
where
w = F.maximum . (0:) . map width $ bs
f mayR bp = case mayR of
Nothing -> bp
Just rw -> case bp of
WithHeight wh -> WithHeight $ padded : wh
_ -> WithHeight [padded]
where
padded = padVert bk al w rw
flatten bp = case bp of
NoHeight _ -> [Nothing]
WithHeight rs -> map Just rs
padHoriz :: Background -> Align Vert -> Int -> BoxP -> [Rod]
padHoriz bk a hght bp = case bp of
NoHeight w -> map (Rod . (:[])) . replicate h $ blanks bk w
WithHeight rs -> concat [tp, rs, bot]
where
nPad = max 0 $ h length rs
(nATop, nBot) = case a of
Center -> split nPad
NonCenter ATop -> (0, nPad)
NonCenter ABottom -> (nPad, 0)
pad = Rod [blanks bk len]
where
len = case rs of
[] -> 0
x:_ -> width x
(tp, bot) = (replicate nATop pad, replicate nBot pad)
where
h = max 0 hght
padVert
:: Background
-> Align Horiz
-> Int
-> Rod
-> Rod
padVert bk a wdth rw@(Rod cs) = Rod . concat $ [lft, cs, rght]
where
nPad = max 0 $ w width rw
(nLeft, nRight) = case a of
Center -> split nPad
NonCenter ALeft -> (0, nPad)
NonCenter ARight -> (nPad, 0)
(lft, rght) = (mkPad nLeft, mkPad nRight)
mkPad n
| n == 0 = []
| otherwise = [blanks bk n]
w = max 0 wdth
mergeHoriz :: [[Rod]] -> [Rod]
mergeHoriz = foldr (zipWith merge) (repeat (Rod []))
where
merge (Rod r1) (Rod r2) = Rod $ r1 ++ r2
viewV :: Int -> Align Vert -> Box -> Box
viewV hght a (Box b) = Box $ case b of
WithHeight rs
| h == 0 -> NoHeight . width . head $ rs
| otherwise -> WithHeight $ case a of
NonCenter ATop -> take h rs
NonCenter ABottom -> drop extra rs
Center -> drop nDrop . take nTake $ rs
where
(trimL, trimR) = split extra
nTake = length rs trimR
nDrop = trimL
where
extra = max 0 $ length rs h
x -> x
where
h = max 0 hght
viewH :: Int -> Align Horiz -> Box -> Box
viewH wdth a (Box b) = Box $ case b of
NoHeight nh -> NoHeight (min w nh)
WithHeight rs -> WithHeight $ map f rs
where
f rw = case a of
NonCenter ALeft -> takeChars w rw
NonCenter ARight -> dropChars extra rw
Center -> dropChars nDrop . takeChars nTake $ rw
where
(trimL, trimR) = split extra
nTake = max 0 $ width rw trimR
nDrop = trimL
where
extra = max 0 $ width rw w
where
w = max 0 wdth
dropChars :: Int -> Rod -> Rod
dropChars colsIn = Rod . go colsIn . unRod
where
go n cs
| n <= 0 = cs
| otherwise = case cs of
[] -> []
x:xs
| lenX <= n -> go (n lenX) xs
| otherwise -> x' : xs
where
lenX = case unNibble x of
Left blnk -> numSpaces blnk
Right chk -> width chk
x' = case unNibble x of
Left blnk -> Nibble . Left $
blnk { numSpaces = numSpaces blnk n }
Right chk -> Nibble . Right . dropChunkChars n $ chk
dropChunkChars :: Int -> Chunk -> Chunk
dropChunkChars n c = c { text = go n (text c) }
where
go nLeft ls = case ls of
[] -> []
t:ts
| len < nLeft -> go (nLeft len) ts
| len == nLeft -> ts
| otherwise -> X.drop nLeft t : ts
where
len = X.length t
takeChars :: Int -> Rod -> Rod
takeChars colsIn = Rod . go colsIn . unRod
where
go n cs
| n <= 0 = []
| otherwise = case cs of
[] -> []
x:xs
| lenX <= n -> x : go (n lenX) xs
| otherwise -> [x']
where
(lenX, x') = case unNibble x of
Left blnk ->
( numSpaces blnk,
Nibble . Left $ blnk { numSpaces = n } )
Right chk ->
( width chk,
Nibble . Right . takeChunkChars n $ chk)
takeChunkChars :: Int -> Chunk -> Chunk
takeChunkChars n c = c { text = go n (text c) }
where
go nLeft ls = case ls of
[] -> []
t:ts
| len < nLeft -> t : go (nLeft len) ts
| len == nLeft -> [t]
| otherwise -> [X.take nLeft t]
where
len = X.length t
blanks
:: Background
-> Int
-> Nibble
blanks bk c = Nibble (Left (Spaces c bk))
split :: Int -> (Int, Int)
split i = (r, r + rm)
where
(r, rm) = i `quotRem` 2