### 15.4.916  src/lib/src/leftist-tree-priority-queue.pkg

`# leftist-tree-priority-queue.pkg`
`# Priority queues implemented as leftist trees`
`# `
`# -- Allen Leung`

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

`###          "Progress is made by lazy men looking`
`###           for easier ways to do things."`
`###`
`###                       -- Robert Heinlein`

`package   leftist_tree_priority_queue`
`:                      Priority_Queue                                           # Priority_Queue        is from   `src/lib/src/priority-queue.api
`{`
`    # A leftist tree is a binary tree with priority ordering`
`    # with the invariant that the left branch is always the taller one         `

`    Leftist(X)`
`      = NODE    (X, Int, Leftist(X), Leftist(X))`
`      ``| EMPTY`
`      ;`

`    Priority_Queue(X)`
`        =`
`        PRIORITY_QUEUE`
`          {`
`            less:  (X, X) -> Bool, `
`            root:  Ref(  Leftist(X) ) `
`          };`

`    exception EMPTY_PRIORITY_QUEUE;`

`    # Assume a is smaller than b:`
`    #`
`    fun merge_trees less (a, b)`
`        =`
`        {   fun dist EMPTY              =>  0;`
`                dist (NODE(_, d, _, _)) =>  d;`
`            end;`

`            fun m (EMPTY, a) =>  a;`
`                m (a, EMPTY) =>  a;`

`                m (a as NODE (x, d, l, r), b as NODE (y, d', l', r'))`
`                =>`
`                    {   my (root, l, r)`
`                            = `
`                            if   (less (x, y)   )   (x, l,  m (r,  b));`
`                                               else   (y, l', m (r', a));   fi; `

`                        d_l =   dist l;`
`                        d_r =   dist r;`

`                        my (l, r)`
`                            =`
`                            if   (d_l  >=  d_r   )   (l, r);`
`                                                else   (r, l);   fi;`

`                        NODE (root, 1+int::max (d_l, d_r), l, r); `
`                    };`
`            end;`

`            m (a, b); `
`       };`

`    fun make_priority_queue  less`
`        =`
`        PRIORITY_QUEUE { less, root => REF EMPTY };`

`    fun make_priority_queue' (less, _, _)`
`      = make_priority_queue   less;`

`    fun min (PRIORITY_QUEUE { root => REF (NODE (x, _, _, _)), ... } ) =>   x;`
`        min _                                                          =>   raise exception EMPTY_PRIORITY_QUEUE;`
`    end;`

`    fun is_empty (PRIORITY_QUEUE { root => REF EMPTY, ... } ) =>   TRUE;`
`        is_empty _                                            =>   FALSE;`
`    end;`

`    fun clear (PRIORITY_QUEUE { root, ... } )`
`        =`
`        root := EMPTY;`

`    fun delete_min (PRIORITY_QUEUE { root => root as REF (NODE (x, _, l, r)), less } )`
`            =>`
`            {   root := merge_trees less (l, r);`
`                x;`
`            };`

`        delete_min _`
`            =>`
`            raise exception EMPTY_PRIORITY_QUEUE;`
`    end;`

`    fun merge (PRIORITY_QUEUE { root => r1, less }, PRIORITY_QUEUE { root => r2, ... } )`
`        =`
`        PRIORITY_QUEUE`
`          { root => REF (merge_trees less (*r1,*r2)),`
`            less`
`          };`

`    fun merge_into { src => PRIORITY_QUEUE { root =>      REF t1, less }, `
`                     dst => PRIORITY_QUEUE { root => r as REF t2, ...  }`
`                   }`
`        =`
`        r := merge_trees less (t1, t2);`

`    fun merge_elems (less, q, elements)`
`        =`
`        m (q, elements)`
`        where`
`            fun m (q,[])      =>  q;`
`                m (q, e ! es) =>  m (merge_trees less (q, NODE (e, 1, EMPTY, EMPTY)), es);`
`            end;`
`        end;`

`    fun set   (PRIORITY_QUEUE { root => r as REF t1,  less })   x`
`        =`
`        r := merge_trees less (t1, NODE (x, 1, EMPTY, EMPTY)); `

`    fun from_list  less  list`
`        =`
`        PRIORITY_QUEUE { root => REF (merge_elems (less, EMPTY, list)),`
`                         less`
`                       };`

`    fun collect (EMPTY,             e) =>   e;`
`        collect (NODE (x, _, l, r), e) =>   collect (l, collect (r, x ! e));`
`    end;`

`    fun to_list (PRIORITY_QUEUE { root => REF t, ... } )`
`        =`
`        collect (t, []);`

`};`

Comments and suggestions to: bugs@mythryl.org