Source file `tries.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
(**************************************************************************)
(*                                                                        *)
(*                 ACG development toolkit                                *)
(*                                                                        *)
(*                  Copyright 2008-2021 INRIA                             *)
(*                                                                        *)
(*  More information on "http://acg.gforge.inria.fr/"                     *)
(*  License: CeCILL, see the LICENSE file or "http://www.cecill.info"     *)
(*  Authors: see the AUTHORS file                                         *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(*  $Rev::                              $:  Revision of last commit       *)
(*  $Author::                           $:  Author of last commit         *)
(*  $Date::                             $:  Date of last commit           *)
(*                                                                        *)
(**************************************************************************)

module Tries =

  struct

(*    type 'a option = None | Some of 'a *)

    type 'a t = ST of 'a option * (char * 'a t) list
    type key=string

    exception Not_found

    exception Conflict
 
    let empty = ST (None, [])

    let explode str = 
      let rec explode_aux i ls =
        if i = -1 then ls
                  else explode_aux (i-1) ((String.get str i)::ls)
      in
      explode_aux (String.length str - 1) []

    let add ?(overwrite=false) id attr smtb =
      let rec insert1 lts (ST (a, s)) =
        match lts with
(*           []    -> (match a with *)
(*                       None   -> ST (Some attr, s) *)
(*                     | Some b -> ST (Some attr, s)(\*raise Conflict*\)) *)
(*         | l::rm -> ST (a, insert2 l rm s) *)
            []    -> (match a,overwrite with
			  None,_   -> ST (Some attr, s)
			| Some _,true -> ST (Some attr, s)
			| Some _,false -> raise Conflict)
          | l::rm -> ST (a, insert2 l rm s)
      and     insert2 lt lts stls =
        match stls with
            []        -> [lt, insert1 lts empty]  
          | (l,i)::rm -> if lt = l 
            then (lt, insert1 lts i)::rm
            else if lt <= l
            then (lt, insert1 lts empty)::stls
            else (l,i)::(insert2 lt lts rm)
      in 
	insert1 (explode id) smtb

    let find w smtb =
      let rec lookup1 lts (ST (a, s)) = 
        match lts with
          []    -> (match a with 
                      None   -> raise Not_found
                    | Some b -> b)
        | l::rm -> lookup2 l rm s
      and     lookup2 lt lts stls =
        match stls with 
          []        -> raise Not_found
        | (l,i)::rm -> if lt = l 
                       then lookup1 lts i
                       else if lt <= l
                       then raise Not_found
                       else lookup2 lt lts rm
      in
      lookup1 (explode w) smtb
              
    (* this function is not used neither exposed through the mli file *)
    (*
    let content tr =
      let rec tr_to_list tr ls =
        match tr with
          ST (None, [])          -> ls
        | ST (Some a, [])        -> a::ls
        | ST (None, (_,t)::rm)   -> trls_to_list rm (tr_to_list t ls)
        | ST (Some a, (_,t)::rm) -> trls_to_list rm (tr_to_list t (a::ls))
      and trls_to_list trls ls =
        match trls with
          []         -> ls
        | (_, t)::rm ->  trls_to_list rm (tr_to_list t ls)
      in
      List.rev (tr_to_list tr [])
     *)
               
    let implode lst =
	let buff = Buffer.create (List.length lst) in
	let() = List.fold_right (fun c _ -> Buffer.add_char buff c) lst () in
	  Buffer.contents buff

      let fold f acc tr =
	let rec fold_aux key acc = function
	  | ST (None,trs) -> List.fold_left (fun acc (c,t) -> fold_aux (c::key) acc t) acc trs
	  | ST (Some v,trs) -> 
	      let new_acc = f (implode key) v acc in
		(List.fold_left (fun acc (c,t) -> fold_aux (c::key) acc t) new_acc trs) in
	  fold_aux [] acc tr
	

  end