File: main.ml

package info (click to toggle)
dag2html 1.01-2
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k, sarge
  • size: 128 kB
  • ctags: 213
  • sloc: ml: 1,471; makefile: 53
file content (253 lines) | stat: -rw-r--r-- 7,304 bytes parent folder | download
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
(* $Id: main.ml,v 1.12 2001/03/10 10:15:48 ddr Exp $ *)

open Dag2html;
open Printf;

value version = "1.01";

(* input dag *)

value strip_spaces str =
  let start = loop 0
    where rec loop i =
      if i == String.length str then i
      else
        match str.[i] with
        [ ' ' | '\r' | '\n' | '\t' -> loop (i + 1)
        | _ -> i ]
  in
  let stop = loop (String.length str - 1)
    where rec loop i =
      if i == -1 then i + 1
      else
        match str.[i] with
        [ ' ' | '\r' | '\n' | '\t' -> loop (i - 1)
        | _ -> i + 1 ]
  in
  if start == 0 && stop == String.length str then str
  else if start > stop then ""
  else String.sub str start (stop - start)
;

value rec get_line ic =
  try
    let line = input_line ic in
    if String.length line > 0 && line.[0] = '#' then get_line ic
    else Some (strip_spaces line)
  with [ End_of_file -> None ]
;

value input_dag ic =
  let rec find cnt s =
    fun
    [ [n :: nl] ->
        if n.valu = s then (n, idag_of_int cnt) else find (cnt - 1) s nl
    | [] -> raise Not_found ]
  in
  let add_node pl cl nl cnt =
    let cl = List.rev cl in
    let pl = List.rev pl in
    let (pl, pnl, nl, cnt) =
      List.fold_left
        (fun (pl, pnl, nl, cnt) p ->
           try
             let (n, p) = find (cnt - 1) p nl in
             ([p :: pl], [n :: pnl], nl, cnt)
           with
           [ Not_found ->
               let n = {pare = []; valu = p; chil = []} in
               let p = idag_of_int cnt in
               ([p :: pl], [n :: pnl], [n :: nl], cnt + 1) ])
        ([], [], nl, cnt) pl
    in
    let pl = List.rev pl in
    let (cl, nl, cnt) =
      List.fold_left
        (fun (cl, nl, cnt) c ->
           try
             let (n, c) = find (cnt - 1) c nl in
             do n.pare := n.pare @ pl; return
             ([c :: cl], nl, cnt)
           with
           [ Not_found ->
               let n = {pare = pl; valu = c; chil = []} in
               let c = idag_of_int cnt in
               ([c :: cl], [n :: nl], cnt + 1) ])
        ([], nl, cnt) cl
    in
    let cl = List.rev cl in
    do List.iter (fun p -> p.chil := p.chil @ cl) pnl; return (nl, cnt)
  in
  let rec input_parents nl pl cnt =
    fun
    [ Some "" -> input_parents nl pl cnt (get_line ic)
    | Some line ->
        match line.[0] with
        [ 'o' ->
            let p =
              strip_spaces (String.sub line 1 (String.length line - 1))
            in
            if p = "" then failwith line
            else input_parents nl [p :: pl] cnt (get_line ic)
        | '-' ->
            if pl = [] then failwith line else
            input_children nl pl [] cnt (Some line)
        | _ -> failwith line ]
    | None ->
        if pl = [] then (nl, cnt) else failwith "end of file 1" ]
  and input_children nl pl cl cnt =
    fun
    [ Some "" -> input_children nl pl cl cnt (get_line ic)
    | Some line ->
        match line.[0] with
        [ 'o' ->
            if cl = [] then failwith line
            else
              let (nl, cnt) = add_node pl cl nl cnt in
              input_parents nl [] cnt (Some line)
        | '-' ->
            let c =
              strip_spaces (String.sub line 1 (String.length line - 1))
            in
            if c = "" then failwith line
            else input_children nl pl [c :: cl] cnt (get_line ic)
        | _ -> failwith line ]
    | None ->
        if cl = [] then failwith "end of file 2"
        else add_node pl cl nl cnt ]
  in
  let (nl, _) = input_parents [] [] 0 (get_line ic) in
  {dag = Array.of_list (List.rev nl)}
;

(* testing *)

value map_dag f d =
  let a =
    Array.map (fun d -> {pare = d.pare; valu = f d.valu; chil = d.chil}) d.dag
  in
  {dag = a}
;

value tag_dag d =
  let c = ref 'A' in
  map_dag
    (fun v ->
       let v = c.val in
       do c.val :=
            if c.val = 'Z' then 'a'
            else if c.val = 'z' then '1'
            else Char.chr (Char.code c.val + 1);
       return String.make 1 v)
    d
;

(* *)

value phony _ = False;
value indi_txt n = n.valu;

value print_char_table d t =
  let print_elem =
    fun
    [ Elem e -> Printf.eprintf "  %s" d.dag.(int_of_idag e).valu
    | Ghost x -> Printf.eprintf "  |"
    | Nothing -> Printf.eprintf "   " ]
  in
  let print_span i j r =
    if j > 0 && t.table.(i).(j - 1).span = r then Printf.eprintf "---"
    else Printf.eprintf "  -"
  in
  let print_newline = prerr_newline in
  for i = 0 to Array.length t.table - 1 do
    for j = 0 to Array.length t.table.(i) - 1 do
      print_elem t.table.(i).(j).elem;
    done;
    print_newline ();
    for j = 0 to Array.length t.table.(i) - 1 do
      print_span i j t.table.(i).(j).span;
    done;
    print_newline ();
  done
;

value print_table border hts =
  do printf "<center><table border=%d" border;
     printf " cellspacing=0 cellpadding=0>\n";
     for i = 0 to Array.length hts - 1 do
       printf "<tr>\n";
       for j = 0 to Array.length hts.(i) - 1 do
         let (colspan, align, td) = hts.(i).(j) in
         do printf "<td";
(*
            if colspan > 1 then printf " colspan=%d" colspan else ();
*)
if colspan=1 && (td=TDstring "&nbsp;" || td=TDhr CenterA) then ()
else printf " colspan=%d" colspan;
(**)
            match (align, td) with
            [ (LeftA, TDhr LeftA) -> printf " align=left"
            | (LeftA, _) -> ()
            | (CenterA, _) -> printf " align=center"
            | (RightA, _) -> printf " align=right" ];
            printf ">";
            match td with
            [ TDstring s -> printf "%s" s
            | TDhr align ->
                do printf "<hr noshade size=1";
                   match align with
                   [ LeftA -> printf " width=\"50%%\" align=left"
                   | RightA -> printf " width=\"50%%\" align=right"
                   | _ -> () ];
                   printf ">";
                return () ];
            printf "</td>\n";
         return ();
       done;
     done;
     printf "</table></center>\n";
  return () 
;

value fname = ref "";
value invert = ref False;
value char = ref False;
value border = ref 0;
value no_optim = ref False;
value no_group = ref False;

value print_version () =
  do eprintf "Dag2html version %s\n" version;
     flush stderr;
  return exit 0
;

value speclist =
  [("-b", Arg.Int (fun x -> border.val := x), "<int>: table border");
   ("-c", Arg.Set char, ": char output");
   ("-i", Arg.Set invert, ": apply algorithm from bottom to top");
   ("-n", Arg.Set no_optim, ": no optimization");
   ("-g", Arg.Set no_group, ": no group");
   ("-v", Arg.Unit print_version, ": print version number and exit")];
value anonfun s = fname.val := s;
value usage = "Usage: " ^ Sys.argv.(0) ^ " [options] file\nwhere options are:";

value main () =
  do Arg.parse speclist anonfun usage;
     if fname.val = "" then
       do Arg.usage speclist usage; return exit 2
     else ();
  return
  let d = input_dag (open_in fname.val) in
  if char.val then
    let d = tag_dag d in
    let t = table_of_dag phony no_optim.val invert.val no_group.val d in
    print_char_table d t
  else
    let print_indi n = print_string n.valu in
    let t = table_of_dag phony no_optim.val invert.val no_group.val d in
    let hts = html_table_struct indi_txt phony d t in
    print_table border.val hts
;

Printexc.catch main ();