helm/ocaml/mathql/mQueryUtil.ml

   1 (* Copyright (C) 2000, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 (*  AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
  27  *)
  28
  29 (* time handling  ***********************************************************)
  30
  31 type time = float * float
  32
  33 let start_time () =
  34    (Sys.time (), Unix.time ())
  35
  36 let stop_time (s0, u0) =
  37    let s1 = Sys.time () in
  38    let u1 = Unix.time () in
  39    Printf.sprintf "%.2fs,%.2fs" (s1 -. s0) (u1 -. u0)
  40
  41 (* operations on lists  *****************************************************)
  42
  43 type 'a comparison = Lt
  44                    | Gt
  45                    | Eq of 'a
  46
  47 let list_join f l1 l2 =
  48    let rec aux = function
  49       | [], v
  50       | v, []                                  -> v
  51       | ((h1 :: t1) as v1), ((h2 :: t2) as v2) -> begin
  52          match f h1 h2 with
  53             | Lt   -> h1 :: aux (t1, v2)
  54             | Gt   -> h2 :: aux (v1, t2)
  55             | Eq h -> h  :: aux (t1, t2)
  56          end
  57    in aux (l1, l2)
  58
  59 let list_meet f l1 l2 =
  60    let rec aux = function
  61       | [], v
  62       | v, []                                  -> []
  63       | ((h1 :: t1) as v1), ((h2 :: t2) as v2) -> begin
  64          match f h1 h2 with
  65             | Lt   -> aux (t1, v2)
  66             | Gt   -> aux (v1, t2)
  67             | Eq h -> h :: aux (t1, t2)
  68          end
  69    in aux (l1, l2)
  70
  71 let rec flat_list out f s = function
  72    | []        -> ()
  73    | [a]       -> f a
  74    | a :: tail -> f a; out s; flat_list out f s tail
  75
  76 let rec add_assoc ap = function
  77    | []                                  -> [ap]
  78    | head :: tail when fst head = fst ap -> ap :: tail
  79    | head :: tail                        -> head :: add_assoc ap tail
  80
  81 (* int of string ************************************************************)
  82
  83 type t = End
  84        | Space
  85        | Figure of int
  86        | Error
  87
  88 let int_of_string s =
  89    let l = String.length s in
  90    let get_t i =
  91       if i = l then End else
  92       match s.[i] with
  93          | ' ' | '\t' | '\r' | 'n' -> Space
  94          | '0' .. '9'              -> Figure (Char.code s.[i] - Char.code '0')
  95          | _                       -> Error
  96    in
  97    let rec aux i xv = match get_t i, xv with
  98       | Error, _
  99       | End, None        -> raise (Failure "int_of_string")
 100       | End, Some v      -> v
 101       | Space, xv        -> aux (succ i) xv
 102       | Figure f, None   -> aux (succ i) (Some f)
 103       | Figure f, Some v -> aux (succ i) (Some (10 * v + f))
 104    in
 105    aux 0 None