treemap-html (empty) → 0.1
raw patch · 6 files changed
+317/−0 lines, 6 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, filepath, ghc, html, parsec, regex-posix
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- src/Text/HTML/TreeList.hs +21/−0
- src/Text/HTML/TreeMap.hs +166/−0
- src/Text/HTML/TreeUtils.hs +57/−0
- treemap-html.cabal +44/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Radoslav Dorcik 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/HTML/TreeList.hs view
@@ -0,0 +1,21 @@+module Text.HTML.TreeList ( treeList )+where+import Data.Tree+import Data.List++mkHTMLBox :: String -> String -> String+mkHTMLBox cs co = "<table style=\"border: 2px solid orange;\" cellpadding=1 cellspacing=1 border=0 bgcolor=\""++co++"\">"+ ++"<tr><td>"++(mkHTMLLines cs)++"</td></tr></table>\n"++mkHTMLLines :: String -> String+mkHTMLLines x = intercalate "<br/>" $ lines x++treeList :: Tree String -> String+treeList (Node s xs) = (mkHTMLBox s "lightyellow") ++ (mkList $ map treeList xs)++mkList :: [String] -> String+mkList [] = ""+mkList xs = let lnStart = "<ul>"+ lnIn = map (\x -> "<li style=\"list-style-type: none;\">"++x++"</li>") xs+ lnEnd = "</u>"+ in unlines ([lnStart] ++ lnIn ++ [lnEnd])
+ src/Text/HTML/TreeMap.hs view
@@ -0,0 +1,166 @@+module Text.HTML.TreeMap ( treeMapExt+ , treeMap+ , defaultTreeOpts+ , TreeMapOptions(..))+where+import Data.Tree+import Data.List (sortBy, groupBy)+import Text.HTML.TreeUtils+import Text.Html++--+-- Configuration Data Types+--+data TreeMapOptions = TreeMapOptions { toLeafColor :: String -- background color of boxes the leafs+ , toAltColors :: [String] -- background colors of non-leafs. they are alternated+ }++-- Good default settings for the colors+defaultTreeOpts :: TreeMapOptions+defaultTreeOpts = TreeMapOptions "white" ["yellow", "orange", "#9ACD32", "#FFD700" , "#FF6347" ]++--+-- Box Data Types. It is used for better expressing layouting algorithm result.+-- Basically layouting algorithm has to decide how many tables with how many+-- columns are used for nested boxes representation. Current implementation +-- uses only one big TableBox in BoxGrid. But for future there migh be better+-- approach. The goal is to display treemap with as much as possible taken place+-- and unused gaps.+-- +data Box = BoxText { boName :: String,+ boId :: Int }+ | BoxGrid { boName :: String,+ boId :: Int,+ boGrid :: [TableBox] } deriving (Ord,Eq,Show)++-- Type used witin Box with already decided layoting, for nested box groups+data TableBox = TableBox { tbCols :: Int, tbCels :: [Box] } deriving (Ord,Eq,Show)++--+-- Size Basic Functions+--+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)+--+-- Get Size of Elements+-- +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))++-- size2square :: BoxSize -> Int+-- size2square (w,h) = w*h++-- boxSquare :: Box -> Int+-- boxSquare = size2square . boxSize++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 -- this will increase height. It is heuristic constant :)+ +-- Function which figure <1..0) number with following meaning+-- 1 : the Box is really Square+-- 0 : the Box is actually Rectangle+boxFactor :: BoxSize -> Float+boxFactor (w,h) | h > w = (fromIntegral w)/(fromIntegral h)+ | otherwise = (fromIntegral h)/(fromIntegral w)+--+-- Layout Functions+--+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)+ --boxesGroups = groupBy (\a b -> (abs $ (snd $ boxSize a) - (snd $ boxSize b)) < thr) (sortBoxesBySize sx)+ --thr = 300++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]++--+-- Render Functions+-- +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++-- Rotate colors during folding tree+rotColors :: TreeMapOptions -> TreeMapOptions+rotColors (TreeMapOptions lc []) = TreeMapOptions lc []+rotColors (TreeMapOptions lc (c:acs)) = TreeMapOptions lc (acs++[c])++--+-- Render given Tree of String into HTML with default+-- options.+--+treeMap :: Tree String -> String+treeMap xs = treeMapExt defaultTreeOpts xs++--+-- Render given Tree of String into HTML using options+-- provided.+--+treeMapExt :: TreeMapOptions -> Tree String -> String+treeMapExt opts xs = renderHtml $ concatHtml [displayBoxJS,boxes]+ where+ boxes = renderBox opts $ treeMapLBox lxs+ lxs = tree2ltree xs++--+-- Create for the Tree of Strings the Box which can+-- be than rendered to String.+--+treeMapLBox :: Tree (Int,String) -> Box+treeMapLBox (Node (i,s) xs) = mkBox s i (map treeMapLBox xs)++--+-- Testing Section, example & main+--+{-+exampleTree :: Tree String+exampleTree = Node "rado" [Node "peter" [Node "jano" [] ], Node "dusan" [Node "jozef" [Node "Longer Name" [] ] ]]++main = putStrLn (treeMap exampleTree)+-}
+ src/Text/HTML/TreeUtils.hs view
@@ -0,0 +1,57 @@+module Text.HTML.TreeUtils (mkHTMLBox, + BoxProps(..), + defBoxProps,+ displayBoxJS,+ tree2ltree)+where+--import Data.List (sortBy, intercalate, groupBy)+import Text.Html+import Data.Tree++data BoxProps = BoxProps { boxFillColor :: String, boxBorderColor :: String, boxBorderWidth :: Int } deriving Show++defBoxProps :: BoxProps+defBoxProps = BoxProps "white" "black" 2++-- Javascript resposible for correct reaction onclick event. +-- Purporse of this code is fold / unfold given element using+-- HTML element style none. +displayBoxJS :: Html+displayBoxJS = primHtml $ unlines [ "<script type=\"text/javascript\">"+ ,"function displayBox(i){"+ ,"var row = document.getElementById(\"boxId\"+i);"+ ,"if (row.style.display == '') row.style.display = 'none';"+ ,"else row.style.display = '';"+ ," }"+ ,"</script>"]++-- Label which call displayBox(x) in the case of mouse click.+clickLabel :: String -> Int -> Html+clickLabel cs i = let txt = prettyHtml $ linesToHtml (lines cs)+ onclick = "onclick=\"displayBox("++(show i)++")\""+ in primHtml $ "<div "++onclick++">" ++ txt ++ "</div>"++mkHTMLBox :: String -> Int -> [Html] -> Int -> BoxProps -> Html+mkHTMLBox cs i [] _ prop = simpleTable (tabAttrs prop) [] [[clickLabel cs i]]+mkHTMLBox cs i xs n prop = simpleTable (tabAttrs prop) [] $ [[clickLabel cs i]] ++ (filter (not . null) $ mkRows xs)+ where+ mkRows [] = [[]]+ mkRows ys = (take n ys):(mkRows (drop n ys))++tabAttrs :: BoxProps -> [HtmlAttr]+tabAttrs prop = let borderStyle = thestyle $ concat [ "border: ",(show $ boxBorderWidth prop), "px solid "+ , (boxBorderColor prop)+ , ";" ]+ in [ borderStyle, bgcolor (boxFillColor prop) ]++-- Ineffectient function for assign unique number to each Node.+-- Has to be rewritten.+tree2ltree :: Tree a -> Tree (Int,a)+tree2ltree xs = tree2ltree' 1 xs+ where+ tree2ltree' l (Node r cx) = Node (l, r) lcx+ where+ lcx = snd $ foldr (labNode) (l+1,[]) cx+ labNode c (l',lcx') = (l'+step, (tree2ltree' l' c):lcx')+ where+ step = length (flatten c)
+ treemap-html.cabal view
@@ -0,0 +1,44 @@+name: treemap-html+version: 0.1+License: BSD3+License-File: LICENSE+author: Radoslav Dorcik <radoslav.dorcik@gmail.com>+maintainer: Radoslav Dorcik <radoslav.dorcik@gmail.com>+description: Generates HTML for Data.Tree as TreeMap which+ is possible explore directly in browser because+ of small javascript code included.+ Each node is displayed as white box without+ any nested boxes inside. +synopsis: Generates HTML for Data.Tree as TreeMap+category: Graphics+stability: provisional+build-type: Simple+cabal-version: >= 1.6++Homepage: http://rampa.sk/static/treemap-html.html+Source-Repository head+ type: darcs+ location: http://patch-tag.com/r/dixiecko/treemap-html++flag testing+ description: Enable Debugging things like QuickCheck properties, etc.+ default: False++library+ build-depends: ghc >= 6.10,+ base == 4.*,+ parsec == 2.1.0.*,+ regex-posix,+ filepath,+ html,+ containers,+ Cabal >= 1.5 && < 1.9+ hs-source-dirs: src+ extensions: CPP, PatternGuards, DeriveDataTypeable, TypeSynonymInstances+ ghc-options: -Wall++ Exposed-modules:+ Text.HTML.TreeMap+ Text.HTML.TreeUtils+ Text.HTML.TreeList+