{-|
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 size equally along the main axis. For hgrid
it requests max width * elements as its width, and the max height as its height.
The reverse happens for vgrid.
-}
{-# 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:

- 'sizeReqUpdater': allows modifying the 'SizeReq' generated by the grid.
-}
newtype GridCfg = GridCfg {
  GridCfg -> [SizeReqUpdater]
_grcSizeReqUpdater :: [SizeReqUpdater]
}

instance Default GridCfg where
  def :: GridCfg
def = GridCfg :: [SizeReqUpdater] -> GridCfg
GridCfg {
    _grcSizeReqUpdater :: [SizeReqUpdater]
_grcSizeReqUpdater = []
  }

instance Semigroup GridCfg where
  <> :: GridCfg -> GridCfg -> GridCfg
(<>) GridCfg
s1 GridCfg
s2 = GridCfg :: [SizeReqUpdater] -> GridCfg
GridCfg {
    _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 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

  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)
    | 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

  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)