Slash-Trees.fs

(*
           Example Tree Print
           ------------------

                  ______________[64]______________      
                 /                                \      
         ____[73]_____                        _____[88]  
        /             \                      /         \
     [0]               [13]              [32]            
    /   \             /    \            /    \          
[-3]     [2]      [-8]      [5]      [6]      [15]      
*)





let printTree tree =
    let bars    x   =
        match x with
        | x when x <= 0 ->  String.replicate 0 "_"
        | x             ->  String.replicate x "_"
    let spaces  x   =
        match x with
        | x when x <= 0 ->  String.replicate 0 " "
        | x             ->  String.replicate x " "
    let listConcat (ls:string list):string=
        let rec concat_stringlist (strs: string list)(acc:string) : string =
            match strs with
            | x::[] -> concat_stringlist [] (acc + x + "\n" )
            | x::xs -> concat_stringlist xs (acc + x + "\n" )
            | []    -> acc
        concat_stringlist ls ""
   
    (* [strings], 1st, 2nd, 3rd
       strings are all the same width (space padded if needed)
       first int is that total width
       second int is the column the root node starts in
       third int is the column the root node ends in *)
    let rec formatNode tree =
        match tree with
        | Leaf              -> [tree.Name()]        ,
                                0                   ,
                                0                   ,
                                0
                           
        | Node(Leaf,s,Leaf) -> [tree.Name()]        ,
                                tree.Name().Length  ,
                                0                   ,
                                tree.Name().Length-1
        | Node(left,s,right)    
            ->  
                let nodestr         = tree.Name()
                let nodelen         = nodestr.Length
                let lhlf            = nodelen /2
                let rhlf            = (nodelen-1)/2
                let leftStrings     ,    
                    lWidth          ,
                    leftColStart    ,
                    leftColEnd      = formatNode left
                let rightStrings    ,
                    rWidth          ,
                    rightColStart   ,
                    rightColEnd     = formatNode right
                let leftWidth,
                    rightWidth      = max 1 lWidth, max 1 rWidth
 
                let totalWidth      = leftWidth     + nodelen + 2 + rightWidth
                let rightColStart2  = rightColStart + nodelen + leftWidth
                let leftbarnum      =  leftWidth - leftColEnd - 1
                let rightbarnum     = rightColStart
                let leftbars        = leftbarnum    |> bars
                let rightbars       = rightbarnum   |> bars
                let leftpadding     = leftWidth  - leftbarnum   + 1 |> spaces
                let rightpadding    = rightWidth - rightbarnum  + 1 |> spaces
                let lconnectpad     = leftpadding.Length        - 1 |> spaces
                let rconnectpad     = rightpadding.Length       - 1 |> spaces
                let baseline        = leftpadding + leftbars + nodestr + rightbars + rightpadding
                let pipeline        = lconnectpad + "/" + (leftbarnum |> spaces)    + (nodelen |> spaces) +
                                        (rightbarnum |> spaces)   + "\\" + rconnectpad
                let ladjHeight, radjHeight =
                    match leftStrings, rightStrings with
                    | l,r when l.Length > r.Length  
                            ->  let hpad = List.init (l.Length - r.Length) (fun x -> "")
                                l, r @ hpad
                    | l,r when r.Length > l.Length  
                            ->  let hpad = List.init (r.Length - l.Length) (fun x -> "")
                                l @ hpad, r
                    | l,r   ->  l,r
                let rec fixWidthLeft  (strs:string list) (width:int) =
                    match strs with
                    | x::xs when x.Length < width
                            -> (spaces (width - x.Length) + x)::fixWidthLeft xs width
                    | x::xs -> x::fixWidthLeft xs width
                    | []    -> []
                let rec fixWidthRight (strs:string list) (width:int) =
                    match strs with
                    | x::xs when x.Length < width
                            -> (x + spaces (width - x.Length))::fixWidthRight xs width
                    | x::xs -> x::fixWidthRight xs width
                    | []    -> []
                let ladjHW, radjHW =    fixWidthLeft  ladjHeight leftWidth ,
                                        fixWidthRight radjHeight rightWidth
                let children = (ladjHW, radjHW )
                                ||> List.map2 (fun left right -> left + (nodelen + 2 |> spaces) + right )
                let treelines = baseline::pipeline::children
                in
                treelines, totalWidth, leftWidth+1, leftWidth + nodelen
    let childStrings,_,_,_ = formatNode tree
    childStrings |> listConcat