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 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
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
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
gridNodesByPageArea :: [GridNode a] -> (
[GridNode a],
[GridNode a],
[GridNode a],
[GridNode a],
[GridNode a]
)
gridNodesByPageArea gns = (
lookupGridNodes InMain,
lookupGridNodes InHeader,
lookupGridNodes InFooter,
lookupGridNodes InLeftSidebar,
lookupGridNodes InRightSidebar
)
where
lookupGridNodes hint = fromMaybe [] (lookup hint classifiedGridNodes)
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
gridNodesVerticalPartitions :: [GridNode a] -> [[GridNode a]]
gridNodesVerticalPartitions = map snd . sortByFst . partitionByEq (verticalHint . layoutHints) . moveSiblings
splitClearSides :: [[GridNode a]] -> [[GridNode a]]
splitClearSides = splitTruesAlone ((==ClearSides) . horizontalHint . layoutHints)
splitTruesAlone :: (a->Bool) -> [[a]] -> [[a]]
splitTruesAlone f = concat . map (splitTruesAlone' f)
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]
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
columns :: Maybe Int -> [GridNode a] -> Int
columns colSpec gns = fromMaybe (columnsQtyElection gns) colSpec
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
boxInMain, boxInHeader, boxInFooter, boxInLeftSidebar, boxInRightSidebar :: a -> GridNode a
boxInMain = inMain . toBox
boxInHeader = inHeader . toBox
boxInFooter = inFooter . toBox
boxInLeftSidebar = inLeftSidebar . toBox
boxInRightSidebar = inRightSidebar . toBox
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
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 (n1) 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