package tree_layout

  1. Overview
  2. Docs

Source file layered.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
(*
 * Copyright (c) 2015 Gabriel Radanne <drupyog@zoho.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Utils
open Common


let fold_sibling f acc (seq : _ Iter.t) =
  let prev = ref None in
  let acc = ref acc in
  seq (fun elt -> acc := f !acc !prev elt ; prev := Some elt)

module type S = sig

  type t
  type vertex

  module H : Hashtbl.S with type key = vertex

  val layout :
    distance:(vertex -> vertex -> float) ->
    t -> vertex -> pos H.t
end

module type TREE = sig
  type t
  module V : Hashtbl.HashedType
  val children : t -> V.t -> (V.t -> unit) -> unit
  val rev_children : t -> V.t -> (V.t -> unit) -> unit
  val rightmost_child : t -> V.t -> V.t option
  val leftmost_child : t -> V.t -> V.t option
  val is_parent : t -> parent:V.t -> child:V.t -> bool
end


(** Implementation of
    Drawing routed trees in linear time
    -- Christoph Buchheim, Michael Jünger and Sebastian Leipert

    See there for proof/details of how it works.

    Also see https://github.com/abego/treelayout for another implementation.
*)
module Make (G : TREE) = struct

  module H = Hashtbl.Make (G.V)
  let get ~default tbl x =
    try H.find tbl x
    with Not_found -> default

  let find tbl x =
    try Some (H.find tbl x)
    with Not_found -> None


  type state = {
    ancestor : G.V.t H.t ;
    thread : G.V.t H.t ;
    modtbl : float H.t ;
    prelim : float H.t ;
    change : float H.t ;
    shift : float H.t ;
    numbers : int H.t ;
    distance : G.V.t -> G.V.t -> float ;
    g : G.t ;
  }

  let get_mod s v = get ~default:0. s.modtbl v
  let get_ancestor s v = get ~default:v s.ancestor v
  let get_prelim s v = get ~default:0. s.prelim v
  let incr tbl v x =
    H.add tbl v @@
    get ~default:0. tbl v +. x

  let next_right s v =
    match G.rightmost_child s.g v with
    | Some w -> Some w
    | None -> find s.thread v

  let next_left s v =
    match G.leftmost_child s.g v with
    | Some w -> Some w
    | None -> find s.thread v

  let number ~s ~parent v =
    match find s.numbers v with
    | Some i -> i
    | None ->
      let f i v = H.add s.numbers v (i+1) in
      Iter.iteri f @@ G.children s.g parent ;
      H.find s.numbers v

  let move_subtree ~s ~parent wm wp shift =
    let subtrees = float @@ number ~s ~parent wp - number ~s ~parent wm in
    incr s.change wp @@ ~-. shift /. subtrees ;
    incr s.shift  wp @@ shift ;
    incr s.change wm @@ shift /. subtrees ;
    incr s.prelim wp @@ shift ;
    incr s.modtbl wp @@ shift ;
    ()

  let execute_shifts ~s v =
    let shift = ref 0. in
    let change = ref 0. in
    let f w =
      incr s.prelim w !shift ;
      incr s.modtbl w !shift ;
      change := !change +. get ~default:0. s.change w ;
      shift := !shift +. get ~default:0. s.shift w +. !change ;
      ()
    in
    Iter.iter f (G.rev_children s.g v) ;
    ()

  let ancestor ~s ~defaultAncestor ~parent vim =
    let child = get_ancestor s vim in
    if G.is_parent s.g ~parent ~child then child
    else defaultAncestor

  let apportion ~s ~parent ~sibling ~defaultAncestor v =
    match sibling with
    | None -> defaultAncestor
    | Some w ->
      let vip = ref v and vop = ref v
      and vim = ref w in
      let vom = ref @@ Opt.get @@ G.leftmost_child s.g parent in
      let sip = ref @@ get_mod s !vip and sop = ref @@ get_mod s !vop
      and sim = ref @@ get_mod s !vim and som = ref @@ get_mod s !vom in
      let rec aux () = match next_right s !vim, next_left s !vip with
        | Some vim_, Some vip_ ->
          vim := vim_ ;
          vip := vip_ ;
          vom := Opt.get @@ next_left s !vom ;
          vop := Opt.get @@ next_right s !vop ;
          H.add s.ancestor !vop v ;
          let shift =
            (get_prelim s !vim +. !sim)
            -. (get_prelim s !vip +. !sip)
            +. s.distance !vim !vip
          in
          if shift > 0. then begin
            move_subtree ~s ~parent
              (ancestor ~s ~defaultAncestor ~parent !vim) v shift ;
            sip := !sip +. shift ;
            sop := !sop +. shift ;
          end ;
          sip := !sip +. get_mod s !vip ;
          sop := !sop +. get_mod s !vop ;
          som := !som +. get_mod s !vom ;
          sim := !sim +. get_mod s !vim ;
          aux ()
        | _ -> ()
      in
      aux () ;

      begin match next_right s !vim, next_right s !vop with
        | Some vim_, None ->
          H.add s.thread !vop vim_ ;
          H.add s.modtbl !vop @@ get_mod s !vop +. !sim -. !sop ;
        | _ -> ()
      end ;

      begin match next_left s !vip, next_left s !vom with
        | Some vip_, None ->
          H.add s.thread !vom vip_ ;
          H.add s.modtbl !vom @@ get_mod s !vom +. !sip -. !som ;
          v
        | _ -> defaultAncestor
      end

  let rec first_walk ~s ~sibling v =
    match G.leftmost_child s.g v with
    | None -> begin match sibling with
        | None -> ()
        | Some w ->
          H.add s.prelim v @@ get_prelim s w +. s.distance v w
      end
    | Some vl -> begin
        let vr = Opt.get @@ G.rightmost_child s.g v in
        fold_sibling
          (fun defaultAncestor sibling w ->
             first_walk ~s ~sibling w ;
             apportion ~s ~parent:v
               ~defaultAncestor
               ~sibling w)
          vl (G.children s.g v) ;
        execute_shifts ~s v ;
        let midpoint =
          ((get_prelim s vl) +. (get_prelim s vr)) /. 2.
        in
        match sibling with
        | Some w ->
          H.add s.prelim v @@ get_prelim s w +. s.distance v w ;
          H.add s.modtbl v @@ get_prelim s v -. midpoint ;
        | None ->
          H.add s.prelim v midpoint ;
      end

  let rec second_walk s result level v m =
    let x = get_prelim s v +. m in
    let y = float level in
    H.add result v {x;y} ;
    let f w = second_walk s result (level+1) w (m +. get_mod s v) in
    Iter.iter f (G.children s.g v) ;
    ()

  let layout ~distance g r =
    let modtbl = H.create 17 in
    let thread = H.create 17 in
    let ancestor = H.create 17 in
    let prelim = H.create 17 in
    let change = H.create 17 in
    let shift = H.create 17 in
    let result = H.create 17 in
    let numbers = H.create 17 in
    let s =
      { prelim ; modtbl ; thread ; ancestor ; change ; shift ; numbers ;
        distance ; g ; }
    in
    first_walk ~s ~sibling:None r ;
    second_walk s result 0 r (-. (H.find prelim r)) ;
    result

end

module type I = Hashtbl.HashedType
module type VIEW = sig
  type t
  val children : t -> t array
end

let array_rev_iter f a =
  let last = Array.length a - 1 in
  for i = last downto 0 do f a.(i) done
module MakeTree (V : I) (T : VIEW with type t = V.t)  = struct

  type t = unit
  module V = V

  let children () a k = Array.iter k @@ T.children a

  let rev_children () a k = array_rev_iter k @@ T.children a

  let leftmost_child () a =
    let a = T.children a in
    let l = Array.length a in
    if l = 0 then None else Some a.(0)

  let rightmost_child () a =
    let a = T.children a in
    let l = Array.length a in
    if l = 0 then None else Some a.(l - 1)

  let is_parent () ~parent ~child =
    Array.exists (V.equal child) @@ T.children parent
end

let layout
    (type a)
    ?(m:(module I with type t = a) option)
    ~children
    : distance:_ -> _ -> _ 
  =
  let (module I) = match m with
    | Some m -> m
    | None ->
      (module (struct type t = a let equal = (=) let hash = Hashtbl.hash end))
  in
  let module X = struct
    type t = a
    let children = children
  end
  in
  let module T = MakeTree(I)(X) in
  let module L = Make(T) in
  fun ~distance t ->
    let h = L.layout ~distance () t in
    L.H.find h
OCaml

Innovation. Community. Security.