{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
module Imj.Graphics.UI.RectContainer
(
RectContainer(..)
, getSideCentersAtDistance
, Colorable(..)
) where
import Imj.Prelude
import Data.List( mapAccumL, zip )
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Reader.Class(MonadReader)
import Imj.Geo.Discrete
import Imj.Graphics.Class.DiscreteColorableMorphing
import Imj.Graphics.Render
import Imj.Graphics.UI.RectContainer.MorphParallel4
data RectContainer = RectContainer {
_rectFrameContentSize :: !Size
, _rectFrameUpperLeft :: !(Coords Pos)
} deriving(Eq, Show)
instance Colorable RectContainer where
drawUsingColor = renderWhole
{-# INLINABLE drawUsingColor #-}
instance DiscreteDistance RectContainer where
{-# INLINABLE distance #-}
distance c@(RectContainer s _)
c'@(RectContainer s' _)
| c == c' = 1
| otherwise = 1 + quot (1 + max (maxLength s) (maxLength s')) 2
instance DiscreteColorableMorphing RectContainer where
{-# INLINABLE drawMorphingUsingColor #-}
drawMorphingUsingColor from to frame color
| frame <= 0 = drawUsingColor from color
| frame >= lastFrame = drawUsingColor to color
| otherwise = renderRectFrameInterpolation from to lastFrame frame color
where
lastFrame = pred $ distance from to
{-# INLINABLE renderWhole #-}
renderWhole :: (Draw e, MonadReader e m, MonadIO m)
=> RectContainer
-> LayeredColor
-> m ()
renderWhole (RectContainer sz upperLeft) =
renderPartialRectContainer sz (upperLeft, 0, countRectContainerChars sz - 1)
{-# INLINABLE renderRectFrameInterpolation #-}
renderRectFrameInterpolation :: (Draw e, MonadReader e m, MonadIO m)
=> RectContainer
-> RectContainer
-> Int
-> Int
-> LayeredColor
-> m ()
renderRectFrameInterpolation rf1@(RectContainer sz1 upperLeft1)
rf2@(RectContainer sz2 upperLeft2) lastFrame frame color = do
let (Coords _ (Coord dc)) = diffCoords upperLeft1 upperLeft2
render di1 di2 = do
let fromRanges = ranges (lastFrame-(frame+di1)) sz1 FromBs
toRanges = ranges (lastFrame-(frame+di2)) sz2 FromAs
mapM_ (renderRectFrameRange rf1 color) fromRanges
mapM_ (renderRectFrameRange rf2 color) toRanges
if dc >= 0
then
render dc 0
else
render 0 (negate dc)
{-# INLINABLE renderRectFrameRange #-}
renderRectFrameRange :: (Draw e, MonadReader e m, MonadIO m)
=> RectContainer
-> LayeredColor
-> (Int, Int)
-> m ()
renderRectFrameRange (RectContainer sz r) color (min_, max_) =
renderPartialRectContainer sz (r, min_, max_) color
data BuildFrom = FromAs
| FromBs
ranges :: Int
-> Size
-> BuildFrom
-> [(Int, Int)]
ranges progress sz =
let h = countRectContainerVerticalChars sz
w = countRectContainerHorizontalChars sz
diff = quot (w - h) 2
extW = rangeByRemovingFromTotal progress w
extH = rangeByRemovingFromTotal (max 0 $ progress-diff) h
exts = [extW, extH, extW, extH]
lengths = [w,h,w,h]
(total, starts) = mapAccumL (\acc v -> (acc + v, acc)) 0 lengths
res = map (\(ext, s) -> ext s) $ zip exts starts
in \case
FromAs -> res
FromBs -> complement 0 (total-1) res
complement :: Int -> Int -> [(Int, Int)] -> [(Int, Int)]
complement a max_ [] = [(a, max_)]
complement a max_ l@((b,c):_) = (a, pred b) : complement (succ c) max_ (tail l)
rangeByRemovingFromTotal :: Int -> Int -> Int -> (Int, Int)
rangeByRemovingFromTotal remove total start =
let min_ = remove
max_ = total - 1 - remove
in (start + min_, start + max_)
getSideCentersAtDistance :: RectContainer
-> Length Width
-> Length Height
-> (Coords Pos, Coords Pos, Coords Pos, Coords Pos)
getSideCentersAtDistance (RectContainer (Size rs' cs') upperLeft') dx dy =
(centerUp, centerDown, leftMiddle, rightMiddle)
where
deltaLength dist =
2 *
(1 +
dist)
rs = rs' + fromIntegral (deltaLength dy)
cs = cs' + fromIntegral (deltaLength dx)
upperLeft = translate' (fromIntegral $ -dy) (fromIntegral $ -dx) upperLeft'
cHalf = quot (cs-1) 2
rHalf = quot (rs-1) 2
rFull = rs-1
centerUp = translate' 0 cHalf upperLeft
centerDown = translate' rFull cHalf upperLeft
leftMiddle = translate' rHalf 0 upperLeft
rightMiddle = translate' rHalf (cs-1) upperLeft