15.4.915  src/lib/src/leftist-heap-priority-queue-g.pkg

## leftist-heap-priority-queue-g.pkg

# Compiled by:
#     src/lib/std/standard.lib

# An implementation of priority queues based on leaftist heaps.
# (See the "Purely Functional Data Structures" book by Chris Okasaki).


###           "Many secrets of art and nature are
###            thought by the unlearned to be magical."
###
###                             -- Roger Bacon


generic package leftist_heap_priority_queue_g (p:  Priority)            # Priority                      is from   src/lib/src/priority.api
: (weak)
Typelocked_Priority_Queue                                       # Typelocked_Priority_Queue     is from   src/lib/src/typelocked-priority-queue.api
{
    Item = p::Item;

    Queue = QUEUE  ((Int, Heap))

    also
    Heap = EMPTY | ND  ((Int, Item, Heap, Heap));

    empty  = QUEUE (0, EMPTY);

    fun singleton_heap x
        =
        ND (1, x, EMPTY, EMPTY);

    fun singleton x
        =
        QUEUE (1, singleton_heap x);

    fun rank EMPTY => 0;
        rank (ND (r, _, _, _)) => r;
    end;

    fun mk_node (x, a, b)
        =
        if (rank a >= rank b) 
            ND (rank b + 1, x, a, b);
        else
            ND (rank a + 1, x, b, a);
        fi;

    fun merge_heap (h, EMPTY) => h;
        merge_heap (EMPTY, h) => h;
        merge_heap (h1 as ND(_, x, h11, h12), h2 as ND(_, y, h21, h22))
            =>
            case (p::compare (p::priority x, p::priority y))
              
                GREATER =>   mk_node (x, h11, merge_heap (h12, h2));
                _       =>   mk_node (y, h21, merge_heap (h1, h22));
            esac;
    end;

    fun set (x, QUEUE (n, h))
        =
        QUEUE (n+1, merge_heap (singleton_heap x, h));

    fun next (QUEUE(_, EMPTY)) => NULL;
        next (QUEUE (n, ND(_, x, h1, h2))) => THE (x, QUEUE (n - 1, merge_heap (h1, h2)));
    end;

    fun remove (QUEUE(_, EMPTY)) => raise exception list::EMPTY;
        remove (QUEUE (n, ND(_, x, h1, h2))) => (x, QUEUE (n - 1, merge_heap (h1, h2)));
    end;

    fun merge (QUEUE (n1, h1), QUEUE (n2, h2)) = QUEUE (n1+n2, merge_heap (h1, h2));

    fun vals_count (QUEUE (n, _)) = n;

    fun is_empty (QUEUE(_, EMPTY)) => TRUE;
        is_empty _ => FALSE;
    end;

    fun from_list [] => empty;
        from_list [x] => QUEUE (1, singleton_heap x);
        from_list l
            =>
            QUEUE (len, merge (hs, []))
            where 

                fun init ([], n, items) => (n, items);
                    init (x ! r, n, items) => init (r, n+1, singleton_heap x ! items);
                end;

                fun merge ([], [h]) => h;
                    merge ([], hl) => merge (hl, []);
                    merge ([h], hl) => merge (h ! hl, []);
                    merge (h1 ! h2 ! r, l) => merge (r, merge_heap (h1, h2) ! l);
                end;

                my (len, hs) = init (l, 0, []);

            end;
    end;
};



## COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.