{-# LANGUAGE FlexibleContexts #-}
module Monomer.Widgets.Containers.Grid (
GridCfg,
hgrid,
hgrid_,
vgrid,
vgrid_
) where
import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~))
import Data.Default
import Data.List (foldl')
import Data.Maybe
import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
newtype GridCfg = GridCfg {
GridCfg -> Maybe SizeReqUpdater
_grcSizeReqUpdater :: Maybe SizeReqUpdater
}
instance Default GridCfg where
def :: GridCfg
def = GridCfg :: Maybe SizeReqUpdater -> GridCfg
GridCfg {
_grcSizeReqUpdater :: Maybe SizeReqUpdater
_grcSizeReqUpdater = Maybe SizeReqUpdater
forall a. Maybe a
Nothing
}
instance Semigroup GridCfg where
<> :: GridCfg -> GridCfg -> GridCfg
(<>) GridCfg
s1 GridCfg
s2 = GridCfg :: Maybe SizeReqUpdater -> GridCfg
GridCfg {
_grcSizeReqUpdater :: Maybe SizeReqUpdater
_grcSizeReqUpdater = GridCfg -> Maybe SizeReqUpdater
_grcSizeReqUpdater GridCfg
s2 Maybe SizeReqUpdater
-> Maybe SizeReqUpdater -> Maybe SizeReqUpdater
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GridCfg -> Maybe SizeReqUpdater
_grcSizeReqUpdater GridCfg
s1
}
instance Monoid GridCfg where
mempty :: GridCfg
mempty = GridCfg
forall a. Default a => a
def
instance CmbSizeReqUpdater GridCfg where
sizeReqUpdater :: SizeReqUpdater -> GridCfg
sizeReqUpdater SizeReqUpdater
updater = GridCfg
forall a. Default a => a
def {
_grcSizeReqUpdater :: Maybe SizeReqUpdater
_grcSizeReqUpdater = SizeReqUpdater -> Maybe SizeReqUpdater
forall a. a -> Maybe a
Just SizeReqUpdater
updater
}
hgrid :: Traversable t => t (WidgetNode s e) -> WidgetNode s e
hgrid :: t (WidgetNode s e) -> WidgetNode s e
hgrid t (WidgetNode s e)
children = [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
hgrid_ [GridCfg]
forall a. Default a => a
def t (WidgetNode s e)
children
hgrid_ :: Traversable t => [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
hgrid_ :: [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
hgrid_ [GridCfg]
configs t (WidgetNode s e)
children = WidgetNode s e
newNode where
config :: GridCfg
config = [GridCfg] -> GridCfg
forall a. Monoid a => [a] -> a
mconcat [GridCfg]
configs
newNode :: WidgetNode s e
newNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"hgrid" (Bool -> GridCfg -> Widget s e
forall s e. Bool -> GridCfg -> Widget s e
makeFixedGrid Bool
True GridCfg
config)
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Seq (WidgetNode s e) -> WidgetNode s e -> Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
-> t (WidgetNode s e)
-> Seq (WidgetNode s e)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Seq (WidgetNode s e) -> WidgetNode s e -> Seq (WidgetNode s e)
forall a. Seq a -> a -> Seq a
(|>) Seq (WidgetNode s e)
forall a. Seq a
Empty t (WidgetNode s e)
children
vgrid :: Traversable t => t (WidgetNode s e) -> WidgetNode s e
vgrid :: t (WidgetNode s e) -> WidgetNode s e
vgrid t (WidgetNode s e)
children = [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
forall (t :: * -> *) s e.
Traversable t =>
[GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
vgrid_ [GridCfg]
forall a. Default a => a
def t (WidgetNode s e)
children
vgrid_ :: Traversable t => [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
vgrid_ :: [GridCfg] -> t (WidgetNode s e) -> WidgetNode s e
vgrid_ [GridCfg]
configs t (WidgetNode s e)
children = WidgetNode s e
newNode where
config :: GridCfg
config = [GridCfg] -> GridCfg
forall a. Monoid a => [a] -> a
mconcat [GridCfg]
configs
newNode :: WidgetNode s e
newNode = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"vgrid" (Bool -> GridCfg -> Widget s e
forall s e. Bool -> GridCfg -> Widget s e
makeFixedGrid Bool
False GridCfg
config)
WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Seq (WidgetNode s e) -> WidgetNode s e -> Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
-> t (WidgetNode s e)
-> Seq (WidgetNode s e)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Seq (WidgetNode s e) -> WidgetNode s e -> Seq (WidgetNode s e)
forall a. Seq a -> a -> Seq a
(|>) Seq (WidgetNode s e)
forall a. Seq a
Empty t (WidgetNode s e)
children
makeFixedGrid :: Bool -> GridCfg -> Widget s e
makeFixedGrid :: Bool -> GridCfg -> Widget s e
makeFixedGrid Bool
isHorizontal GridCfg
config = Widget s e
forall s e. Widget s e
widget where
widget :: Widget s e
widget = () -> Container s e () -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer () Container s e ()
forall a. Default a => a
def {
containerLayoutDirection :: LayoutDirection
containerLayoutDirection = Bool -> LayoutDirection
getLayoutDirection Bool
isHorizontal,
containerGetSizeReq :: ContainerGetSizeReqHandler s e
containerGetSizeReq = ContainerGetSizeReqHandler s e
forall p p s e.
p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq,
containerResize :: ContainerResizeHandler s e
containerResize = ContainerResizeHandler s e
forall s e s e.
WidgetEnv s e
-> WidgetNode s e
-> Rect
-> Seq (WidgetNode s e)
-> (WidgetResult s e, Seq Rect)
resize
}
isVertical :: Bool
isVertical = Bool -> Bool
not Bool
isHorizontal
getSizeReq :: p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node Seq (WidgetNode s e)
children = (SizeReq, SizeReq)
newSizeReq where
updateSizeReq :: SizeReqUpdater
updateSizeReq = SizeReqUpdater -> Maybe SizeReqUpdater -> SizeReqUpdater
forall a. a -> Maybe a -> a
fromMaybe SizeReqUpdater
forall a. a -> a
id (GridCfg -> Maybe SizeReqUpdater
_grcSizeReqUpdater GridCfg
config)
vchildren :: Seq (WidgetNode s e)
vchildren = (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
newSizeReqW :: SizeReq
newSizeReqW = Bool
-> (WidgetNode s e -> SizeReq) -> Seq (WidgetNode s e) -> SizeReq
forall a. Bool -> (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq Bool
isHorizontal (WidgetNodeInfo -> SizeReq
_wniSizeReqW (WidgetNodeInfo -> SizeReq)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
vchildren
newSizeReqH :: SizeReq
newSizeReqH = Bool
-> (WidgetNode s e -> SizeReq) -> Seq (WidgetNode s e) -> SizeReq
forall a. Bool -> (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq Bool
isVertical (WidgetNodeInfo -> SizeReq
_wniSizeReqH (WidgetNodeInfo -> SizeReq)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> SizeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
vchildren
newSizeReq :: (SizeReq, SizeReq)
newSizeReq = SizeReqUpdater
updateSizeReq (SizeReq
newSizeReqW, SizeReq
newSizeReqH)
getDimSizeReq :: Bool -> (a -> SizeReq) -> Seq a -> SizeReq
getDimSizeReq Bool
mainAxis a -> SizeReq
accesor Seq a
vchildren
| Seq SizeReq -> Bool
forall a. Seq a -> Bool
Seq.null Seq SizeReq
vreqs = Double -> SizeReq
fixedSize Double
0
| Bool
mainAxis = (SizeReq -> SizeReq -> SizeReq) -> Seq SizeReq -> SizeReq
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SizeReq -> SizeReq -> SizeReq
sizeReqMergeSum (Int -> SizeReq -> Seq SizeReq
forall a. Int -> a -> Seq a
Seq.replicate Int
nreqs SizeReq
maxSize)
| Bool
otherwise = SizeReq
maxSize
where
vreqs :: Seq SizeReq
vreqs = a -> SizeReq
accesor (a -> SizeReq) -> Seq a -> Seq SizeReq
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq a
vchildren
nreqs :: Int
nreqs = Seq SizeReq -> Int
forall a. Seq a -> Int
Seq.length Seq SizeReq
vreqs
maxSize :: SizeReq
maxSize = (SizeReq -> SizeReq -> SizeReq) -> Seq SizeReq -> SizeReq
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 SizeReq -> SizeReq -> SizeReq
sizeReqMergeMax Seq SizeReq
vreqs
resize :: WidgetEnv s e
-> WidgetNode s e
-> Rect
-> Seq (WidgetNode s e)
-> (WidgetResult s e, Seq Rect)
resize WidgetEnv s e
wenv WidgetNode s e
node Rect
viewport Seq (WidgetNode s e)
children = (WidgetResult s e, Seq Rect)
resized where
style :: StyleState
style = WidgetEnv s e -> WidgetNode s e -> StyleState
forall s e. WidgetEnv s e -> WidgetNode s e -> StyleState
currentStyle WidgetEnv s e
wenv WidgetNode s e
node
contentArea :: Rect
contentArea = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
forall a. Default a => a
def (StyleState -> Rect -> Maybe Rect
removeOuterBounds StyleState
style Rect
viewport)
Rect Double
l Double
t Double
w Double
h = Rect
contentArea
vchildren :: Seq (WidgetNode s e)
vchildren = (WidgetNode s e -> Bool)
-> Seq (WidgetNode s e) -> Seq (WidgetNode s e)
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (WidgetNodeInfo -> Bool
_wniVisible (WidgetNodeInfo -> Bool)
-> (WidgetNode s e -> WidgetNodeInfo) -> WidgetNode s e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetNode s e -> WidgetNodeInfo
forall s e. WidgetNode s e -> WidgetNodeInfo
_wnInfo) Seq (WidgetNode s e)
children
cols :: Int
cols = if Bool
isHorizontal then Seq (WidgetNode s e) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (WidgetNode s e)
vchildren else Int
1
rows :: Int
rows = if Bool
isHorizontal then Int
1 else Seq (WidgetNode s e) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (WidgetNode s e)
vchildren
cw :: Double
cw = if Int
cols Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cols else Double
0
ch :: Double
ch = if Int
rows Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rows else Double
0
cx :: Int -> Double
cx Int
i
| Int
rows Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
rows) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cw
| Bool
otherwise = Double
0
cy :: Int -> Double
cy Int
i
| Int
cols Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
cols) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ch
| Bool
otherwise = Double
0
foldHelper :: (Seq Rect, Int) -> s -> (Seq Rect, Int)
foldHelper (Seq Rect
currAreas, Int
index) s
child = (Seq Rect
newAreas, Int
newIndex) where
(Int
newIndex, Rect
newViewport)
| s
child s -> Getting Bool s Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (a -> Const Bool a) -> s -> Const Bool s
forall s a. HasInfo s a => Lens' s a
L.info ((a -> Const Bool a) -> s -> Const Bool s)
-> ((Bool -> Const Bool Bool) -> a -> Const Bool a)
-> Getting Bool s Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool) -> a -> Const Bool a
forall s a. HasVisible s a => Lens' s a
L.visible = (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int -> Rect
calcViewport Int
index)
| Bool
otherwise = (Int
index, Rect
forall a. Default a => a
def)
newArea :: Rect
newArea = Rect
newViewport
newAreas :: Seq Rect
newAreas = Seq Rect
currAreas Seq Rect -> Rect -> Seq Rect
forall a. Seq a -> a -> Seq a
|> Rect
newArea
calcViewport :: Int -> Rect
calcViewport Int
i = Double -> Double -> Double -> Double -> Rect
Rect (Int -> Double
cx Int
i) (Int -> Double
cy Int
i) Double
cw Double
ch
assignedAreas :: Seq Rect
assignedAreas = (Seq Rect, Int) -> Seq Rect
forall a b. (a, b) -> a
fst ((Seq Rect, Int) -> Seq Rect) -> (Seq Rect, Int) -> Seq Rect
forall a b. (a -> b) -> a -> b
$ ((Seq Rect, Int) -> WidgetNode s e -> (Seq Rect, Int))
-> (Seq Rect, Int) -> Seq (WidgetNode s e) -> (Seq Rect, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Seq Rect, Int) -> WidgetNode s e -> (Seq Rect, Int)
forall s a.
(HasInfo s a, HasVisible a Bool) =>
(Seq Rect, Int) -> s -> (Seq Rect, Int)
foldHelper (Seq Rect
forall a. Seq a
Seq.empty, Int
0) Seq (WidgetNode s e)
children
resized :: (WidgetResult s e, Seq Rect)
resized = (WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node, Seq Rect
assignedAreas)