{-|
Module      : Monomer.Widgets.Containers.Grid
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Layout container which distributes space evenly along the main axis. For the
secondary axis children will receive as much space as available for the grid
widget itself.

In the same way as with hstack and vstack, 'hgrid' and 'vgrid' can be combined
to create more complex layouts.

The hgrid widget requests maxWidth * elements as its width, and the max height
as its height. The inverse happens for vgrid.

@
hgrid [
    label "Third 1",
    label "Third 2",
    label "Third 3"
  ]
@
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Containers.Grid (
  -- * Configuration
  GridCfg,
  -- * Constructors
  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.Helper (applyFnList)
import Monomer.Widgets.Container

import qualified Monomer.Lens as L

{-|
Configuration options for grid:

- 'childSpacing': spacing between the child widgets.
- 'sizeReqUpdater': allows modifying the 'SizeReq' generated by the grid.
-}
data GridCfg = GridCfg {
  GridCfg -> Maybe Double
_grcChildSpacing :: Maybe Double,
  GridCfg -> [SizeReqUpdater]
_grcSizeReqUpdater :: [SizeReqUpdater]
}

instance Default GridCfg where
  def :: GridCfg
def = GridCfg :: Maybe Double -> [SizeReqUpdater] -> GridCfg
GridCfg {
    _grcChildSpacing :: Maybe Double
_grcChildSpacing = Maybe Double
forall a. Maybe a
Nothing,
    _grcSizeReqUpdater :: [SizeReqUpdater]
_grcSizeReqUpdater = []
  }

instance Semigroup GridCfg where
  <> :: GridCfg -> GridCfg -> GridCfg
(<>) GridCfg
s1 GridCfg
s2 = GridCfg :: Maybe Double -> [SizeReqUpdater] -> GridCfg
GridCfg {
    _grcChildSpacing :: Maybe Double
_grcChildSpacing = GridCfg -> Maybe Double
_grcChildSpacing GridCfg
s2 Maybe Double -> Maybe Double -> Maybe Double
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GridCfg -> Maybe Double
_grcChildSpacing GridCfg
s1,
    _grcSizeReqUpdater :: [SizeReqUpdater]
_grcSizeReqUpdater = GridCfg -> [SizeReqUpdater]
_grcSizeReqUpdater GridCfg
s1 [SizeReqUpdater] -> [SizeReqUpdater] -> [SizeReqUpdater]
forall a. Semigroup a => a -> a -> a
<> GridCfg -> [SizeReqUpdater]
_grcSizeReqUpdater GridCfg
s2
  }

instance Monoid GridCfg where
  mempty :: GridCfg
mempty = GridCfg
forall a. Default a => a
def

instance CmbChildSpacing GridCfg where
  childSpacing_ :: Double -> GridCfg
childSpacing_ Double
spacing = GridCfg
forall a. Default a => a
def {
    _grcChildSpacing :: Maybe Double
_grcChildSpacing = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
spacing
  }

instance CmbSizeReqUpdater GridCfg where
  sizeReqUpdater :: SizeReqUpdater -> GridCfg
sizeReqUpdater SizeReqUpdater
updater = GridCfg
forall a. Default a => a
def {
    _grcSizeReqUpdater :: [SizeReqUpdater]
_grcSizeReqUpdater = [SizeReqUpdater
updater]
  }

-- | Creates a grid of items with the same width.
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

-- | Creates a grid of items with the same width. Accepts config.
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

-- | Creates a grid of items with the same height.
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

-- | Creates a grid of items with the same height. Accepts config.
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
  childSpacing :: Double
childSpacing = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 (GridCfg -> Maybe Double
_grcChildSpacing GridCfg
config)

  getSizeReq :: p -> p -> Seq (WidgetNode s e) -> (SizeReq, SizeReq)
getSizeReq p
wenv p
node Seq (WidgetNode s e)
children = (SizeReq, SizeReq)
newSizeReq where
    sizeReqFns :: [SizeReqUpdater]
sizeReqFns = GridCfg -> [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] -> SizeReqUpdater
forall a. [a -> a] -> a -> a
applyFnList [SizeReqUpdater]
sizeReqFns (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) SizeReq -> (SizeReq -> SizeReq) -> SizeReq
forall a b. a -> (a -> b) -> b
& (Double -> Identity Double) -> SizeReq -> Identity SizeReq
forall s a. HasFixed s a => Lens' s a
L.fixed ((Double -> Identity Double) -> SizeReq -> Identity SizeReq)
-> (Double -> Double) -> SizeReq -> SizeReq
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
totalSpacing)
    | 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
      ~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
      totalSpacing :: Double
totalSpacing = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
nreqs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
childSpacing

  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

    totalSpacingW :: Double
totalSpacingW = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
cols Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
childSpacing
    totalSpacingH :: Double
totalSpacingH = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
rows Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
childSpacing

    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. Num a => a -> a -> a
- Double
totalSpacingW) 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. Num a => a -> a -> a
- Double
totalSpacingH) 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 :: a -> Double
cx a
i
      | Int
rows Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Double
0
      | Bool
isHorizontal = Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
cw Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Integral a => a -> Double
spacingOffset a
i
      | Bool
otherwise = Double
l
    cy :: a -> Double
cy a
i
      | Int
cols Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Double
0
      | Bool
isVertical = Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ch Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. Integral a => a -> Double
spacingOffset a
i
      | Bool
otherwise = Double
t
    spacingOffset :: a -> Double
spacingOffset a
i =
      a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
childSpacing

    foldHelper :: (Seq Rect, b) -> s -> (Seq Rect, b)
foldHelper (Seq Rect
currAreas, b
index) s
child = (Seq Rect
newAreas, b
newIndex) where
      (b
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 = (b
index b -> b -> b
forall a. Num a => a -> a -> a
+ b
1, b -> Rect
forall a. Integral a => a -> Rect
calcViewport b
index)
        | Bool
otherwise = (b
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 :: a -> Rect
calcViewport a
i = Double -> Double -> Double -> Double -> Rect
Rect (a -> Double
forall a. Integral a => a -> Double
cx a
i) (a -> Double
forall a. Integral a => a -> Double
cy a
i) Double
cw Double
ch

    assignedAreas :: Seq Rect
assignedAreas = (Seq Rect, Integer) -> Seq Rect
forall a b. (a, b) -> a
fst ((Seq Rect, Integer) -> Seq Rect)
-> (Seq Rect, Integer) -> Seq Rect
forall a b. (a -> b) -> a -> b
$ ((Seq Rect, Integer) -> WidgetNode s e -> (Seq Rect, Integer))
-> (Seq Rect, Integer)
-> Seq (WidgetNode s e)
-> (Seq Rect, Integer)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Seq Rect, Integer) -> WidgetNode s e -> (Seq Rect, Integer)
forall s a b.
(HasInfo s a, HasVisible a Bool, Integral b) =>
(Seq Rect, b) -> s -> (Seq Rect, b)
foldHelper (Seq Rect
forall a. Seq a
Seq.empty, Integer
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)