unison

Fork of Unison, a bi-directional file synchronization tool
git clone git://git.laack.co/unison.git
Log | Files | Refs | README | LICENSE

pqueue.ml (2671B)

      1 (* Unison file synchronizer: src/lwt/pqueue.ml *)
      2 (* Copyright 1999-2020, Benjamin C. Pierce
      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 3 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
     15     along with this program.  If not, see <http://www.gnu.org/licenses/>.
     16 *)
     17 
     18 
     19 module type OrderedType =
     20   sig
     21     type t
     22     val compare: t -> t -> int
     23   end
     24 
     25 module type S =
     26   sig
     27     type elt
     28     type t
     29     val empty: t
     30     val is_empty: t -> bool
     31     val add: elt -> t -> t
     32     val union: t -> t -> t
     33     val find_min: t -> elt
     34     val remove_min: t -> t
     35   end
     36 
     37 module Make(Ord: OrderedType) : (S with type elt = Ord.t) =
     38   struct
     39     type elt = Ord.t
     40 
     41     type t = tree list
     42     and tree = Node of elt * int * tree list
     43 
     44     let root (Node (x, _, _)) = x
     45     let rank (Node (_, r, _)) = r
     46     let link (Node (x1, r1, c1) as t1) (Node (x2, r2, c2) as t2) =
     47       let c = Ord.compare x1 x2 in
     48       if c <= 0 then Node (x1, r1 + 1, t2::c1) else Node(x2, r2 + 1, t1::c2)
     49     let rec ins t =
     50       function
     51         []     ->
     52           [t]
     53       | (t'::_) as ts when rank t < rank t' ->
     54           t::ts
     55       | t'::ts ->
     56           ins (link t t') ts
     57 
     58     let empty = []
     59     let is_empty ts = ts = []
     60     let add x ts = ins (Node (x, 0, [])) ts
     61     let rec union ts ts' =
     62       match ts, ts' with
     63         ([], _) -> ts'
     64       | (_, []) -> ts
     65       | (t1::ts1, t2::ts2)  ->
     66           if rank t1 < rank t2 then t1 :: union ts1 (t2::ts2)
     67           else if rank t2 < rank t1 then t2 :: union (t1::ts1) ts2
     68           else ins (link t1 t2) (union ts1 ts2)
     69 
     70     let rec find_min =
     71       function
     72         []    -> raise Not_found
     73       | [t]   -> root t
     74       | t::ts ->
     75           let x = find_min ts in
     76           let c = Ord.compare (root t) x in
     77           if c < 0 then root t else x
     78 
     79     let rec get_min =
     80       function
     81         []    -> assert false
     82       | [t]   -> (t, [])
     83       | t::ts ->
     84           let (t', ts') = get_min ts in
     85           let c = Ord.compare (root t) (root t') in
     86           if c < 0 then (t, ts) else (t', t::ts')
     87 
     88     let remove_min =
     89       function
     90         [] -> raise Not_found
     91       | ts ->
     92           let (Node (x, r, c), ts) = get_min ts in
     93           union (List.rev c) ts
     94   end