A.13 DTreeFrame.oz

functor 
import Tk
export 'class' : DtreeFrame
define 
   DB = o(
           bg   : ivory
           word : o(font : o(family:helvetica
                             weight:bold
                             size  :12)
                    color: black)
           label: o(font : o(family:fixed
                             weight:normal
                             size  :12)
                    color: black)
           vstep: 15
           hstep: 5
           margin : o(top:20 left:20)
           vline: o(color:orange width:2)
           sline: o(color:slateblue width:2)
           )
   class Font from Tk.font 
      attr ascent descent
      meth tkInit(...) = M
         Tk.font,M
         ascent <- {Tk.returnInt font(metrics self ascent:unit)}
         descent<- {Tk.returnInt font(metrics self descent:unit)}
      end 
      meth measure(Text $)
         {Tk.returnInt font(measure self Text)}
      end 
      meth getAscent($) @ascent end 
      meth getDescent($) @descent end 
   end 
   WordFont = {New Font tkInit(family:DB.word.font.family
                               weight:DB.word.font.weight
                               size  :DB.word.font.size)}
   LabelFont= {New Font tkInit(family:DB.label.font.family
                               weight:DB.label.font.weight
                               size  :DB.label.font.size)}
   class DtreeFrame from Tk.frame 
      attr canvas tag
      meth tkInit(...)=M
         Tk.frame,M
         canvas <- {New Tk.canvas tkInit(parent:self bg:DB.bg)}
         tag    <- {New Tk.canvasTag tkInit(parent:@canvas)}
         H = {New Tk.scrollbar tkInit(parent:self orient:horizontal)}
         V = {New Tk.scrollbar tkInit(parent:self orient:vertical)}
      in 
         {@canvas tk(configure scrollregion:q(0 0 0 0))}
         {Tk.addXScrollbar @canvas H}
         {Tk.addYScrollbar @canvas V}
         {Tk.batch [grid(rowconfigure self 0 weight:1)
                    grid(columnconfigure self 0 weight:1)
                    grid(@canvas row:0 column:0 sticky:nswe)
                    grid(H row:1 column:0 sticky:we)
                    grid(V row:0 column:1 sticky:ns)]}
      end 
      meth clear {@canvas tk(delete @tag)} end 
      meth show(L)
         {self clear}
         %% L is a list of elements of the form
         %% o(string:WORD index:INDEX parent:INDEX2 label:LABEL)
         Nodes = {Map L
                  fun {$ X}
                     o(string:X.string label:X.label
                       index:X.index parent:{CondSelect X parent unit}
                       height:_ left:_
                       width:{Max
                              {WordFont  measure(X.string $)}
                              {LabelFont measure(X.label  $)}})
                  end}
         NodesR = {List.toRecord o {Map Nodes fun {$ N} N.index#N end}}
         %% we compute how high to place each node
         fun {Height N}
            if {IsDet N.height} then N.height
            elseif N.parent==unit then N.height=1
            else N.height=(1+{Height NodesR.(N.parent)}) end 
         end 
         MaxHeight =
         {FoldL Nodes fun {$ Accu N} {Max Accu {Height N}} end 0}
         Top = MaxHeight*DB.vstep+DB.margin.top
         %% compute left coord of each node
         ScrollWidth =
         {FoldL Nodes
          fun {$ Left N} N.left=Left Left+N.width+DB.hstep end 
          DB.margin.left}-DB.hstep+DB.margin.left
         ScrollHeight =
         Top+DB.margin.top+{WordFont getDescent($)}+{WordFont getAscent($)}
         {@canvas tk(configure scrollregion:q(0 0 ScrollWidth ScrollHeight))}
         %% create slanted lines
         {ForAll Nodes
          proc {$ N}
             if N.parent\=unit then 
                P  = NodesR.(N.parent)
                X1 = N.left+(N.width div 2)
                Y1 = N.height*DB.vstep
                X2 = P.left+(P.width div 2)
                Y2 = P.height*DB.vstep
             in 
                {@canvas tk(create line X1 Y1 X2 Y2 fill:DB.sline.color
                            width:DB.vline.width tags:@tag)}
             end 
          end}
         %% create text items, vertical lines, and labels
         {ForAll Nodes
          proc {$ N}
             X = N.left+(N.width div 2)
             Y = N.height*DB.vstep
          in 
             {@canvas tk(create line X Top X Y fill:DB.vline.color
                         width:DB.vline.width tags:@tag)}
             {@canvas tk(create text X Top fill:DB.word.color
                         font:WordFont anchor:n text:N.string tags:@tag)}
             {@canvas tk(create text X Y fill:DB.label.color
                         font:LabelFont anchor:s text:N.label tags:@tag)}
          end}
      in skip end 
   end 
end