(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_sbheap.ml

  Copyright (c) 2002-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

type 'a node_t = 'a tree_t list
and 'a tree_t = N of int * 'a * 'a list * 'a node_t

module type Node_T = sig
    module Key: Cf_ordered.Total_T
    type +'a t
    val compare: 'a t -> 'a t -> int
end

module Core(N: Node_T) = struct
    module N = N
        
    let nil = []
    let empty h = (h = [])
    
    let rec size = function hd :: tl -> (size_tree_ hd + size tl) | [] -> 0
    and size_tree_ (N (_, _, xs, ts)) = 1 + List.length xs + size ts
        
    let rank_ (N (r, _, _, _)) = r
    let root_ (N (_, x, _, _)) = x
    
    let link_ t1 t2 =
        let N (r, x1, xs1, c1) = t1
        and N (_, x2, xs2, c2) = t2
        in
        let r = succ r in
        if N.compare x1 x2 < 0
            then N (r, x1, xs1, t2 :: c1)
            else N (r, x2, xs2, t1 :: c2)
    
    let skew_link_ x t1 t2 =
        let N (r, y, ys, c) = link_ t1 t2 in
        if N.compare x y < 0
            then N (r, x, y :: ys, c)
            else N (r, y, x :: ys, c)
    
    let rec insert_tree_ t = function
        | [] ->
            [ t ]
        | hd :: tl as ts ->
            if rank_ t < rank_ hd
                then t :: ts
                else insert_tree_ (link_ t hd) tl
    
    let rec merge_trees_ ts1 ts2 =
        match ts1, ts2 with
        | _, [] -> ts1
        | [], _ -> ts2
        | t1 :: ts1', t2 :: ts2' ->
            if rank_ t1 < rank_ t2 then
                t1 :: merge_trees_ ts1' ts2
            else if rank_ t2 < rank_ t1 then
                t2 :: merge_trees_ ts1 ts2'
            else
                insert_tree_ (link_ t1 t2) (merge_trees_ ts1' ts2')
    
    let normalize_ = function
        | [] -> []
        | hd :: tl -> insert_tree_ hd tl
    
    let put x = function
        | t1 :: t2 :: tail as ts ->
            if rank_ t1 = rank_ t2
                then skew_link_ x t1 t2 :: tail
                else N (0, x, [], []) :: ts
        | ts ->
            N (0, x, [], []) :: ts
    
    let merge ts1 ts2 = merge_trees_ (normalize_ ts1) (normalize_ ts2)
    
    let rec shift_tree_ = function
        | [] -> raise Not_found
        | x :: [] -> x
        | hd :: tl ->
            let hd' = shift_tree_ tl in
            let x = root_ hd and y = root_ hd' in
            if N.compare x y < 0 then hd else hd'
    
    let head ts = root_ (shift_tree_ ts)

    let rec remove_tree_ = function
        | [] -> raise Not_found
        | x :: [] -> x, []
        | hd :: tl ->
            let hd', tl' = remove_tree_ tl in
            let x = root_ hd in
            let y = root_ hd' in
            if N.compare x y < 0
                then hd, tl
                else hd', hd :: tl'
        
    let rec tail_loop_ ts = function
        | x :: xs' -> tail_loop_ (put x ts) xs'
        | [] -> ts

    let tail ts =
        let N (_, _, xs, ts1), ts2 = remove_tree_ ts in
        tail_loop_ (merge (List.rev ts1) ts2) xs
    
    let pop ts = try Some (head ts, tail ts) with Not_found -> None
    
    let rec iterate f =
        let sub (N (_, x, xs, ts)) = f x; List.iter f xs; iterate f ts in
        function
        | hd :: tl -> sub hd; iterate f tl
        | [] -> ()
    
    let rec predicate f =
        let sub (N (_, x, xs, ts)) =
            f x && List.for_all f xs && predicate f ts
        in
        function
        | hd :: tl -> sub hd && predicate f tl
        | [] -> true
    
    let rec fold f =
        let sub x0 (N (_, x, xs, ts)) =
            let x0 = fold f x0 ts in
            let x0 = List.fold_left f x0 xs in
            f x0 x
        in
        fun x0 ->
            function
            | hd :: tl -> fold f (sub x0 hd) tl
            | [] -> x0
    
    let filter f =
        let g h x = if f x then put x h else h in
        fun ts -> fold g nil ts
    
    let partition f =
        let g (h0, h1) x = if f x then put x h0, h1 else h0, put x h1 in
        fun ts -> fold g (nil, nil) ts
    
    let of_list =
        let rec loop acc = function
            | hd :: tl -> loop (put hd acc) tl
            | [] -> acc
        in
        fun z ->
            loop nil z
    
    let of_seq =
        let rec loop acc seq =
            match Lazy.force seq with
            | Cf_seq.P (hd, tl) -> loop (put hd acc) tl
            | Cf_seq.Z -> acc
        in
        fun seq ->
            loop nil seq

    let rec to_seq h =
        lazy begin
            try
                Cf_seq.P (head h, to_seq (tail h))
            with
            | Not_found ->
                Cf_seq.Z
        end
    
    let rec to_seq2 h =
        lazy begin
            try
                let N (_, x, xs, ts1), ts2 = remove_tree_ h in
                let tl = tail_loop_ (merge (List.rev ts1) ts2) xs in
                Cf_seq.P ((x, tl), to_seq2 tl)
            with
            | Not_found ->
                Cf_seq.Z
        end
end

module Heap(E: Cf_ordered.Total_T) = struct
    include Core(struct
        module Key = E
        
        type 'a t = E.t
        
        let compare x y = E.compare x y
    end)
    
    module Element = E
    type t = E.t node_t
end

module PQueue(K: Cf_ordered.Total_T) = struct
    include Core(struct
        module Key = K
        type 'a t = Key.t * 'a
        
        let compare (x, _) (y, _) = Key.compare x y
    end)

    module Key = K
    
    type 'a t = 'a N.t node_t
    
    let map f =
        let g h (k, _ as x) = put (k, f x) h in
        fun ts -> fold g nil ts
    
    let optmap f =
        let g h (k, _ as x) =
            match f x with
            | Some x -> put (k, x) h
            | None -> h
        in
        fun ts -> fold g nil ts
end

(*--- End of File [ cf_sbheap.ml ] ---*)