module Text.HTML.TreeMap ( treeMapExt
, treeMap
, defaultTreeOpts
, TreeMapOptions(..))
where
import Data.Tree
import Data.List (sortBy, groupBy)
import Text.HTML.TreeUtils
import Text.Html
data TreeMapOptions = TreeMapOptions { toLeafColor :: String
, toAltColors :: [String]
}
defaultTreeOpts :: TreeMapOptions
defaultTreeOpts = TreeMapOptions "white" ["yellow", "orange", "#9ACD32", "#FFD700" , "#FF6347" ]
data Box = BoxText { boName :: String,
boId :: Int }
| BoxGrid { boName :: String,
boId :: Int,
boGrid :: [TableBox] } deriving (Ord,Eq,Show)
data TableBox = TableBox { tbCols :: Int, tbCels :: [Box] } deriving (Ord,Eq,Show)
type IntW = Int
type IntH = Int
type BoxSize = (IntW,IntH)
concatRowSize :: [BoxSize] -> BoxSize
concatRowSize [] = (0,0)
concatRowSize (x:xs) = plusSize x (concatRowSize xs)
where
plusSize (a1,b1) (a2,b2) = (a1+a2,max b1 b2)
tableSize :: TableBox -> BoxSize
tableSize (TableBox _ []) = (0,0)
tableSize (TableBox n xs) = (maximum (rowW xs), sum (rowH xs))
where
rowW [] = [0]
rowW ys = (fst $ concatRowSize $ map (boxSize) (take n ys)):(rowW (drop n ys))
rowH [] = [0]
rowH ys = (snd $ concatRowSize $ map (boxSize) (take n ys)):(rowH (drop n ys))
labelSize :: String -> BoxSize
labelSize cs = (maximum $ map length (lines cs),length (lines cs))
boxSize :: Box -> BoxSize
boxSize (BoxText cs _ ) = labelSize cs
boxSize (BoxGrid cs _ xs) = (boxW, boxH)
where
boxW = maximum (rowW xs)
boxH = round (fontCorr * (fromIntegral $ sum (rowH xs)) :: Double)
rowW [] = [fst $ labelSize cs]
rowW ys = (fst $ concatRowSize $ map (tableSize) (take 1 ys)):(rowW (drop 1 ys))
rowH [] = [snd $ labelSize cs]
rowH ys = (snd $ concatRowSize $ map (tableSize) (take 1 ys)):(rowH (drop 1 ys))
fontCorr = 1.3
boxFactor :: BoxSize -> Float
boxFactor (w,h) | h > w = (fromIntegral w)/(fromIntegral h)
| otherwise = (fromIntegral h)/(fromIntegral w)
mkBox :: String -> Int -> [Box] -> Box
mkBox cs i [] = BoxText cs i
mkBox cs i sx = BoxGrid cs i (sortBy (\t1 t2 -> (tbCols t2) `compare` (tbCols t1)) $ map findBestTable boxesGroupsSorted)
where
boxesGroupsSorted = map (sortBoxesByH) boxesGroups
boxesGroups = groupBy (\_ _ -> True) (sortBoxesBySize sx)
sortBoxesBySize, sortBoxesByH :: [Box] -> [Box]
sortBoxesBySize = sortBy (\a b -> boxSize a `compare` boxSize b)
sortBoxesByH = sortBy (\a b -> (snd $ boxSize a) `compare` (snd $ boxSize b))
findBestTable :: [Box] -> TableBox
findBestTable ys = TableBox (bestBoxCols ys) ys
where
tables xs = [ TableBox c xs | c <- [1..50] ]
bestBoxFactor xs = maximum [boxFactor $ tableSize t | t <- tables xs]
bestBoxCols xs = head [tbCols t | t <- tables xs, (boxFactor $ tableSize t) == bestBoxFactor xs]
renderTableBox :: TreeMapOptions -> Int -> TableBox -> Html
renderTableBox opts i (TableBox n xs) = simpleTable tAttr [] (filter (not . null) $ mkRows xs)
where
tAttr = [identifier ("boxId"++(show i)), thestyle "display: none;"]
mkRows [] = [[]]
mkRows ys = (map (renderBox (rotColors opts)) $ take n ys):(mkRows (drop n ys))
renderBox :: TreeMapOptions -> Box -> Html
renderBox opts (BoxText l i ) = mkHTMLBox l i [] 1 (defBoxProps { boxFillColor = toLeafColor opts })
renderBox opts (BoxGrid l i xs) = mkHTMLBox l i tbl 1 (defBoxProps { boxFillColor = head $ toAltColors opts })
where
tbl = map (renderTableBox opts i) xs
rotColors :: TreeMapOptions -> TreeMapOptions
rotColors (TreeMapOptions lc []) = TreeMapOptions lc []
rotColors (TreeMapOptions lc (c:acs)) = TreeMapOptions lc (acs++[c])
treeMap :: Tree String -> String
treeMap xs = treeMapExt defaultTreeOpts xs
treeMapExt :: TreeMapOptions -> Tree String -> String
treeMapExt opts xs = renderHtml $ concatHtml [displayBoxJS,boxes]
where
boxes = renderBox opts $ treeMapLBox lxs
lxs = tree2ltree xs
treeMapLBox :: Tree (Int,String) -> Box
treeMapLBox (Node (i,s) xs) = mkBox s i (map treeMapLBox xs)