(**************************************************************************) (* *) (* The Zen Computational Linguistics Toolkit *) (* *) (* Gérard Huet *) (* *) (* ©2002 Institut National de Recherche en Informatique et en Automatique *) (**************************************************************************) (* We complement [List] here with a few auxiliary list service functions. *) (*i module List2 = struct i*) (* [unstack l r = (rev l) @ r] *) (* [unstack = List.rev_append] *) value rec unstack l1 l2 = match l1 with [ [] -> l2 | [ a :: l ] -> unstack l [ a :: l2 ] ] ; value non_empty = fun [ [] -> False | _ -> True ] ; (* Subtraction derivative. *) (* [subtract : list 'a -> list 'a -> option (list 'a)] *) (* [subtract [ c1; ... cN ][ c1; ... cn ] = Some [ cn+1; ... cN ]] *) (* otherwise returns [None]. *) value rec subtract input = fun [ [] -> Some input | [ c :: r ] -> match input with [ [ c' :: r' ] when c'=c -> subtract r' r | _ -> None ] ] ; (* Association lists. *) (* The right way to program [assoc], without exceptions. *) (* [ass : 'a -> list ('a * 'b) -> option 'b] *) value ass x = ass_rec where rec ass_rec = fun [ [ (a,u) :: rest ] -> if a=x then Some u else ass_rec rest | [] -> None ] ; (* Set operations with lists. *) exception Twice_the_same_value ; value union1 e l = if List.mem e l then l else [ e :: l ] ; (* Used in ZEN/Lexmap. *) value union2 e l = if List.mem e l then (raise Twice_the_same_value) else [ e :: l ] ; (* Terminal recursive union of finite sets represented as as lists - does not respect the order of elements in [l1]: [union_f [ 1; 2 ] [] = [ 2; 1 ]] *) value rec union_f l1 l2 = match l1 with [ [] -> l2 | [ e :: l ] -> union_f l (union1 e l2) ] ; (* Same, respecting the order: *) value union l1 l2 = List.fold_right union1 l1 l2 ; value set_of l = (*i eta expansion for polymorphism i*) let add acc x = if List.mem x acc then acc else [ x :: acc ] in List.fold_left add [] l ; (* [last : list 'a -> 'a ] *) value rec last = fun [ [] -> raise (Failure "last") | [ x ] -> x | [ _ :: l ] -> last l ] ; (* [truncate n l] removes from [l] its initial sublist of length [n]. *) (* *) (* [truncate : int -> list 'a -> list 'a] *) value rec truncate n l = if n=0 then l else match l with [ [] -> failwith "truncate" | [ _ :: r ] -> truncate (n-1) r ] ; type ranked 'a = list (int * 'a) ; (* [zip n l] assumes [l] sorted in increasing order of ranks; it returns a partition of [l] as [(l1,l2)] with [l1] maximum such that ranks in [l1] are [< n]. [l1] is reversed, i.e. we enforce the invariant: [zip n l = (l1,l2)] such that [l = unstack l1 l2]. *) (* *) (* [zip : int -> (ranked 'a) -> ((ranked 'a) * (ranked 'a))] *) value zip n = zip_rec [] where rec zip_rec acc l = match l with [ [] -> (acc,[]) | [ ((m,_) as current) :: rest ] -> if m list char] *) value explode s = let rec expl i accu = if i < 0 then accu else expl (i - 1) [ s.[i] :: accu ] in expl (String.length s - 1) [] ; (* [implode: list char -> string] *) value implode l = let result = Bytes.create (List.length l) in let rec loop i = fun [ [] -> result | [ c :: cs ] -> do { Bytes.set result i c; loop (i + 1) cs } ] in loop 0 l ; (* Process a list with using [pr] for elements and [sep] for separator *) (* [process_list_sep : ('a -> unit) -> (unit -> unit) -> list 'a -> unit ] *) value process_list_sep pr sep = let rec prl = fun [ [] -> () | [ s ] -> pr s | [ s :: ls ] -> do { pr s; sep (); prl ls } ] in prl ; (* Insert in a list of buckets with increasing keys *) value in_bucket key element buckets = in_rec [] buckets where rec in_rec accu buckets = match buckets with [ [] -> unstack accu [ (key,[ element ]) ] | [ ((k,l) as bucket) :: rest ] -> if k>key then unstack accu [ (key,[ element ]) :: buckets ] else if k=key then unstack accu [ (k,[ element :: l ]) :: buckets ] else in_rec [ bucket :: accu ] rest ] ; (*i end; i*)