module FPPrac.Trees.GeneralTree where
import EventLoop.CommonTypes
import EventLoop.Output
import FPPrac.Trees.LayoutTree
textFont = "Courier"
textHeight = 16 :: Float
charWidth = 10 :: Float
marginBetweenTrees = 10 :: Float
marginBetweenNodeContent = 2 :: Float
marginBetweenNodeRows = 20 :: Float
marginBetweenNodeColumns = 20 :: Float
data GeneralTree = GeneralTreeBox [GeneralNodeContent] [(GeneralLine, GeneralTree)] deriving (Show)
data GeneralNodeContent = GeneralNodeText Color String
| GeneralNode Color Radius
deriving (Show)
data GeneralLine = GeneralLine Color
deriving (Show)
type Offset = Float
type LeftOffset = Offset
type TopOffset = Offset
type RightOffset = Offset
type BottomOffset = Offset
type Middle = Float
type Height = Float
class GeneralizeTree a where
generalizeTree :: a -> GeneralTree
instance GeneralizeTree GeneralTree where
generalizeTree a = a
generalNodeDimension :: GeneralTree -> Dimension
generalNodeDimension (GeneralTreeBox content _) = flattenDimensions contentDimensions
where
contentDimensions = map generalNodeContentDimension content
flattenDimensions :: [Dimension] -> Dimension
flattenDimensions [] = (0.0,0.0)
flattenDimensions [d] = d
flattenDimensions ((w,h):ds) = (max w wTotal, h + marginBetweenNodeContent + hTotal)
where
(wTotal, hTotal) = flattenDimensions ds
generalNodeContentDimension :: GeneralNodeContent -> Dimension
generalNodeContentDimension (GeneralNodeText _ str) = textSize str
generalNodeContentDimension (GeneralNode _ rad ) = (2*rad, 2*rad)
layoutGeneralTree :: LeftOffset -> TopOffset -> GeneralTree -> (LayoutTree, RightOffset, BottomOffset)
layoutGeneralTree leftOffset topOffset box@(GeneralTreeBox content children) = (LBox (x, y) topConnect bottomConnect lcs lchildrenWithLines, rightOffset, bottomOffsetChildren)
where
x = leftBorder
y = topOffset
middle = (rightOffset leftOffset) / 2 + leftOffset
rightOffset = max rightOffsetChildren (leftOffset + width)
leftBorder = middle (width / 2)
topConnect = (width / 2, 0)
bottomConnect = (width / 2, height)
(width, height) = generalNodeDimension box
lcs = layoutGeneralNodeContentList (width / 2) 0 content
(lchildrenWithLines, rightOffsetChildren, bottomOffsetChildren) = layoutGeneralTreeChildren leftOffset (topOffset + marginBetweenNodeRows + height) children
layoutGeneralTreeChildren :: LeftOffset -> TopOffset -> [(GeneralLine, GeneralTree)] -> ([(LayoutLine, LayoutTree)], RightOffset, BottomOffset)
layoutGeneralTreeChildren left top treesWithLines =(zip lLines lTrees, right, bottom)
where
lines = map fst treesWithLines
generalTrees = map snd treesWithLines
lLines = map layoutLine lines
(lTrees, right, bottom) = layoutGeneralTrees left top generalTrees
layoutLine :: GeneralLine -> LayoutLine
layoutLine (GeneralLine color) = LayoutLine color
layoutGeneralTrees :: LeftOffset -> TopOffset -> [GeneralTree] -> ([LayoutTree], RightOffset, BottomOffset)
layoutGeneralTrees left top [] = ([], left, top)
layoutGeneralTrees left top [box] = (\(a,b,c) -> ([a],b,c)) $ layoutGeneralTree left top box
layoutGeneralTrees left top (box:bs) = (lbox:lrest, rightRest, max bottom bottomRest)
where
(lbox, right , bottom) = layoutGeneralTree left top box
(lrest, rightRest, bottomRest) = (layoutGeneralTrees (right + marginBetweenNodeColumns) top bs)
layoutGeneralNodeContentList :: Middle -> Height -> [GeneralNodeContent] -> [LayoutNodeContent]
layoutGeneralNodeContentList _ _ [] = []
layoutGeneralNodeContentList middle height [nc] = [layoutGeneralNodeContent (middle, height) nc]
layoutGeneralNodeContentList middle height (nc:ncs) = lnc:(layoutGeneralNodeContentList middle height' ncs)
where
height' = height + ncHeight + marginBetweenNodeContent
(_, ncHeight) = generalNodeContentDimension nc
lnc = layoutGeneralNodeContent (middle, height) nc
layoutGeneralNodeContent :: Pos -> GeneralNodeContent -> LayoutNodeContent
layoutGeneralNodeContent (middle, top) gnc@(GeneralNodeText color str) = LayoutNodeText color (x,y) str (textSize str)
where
x = middle
y = top + h/2
(w, h) = generalNodeContentDimension gnc
layoutGeneralNodeContent (middle, top) gnc@(GeneralNode color rad) = LayoutNode color (x,y) rad
where
x = middle
y = top + h/2
(w, h) = generalNodeContentDimension gnc
textSize :: [Char] -> (Float, Float)
textSize str = (textWidth, textHeight)
where
textWidth = charWidth * (fromIntegral (length str))
showTree :: (GeneralizeTree a) => a -> IO ()
showTree a = showTreeList [a]
showTreeList :: (GeneralizeTree a) => [a] -> IO ()
showTreeList list = outSingle (OutGraphical (Draw (showTreeList' 0 0 0 0 list) "trees"))
showTreeList' :: (GeneralizeTree a) => LeftOffset -> TopOffset -> Float -> Int -> [a] -> GObject
showTreeList' _ _ _ _ [] = Container []
showTreeList' left top maxBottom i (x:xs) | right <= 1024 = Container (text:gtree:gtrees)
| width > 1024 = Container (text:gtree:gtrees)
| otherwise = showTreeList' 0 maxBottom' maxBottom' i (x:xs)
where
maxBottom' = max maxBottom bottom
(ltree, right, bottom) = layoutGeneralTree left top (generalizeTree x)
gtree = printTree ltree
Container gtrees = showTreeList' (right + marginBetweenTrees) top maxBottom' i' xs
i' = i + 1
text = treeIndex i (left, top)
width = right left
treeIndex :: Int -> Pos -> GObject
treeIndex i pos = GObject "treeIndex" (Text (255, 125, 125) 0 (255,75,75) pos 20 "Courier" (show i) False) []