module Wumpus.Tree
(
ScaleFactors
, uniformSF
, scaleFactors
, drawScaledTree
, TreeDirection(..)
, drawScaledTreeD
, drawScaledFamilyTree
, charNode
, textNode
, circleNode
, diskNode
)
where
import Wumpus.Tree.Base
import Wumpus.Tree.Design
import Wumpus.Tree.Draw
import Wumpus.Tree.ScalingContext
import Wumpus.Tree.TreeBuildMonad
import Wumpus.Basic.Kernel
import Wumpus.Drawing.Dots.AnchorDots
import Wumpus.Core
import Data.VectorSpace
type ScaleFactors u = ScalingContext u Int u
uniformSF :: Num u => u -> ScaleFactors u
uniformSF u = ScalingContext (\x -> u * x)
(\y -> u * fromIntegral y)
scaleFactors :: Num u => u -> u -> ScaleFactors u
scaleFactors sx sy = ScalingContext (\x -> sx * x)
(\y -> sy * fromIntegral y)
drawScaledTree :: (Real u, Floating u, InterpretUnit u, InnerSpace (Vec2 u))
=> ScaleFactors u -> Point2 u -> TreeBuildAns u
-> TreeDrawing u
drawScaledTree scale_f ogin (tree,annos) =
drawTree annos $ design ogin scale_f tree
data TreeDirection = TREE_UP | TREE_DOWN | TREE_LEFT | TREE_RIGHT
deriving (Eq,Ord,Show)
drawScaledTreeD :: (Real u, Floating u, InterpretUnit u, InnerSpace (Vec2 u))
=> ScaleFactors u -> Point2 u
-> TreeDirection -> TreeBuildAns u
-> TreeDrawing u
drawScaledTreeD scale_f ogin tdir (tree,annos) =
drawTree annos $ rotTree tdir $ design ogin scale_f tree
rotTree :: (Real u, Floating u)
=> TreeDirection -> CoordTree u a -> CoordTree u a
rotTree TREE_UP = rotateAboutRoot pi
rotTree TREE_DOWN = id
rotTree TREE_LEFT = rotateAboutRoot (1.5*pi)
rotTree TREE_RIGHT = rotateAboutRoot (0.5*pi)
drawScaledFamilyTree :: (Real u, Floating u, InterpretUnit u, InnerSpace (Vec2 u))
=> ScaleFactors u -> Point2 u -> TreeBuildAns u
-> TreeDrawing u
drawScaledFamilyTree scale_f ogin (tree,annos) =
drawFamilyTree annos $ design ogin scale_f tree
charNode :: (Real u, Floating u, InterpretUnit u)
=> Char -> TreeNode u
charNode = dotChar
textNode :: (Real u, Floating u, InterpretUnit u)
=> String -> TreeNode u
textNode = dotText . uptoNewline
where
uptoNewline = takeWhile (/='\n')
circleNode :: (Floating u, InterpretUnit u)
=> RGBi -> (a -> TreeNode u)
circleNode rgb = \_ -> localize (stroke_colour rgb) dotCircle
diskNode :: (Floating u, InterpretUnit u)
=> RGBi -> (a -> TreeNode u)
diskNode rgb = \_ -> localize (fill_colour rgb) dotDisk