Binary.hs

-- | Binary trees.
--
-- For example, @map drawBinTree_ (binaryTrees 4)@ produces the diagrams:
--
-- <<svg/bintrees.svg>>
--
--

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
module Math.Combinat.Diagrams.Trees.Binary where

--------------------------------------------------------------------------------

import Math.Combinat.Trees.Binary

-- import Data.Colour hiding ( atop )

import Diagrams.Core

import Diagrams.Prelude

--------------------------------------------------------------------------------

drawBinTree_ :: forall a b. (Backend b V2 Double, Renderable (Path V2 Double) b) => BinTree a -> QDiagram b V2 Double Any
drawBinTree_ = go "." where

  radius  = 0.25 :: Double
  radius1 = 0.15 :: Double

  fx = 0.5 :: Double
  fy = 1.0 :: Double

  linewidth = 0.04 :: Double
  
  go :: String -> BinTree a -> QDiagram b V2 Double Any
  go name t = (centerXY stuff # lwL linewidth) where
    stuff = case t of
      Leaf   _   -> square radius # named name # fc blue 
      Branch l r -> cherry where
        cherry = subdiags # attach name lname # attach name rname
        node   = circle radius1 # extrudeBottom fy # fc red # named name
        subdiags = (centerX node) === (centerX (ldiag ||| rdiag))
        ldiag = alignT (go lname l # extrudeRight fx)
        rdiag = alignT (go rname r # extrudeLeft  fx)
        lname = 'L' : name
        rname = 'R' : name
 
  attach n1 n2 =
    withName n1 $ \b1 -> withName n2 $ \b2 ->
      (flip atop) ((location b1 ~~ location b2) # lwL linewidth)           
      
  frameX t = extrudeLeft t . extrudeRight t
  frameY t = extrudeTop  t

--------------------------------------------------------------------------------

{-
padX :: (Backend b V2 Double, Monoid' m) => Double -> QDiagram b V2 Double m -> QDiagram b V2 Double m
padX s d = withEnvelope (d # scaleX s) d

frame :: ( Backend b v, InnerSpace v, OrderedField (Scalar v), Monoid' m)
        => Scalar v -> QDiagram b v m -> QDiagram b v m
frame s d = setEnvelope (onEnvelope t (d^.envelope)) d
  where
    t f = \x -> f x + s
-}