cladogram.ml

   1 (* virt-similarity
   2  * Copyright (C) 2013 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *)
  18
  19 open Printf
  20
  21 type t =
  22   | Leaf of int                  (* A single disk image (index of). *)
  23   | Node of t list               (* An interior node in the tree. *)
  24
  25 let rec images_in_subtree = function
  26   | Leaf i -> [i]
  27   | Node xs -> List.concat (List.map images_in_subtree xs)
  28
  29 let max_list = List.fold_left max min_int
  30
  31 let mapi f xs =
  32   let rec loop i = function
  33     | [] -> []
  34     | x :: xs -> let r = f i x in r :: loop (i+1) xs
  35   in
  36   loop 0 xs
  37
  38 let format_cladogram ?format_leaf t =
  39   let format_leaf = match format_leaf with
  40     | None -> string_of_int
  41     | Some f -> f
  42   in
  43   let rec format = function
  44     | Leaf i ->
  45       let s = "--- " ^ format_leaf i in
  46       [s; ""], String.length s
  47     | Node xs ->
  48       let xs = List.map format xs in
  49       let n = List.length xs in
  50       let w = 7 + max_list (List.map snd xs) in
  51       let xs = mapi (
  52         fun row (ss, _) ->
  53           let s, ss = match ss with
  54             | s :: ss -> s, ss
  55             | [] -> assert false in
  56           if row = 0 then (
  57             ("---+---" ^ s) ::
  58               List.map (fun s -> "   |   " ^ s) ss
  59           ) else if row < n-1 then (
  60             ("   +---" ^ s) ::
  61               List.map (fun s -> "   |   " ^ s) ss
  62           ) else (
  63             ("   +---" ^ s) ::
  64               List.map (fun s -> "       " ^ s) ss
  65           )
  66       ) xs in
  67       List.concat xs, w
  68   in
  69   let strs, _ = format t in
  70   strs