yuiGrid-0.1: Text/YuiGrid/Grid.hs
module Text.YuiGrid.Grid where
import Data.Maybe (fromJust, fromMaybe, catMaybes)
import Data.List (partition, maximumBy, sortBy)
import Control.Monad (mplus)
import Data.Ord (comparing)
import Text.YuiGrid.LayoutHints
data GridNode a = Box a LayoutHints
| Container [GridNode a] LayoutHints
instance HasLayoutHints (GridNode a) where
--modLayoutHints :: (LayoutHints -> LayoutHints) -> GridNode a -> GridNode a
modLayoutHints f (Box x lhs) = Box x (f lhs)
modLayoutHints f (Container gns lhs) = Container gns (f lhs)
instance Functor GridNode where
fmap f (Box x lhs) = Box (f x) lhs
fmap f (Container gns lhs) = Container (map (fmap f) gns) lhs
-- other hints that might be implemented in the future
-- | ClearLeft | ClearRight | MinHeight Int | MaxHeight Int | MinWidth Int | MaxWidth Int
layoutHints :: GridNode a -> LayoutHints
layoutHints (Box _ lhs) = lhs
layoutHints (Container _ lhs) = lhs
addChildren :: GridNode a -> [GridNode a] -> GridNode a
addChildren gn [] = gn
addChildren (Container gns lhs) gns' = Container (gns ++gns') lhs
addChildren (Box x lhs) gns' = Container (toBox x : gns') lhs
-----------------------------
-- in first sibling ---------
-----------------------------
moveSiblings :: [GridNode a] -> [GridNode a]
moveSiblings [] = []
moveSiblings (gn:gns) = moveSiblings' (resetInFstSibling gn) gns
moveSiblings' :: GridNode a -> [GridNode a] -> [GridNode a]
moveSiblings' gn gns = addChildren gn (map resetInFstSibling toBeMovedGns) : notToBeMovedGns
where
(toBeMovedGns, notToBeMovedGns) = partition (inFstSibling . layoutHints) gns
-----------------------------
-- page area calculation ----
-----------------------------
gridNodesByPageArea :: [GridNode a] -> (
[GridNode a], -- inMain nodes
[GridNode a], -- inHeader nodes
[GridNode a], -- inFooter nodes
[GridNode a], -- inLeftSidebar nodes
[GridNode a] -- inRightSidebar nodes
)
gridNodesByPageArea gns = (
lookupGridNodes InMain,
lookupGridNodes InHeader,
lookupGridNodes InFooter,
lookupGridNodes InLeftSidebar,
lookupGridNodes InRightSidebar
)
where
--lookupGridNodes :: PageAreaHint -> [GridNode a]
lookupGridNodes hint = fromMaybe [] (lookup hint classifiedGridNodes)
--classifiedGridNodes :: [(PageAreaHint,[GridNode a])]
classifiedGridNodes = partitionByEq pageArea gns
pageArea :: GridNode a -> PageAreaHint
pageArea = (fromMaybe InMain) . pageAreaHint'
pageAreaHint' :: GridNode a -> Maybe PageAreaHint
pageAreaHint' (Box _ lhs) = pageAreaHint lhs
pageAreaHint' (Container gns lhs) = pageAreaHint lhs `mplus` (occurresMost . catMaybes . map pageAreaHint') gns
-----------------------------------
-- vertical layout calculation ----
-----------------------------------
-- must be applied to all containers, not just top level containers. It is not recursive.
gridNodesVerticalPartitions :: [GridNode a] -> [[GridNode a]]
gridNodesVerticalPartitions = map snd . sortByFst . partitionByEq (verticalHint . layoutHints) . moveSiblings
------------------------------------------
-- columns and clearsides calculation ----
------------------------------------------
splitClearSides :: [[GridNode a]] -> [[GridNode a]]
splitClearSides = splitTruesAlone ((==ClearSides) . horizontalHint . layoutHints)
splitTruesAlone :: (a->Bool) -> [[a]] -> [[a]]
splitTruesAlone f = concat . map (splitTruesAlone' f)
{-
[[top], [bot]]
[[[topCs1],[topCs2],[topothers]], [[botCs1],[botCs2],[botothers]] ]
[[topCs1],[topCs2],[topothers], [botCs1],[botCs2],[botothers] ]
-}
splitTruesAlone' :: (a->Bool) -> [a] -> [[a]]
splitTruesAlone' f gns = case withFalse of
[] -> withTrueLists
_ -> withTrueLists ++ [withFalse]
where
(withTrue, withFalse) = partition f gns
withTrueLists = map (:[]) withTrue
gridNodesByColumns :: Maybe Int -> [GridNode a] -> [[GridNode a]]
gridNodesByColumns colSpec gns
= if cols == 1
then [gns] -- dont care about horizontal layouts since all of them go in 1 column
else (balancedGroups cols . concat . gridNodesHorizontalPartitions) gns
where
cols = columns colSpec gns
gridNodesHorizontalPartitions :: [GridNode a] -> [[GridNode a]]
gridNodesHorizontalPartitions = map snd . sortByFst . partitionByEq (horizontalHint . layoutHints)
columnsQtyOpts = [1,2,3,4]
defaultColumnQty = 1
-- select the number of columns that will be used for a subset of the children of a container
-- The first argument, is the container specification of columns
-- the second argument is a subset of the children of the container to layout
columns :: Maybe Int -> [GridNode a] -> Int
columns colSpec gns = fromMaybe (columnsQtyElection gns) colSpec
-- uses valid votes from children to select from columnsQtyOpts or the default if there are no valid votes
columnsQtyElection :: [GridNode a] -> Int
columnsQtyElection = selectColumnQtyOption . catMaybes . map (columnsQtyVote . layoutHints)
selectColumnQtyOption :: [Int] -> Int
selectColumnQtyOption [] = defaultColumnQty
selectColumnQtyOption votes = (head . sortOptionsByVotes columnsQtyOpts) votes
sortOptionsByVotes :: [Int] -> [Int] -> [Int]
sortOptionsByVotes opts votes
= sortBy (comparing (distance votes)) opts
where
distance :: [Int] -> Int -> Int
distance vs opt = sum $ map (sqr . (opt-) ) vs
sqr x = x*x
--------------------------------------
------ More GridNode combinators -----
--------------------------------------
boxInMain, boxInHeader, boxInFooter, boxInLeftSidebar, boxInRightSidebar :: a -> GridNode a
boxInMain = inMain . toBox
boxInHeader = inHeader . toBox
boxInFooter = inFooter . toBox
boxInLeftSidebar = inLeftSidebar . toBox
boxInRightSidebar = inRightSidebar . toBox
-- unsafe
fromBox :: GridNode a -> a
fromBox (Box x _) = x
toBox :: a -> GridNode a
toBox x = Box x blankHints
fromContainer :: GridNode a -> [GridNode a]
fromContainer (Container xs _) = xs
toContainer :: [GridNode a] -> GridNode a
toContainer xs = Container xs blankHints
------------------------------
------ Utility functions -----
------------------------------
{- | Separates a list of elements in n lists of list of elements (or n groups), being n the value of the first arg.
The number of elements in the lists produced is balanced.
As the number of elements in the orginal group might not be a multiple of n, some lists produced will have one more elements
than others
Some examples of the usage of the function:
balancedGroups 3 [1..9] = [[1,2,3],[4,5,6],[7,8,9]]
balancedGroups 3 [1..10] = [[1,2,3,4],[5,6,7],[8,9,10]]
balancedGroups 3 [1..11] = [[1,2,3,4],[5,6,7,8],[9,10,11]]
balancedGroups 3 [1..12] = [[1,2,3,4],[5,6,7,8],[9,10,11,12]]
-}
balancedGroups :: Int -> [a] -> [[a]]
balancedGroups n xs = bigGroups ++ smallGroups
where
(bigGroups, xs') = iterateNTimes bigGroupsQty (splitAt elemsQtyMax) xs
(smallGroups, xs'') = iterateNTimes smallGroupsQty (splitAt elemsQtyMin) xs'
elemsQtyMin = xsLength `div` n
elemsQtyMax = elemsQtyMin + 1
bigGroupsQty = xsLength `mod` n
smallGroupsQty = n - bigGroupsQty
xsLength = length xs
iterateNTimes :: Int -> (a -> (b,a)) -> a -> ([b],a)
iterateNTimes 0 f seed = ([],seed)
iterateNTimes n f seed = (x:xs, seed'')
where
(x, seed') = f seed
(xs, seed'') = iterateNTimes (n-1) f seed'
sortByFst :: Ord a => [(a,b)] -> [(a,b)]
sortByFst = sortBy (comparing fst)
partitionByEq :: Eq b => (a -> b) -> [a] -> [(b,[a])]
partitionByEq f = partitionByEq' . map (\x->(f x, x))
partitionByEq' :: Eq b => [(b,a)] -> [(b,[a])]
partitionByEq' [] = []
partitionByEq' ((y,x): ysxs)
= (y, x:inClassY) : partitionByEq' ysxs'
where
(withY, ysxs') = partition ( (==y) . fst) ysxs
inClassY = map snd withY
occurrencies :: Eq a => [a] -> [(a,Int)]
occurrencies [] = []
occurrencies (x:xs) = let (equalsToX,others) = partition (==x) xs
in (x, 1 + length equalsToX) : occurrencies others
occurresMost :: Eq a => [a] -> Maybe a
occurresMost xs = case occurrencies xs of
[] -> Nothing
howManies -> (Just . fst . maximumBy cmp) howManies
where
cmp (_,x) (_,y) = compare x y