;priority-queue's are implemented with association lists
(defun make-pq (alist)
  (sort (copy-alist alist) (lambda (a b) (< (car a) (car b)))))
;
;Will change the state of pq
;
(define-modify-macro insert-pq (pair)
                     (lambda (pq pair) (sort-alist (cons pair pq))))

(define-modify-macro remove-pq-aux () cdr)

(defmacro remove-pq (pq)
  `(let ((aux (copy-alist ,pq)))
     (REMOVE-PQ-AUX ,pq)
     (car aux)))
;
;Will not change the state of pq
;
(defun insert-pq-non-destructive (pair pq)
  (sort-alist (cons pair pq)))

(defun remove-pq-non-destructive (pq)
  (cdr pq))
;testing
(defparameter a (make-pq '((1 . "Solve RC tasks") (3 . "Clear drains") (2 . "Tax return") (5 . "Make tea"))))
(format t "~a~&" a)
(insert-pq a '(4 . "Feed cat"))
(format t "~a~&" a)
(format t "~a~&" (remove-pq a))
(format t "~a~&" a)
(format t "~a~&" (remove-pq a))
(format t "~a~&" a)


MODULE PQueues;
IMPORT StdLog,Boxes;

TYPE
  Rank* = POINTER TO RECORD
    p-: LONGINT; (* Priority *)
    value-: Boxes.Object
  END;

  PQueue* = POINTER TO RECORD
    a: POINTER TO ARRAY OF Rank;
    size-: LONGINT;
  END;

  PROCEDURE NewRank*(p: LONGINT; v: Boxes.Object): Rank;
  VAR
    r: Rank;
  BEGIN
    NEW(r);r.p := p;r.value := v;
    RETURN r
  END NewRank;

  PROCEDURE NewPQueue*(cap: LONGINT): PQueue;
  VAR
    pq: PQueue;
  BEGIN
    NEW(pq);pq.size := 0;
    NEW(pq.a,cap);pq.a[0] := NewRank(MIN(INTEGER),NIL);
    RETURN pq
  END NewPQueue;

  PROCEDURE (pq: PQueue) Push*(r:Rank), NEW;
  VAR
    i: LONGINT;
  BEGIN
    INC(pq.size);
    i := pq.size;
    WHILE r.p < pq.a[i DIV 2].p DO
      pq.a[i] := pq.a[i DIV 2];i := i DIV 2
    END;
    pq.a[i] := r
  END Push;

  PROCEDURE (pq: PQueue) Pop*(): Rank,NEW;
  VAR
    r,y: Rank;
    i,j: LONGINT;
    ok: BOOLEAN;
  BEGIN
    r := pq.a[1]; (* Priority object *)
    y := pq.a[pq.size]; DEC(pq.size); i := 1; ok := FALSE;
    WHILE (i <= pq.size DIV 2) & ~ok DO
      j := i + 1;
      IF (j < pq.size) & (pq.a[i].p > pq.a[j + 1].p) THEN INC(j) END;
      IF y.p > pq.a[j].p THEN pq.a[i] := pq.a[j]; i := j ELSE ok := TRUE END
    END;
    pq.a[i] := y;
    RETURN r
  END Pop;

  PROCEDURE (pq: PQueue) IsEmpty*(): BOOLEAN,NEW;
  BEGIN
    RETURN pq.size = 0
  END IsEmpty;

  PROCEDURE Test*;
  VAR
    pq: PQueue;
    r: Rank;
    PROCEDURE ShowRank(r:Rank);
    BEGIN
      StdLog.Int(r.p);StdLog.String(":> ");StdLog.String(r.value.AsString());StdLog.Ln;
    END ShowRank;
  BEGIN
    pq := NewPQueue(128);
    pq.Push(NewRank(3,Boxes.NewString("Clear drains")));
    pq.Push(NewRank(4,Boxes.NewString("Feed cat")));
    pq.Push(NewRank(5,Boxes.NewString("Make tea")));
    pq.Push(NewRank(1,Boxes.NewString("Solve RC tasks")));
    pq.Push(NewRank(2,Boxes.NewString("Tax return")));
    ShowRank(pq.Pop());
    ShowRank(pq.Pop());
    ShowRank(pq.Pop());
    ShowRank(pq.Pop());
    ShowRank(pq.Pop());
  END Test;

END PQueues.


import std.stdio, std.container, std.array, std.typecons;

void main() {
    alias tuple T;
    auto heap = heapify([T(3, "Clear drains"),
                         T(4, "Feed cat"),
                         T(5, "Make tea"),
                         T(1, "Solve RC tasks"),
                         T(2, "Tax return")]);

    while (!heap.empty) {
        writeln(heap.front);
        heap.removeFront();
    }
}


program Priority_queue;

{$APPTYPE CONSOLE}

uses
  System.SysUtils, Boost.Generics.Collection;

var
  Queue: TPriorityQueue<String>;

begin
  Queue := TPriorityQueue<String>.Create(['Clear drains', 'Feed cat',
    'Make tea', 'Solve RC tasks', 'Tax return'], [3, 4, 5, 1, 2]);

  while not Queue.IsEmpty do
    with Queue.DequeueEx do
      Writeln(Priority, ', ', value);
end.


(lib 'tree)
(define tasks (make-bin-tree 3 "Clear drains"))
(bin-tree-insert tasks 2 "Tax return")
(bin-tree-insert tasks 5 "Make tea")
(bin-tree-insert tasks 1 "Solve RC tasks")
(bin-tree-insert tasks 4 "Feed 🐡")

(bin-tree-pop-first tasks) → (1 . "Solve RC tasks")
(bin-tree-pop-first tasks) → (2 . "Tax return")
(bin-tree-pop-first tasks) → (3 . "Clear drains")
(bin-tree-pop-first tasks) → (4 . "Feed 🐡")
(bin-tree-pop-first tasks) → (5 . "Make tea")
(bin-tree-pop-first tasks) → null

;; similarly
(bin-tree-pop-last tasks) → (5 . "Make tea")
(bin-tree-pop-last tasks) → (4 . "Feed 🐡")
; etc.


defmodule Priority do
  def create, do: :gb_trees.empty

  def insert( element, priority, queue ), do: :gb_trees.enter( priority, element, queue )

  def peek( queue ) do
    {_priority, element, _new_queue} = :gb_trees.take_smallest( queue )
    element
  end

  def task do
    items = [{3, "Clear drains"}, {4, "Feed cat"}, {5, "Make tea"}, {1, "Solve RC tasks"}, {2, "Tax return"}]
    queue = Enum.reduce(items, create, fn({priority, element}, acc) -> insert( element, priority, acc ) end)
    IO.puts "peek priority: #{peek( queue )}"
    Enum.reduce(1..length(items), queue, fn(_n, q) -> write_top( q ) end)
  end

  def top( queue ) do
    {_priority, element, new_queue} = :gb_trees.take_smallest( queue )
    {element, new_queue}
  end

  defp write_top( q ) do
    {element, new_queue} = top( q )
    IO.puts "top priority: #{element}"
    new_queue
  end
end

Priority.task


-module( priority_queue ).

-export( [create/0, insert/3, peek/1, task/0, top/1] ).

create() -> gb_trees:empty().

insert( Element, Priority, Queue ) -> gb_trees:enter( Priority, Element, Queue ).

peek( Queue ) ->
  {_Priority, Element, _New_queue} = gb_trees:take_smallest( Queue ),
  Element.

task() ->
  Items = [{3, "Clear drains"}, {4, "Feed cat"}, {5, "Make tea"}, {1, "Solve RC tasks"}, {2, "Tax return"}],
  Queue = lists:foldl( fun({Priority, Element}, Acc) -> insert( Element, Priority, Acc ) end, create(), Items ),
  io:fwrite( "peek priority: ~p~n", [peek( Queue )] ),
  lists:foldl( fun(_N, Q) -> write_top( Q ) end, Queue, lists:seq(1, erlang:length(Items)) ).

top( Queue ) ->
  {_Priority, Element, New_queue} = gb_trees:take_smallest( Queue ),
  {Element, New_queue}.

write_top( Q ) ->
  {Element, New_queue} = top( Q ),
  io:fwrite( "top priority: ~p~n", [Element] ),
  New_queue.


[<RequireQualifiedAccess>]
module PriorityQ =

//  type 'a treeElement = Element of uint32 * 'a
  type 'a treeElement = struct val k:uint32 val v:'a new(k,v) = { k=k;v=v } end

  type 'a tree = Node of uint32 * 'a treeElement * 'a tree list

  type 'a heap = 'a tree list

  [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
  [<NoEquality; NoComparison>]
  type 'a outerheap = | HeapEmpty | HeapNotEmpty of 'a treeElement * 'a heap

  let empty = HeapEmpty

  let isEmpty = function | HeapEmpty -> true | _ -> false

  let inline private rank (Node(r,_,_)) = r

  let inline private root (Node(_,x,_)) = x

  exception Empty_Heap

  let peekMin = function | HeapEmpty -> None
                         | HeapNotEmpty(min, _) -> Some (min.k, min.v)

  let rec private findMin heap =
    match heap with | [] -> raise Empty_Heap //guarded so should never happen
                    | [node] -> root node,[]
                    | topnode::heap' ->
                      let min,subheap = findMin heap' in let rtn = root topnode
                      match subheap with
                        | [] -> if rtn.k > min.k then min,[] else rtn,[]
                        | minnode::heap'' ->
                          let rmn = root minnode
                          if rtn.k <= rmn.k then rtn,heap
                          else rmn,minnode::topnode::heap''

  let private mergeTree (Node(r,kv1,ts1) as tree1) (Node (_,kv2,ts2) as tree2) =
    if kv1.k > kv2.k then Node(r+1u,kv2,tree1::ts2)
    else Node(r+1u,kv1,tree2::ts1)

  let rec private insTree (newnode: 'a tree) heap =
    match heap with
      | [] -> [newnode]
      | topnode::heap' -> if (rank newnode) < (rank topnode) then newnode::heap
                          else insTree (mergeTree newnode topnode) heap'

  let push k v = let kv = treeElement(k,v) in let nn = Node(0u,kv,[])
                   function | HeapEmpty -> HeapNotEmpty(kv,[nn])
                            | HeapNotEmpty(min,heap) -> let nmin = if k > min.k then min else kv
                                                        HeapNotEmpty(nmin,insTree nn heap)

  let rec private merge' heap1 heap2 = //doesn't guaranty minimum tree node as head!!!
    match heap1,heap2 with
      | _,[] -> heap1
      | [],_ -> heap2
      | topheap1::heap1',topheap2::heap2' ->
        match compare (rank topheap1) (rank topheap2) with
          | -1 -> topheap1::merge' heap1' heap2
          | 1 -> topheap2::merge' heap1 heap2'
          | _ -> insTree (mergeTree topheap1 topheap2) (merge' heap1' heap2')

  let merge oheap1 oheap2 = match oheap1,oheap2 with
                              | _,HeapEmpty -> oheap1
                              | HeapEmpty,_ -> oheap2
                              | HeapNotEmpty(min1,heap1),HeapNotEmpty(min2,heap2) ->
                                  let min = if min1.k > min2.k then min2 else min1
                                  HeapNotEmpty(min,merge' heap1 heap2)

  let rec private removeMinTree = function
                          | [] -> raise Empty_Heap // will never happen as already guarded
                          | [node] -> node,[]
                          | t::ts -> let t',ts' = removeMinTree ts
                                     if (root t).k <= (root t').k then t,ts else t',t::ts'

  let deleteMin =
    function | HeapEmpty -> HeapEmpty
             | HeapNotEmpty(_,heap) ->
               match heap with
                 | [] -> HeapEmpty // should never occur: non empty heap with no elements
                 | [Node(_,_,heap')] -> match heap' with
                                          | [] -> HeapEmpty
                                          | _ -> let min,_ = findMin heap'
                                                 HeapNotEmpty(min,heap')
                 | _::_ -> let Node(_,_,ts1),ts2 = removeMinTree heap
                           let nheap = merge' (List.rev ts1) ts2 in let min,_ = findMin nheap
                           HeapNotEmpty(min,nheap)

  let replaceMin k v pq = push k v (deleteMin pq)

  let fromSeq sq = Seq.fold (fun pq (k, v) -> push k v pq) empty sq

  let popMin pq = match peekMin pq with
                      | None -> None
                      | Some(kv) -> Some(kv, deleteMin pq)

  let toSeq pq = Seq.unfold popMin pq

  let sort sq = sq |> fromSeq |> toSeq

  let adjust f pq = pq |> toSeq |> Seq.map (fun (k, v) -> f k v) |> fromSeq


<min-heap> [ {
    { 3 "Clear drains" }
    { 4 "Feed cat" }
    { 5 "Make tea" }
    { 1 "Solve RC tasks" }
    { 2 "Tax return" }
  } swap heap-push-all
] [
  [ print ] slurp-heap
] bi


module priority_queue_mod
implicit none

type node
  character (len=100)              :: task
  integer                          :: priority
end type

type queue
  type(node), allocatable :: buf(:)
  integer                 :: n = 0
contains
  procedure :: top
  procedure :: enqueue
  procedure :: siftdown
end type

contains

subroutine siftdown(this, a)
  class (queue)           :: this
  integer                 :: a, parent, child
  associate (x => this%buf)
  parent = a
  do while(parent*2 <= this%n)
    child = parent*2
    if (child + 1 <= this%n) then
      if (x(child+1)%priority > x(child)%priority ) then
        child = child +1
      end if
    end if
    if (x(parent)%priority < x(child)%priority) then
      x([child, parent]) = x([parent, child])
      parent = child
    else
      exit
    end if
  end do
  end associate
end subroutine

function top(this) result (res)
  class(queue) :: this
  type(node)   :: res
  res = this%buf(1)
  this%buf(1) = this%buf(this%n)
  this%n = this%n - 1
  call this%siftdown(1)
end function

subroutine enqueue(this, priority, task)
  class(queue), intent(inout) :: this
  integer                     :: priority
  character(len=*)            :: task
  type(node)                  :: x
  type(node), allocatable     :: tmp(:)
  integer                     :: i
  x%priority = priority
  x%task = task
  this%n = this%n +1
  if (.not.allocated(this%buf)) allocate(this%buf(1))
  if (size(this%buf)<this%n) then
    allocate(tmp(2*size(this%buf)))
    tmp(1:this%n-1) = this%buf
    call move_alloc(tmp, this%buf)
  end if
  this%buf(this%n) = x
  i = this%n
  do
    i = i / 2
    if (i==0) exit
    call this%siftdown(i)
  end do
end subroutine
end module

program main
  use priority_queue_mod

  type (queue) :: q
  type (node)  :: x

  call q%enqueue(3, "Clear drains")
  call q%enqueue(4, "Feed cat")
  call q%enqueue(5, "Make Tea")
  call q%enqueue(1, "Solve RC tasks")
  call q%enqueue(2, "Tax return")

  do while (q%n >0)
    x = q%top()
    print "(g0,a,a)", x%priority, " -> ", trim(x%task)
  end do

end program

! Output:
! 5 -> Make Tea
! 4 -> Feed cat
! 3 -> Clear drains
! 2 -> Tax return
! 1 -> Solve RC tasks


Type Tupla
    Prioridad As Integer
    Tarea As String
End Type
Dim Shared As Tupla a()
Dim Shared As Integer n 'número de eltos. en la matriz, el último elto. es n-1

Function Izda(i As Integer) As Integer
    Izda = 2 * i + 1
End Function

Function Dcha(i As Integer) As Integer
    Dcha = 2 * i + 2
End Function

Function Parent(i As Integer) As Integer
    Parent = (i - 1) \ 2
End Function

Sub Intercambio(i As Integer, j As Integer)
    Dim t As Tupla
    t = a(i)
    a(i) = a(j)
    a(j) = t
End Sub

Sub bubbleUp(i As Integer)
    Dim As Integer p = Parent(i)
    Do While i > 0 And a(i).Prioridad < a(p).Prioridad
        Intercambio i, p
        i = p
        p = Parent(i)
    Loop
End Sub

Sub Annadir(fPrioridad As Integer, fTarea As String)
    n += 1
    If n > Ubound(a) Then Redim Preserve a(2 * n)
    a(n - 1).Prioridad = fPrioridad
    a(n - 1).Tarea = fTarea
    bubbleUp (n - 1)
End Sub

Sub trickleDown(i As Integer)
    Dim As Integer j, l, r
    Do
        j = -1
        r = Dcha(i)
        If r < n And a(r).Prioridad < a(i).Prioridad Then
            l = Izda(i)
            If a(l).Prioridad < a(r).Prioridad Then
                j = l
            Else
                j = r
            End If
        Else
            l = Izda(i)
            If l < n And a(l).Prioridad < a(i).Prioridad Then j = l
        End If
        If j >= 0 Then Intercambio i, j
        i = j
    Loop While i >= 0
End Sub

Function Remove() As Tupla
    Dim As Tupla x = a(0)
    a(0) = a(n - 1)
    n = n - 1
    trickleDown 0
    If 3 * n < Ubound(a) Then Redim Preserve a(Ubound(a) \ 2)
    Remove = x
End Function

Redim a(4)
Annadir (3, "Clear drains")
Annadir (4, "Feed cat")
Annadir (5, "Make tea")
Annadir (1, "Solve RC tasks")
Annadir (2, "Tax return")
Dim t As Tupla
Do While n > 0
    t = Remove
    Print t.Prioridad; "  "; t.Tarea
Loop
Sleep


import util.ordering
native scala.collection.mutable.PriorityQueue

data Task( priority, description )

def comparator( Task(a, _), Task(b, _) )
  | a > b     = -1
  | a < b     =  1
  | otherwise =  0

q = PriorityQueue( ordering(comparator) )

q.enqueue(
  Task(3, 'Clear drains'),
  Task(4, 'Feed cat'),
  Task(5, 'Make tea'),
  Task(1, 'Solve RC tasks'),
  Task(2, 'Tax return')
  )

while not q.isEmpty()
  println( q.dequeue() )


package main

import (
    "fmt"
    "container/heap"
)

type Task struct {
    priority int
    name     string
}

type TaskPQ []Task

func (self TaskPQ) Len() int { return len(self) }
func (self TaskPQ) Less(i, j int) bool {
    return self[i].priority < self[j].priority
}
func (self TaskPQ) Swap(i, j int) { self[i], self[j] = self[j], self[i] }
func (self *TaskPQ) Push(x interface{}) { *self = append(*self, x.(Task)) }
func (self *TaskPQ) Pop() (popped interface{}) {
    popped = (*self)[len(*self)-1]
    *self = (*self)[:len(*self)-1]
    return
}

func main() {
    pq := &TaskPQ{{3, "Clear drains"},
        {4, "Feed cat"},
        {5, "Make tea"},
        {1, "Solve RC tasks"}}

    // heapify
    heap.Init(pq)

    // enqueue
    heap.Push(pq, Task{2, "Tax return"})

    for pq.Len() != 0 {
        // dequeue
        fmt.Println(heap.Pop(pq))
    }
}


import groovy.transform.Canonical

@Canonical
class Task implements Comparable<Task> {
    int priority
    String name
    int compareTo(Task o) { priority <=> o?.priority }
}

new PriorityQueue<Task>().with {
    add new Task(priority: 3, name: 'Clear drains')
    add new Task(priority: 4, name: 'Feed cat')
    add new Task(priority: 5, name: 'Make tea')
    add new Task(priority: 1, name: 'Solve RC tasks')
    add new Task(priority: 2, name: 'Tax return')

    while (!empty) { println remove() }
}


import Data.PQueue.Prio.Min

main = print (toList (fromList [(3, "Clear drains"),(4, "Feed cat"),(5, "Make tea"),(1, "Solve RC tasks"), (2, "Tax return")]))


import Utils   # For Closure class
import Collections      # For Heap (dense priority queue) class

procedure main()
   pq := Heap(, Closure("[]",Arg,1) )
   pq.add([3, "Clear drains"])
   pq.add([4, "Feed cat"])
   pq.add([5, "Make tea"])
   pq.add([1, "Solve RC tasks"])
   pq.add([2, "Tax return"])

   while task := pq.get() do write(task[1]," -> ",task[2])
end


coclass 'priorityQueue'

PRI=: ''
QUE=: ''

insert=:4 :0
  p=. PRI,x
  q=. QUE,y
  assert. p -:&$ q
  assert. 1 = #$q
  ord=: \: p
  QUE=: ord { q
  PRI=: ord { p
  i.0 0
)

topN=:3 :0
  assert y<:#PRI
  r=. y{.QUE
  PRI=: y}.PRI
  QUE=: y}.QUE
  r
)


import java.util.PriorityQueue;

class Task implements Comparable<Task> {
    final int priority;
    final String name;

    public Task(int p, String n) {
        priority = p;
        name = n;
    }

    public String toString() {
        return priority + ", " + name;
    }

    public int compareTo(Task other) {
        return priority < other.priority ? -1 : priority > other.priority ? 1 : 0;
    }

    public static void main(String[] args) {
        PriorityQueue<Task> pq = new PriorityQueue<Task>();
        pq.add(new Task(3, "Clear drains"));
        pq.add(new Task(4, "Feed cat"));
        pq.add(new Task(5, "Make tea"));
        pq.add(new Task(1, "Solve RC tasks"));
        pq.add(new Task(2, "Tax return"));

        while (!pq.isEmpty())
            System.out.println(pq.remove());
    }
}


# In the following, pq stands for "priority queue".

# Add an item with the given priority (an integer,
# or a string representing an integer)
# Input: a pq
def pq_add(priority; item):
  (priority|tostring) as $p
  | if .priorities|index($p) then
      if (.[$p] | index(item)) then . else .[$p] += [item] end
    else .[$p] = [item] | .priorities = (.priorities + [$p] | sort)
    end ;

# emit [ item, pq ]
# Input: a pq
def pq_pop:
  .priorities as $keys
  | if ($keys|length) == 0 then [ null, . ]
    else
      if (.[$keys[0]] | length) == 1
      then .priorities =  .priorities[1:]
      else .
      end
      | [ (.[$keys[0]])[0], (.[$keys[0]] = .[$keys[0]][1:]) ]
    end ;

# Emit the item that would be popped, or null if there is none
# Input: a pq
def pq_peep:
  .priorities as $keys
  | if ($keys|length) == 0 then null
    else (.[$keys[0]])[0]
    end ;

# Add a bunch of tasks, presented as an array of arrays
# Input: a pq
def pq_add_tasks(list):
  reduce list[] as $pair (.; . + pq_add( $pair[0]; $pair[1]) ) ;

# Pop all the tasks, producing a stream
# Input: a pq
def pq_pop_tasks:
  pq_pop as $pair
  | if $pair[0] == null then empty
    else $pair[0], ( $pair[1] | pq_pop_tasks )
    end ;

# Input: a bunch of tasks, presented as an array of arrays
def prioritize:
  . as $list | {} | pq_add_tasks($list) | pq_pop_tasks ;


using Base.Collections

test = ["Clear drains" 3;
        "Feed cat" 4;
        "Make tea" 5;
        "Solve RC tasks" 1;
        "Tax return" 2]

task = PriorityQueue(Base.Order.Reverse)
for i in 1:size(test)[1]
    enqueue!(task, test[i,1], test[i,2])
end

println("Tasks, completed according to priority:")
while !isempty(task)
    (t, p) = peek(task)
    dequeue!(task)
    println("    \"", t, "\" has priority ", p)
end


import java.util.PriorityQueue

internal data class Task(val priority: Int, val name: String) : Comparable<Task> {
    override fun compareTo(other: Task) = when {
        priority < other.priority -> -1
        priority > other.priority -> 1
        else -> 0
    }
}

private infix fun String.priority(priority: Int) = Task(priority, this)

fun main(args: Array<String>) {
    val q = PriorityQueue(listOf("Clear drains" priority 3,
                                 "Feed cat" priority 4,
                                 "Make tea" priority 5,
                                 "Solve RC tasks" priority 1,
                                 "Tax return" priority 2))
    while (q.any()) println(q.remove())
}


define priorityQueue => type {
    data
        store        = map,
        cur_priority = void

    public push(priority::integer, value) => {
        local(store) = .`store`->find(#priority)

        if(#store->isA(::array)) => {
            #store->insert(#value)
            return
        }
        .`store`->insert(#priority=array(#value))

        .`cur_priority`->isA(::void) or #priority < .`cur_priority`
            ? .`cur_priority` = #priority
    }

    public pop => {
        .`cur_priority` == void
            ? return void

        local(store)  = .`store`->find(.`cur_priority`)
        local(retVal) =  #store->first

        #store->removeFirst&size > 0
            ? return #retVal

        // Need to find next priority
        .`store`->remove(.`cur_priority`)

        if(.`store`->size == 0) => {
            .`cur_priority` = void
        else
            // There are better / faster ways to do this
            // The keys are actually already sorted, but the order of
            // storage in a map is not actually defined, can't rely on it
            .`cur_priority` = .`store`->keys->asArray->sort&first
        }

        return #retVal
    }

    public isEmpty => (.`store`->size == 0)

}

local(test) = priorityQueue

#test->push(2,`e`)
#test->push(1,`H`)
#test->push(5,`o`)
#test->push(2,`l`)
#test->push(5,`!`)
#test->push(4,`l`)

while(not #test->isEmpty) => {
    stdout(#test->pop)
}


PriorityQueue = {
    __index = {
        put = function(self, p, v)
            local q = self[p]
            if not q then
                q = {first = 1, last = 0}
                self[p] = q
            end
            q.last = q.last + 1
            q[q.last] = v
        end,
        pop = function(self)
            for p, q in pairs(self) do
                if q.first <= q.last then
                    local v = q[q.first]
                    q[q.first] = nil
                    q.first = q.first + 1
                    return p, v
                else
                    self[p] = nil
                end
            end
        end
    },
    __call = function(cls)
        return setmetatable({}, cls)
    end
}

setmetatable(PriorityQueue, PriorityQueue)

-- Usage:
pq = PriorityQueue()

tasks = {
    {3, 'Clear drains'},
    {4, 'Feed cat'},
    {5, 'Make tea'},
    {1, 'Solve RC tasks'},
    {2, 'Tax return'}
}

for _, task in ipairs(tasks) do
    print(string.format("Putting: %d - %s", unpack(task)))
    pq:put(unpack(task))
end

for prio, task in pq.pop, pq do
    print(string.format("Popped: %d - %s", prio, task))
end


Module UnOrderedArray {
      Class PriorityQueue {
      Private:
            Dim Item()
            many=0, level=0, first
            cmp = lambda->0
            Module Reduce {
                  if .many<.first*2 then exit
                  If .level<.many/2 then .many/=2 : Dim .Item(.many)
            }
      Public:
            Module Clear {
              Dim .Item() \\ erase all
              .many<=0 \\ default
              .Level<=0
            }
            Module PriorityQueue {
                  If .many>0 then Error "Clear List First"
                  Read .many, .cmp
                  .first<=.many
                  Dim .Item(.many)
            }
            Module Add {
                 If .level=.many Then {
                       If .many=0 then Error "Define Size First"
                        Dim .Item(.many*2)
                        .many*=2
                 }
                 Read Item
                 If .level=0 Then {
                       .Item(0)=Item
                 } Else.if .cmp(.Item(0), Item)=-1 Then { \\ Item is max
                       .Item(.level)=Item
                       swap .Item(0), .Item(.level)
                 } Else .Item(.level)=Item
                 .level++
            }
            Function Peek {
                  If .level=0 Then error "empty"
                  =.Item(0)
            }
            Function Poll {
                  If .level=0 Then error "empty"
                  =.Item(0)
                  If .level=2 Then {
                  swap .Item(0), .Item(1)
                  .Item(1)=0
                  .Level<=1
                  } Else.If .level>2 Then {
                        .Level--
                        Swap .Item(.level), .Item(0)
                        .Item(.level)=0
                        For I=.level-1 to 1 {
                              If .cmp(.Item(I), .Item(I-1))=1 Then Swap .Item(I), .Item(I-1)
                        }
                  } else .level<=0 : .Item(0)=0
                  .Reduce
            }
            Module Remove {
                  If .level=0 Then error "empty"
                  Read Item
                  k=true
                  If .cmp(.Item(0), Item)=0 Then {
                        Item=.Poll()
                        K~  \\ k=false
                  } Else.If .Level>1 Then {
                        I2=.Level-1
                            For I=1 to I2 {
                                    If k Then {
                                           If .cmp(.Item(I), Item)=0 Then {
                                                 If I<I2 Then Swap .Item(I), .Item(I2)
                                                 .Item(I2)=0
                                                 k=false
                                           }
                                    } else exit
                              }
                       .Level--
                  }
                  If k Then Error "Not Found"
                  .Reduce
            }
            Function Size {
                  If .many=0 then Error "Define Size First"
                  =.Level
            }
      }

      Class Item { X, S$
            Module Item { Read .X, .S$}
      }
      Function PrintTop {
            M=Queue.Peek() : Print "Item ";M.X, M.S$
      }
      Comp=Lambda -> { Read A,B : =COMPARE(A.X,B.X)}

      Queue=PriorityQueue(100,Comp)
      Queue.Add Item(3, "Clear drains")
      Call Local PrintTop()
      Queue.Add Item(4  ,"Feed cat")
      Call Local PrintTop()
      Queue.Add Item(5  ,"Make tea")
      Call Local PrintTop()
      Queue.Add Item(1  ,"Solve RC tasks")
      Call Local PrintTop()
      Queue.Add Item(2  ,"Tax return")
      Call Local PrintTop()
      Print "remove items"
      While true {
            MM=Queue.Poll()
            Print MM.X, MM.S$
            Print "Size="; Queue.Size()
            If Queue.Size()=0 Then exit
            Call Local PrintTop()
      }
}
UnOrderedArray


push = Function[{queue, priority, item},
   queue = SortBy[Append[queue, {priority, item}], First], HoldFirst];
pop = Function[queue,
   If[[email protected] == 0, Null,
    With[{item = queue[[-1, 2]]}, queue = [email protected]; item]],
   HoldFirst];
peek = Function[queue,
   If[[email protected] == 0, Null, Max[queue[[All, 1]]]], HoldFirst];
merge = Function[{queue1, queue2},
   SortBy[Join[queue1, queue2], First], HoldAll];


/* Naive implementation using a sorted list of pairs [key, [item[1], ..., item[n]]].
The key may be any number (integer or not). Items are extracted in FIFO order. */

defstruct(pqueue(q = []))$

/* Binary search */

find_key(q, p) := block(
   [i: 1, j: length(q), k, c],
   if j = 0 then false
   elseif (c: q[i][1]) >= p then
      (if c = p then i else false)
   elseif (c: q[j][1]) <= p then
      (if c = p then j else false)
   else catch(
      while j >= i do (
         k: quotient(i + j, 2),
         if (c: q[k][1]) = p then throw(k)
         elseif c < p then i: k + 1 else j: k - 1
      ),
      false
   )
)$

pqueue_push(pq, x, p) := block(
   [q: [email protected], k],
   k: find_key(q, p),
   if integerp(k) then q[k][2]: endcons(x, q[k][2])
   else [email protected]: sort(cons([p, [x]], q)),
   'done
)$

pqueue_pop(pq) := block(
   [q: [email protected], v, x],
   if emptyp(q) then 'fail else (
      p: q[1][1],
      v: q[1][2],
      x: v[1],
      if length(v) > 1 then q[1][2]: rest(v) else [email protected]: rest(q),
      x
   )
)$

pqueue_print(pq) := block([t], while (t: pqueue_pop(pq)) # 'fail do disp(t))$

/* An example */

a: new(pqueue)$

pqueue_push(a, "take milk", 4)$
pqueue_push(a, "take eggs", 4)$
pqueue_push(a, "take wheat flour", 4)$
pqueue_push(a, "take salt", 4)$
pqueue_push(a, "take oil", 4)$
pqueue_push(a, "carry out crepe recipe", 5)$
pqueue_push(a, "savour !", 6)$
pqueue_push(a, "add strawberry jam", 5 + 1/2)$
pqueue_push(a, "call friends", 5 + 2/3)$
pqueue_push(a, "go to the supermarket and buy food", 3)$
pqueue_push(a, "take a shower", 2)$
pqueue_push(a, "get dressed", 2)$
pqueue_push(a, "wake up", 1)$
pqueue_push(a, "serve cider", 5 + 3/4)$
pqueue_push(a, "buy also cider", 3)$

pqueue_print(a);
"wake up"
"take a shower"
"get dressed"
"go to the supermarket and buy food"
"buy also cider"
"take milk"
"take butter"
"take flour"
"take salt"
"take oil"
"carry out recipe"
"add strawberry jam"
"call friends"
"serve cider"
"savour !"


:- module test_pqueue.

:- interface.

:- import_module io.

:- pred main(io::di, io::uo) is det.

:- implementation.

:- import_module int.
:- import_module list.
:- import_module pqueue.
:- import_module string.

:- pred build_pqueue(pqueue(int,string)::in, pqueue(int,string)::out) is det.
build_pqueue(!PQ) :-
  pqueue.insert(3, "Clear drains",   !PQ),
  pqueue.insert(4, "Feed cat",       !PQ),
  pqueue.insert(5, "Make tea",       !PQ),
  pqueue.insert(1, "Solve RC tasks", !PQ),
  pqueue.insert(2, "Tax return",     !PQ).

:- pred display_pqueue(pqueue(int, string)::in, io::di, io::uo) is det.
display_pqueue(PQ, !IO) :-
  ( pqueue.remove(K, V, PQ, PQO) ->
      io.format("Key = %d, Value = %s\n", [i(K), s(V)], !IO),
      display_pqueue(PQO, !IO)
  ;
      true
  ).

main(!IO) :-
  build_pqueue(pqueue.init, PQO),
  display_pqueue(PQO, !IO).


type
  PriElem[T] = tuple
    data: T
    pri: int

  PriQueue[T] = object
    buf: seq[PriElem[T]]
    count: int

# first element not used to simplify indices
proc initPriQueue[T](initialSize = 4): PriQueue[T] =
  result.buf.newSeq(initialSize)
  result.buf.setLen(1)
  result.count = 0

proc add[T](q: var PriQueue[T], data: T, pri: int) =
  var n = q.buf.len
  var m = n div 2
  q.buf.setLen(n + 1)

  # append at end, then up heap
  while m > 0 and pri < q.buf[m].pri:
    q.buf[n] = q.buf[m]
    n = m
    m = m div 2

  q.buf[n] = (data, pri)
  q.count = q.buf.len - 1

proc pop[T](q: var PriQueue[T]): PriElem[T] =
  assert q.buf.len > 1
  result = q.buf[1]

  var qn = q.buf.len - 1
  var n = 1
  var m = 2
  while m < qn:
    if m + 1 < qn and q.buf[m].pri > q.buf[m+1].pri:
      inc m

    if q.buf[qn].pri <= q.buf[m].pri:
      break

    q.buf[n] = q.buf[m]
    n = m
    m = m * 2

  q.buf[n] = q.buf[qn]
  q.buf.setLen(q.buf.len - 1)
  q.count = q.buf.len - 1

var p = initPriQueue[string]()
p.add("Clear drains", 3)
p.add("Feed cat", 4)
p.add("Make tea", 5)
p.add("Solve RC tasks", 1)
p.add("Tax return", 2)

while p.count > 0:
  echo p.pop()


#import <Foundation/Foundation.h>

const void *PQRetain(CFAllocatorRef allocator, const void *ptr) {
  return (__bridge_retained const void *)(__bridge id)ptr;
}
void PQRelease(CFAllocatorRef allocator, const void *ptr) {
  (void)(__bridge_transfer id)ptr;
}
CFComparisonResult PQCompare(const void *ptr1, const void *ptr2, void *unused) {
  return [(__bridge id)ptr1 compare:(__bridge id)ptr2];
}

@interface Task : NSObject {
  int priority;
  NSString *name;
}
- (instancetype)initWithPriority:(int)p andName:(NSString *)n;
- (NSComparisonResult)compare:(Task *)other;
@end

@implementation Task
- (instancetype)initWithPriority:(int)p andName:(NSString *)n {
  if ((self = [super init])) {
    priority = p;
    name = [n copy];
  }
  return self;
}
- (NSString *)description {
  return [NSString stringWithFormat:@"%d, %@", priority, name];
}
- (NSComparisonResult)compare:(Task *)other {
  if (priority == other->priority)
    return NSOrderedSame;
  else if (priority < other->priority)
    return NSOrderedAscending;
  else
    return NSOrderedDescending;
}
@end

int main (int argc, const char *argv[]) {
  @autoreleasepool {

    CFBinaryHeapCallBacks callBacks = {0, PQRetain, PQRelease, NULL, PQCompare};
    CFBinaryHeapRef pq = CFBinaryHeapCreate(NULL, 0, &callBacks, NULL);

    CFBinaryHeapAddValue(pq, [[Task alloc] initWithPriority:3 andName:@"Clear drains"]);
    CFBinaryHeapAddValue(pq, [[Task alloc] initWithPriority:4 andName:@"Feed cat"]);
    CFBinaryHeapAddValue(pq, [[Task alloc] initWithPriority:5 andName:@"Make tea"]);
    CFBinaryHeapAddValue(pq, [[Task alloc] initWithPriority:1 andName:@"Solve RC tasks"]);
    CFBinaryHeapAddValue(pq, [[Task alloc] initWithPriority:2 andName:@"Tax return"]);

    while (CFBinaryHeapGetCount(pq) != 0) {
      Task *task = (id)CFBinaryHeapGetMinimum(pq);
      NSLog(@"%@", task);
      CFBinaryHeapRemoveMinimumValue(pq);
    }

    CFRelease(pq);

  }
  return 0;
}


module PQ = Base.PriorityQueue

let () =
  let tasks = [
    3, "Clear drains";
    4, "Feed cat";
    5, "Make tea";
    1, "Solve RC tasks";
    2, "Tax return";
  ] in
  let pq = PQ.make (fun (prio1, _) (prio2, _) -> prio1 > prio2) in
  List.iter (PQ.add pq) tasks;
  while not (PQ.is_empty pq) do
    let _, task = PQ.first pq in
    PQ.remove_first pq;
    print_endline task
  done


'PRIORITY QUEUE WITH 16 LEVELS

uses console

% pl 16 'priority levels

===================
Class PriorityQueue
===================

indexbase 1
bstring buf[pl] 'buffers to hold priority queues content
int      bg[pl] 'buffers base offset
int       i[pl] 'indexers
int      le[pl] 'length of buffer

method constructor()
====================
int p
for p=1 to pl
  buf[p]=""
  le[p]=0
  bg[p]=0
  i=[p]=0
next
end method

method destructor()
===================
int p
for p=1 to pl
  del (buf[p])
  le[p]=0
  bg[p]=0
  i=[p]=0
next
end method

method Encodelength(int ls,p)
=============================
int ll at i[p]+strptr(buf[p])
ll=ls
i[p]+=sizeof int
end method

method limit(int*p)
===================
if p>pl
  p=pl
endif
if p<1
  p=1
endif
end method

method push(string s,int p)
=============================
limit p
int ls
ls=len s
if i[p]+ls+8 > le[p] then
  int e=8000+(ls*2) 'extra buffer bytes
  buf[p]=buf[p]+nuls e 'extend buf
  le[p]=len buf[p]
end if
EncodeLength ls,p   'length of input s
mid buf[p],i[p]+1,s 'patch in s
i[p]+=ls
end method

method popLength(int p) as int
==============================
if bg[p]>=i[p]
  return -1 'buffer empty
endif
int ll at (bg[p]+strptr buf[p])
bg[p]+=sizeof int
return ll
end method

method pop(string *s, int *p=1, lpl=0) as int
=============================================
limit p
int ls
do
  ls=popLength p
  if ls=-1
    if not lpl 'lpl: lock priority level
      p++ 'try next priority level
      if p<=pl
        continue do
      endif
    endif
    s=""
    return ls 'empty buffers
  endif
  exit do
loop
s=mid buf[p],bg[p]+1,ls
bg[p]+=ls
'cleanup buffer
if bg[p]>1e6 then
  buf[p]=mid buf[p],bg[p]+1 'remove old popped data
  le[p]=len buf[p]
  i[p]-=bg[p] 'shrink buf
  bg[p]=0
end if
end method

method clear()
==============
constructor
end method

end class 'PriorityQueue

'====
'DEMO
'====
new PriorityQueue  medo()
string s

def inp
  medo.push %2,%1
end def

'   Priority         Task
'   ══════════         ════════════════
inp        3         "Clear drains"
inp        4         "Feed cat"
inp        5         "Make tea"
inp        1         "Solve RC tasks"
inp        2         "Tax return"
inp        4         "Plant beans"
'
int er
int p
print "Priority Task" cr
print "=================" cr
do
  er=medo.pop s,p
  if er=-1
    print "(buffer empty)"
    exit do
  endif
  print p tab s cr
loop
pause
del medo

/*
RESULTS:
Priority Task
=================
1       Solve RC tasks
2       Tax return
3       Clear drains
4       Feed cat
4       Plant beans
5       Make tea
(buffer empty)
*/


program PriorityQueueTest;

uses Classes;

Type
 TItem = record
    Priority:Integer;
    Value:string;
 end;

 PItem = ^TItem;

TPriorityQueue = class(Tlist)
 procedure Push(Priority:Integer;Value:string);
 procedure SortPriority();
 function Pop():String;
 function Empty:Boolean;
end;

{ TPriorityQueue }

procedure TPriorityQueue.Push(Priority:Integer;Value:string);
var
 Item: PItem;
begin
    new(Item);
    Item^.Priority := Priority;
    Item^.Value := Value;
    inherited Add(Item);
    SortPriority();
end;

procedure TPriorityQueue.SortPriority();
var
 i,j:Integer;
begin
 if(Count < 2) Then  Exit();

 for i:= 0 to Count-2 do
  for j:= i+1 to Count-1 do
    if ( PItem(Items[i])^.Priority > PItem(Items[j])^.Priority)then
      Exchange(i,j);
end;

function TPriorityQueue.Pop():String;
begin
 if count = 0  then
   Exit('');
 result := PItem(First)^.value;
 Dispose(PItem(First));
 Delete(0);
end;

function TPriorityQueue.Empty:Boolean;
begin
 Result := Count = 0;
end;

var
 Queue : TPriorityQueue;
begin
  Queue:= TPriorityQueue.Create();

  Queue.Push(3,'Clear drains');
  Queue.Push(4,'Feed cat');
  Queue.Push(5,'Make tea');
  Queue.Push(1,'Solve RC tasks');
  Queue.Push(2,'Tax return');

  while not Queue.Empty() do
   writeln(Queue.Pop());

  Queue.free;
end.


use 5.10.0;
use strict;
use Heap::Priority;

my $h = new Heap::Priority;

$h->highest_first(); # higher or lower number is more important
$h->add(@$_) for ["Clear drains",   3],
     ["Feed cat",     4],
     ["Make tea",     5],
     ["Solve RC tasks", 1],
     ["Tax return",     2];

say while ($_ = $h->pop);


with javascript_semantics
constant tasklist = new_dict()

procedure add_task(integer priority, string desc)
    integer k = getd_index(priority,tasklist)
    if k=0 then
        putd(priority,{desc},tasklist)
    else
        sequence descs = getd_by_index(k,tasklist)
        putd(priority,append(descs,desc),tasklist)
    end if
end procedure

function list_task_visitor(integer priority, sequence descs, integer /*user_data*/)
    ?{priority,descs}
    return true -- continue
end function

procedure list_tasks()
    traverse_dict(list_task_visitor, 0, tasklist, true)
end procedure

function pop_task_visitor(integer priority, sequence descs, integer rid)
    string desc = descs[1]
    descs = descs[2..$]
    if length(descs)=0 then
        deld(priority,tasklist)
    else
        putd(priority,descs,tasklist)
    end if
    rid(priority,desc)
    return false -- stop
end function

procedure pop_task(integer rid)
    if dict_size(tasklist)!=0 then
        traverse_dict(pop_task_visitor, rid, tasklist, true)
    end if
end procedure

add_task(3,"Clear drains")
add_task(4,"Feed cat")
add_task(5,"Make tea")
add_task(1,"Solve RC tasks")
add_task(2,"Tax return")

procedure do_task(integer priority, string desc)
    ?{priority,desc}
end procedure

list_tasks()
?"==="
pop_task(do_task)
?"==="
list_tasks()


/# Rosetta Code problem: http://rosettacode.org/wiki/Priority_queue
by Galileo, 05/2022 #/

include ..\Utilitys.pmt

( )
( 3 "Clear drains" ) 0 put ( 4 "Feed cat" ) 0 put ( 5 "Make tea" ) 0 put ( 1 "Solve RC tasks" ) 0 put ( 2 "Tax return" ) 0 put
sort pop swap print pstack


<?php
$pq = new SplPriorityQueue;

$pq->insert('Clear drains', 3);
$pq->insert('Feed cat', 4);
$pq->insert('Make tea', 5);
$pq->insert('Solve RC tasks', 1);
$pq->insert('Tax return', 2);

// This line causes extract() to return both the data and priority (in an associative array),
// Otherwise it would just return the data
$pq->setExtractFlags(SplPriorityQueue::EXTR_BOTH);

while (!$pq->isEmpty()) {
    print_r($pq->extract());
}
?>


main =>
  Tasks = [[3,"Clear drains"],
           [4,"Feed cat"],
           [5,"Make tea"],
           [1,"Solve RC tasks"],
           [2,"Tax return"]],
  Heap = new_min_heap([]),
  foreach(Task in Tasks)
     Heap.heap_push(Task),
     println(top=Heap.heap_top())
  end,
  nl,
  println(Heap),
  println(size=Heap.heap_size),
  nl,
  println("Pop the elements from the queue:"),
  println([Heap.heap_pop() : _ in 1..Heap.heap_size]).


# Insert item into priority queue
(de insertPQ (Queue Prio Item)
   (idx Queue (cons Prio Item) T) )

# Remove and return top item from priority queue
(de removePQ (Queue)
   (cdar (idx Queue (peekPQ Queue) NIL)) )

# Find top element in priority queue
(de peekPQ (Queue)
   (let V (val Queue)
      (while (cadr V)
         (setq V @) )
      (car V) ) )

# Merge second queue into first
(de mergePQ (Queue1 Queue2)
   (balance Queue1 (sort (conc (idx Queue1) (idx Queue2)))) )


priority-queue :-
  TL0 = [3-'Clear drains',
         4-'Feed cat'],

  % we can create a priority queue from a list
  list_to_heap(TL0, Heap0),

  % alternatively we can start from an empty queue
  % get from empty_heap/1.

  % now we add the other elements
  add_to_heap(Heap0, 5, 'Make tea', Heap1),
  add_to_heap(Heap1, 1, 'Solve RC tasks', Heap2),
  add_to_heap(Heap2, 2, 'Tax return', Heap3),

  % we list the content of the heap:
  heap_to_list(Heap3, TL1),
  writeln('Content of the queue'), maplist(writeln, TL1),
  nl,

  % now we retrieve the minimum-priority pair
  get_from_heap(Heap3, Priority, Key, Heap4),
  format('Retrieve top of the queue : Priority ~w, Element ~w~n', [Priority, Key]),
  nl,

  % we list the content of the heap:
  heap_to_list(Heap4, TL2),
  writeln('Content of the queue'), maplist(writeln, TL2).


Structure taskList
  List description.s()  ;implements FIFO queue
EndStructure

Structure task
  *tl.tList  ;pointer to a list of task descriptions
  Priority.i ;tasks priority, lower value has more priority
EndStructure

Structure priorityQueue
  maxHeapSize.i ;increases as needed
  heapItemCount.i  ;number of elements currently in heap
  Array heap.task(0) ;elements hold FIFO queues ordered by priorities, lowest first
  map heapMap.taskList() ;holds lists of tasks with the same priority that are FIFO queues
EndStructure

Procedure insertPQ(*PQ.priorityQueue, description.s, p)
  If FindMapElement(*PQ\heapMap(), Str(p))
    LastElement(*PQ\heapMap()\description())
    AddElement(*PQ\heapMap()\description())
    *PQ\heapMap()\description() = description
  Else
    Protected *tl.taskList = AddMapElement(*PQ\heapMap(), Str(p))
    AddElement(*tl\description())
    *tl\description() = description

    Protected pos = *PQ\heapItemCount

    *PQ\heapItemCount + 1
    If *PQ\heapItemCount > *PQ\maxHeapSize
      Select *PQ\maxHeapSize
        Case 0
          *PQ\maxHeapSize = 128
        Default
          *PQ\maxHeapSize * 2
      EndSelect
      Redim *PQ\heap.task(*PQ\maxHeapSize)
    EndIf

    While pos > 0 And p < *PQ\heap((pos - 1) / 2)\Priority
      *PQ\heap(pos) = *PQ\heap((pos - 1) / 2)
      pos = (pos - 1) / 2
    Wend

    *PQ\heap(pos)\tl = *tl
    *PQ\heap(pos)\Priority = p
  EndIf
EndProcedure

Procedure.s removePQ(*PQ.priorityQueue)
  Protected *tl.taskList = *PQ\heap(0)\tl, description.s
  FirstElement(*tl\description())
  description = *tl\description()
  If ListSize(*tl\description()) > 1
    DeleteElement(*tl\description())
  Else
    DeleteMapElement(*PQ\heapMap(), Str(*PQ\heap(0)\Priority))

    *PQ\heapItemCount - 1
    *PQ\heap(0) = *PQ\heap(*PQ\heapItemCount)

    Protected pos
    Repeat
      Protected child1 = 2 * pos + 1
      Protected child2 = 2 * pos + 2
      If child1 >= *PQ\heapItemCount
        Break
      EndIf

      Protected smallestChild
      If child2 >= *PQ\heapItemCount
        smallestChild = child1
      ElseIf *PQ\heap(child1)\Priority <= *PQ\heap(child2)\Priority
        smallestChild = child1
      Else
        smallestChild = child2
      EndIf

      If (*PQ\heap(smallestChild)\Priority >= *PQ\heap(pos)\Priority)
        Break
      EndIf
      Swap *PQ\heap(pos)\tl, *PQ\heap(smallestChild)\tl
      Swap *PQ\heap(pos)\Priority, *PQ\heap(smallestChild)\Priority
      pos = smallestChild
    ForEver
  EndIf

  ProcedureReturn description
EndProcedure

Procedure isEmptyPQ(*PQ.priorityQueue) ;returns 1 if empty, otherwise returns 0
  If *PQ\heapItemCount
    ProcedureReturn 0
  EndIf
  ProcedureReturn 1
EndProcedure

If OpenConsole()
  Define PQ.priorityQueue
  insertPQ(PQ, "Clear drains", 3)
  insertPQ(PQ, "Answer Phone 1", 8)
  insertPQ(PQ, "Feed cat", 4)
  insertPQ(PQ, "Answer Phone 2", 8)
  insertPQ(PQ, "Make tea", 5)
  insertPQ(PQ, "Sleep", 9)
  insertPQ(PQ, "Check email", 3)
  insertPQ(PQ, "Solve RC tasks", 1)
  insertPQ(PQ, "Answer Phone 3", 8)
  insertPQ(PQ, "Exercise", 9)
  insertPQ(PQ, "Answer Phone 4", 8)
  insertPQ(PQ, "Tax return", 2)

  While Not isEmptyPQ(PQ)
    PrintN(removePQ(PQ))
  Wend

  Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
  CloseConsole()
EndIf


>>> import queue
>>> pq = queue.PriorityQueue()
>>> for item in ((3, "Clear drains"), (4, "Feed cat"), (5, "Make tea"), (1, "Solve RC tasks"), (2, "Tax return")):
  pq.put(item)

>>> while not pq.empty():
  print(pq.get_nowait())

(1, 'Solve RC tasks')
(2, 'Tax return')
(3, 'Clear drains')
(4, 'Feed cat')
(5, 'Make tea')
>>>


( ***** priotity queue ***** )

  [ stack ]                      is heap.pq     (     --> s   )

  [ stack ]                      is comp.pq     (     --> s   )

  [ unpack
    comp.pq put heap.pq put ]    is pq->stacks  (   p -->     )

  [ heap.pq take comp.pq take
    2 pack ]                     is stacks->pq  (     --> p   )

  [ heap.pq share swap peek ]    is heapeek     (   n --> x   )

  [ heap.pq take
    swap poke heap.pq put ]      is heapoke     ( n x -->     )

  [ 1 - 1 >> ]                   is parent      (   n --> n   )

  [ 0 > ]                        is has-parent  (   n --> b   )

  [ 1 << 1+ ]                    is child       (   n --> n   )

  [ child heap.pq share size < ] is has-child   (   n --> b   )

  [ 1+ ]                         is sibling     (   n --> n   )

  [ sibling
    heap.pq share size < ]       is has-sibling (   n --> b   )

  [ comp.pq share do ]           is compare     ( x x --> b   )

  [ 0 peek size ]                is pqsize      (   p --> n   )

  [ swap pq->stacks
    heap.pq take tuck size
    rot 0 join heap.pq put
    [ dup has-parent while
      dup parent
      rot over heapeek
      2dup compare iff
        [ 2swap unrot heapoke ]
        again
      rot 2drop swap ]
    heapoke
    stacks->pq ]                 is topq        ( p x --> p   )

  [ dup heapeek swap
    [ dup has-child while
      dup child
      dup has-sibling if
        [ dup sibling heapeek
          over heapeek
          compare if sibling ]
      dip over dup heapeek
      rot dip dup compare iff
        [ rot heapoke ] again
      2drop ]
    heapoke ]                    is heapify.pq  (   n -->     )

  [ dup pqsize 0 = if
      [ $ "Unexpectedly empty priority queue."
        fail ]
    pq->stacks heap.pq share
    behead
    over [] = iff
      [ swap heap.pq replace ]
    else
      [ swap -1 split
        swap join heap.pq put
        0 heapify.pq ]
    stacks->pq swap ]            is frompq      (   p --> p x )

  [ ]'[ 2 pack pq->stacks
    heap.pq share
    size 1 >> times
      [ i heapify.pq ]
    stacks->pq ]                 is pqwith      (   [ --> p   )

( ***** task ***** )

  [ 2 pack topq ]                is insert      ( p n $ --> p     )

  [ frompq unpack ]              is dequeue    (     p --> p n $ )

  [] pqwith [ 0 peek dip [ 0 peek ] < ]

  3 $ "Clear drains"   insert
  4 $ "Feed cat"       insert
  5 $ "Make tea"       insert
  1 $ "Solve RC tasks" insert
  2 $ "Tax return"     insert

  5 times
    [ dequeue
      swap echo say ": "
      echo$ cr ]
  drop


PriorityQueue <- function() {
  keys <- values <- NULL
  insert <- function(key, value) {
    ord <- findInterval(key, keys)
    keys <<- append(keys, key, ord)
    values <<- append(values, value, ord)
  }
  pop <- function() {
    head <- list(key=keys[1],value=values[[1]])
    values <<- values[-1]
    keys <<- keys[-1]
    return(head)
  }
  empty <- function() length(keys) == 0
  environment()
}

pq <- PriorityQueue()
pq$insert(3, "Clear drains")
pq$insert(4, "Feed cat")
pq$insert(5, "Make tea")
pq$insert(1, "Solve RC tasks")
pq$insert(2, "Tax return")
while(!pq$empty()) {
  with(pq$pop(), cat(key,":",value,"\n"))
}


#lang racket
(require data/heap)

(define pq (make-heap (λ(x y) (<= (second x) (second y)))))

(define (insert! x pri)
  (heap-add! pq (list pri x)))

(define (remove-min!)
  (begin0
    (first (heap-min pq))
    (heap-remove-min! pq)))

(insert! 3 "Clear drains")
(insert! 4 "Feed cat")
(insert! 5 "Make tea")
(insert! 1 "Solve RC tasks")
(insert! 2 "Tax return")

(remove-min!)
(remove-min!)
(remove-min!)
(remove-min!)
(remove-min!)


class PriorityQueue {
    has @!tasks;

    method insert (Int $priority where * >= 0, $task) {
        @!tasks[$priority].push: $task;
    }

    method get { @!tasks.first(?*).shift }

    method is-empty { ?none @!tasks }
}

my $pq = PriorityQueue.new;

for (
    3, 'Clear drains',
    4, 'Feed cat',
    5, 'Make tea',
    9, 'Sleep',
    3, 'Check email',
    1, 'Solve RC tasks',
    9, 'Exercise',
    2, 'Do taxes'
) -> $priority, $task {
    $pq.insert( $priority, $task );
}

say $pq.get until $pq.is-empty;


/*REXX program implements a  priority queue   with  insert/display/delete  the top task.*/
#=0;   @.=                                       /*0 tasks;  nullify the priority queue.*/
say '══════ inserting tasks.';     call .ins  3  "Clear drains"
                                   call .ins  4  "Feed cat"
                                   call .ins  5  "Make tea"
                                   call .ins  1  "Solve RC tasks"
                                   call .ins  2  "Tax return"
                                   call .ins  6  "Relax"
                                   call .ins  6  "Enjoy"
say '══════ showing tasks.';       call .show
say '══════ deletes top task.';    say .del()    /*delete the top task.                 */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
.del:  procedure expose @. #; arg p;  if p=''  then p=.top();    [email protected].p;   @.p=;   return y
.ins:  procedure expose @. #; #=#+1;  @.#=arg(1);    return #          /*entry, P, task.*/
.show: procedure expose @. #; do j=1  for #;  [email protected].j;  if _\==''  then say _;  end;  return
/*──────────────────────────────────────────────────────────────────────────────────────*/
.top:  procedure expose @. #;      top=;              top#=
                   do j=1  for #;  _=word(@.j, 1);    if _==''  then iterate
                   if top=='' | _>top  then do;    top=_;    top#=j;    end
                   end   /*j*/
       return top#


class PriorityQueueNaive
  def initialize(data=nil)
    @q = Hash.new {|h, k| h[k] = []}
    data.each {|priority, item| @q[priority] << item}  if data
    @priorities = @q.keys.sort
  end

  def push(priority, item)
    @q[priority] << item
    @priorities = @q.keys.sort
  end

  def pop
    p = @priorities[0]
    item = @q[p].shift
    if @q[p].empty?
      @q.delete(p)
      @priorities.shift
    end
    item
  end

  def peek
    unless empty?
      @q[@priorities[0]][0]
    end
  end

  def empty?
    @priorities.empty?
  end

  def each
    @q.each do |priority, items|
      items.each {|item| yield priority, item}
    end
  end

  def dup
    @q.each_with_object(self.class.new) do |(priority, items), obj|
      items.each {|item| obj.push(priority, item)}
    end
  end

  def merge(other)
    raise TypeError  unless self.class == other.class
    pq = dup
    other.each {|priority, item| pq.push(priority, item)}
    pq                  # return a new object
  end

  def inspect
    @q.inspect
  end
end

test = [
  [6, "drink tea"],
  [3, "Clear drains"],
  [4, "Feed cat"],
  [5, "Make tea"],
  [6, "eat biscuit"],
  [1, "Solve RC tasks"],
  [2, "Tax return"],
]

pq = PriorityQueueNaive.new
test.each {|pr, str| pq.push(pr, str) }
until pq.empty?
  puts pq.pop
end

puts
test2 = test.shift(3)
p pq1 = PriorityQueueNaive.new(test)
p pq2 = PriorityQueueNaive.new(test2)
p pq3 = pq1.merge(pq2)
puts "peek : #{pq3.peek}"
until pq3.empty?
  puts pq3.pop
end
puts "peek : #{pq3.peek}"


sqliteconnect #mem, ":memory:"
#mem execute("CREATE TABLE queue (priority float,descr text)")

' --------------------------------------------------------------
' Insert items into the que
' --------------------------------------------------------------
#mem execute("INSERT INTO queue VALUES (3,'Clear drains')")
#mem execute("INSERT INTO queue VALUES (4,'Feed cat')")
#mem execute("INSERT INTO queue VALUES (5,'Make tea')")
#mem execute("INSERT INTO queue VALUES (1,'Solve RC tasks')")
#mem execute("INSERT INTO queue VALUES (2,'Tax return')")

'--------------- insert priority between 4 and 5 -----------------
#mem execute("INSERT INTO queue VALUES (4.5,'My Special Project')")

what$ = " -------------- Find first priority ---------------------"
mem$ = "SELECT * FROM queue ORDER BY priority LIMIT 1"
gosub [getQueue]

what$ = " -------------- Find last priority ---------------------"
mem$ = "SELECT * FROM queue ORDER BY priority desc LIMIT 1"
gosub [getQueue]

what$ = " -------------- Delete Highest Priority ---------------------"
mem$ = "DELETE FROM queue WHERE priority = (select max(q.priority) FROM queue as q)"
#mem  execute(mem$)

what$ = " -------------- List Priority Sequence ---------------------"
mem$ = "SELECT * FROM queue ORDER BY priority"
gosub [getQueue]
end

[getQueue]
print what$
#mem  execute(mem$)
rows    = #mem ROWCOUNT()
print "Priority    Description"
for i = 1 to rows
  #row     = #mem #nextrow()
  priority = #row priority()
  descr$   = #row descr$()
print priority;"         ";descr$
next i
RETURN


use std::collections::BinaryHeap;
use std::cmp::Ordering;
use std::borrow::Cow;

#[derive(Eq, PartialEq)]
struct Item<'a> {
    priority: usize,
    task: Cow<'a, str>, // Takes either borrowed or owned string
}

impl<'a> Item<'a> {
    fn new<T>(p: usize, t: T) -> Self
        where T: Into<Cow<'a, str>>
    {
        Item {
            priority: p,
            task: t.into(),
        }
    }
}

// Manually implpement Ord so we have a min heap
impl<'a> Ord for Item<'a> {
    fn cmp(&self, other: &Self) -> Ordering {
        other.priority.cmp(&self.priority)
    }
}

// PartialOrd is required by Ord
impl<'a> PartialOrd for Item<'a> {
    fn partial_cmp(&self, other: &Self) -> Option<Ordering> {
        Some(self.cmp(other))
    }
}

fn main() {
    let mut queue = BinaryHeap::with_capacity(5);
    queue.push(Item::new(3, "Clear drains"));
    queue.push(Item::new(4, "Feed cat"));
    queue.push(Item::new(5, "Make tea"));
    queue.push(Item::new(1, "Solve RC tasks"));
    queue.push(Item::new(2, "Tax return"));

    for item in queue {
        println!("{}", item.task);
    }
}


%macro HeapInit(size=1000,nchar=20);
do;
	_len = 0;
	_size = &size;
	array _times(&size) _temporary_ ;
	array _kinds(&size) $ &nchar _temporary_;
	drop _size _len;
end;
%mend;
%macro HeapSwapItem(index1, index2);
do;
	_tempN = _times[&index1]; _times[&index1] = _times[&index2]; _times[&index2] = _tempN;
	_tempC = _kinds[&index1]; _kinds[&index1] = _kinds[&index2]; _kinds[&index2]= _tempC;
	drop _tempN _tempC;
end;
%mend;
%macro HeapEmpty;
	(_len=0)
%mend;
%macro HeapCompare(index1, index2);
	(_times[&index1] < _times[&index2])
%mend;
%macro HeapSiftdown(index);
do;
	_parent = &index;
	_done = 0;
	do while (_parent*2 <= _len & ^_done);
		_child = _parent*2;
		if (_child+1 <= _len and %HeapCompare(_child+1,_child)) then
			_child = _child + 1;
		if %HeapCompare(_child,_parent) then do;
			%HeapSwapItem(_child,_parent);
			_parent = _child;
		end;
		else _done = 1;
	end;
	drop _done _parent _child;
end;
%mend;
%macro HeapSiftup(index);
do;
	_child = &index;
	_done = 0;
	do while(_child>1 and ^_done);
		_parent = floor(_child/2);
		if %HeapCompare(_parent,_child) then
			_done = 1;
		else do;
			%HeapSwapItem(_child,_parent);
			_tempN = _child;
			_child = _parent;
			_parent = _tempN;
		end;
	end;
	drop _parent _child _done _tempN;
end;
%mend;
%macro HeapPush(time, kind);
do;
	if _len >= _size then do;
		put "ERROR: exceeded size of heap. Consider changing size argument to %HeapInit.";
		stop;
	end;
	_len = _len + 1;
	_times[_len] = &time;
	_kinds[_len] = &kind;
	%HeapSiftup(_len);
end;
%mend;
%macro HeapPop;
do;
	_len = _len - 1;
	if (_len>0) then do;
		_times[1] = _times[_len+1];
		_kinds[1] = _kinds[_len+1];
		%HeapSiftdown(1);
	end;
end;
%mend;
%macro HeapPeek;
	time = _times[1];
	kind = _kinds[1];
	put time kind;
%mend;
data _null_;
	%HeapInit;
	%HeapPush(3, "Clear drains");
	%HeapPush(4, "Feed cat");
	%HeapPush(5, "Make tea");
	%HeapPush(1, "Solve RC tasks");
	%HeapPush(2, "Tax return");
	do while(^%HeapEmpty);
		%HeapPeek;
		%HeapPop;
	end;
run;


import scala.collection.mutable.PriorityQueue
case class Task(prio:Int, text:String) extends Ordered[Task] {
  def compare(that: Task)=that.prio compare this.prio
}

//test
var q=PriorityQueue[Task]() ++ Seq(Task(3, "Clear drains"), Task(4, "Feed cat"),
  Task(5, "Make tea"), Task(1, "Solve RC tasks"), Task(2, "Tax return"))
while(q.nonEmpty) println(q dequeue)


// PriorityQueue.script
set Tasks to a new PriorityQueue

tell Tasks to add 3,"Clear drains"
tell Tasks to add 4,"Feed cat"
tell Tasks to add 5,"Make tea"
tell Tasks to add 1,"Solve RC tasks"
tell Tasks to add 2,"Tax return"

put "Initial tasks:"
put Tasks.report & return

put Tasks.getTop into topItem
put "Top priority: " & topItem & return

put "Remaining:" & return & Tasks.report

------
properties
	queue:[]
end properties

to add newPriority, newTask
	repeat with each item of my queue
		if newPriority comes before the priority of it then
			insert {priority:newPriority, task:newTask} before item the counter of my queue
			return
		end if
	end repeat
	insert {priority:newPriority, task:newTask} into my queue -- add at end if last priority
end add

to getTop
	pull my queue into firstItem
	return firstItem
end getTop

to report
	return (priority of each && task of each for each item of my queue) joined by return
end report


class PriorityQueue {
    has tasks = []

    method insert (Number priority { _ >= 0 }, task) {
        for n in range(tasks.len, priority) {
            tasks[n] = []
        }
        tasks[priority].append(task)
    }

    method get      { tasks.first { !.is_empty } -> shift }
    method is_empty { tasks.all   {  .is_empty } }
}

var pq = PriorityQueue()

[
    [3, 'Clear drains'],
    [4, 'Feed cat'],
    [5, 'Make tea'],
    [9, 'Sleep'],
    [3, 'Check email'],
    [1, 'Solve RC tasks'],
    [9, 'Exercise'],
    [2, 'Do taxes'],
].each { |pair|
    pq.insert(pair...)
}

say pq.get while !pq.is_empty


structure TaskPriority = struct
  type priority = int
  val compare = Int.compare
  type item = int * string
  val priority : item -> int = #1
end

structure PQ = LeftPriorityQFn (TaskPriority)
;

let
  val tasks = [
    (3, "Clear drains"),
    (4, "Feed cat"),
    (5, "Make tea"),
    (1, "Solve RC tasks"),
    (2, "Tax return")]
  val pq = foldl PQ.insert PQ.empty tasks
  (* or val pq = PQ.fromList tasks *)
  fun aux pq' =
    case PQ.next pq' of
      NONE => ()
    | SOME ((prio, name), pq'') => (
        print (Int.toString prio ^ ", " ^ name ^ "\n");
        aux pq''
      )
in
  aux pq
end


mata
	struct Node {
		real scalar time
		transmorphic data
		}
	class Heap {
		public:
		struct Node rowvector nodes
		real scalar len
		real scalar size
		real scalar minHeap
		void new()
		void push()
		void siftup()
		void siftdown()
		struct Node scalar pop()
		real scalar empty()
		real scalar compare()
		}
	real scalar Heap::compare(a,b) {
		struct Node scalar left, right
		left = nodes[a]
		right = nodes[b]
		return(minHeap ? left.time<right.time : left.time>right.time)
		}
	void Heap::new()  {
		len = 0
		size = 4
		nodes = Node(1,size)
		minHeap = 1 // defaults to min heap
		}
	real scalar Heap::empty() {
		return(len==0)
		}
	void Heap::siftdown(real scalar index) {
		parent = index
		while (parent*2 <= len) {
			child = parent*2
			if (child+1 <= len ? compare(child+1,child) : 0) {
				child++
				}
			if (compare(child,parent)) {
				nodes[(child,parent)] = nodes[(parent,child)]
				parent = child
				} else break
			}
		}
	void Heap::siftup(real scalar index) {
		child = index
		while(child>1) {
			parent = floor(child/2)
			if (compare(parent,child)) {
				break
				}
			nodes[(child,parent)] = nodes[(parent,child)]
			temp = child
			child = parent
			parent = temp
			}
		}
	void Heap::push (real scalar time, transmorphic data) {
		if (len + 1 >= size) {
			nodes = (nodes, nodes)
			size = size*2
			}
		len++
		nodes[len].time = time
		nodes[len].data = data
		siftup(len)
		}
	struct Node scalar Heap::pop () {
		if (len==0) {
			_error(3000,"empty heap")
			}
		len--
		struct Node scalar newnode
		newnode.time = nodes[1].time
		newnode.data = nodes[1].data
		if (len>0) {
			nodes[1] = nodes[len+1]
			siftdown(1)
			}
		return(newnode)
		}
	void testHeap(real scalar minHeap) {
		class Heap scalar h
		struct Node scalar node
		h = Heap()
		h.minHeap = minHeap
		h.push(3, "Clear drains")
		h.push(4, "Feed cat")
		h.push(5, "Make tea")
		h.push(1, "Solve RC tasks")
		h.push(2, "Tax return")
		while (!h.empty()) {
			node = h.pop()
			printf("%f -> %s\n", node.time, node.data)
			}
		}
	testHeap(1)
	testHeap(0)
end


class Task : Comparable, CustomStringConvertible {
  var priority : Int
  var name: String
  init(priority: Int, name: String) {
    self.priority = priority
    self.name = name
  }
  var description: String {
    return "\(priority), \(name)"
  }
}
func ==(t1: Task, t2: Task) -> Bool {
  return t1.priority == t2.priority
}
func <(t1: Task, t2: Task) -> Bool {
  return t1.priority < t2.priority
}

struct TaskPriorityQueue {
  let heap : CFBinaryHeapRef = {
    var callBacks = CFBinaryHeapCallBacks(version: 0, retain: {
      UnsafePointer(Unmanaged<Task>.fromOpaque(COpaquePointer($1)).retain().toOpaque())
      }, release: {
        Unmanaged<Task>.fromOpaque(COpaquePointer($1)).release()
      }, copyDescription: nil, compare: { (ptr1, ptr2, _) in
        let t1 : Task = Unmanaged<Task>.fromOpaque(COpaquePointer(ptr1)).takeUnretainedValue()
        let t2 : Task = Unmanaged<Task>.fromOpaque(COpaquePointer(ptr2)).takeUnretainedValue()
        return t1 == t2 ? CFComparisonResult.CompareEqualTo : t1 < t2 ? CFComparisonResult.CompareLessThan : CFComparisonResult.CompareGreaterThan
    })
    return CFBinaryHeapCreate(nil, 0, &callBacks, nil)
  }()
  var count : Int { return CFBinaryHeapGetCount(heap) }
  mutating func push(t: Task) {
    CFBinaryHeapAddValue(heap, UnsafePointer(Unmanaged.passUnretained(t).toOpaque()))
  }
  func peek() -> Task {
    return Unmanaged<Task>.fromOpaque(COpaquePointer(CFBinaryHeapGetMinimum(heap))).takeUnretainedValue()
  }
  mutating func pop() -> Task {
    let result = Unmanaged<Task>.fromOpaque(COpaquePointer(CFBinaryHeapGetMinimum(heap))).takeUnretainedValue()
    CFBinaryHeapRemoveMinimumValue(heap)
    return result
  }
}

var pq = TaskPriorityQueue()

pq.push(Task(priority: 3, name: "Clear drains"))
pq.push(Task(priority: 4, name: "Feed cat"))
pq.push(Task(priority: 5, name: "Make tea"))
pq.push(Task(priority: 1, name: "Solve RC tasks"))
pq.push(Task(priority: 2, name: "Tax return"))

while pq.count != 0 {
  print(pq.pop())
}


package require struct::prioqueue

set pq [struct::prioqueue]
foreach {priority task} {
    3 "Clear drains"
    4 "Feed cat"
    5 "Make tea"
    1 "Solve RC tasks"
    2 "Tax return"
} {
    # Insert into the priority queue
    $pq put $task $priority
}
# Drain the queue, in priority-sorted order
while {[$pq size]} {
    # Remove the front-most item from the priority queue
    puts [$pq get]
}


Type Tuple
    Priority As Integer
    Data As String
End Type
Dim a() As Tuple
Dim n As Integer 'number of elements in array, last element is n-1
Private Function Left(i As Integer) As Integer
    Left = 2 * i + 1
End Function
Private Function Right(i As Integer) As Integer
    Right = 2 * i + 2
End Function
Private Function Parent(i As Integer) As Integer
    Parent = (i - 1) \ 2
End Function
Private Sub Add(fPriority As Integer, fData As String)
    n = n + 1
    If n > UBound(a) Then ReDim Preserve a(2 * n)
    a(n - 1).Priority = fPriority
    a(n - 1).Data = fData
    bubbleUp (n - 1)
End Sub
Private Sub Swap(i As Integer, j As Integer)
    Dim t As Tuple
    t = a(i)
    a(i) = a(j)
    a(j) = t
End Sub
Private Sub bubbleUp(i As Integer)
    Dim p As Integer
    p = Parent(i)
    Do While i > 0 And a(i).Priority < a(p).Priority
        Swap i, p
        i = p
        p = Parent(i)
    Loop
End Sub
Private Function Remove() As Tuple
    Dim x As Tuple
    x = a(0)
    a(0) = a(n - 1)
    n = n - 1
    trickleDown 0
    If 3 * n < UBound(a) Then ReDim Preserve a(UBound(a) \ 2)
    Remove = x
End Function
Private Sub trickleDown(i As Integer)
    Dim j As Integer, l As Integer, r As Integer
    Do
        j = -1
        r = Right(i)
        If r < n And a(r).Priority < a(i).Priority Then
            l = Left(i)
            If a(l).Priority < a(r).Priority Then
                j = l
            Else
                j = r
            End If
        Else
            l = Left(i)
            If l < n And a(l).Priority < a(i).Priority Then j = l
        End If
        If j >= 0 Then Swap i, j
        i = j
    Loop While i >= 0
End Sub
Public Sub PQ()
    ReDim a(4)
    Add 3, "Clear drains"
    Add 4, "Feed cat"
    Add 5, "Make tea"
    Add 1, "Solve RC tasks"
    Add 2, "Tax return"
    Dim t As Tuple
    Do While n > 0
        t = Remove
        Debug.Print t.Priority, t.Data
    Loop
End Sub


option explicit
 Class prio_queue
  private size
  private q

  'adapt this function to your data
  private function out_of_order(f1,f2): out_of_order = f1(0)>f2(0):end function

 function peek
    peek=q(1)
 end function

 property get qty
    qty=size
 end property

property get isempty
    isempty=(size=0)
end property

 function remove
    dim x
    x=q(1)
    q(1)=q(size)
    size=size-1
    sift_down
    remove=x
 end function

 sub add (x)
    size=size+1
    if size>ubound(q) then redim preserve q(ubound(q)*1.1)
    q(size)=x
    sift_up
 end sub

 Private sub swap (i,j)
    dim x
    x=q(i):q(i)=q(j):q(j)=x
  end sub

  private sub sift_up
    dim h,p
    h=size
    p=h\2
    if p=0 then exit sub
   while out_of_order(q(p),q(h))
       swap h,p
       h=p
       p=h\2
      if p=0 then exit sub
    wend
 end sub

  end sub

  private sub sift_down
  dim p,h
  p=1
  do
    if p>=size then exit do
    h =p*2
    if h >size then exit do
    if h+1<=size then if  out_of_order(q(h),q(h+1)) then h=h+1
    if out_of_order(q(p),q(h)) then swap h,p
    p=h
  loop
 end sub

 'Al instanciar objeto con New
 Private Sub Class_Initialize(  )
     redim q(100)
     size=0
 End Sub

'When Object is Set to Nothing
 Private Sub Class_Terminate(  )
      erase q
 End Sub
End Class
'-------------------------------------
'test program
'---------------------------------
dim tasks:tasks=array(_
  array(3,"Clear drains"),_
  array(4,"Feed cat"),_
  array(5,"Make tea"),_
  array(1,"Solve RC tasks"),_
  array(2,"Tax return"))

dim queue,i,x
set queue=new prio_queue
for i=0 to ubound(tasks)
   queue.add(tasks(i))
next

wscript.echo  "Done: " & queue.qty() &" items in queue. "&  queue.peek()(1)& " is at the top." & vbcrlf

while not queue.isempty()
   x=queue.remove()
   wscript.echo x(0),x(1)
wend

set queue= nothing


import "/queue" for PriorityQueue

var tasks = PriorityQueue.new()
tasks.push("Clear drains", 3)
tasks.push("Feed cat", 4)
tasks.push("Make tea", 5)
tasks.push("Solve RC tasks", 1)
tasks.push("Tax return", 2)
while (!tasks.isEmpty) {
    var t = tasks.pop()
    System.print(t)
}


(define-class priority-queue
	(instance-variables queue lowest-priority most-urgent) )

(define-method (priority-queue 'initialize limit)
	(defun setup (x)
		(vector-set! queue x nil)
		(if (< x limit)
			(setup (+ x 1)) ) )
	(setq lowest-priority limit)
	(setq most-urgent limit)
	(setq queue (make-vector (+ limit 1)))
	(setup 0)
	self )

(define-method (priority-queue 'push item priority)
	(if (and (integerp priority) (>= priority 0) (<= priority lowest-priority))
		(progn
			(setq most-urgent (min priority most-urgent))
			(vector-set! queue priority (nconc (vector-ref queue priority) (cons item nil))) ) ) )

(define-method (priority-queue 'pop)
	(defun find-next (q)
		(if (or (= q lowest-priority) (not (null (vector-ref queue q))))
			q
			(find-next (+ q 1)) ) )
	(define item (car (vector-ref queue most-urgent)))
	(vector-set! queue most-urgent (cdr (vector-ref queue most-urgent)))
	(setq most-urgent (find-next most-urgent))
	item )

(define-method (priority-queue 'peek)
	(car (vector-ref queue most-urgent)) )

(define-method (priority-queue 'emptyp)
	(and (= most-urgent lowest-priority) (null (vector-ref queue most-urgent))) )


const std = @import("std");
const PriorityQueue = std.PriorityQueue;
const Allocator = std.mem.Allocator;
const testing = std.testing;

/// wrapper for the task - stores task priority
/// along with the task name
const Task = struct {
    const Self = @This();

    priority: i32,
    name: []const u8,

    pub fn init(priority: i32, name: []const u8) Self {
        return Self{
            .priority = priority,
            .name = name,
        };
    }
};

/// Simple wrapper for the comparator function.
/// Each comparator function has the following signature:
///
/// fn(T, T) bool
const Comparator = struct {
    fn maxCompare(a: Task, b: Task) bool {
        return a.priority > b.priority;
    }

    fn minCompare(a: Task, b: Task) bool {
        return a.priority < b.priority;
    }
};

test "priority queue (max heap)" {
    var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
    defer arena.deinit();
    var allocator = &arena.allocator;

    var pq = PriorityQueue(Task).init(allocator, Comparator.maxCompare);
    defer pq.deinit();

    try pq.add(Task.init(3, "Clear drains"));
    try pq.add(Task.init(4, "Feed Cat"));
    try pq.add(Task.init(5, "Make tea"));
    try pq.add(Task.init(1, "Solve RC tasks"));
    try pq.add(Task.init(2, "Tax returns"));
    testing.expectEqual(pq.count(), 5);

    std.debug.print("\n", .{});

    // execute the tasks in decreasing order of priority
    while (pq.count() != 0) {
        const task = pq.remove();
        std.debug.print("Executing:  {} (priority {})\n", .{ task.name, task.priority });
    }
    std.debug.print("\n", .{});
}

test "priority queue (min heap)" {
    var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
    defer arena.deinit();
    var allocator = &arena.allocator;

    var pq = PriorityQueue(Task).init(allocator, Comparator.minCompare);
    defer pq.deinit();

    try pq.add(Task.init(3, "Clear drains"));
    try pq.add(Task.init(4, "Feed Cat"));
    try pq.add(Task.init(5, "Make tea"));
    try pq.add(Task.init(1, "Solve RC tasks"));
    try pq.add(Task.init(2, "Tax returns"));
    testing.expectEqual(pq.count(), 5);

    std.debug.print("\n", .{});

    // execute the tasks in increasing order of priority
    while (pq.count() != 0) {
        const task = pq.remove();
        std.debug.print("Executing:  {} (priority {})\n", .{ task.name, task.priority });
    }
    std.debug.print("\n", .{});
}


class PQ{
   fcn init(numLevels=10){  // 0..numLevels, bigger # == lower priorty
      var [const] queue=(1).pump(numLevels+1,List.createLong(numLevels).write,L().copy);
   }
   fcn add(item,priorty){ queue[priorty].append(item); }
   fcn peek{ if(q:=queue.filter1()) return(q[-1]);   Void }// -->Void if empty
   fcn pop { if(q:=queue.filter1()) return(q.pop()); Void }// -->Void if empty
   var [private] state=L();
   fcn [private] next{ // iterate
      qi,ii:=state;
      foreach n in ([qi..queue.len()-1]){
         q:=queue[n];
	 if(ii>=q.len()) ii=0;
	 else{ state.clear().append(n,ii+1); return(q[ii]) }
      }
      Void.Stop
   }
   fcn walker{ state.clear().append(0,0); Walker(next) } // iterator front end
   fcn toString{ "PQ(%d) items".fmt(queue.reduce(fcn(sum,q){ sum+q.len() },0)) }
}


F decompose(BigInt number)
   [BigInt] result
   V n = number
   BigInt i = 2
   L n % i == 0
      result.append(i)
      n I/= i
   i = 3
   L n >= i * i
      L n % i == 0
         result.append(i)
         n I/= i
      i += 2
   I n != 1
      result.append(n)
   R result

L(i) 2..9
   print(decompose(i))
print(decompose(1023 * 1024))
print(decompose(2 * 3 * 5 * 7 * 11 * 11 * 13 * 17))
print(decompose(BigInt(16860167264933) * 179951))


PRIMEDE  CSECT
         USING  PRIMEDE,R13
         B      80(R15)            skip savearea
         DC     17F'0'             savearea
         DC     CL8'PRIMEDE'
         STM    R14,R12,12(R13)
         ST     R13,4(R15)
         ST     R15,8(R13)
         LR     R13,R15            end prolog
         LA     R2,0
         LA     R3,1023
         LA     R4,1024
         MR     R2,R4
         ST     R3,N               n=1023*1024
         LA     R5,WBUFFER
         LA     R6,0
         L      R1,N               n
         XDECO  R1,0(R5)
         LA     R5,12(R5)
         MVC    0(3,R5),=C' : '
         LA     R5,3(R5)
         LA     R0,2
         ST     R0,I               i=2
WHILE1   EQU    *                  do while(i<=n/2)
         L      R2,N
         SRA    R2,1
         L      R4,I
         CR     R4,R2              i<=n/2
         BH     EWHILE1
WHILE2   EQU    *                  do while(n//i=0)
         L      R3,N
         LA     R2,0
         D      R2,I
         LTR    R2,R2              n//i=0
         BNZ    EWHILE2
         ST     R3,N               n=n/i
         ST     R3,M               m=n
         L      R1,I               i
         XDECO  R1,WDECO
         MVC    0(5,R5),WDECO+7
         LA     R5,5(R5)
         MVI    OK,X'01'           ok
         B      WHILE2
EWHILE2  EQU    *
         L      R4,I
         CH     R4,=H'2'           if i=2 then
         BNE    NE2
         LA     R0,3
         ST     R0,I               i=3
         B      EIFNE2
NE2      L      R2,I               else
         LA     R2,2(R2)
         ST     R2,I               i=i+2
EIFNE2   B      WHILE1
EWHILE1  EQU    *
         CLI    OK,X'01'           if ^ok then
         BE     NOTPRIME
         MVC    0(7,R5),=C'[prime]'
         LA     R5,7(R5)
         B      EPRIME
NOTPRIME L      R1,M               m
         XDECO  R1,WDECO
         MVC    0(5,R5),WDECO+7
EPRIME   XPRNT  WBUFFER,80         put
         L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)
         XR     R15,R15
         BR     R14
N        DS     F
I        DS     F
M        DS     F
OK       DC     X'00'
WBUFFER  DC     CL80' '
WDECO    DS     CL16
         YREGS
         END    PRIMEDE


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program primeDecomp64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"
.equ NBFACT,            100

/*******************************************/
/* Structures                               */
/********************************************/
/* structurea area factors  */
    .struct  0
fac_value:                     // factor
    .struct  fac_value + 8
fac_number:                    // number of identical factors
    .struct  fac_number + 8
fac_end:
/*******************************************/
/* Initialized data */
/*******************************************/
.data
szMessStartPgm:            .asciz "Program start \n"
szMessEndPgm:              .asciz "Program normal end.\n"
szMessNotPrime:            .asciz "Not prime.\n"
szMessPrime:               .asciz "Prime\n"
szCarriageReturn:          .asciz "\n"
szSpaces:                  .asciz "  "
szMessNumber:              .asciz " The factors of @ are :\n"
/*******************************************/
/* UnInitialized data                      */
/*******************************************/
.bss
sZoneConv:           .skip 32
.align 4
tbZoneDecom:         .skip fac_end * NBFACT
/*******************************************/
/*  code section                           */
/*******************************************/
.text
.global main
main:                                    // program start
    ldr x0,qAdrszMessStartPgm            // display start message
    bl affichageMess
    ldr x20,qVal
    //mov x20,17
    mov x0,x20
    ldr x1,qAdrtbZoneDecom
    bl decompFact                        // decomposition
    cmp x0,#0
    beq 1f
    mov x2,x0
    mov x0,x20
    ldr x1,qAdrtbZoneDecom
    bl displayFactors                    // display factors
    b 2f
1:
    ldr x0,qAdrszMessPrime              // prime
    bl affichageMess

2:

    ldr x0,qAdrszMessEndPgm            // display end message
    bl affichageMess

100:                                   // standard end of the program
    mov x0,0                           // return code
    mov x8,EXIT                        // request to exit program
    svc 0                              // perform system call
qAdrszMessStartPgm:        .quad szMessStartPgm
qAdrszMessEndPgm:          .quad szMessEndPgm
qAdrszCarriageReturn:      .quad szCarriageReturn
qAdrszMessNotPrime:        .quad szMessNotPrime
qAdrszMessPrime:           .quad szMessPrime
qAdrtbZoneDecom:           .quad tbZoneDecom
//qVal:                      .quad 2 <<31
qVal:                      .quad 1047552       // test not prime
//qVal:                      .quad 1429671721    // test not prime (37811 * 37811)

/******************************************************************/
/*     prime decomposition                                               */
/******************************************************************/
/* x0 contains the number */
/* x1 contains address factors array */
/* REMARK no save register x9-x19   */
decompFact:
    stp x1,lr,[sp,-16]!       // save  registers
    mov x12,x0                // save number
    bl isPrime                // prime ?
    cbnz x0,12f               // yes -> no decomposition
    mov x19,fac_end           // element area size
    mov x18,0                 // raz indice
    mov x16,0                 // prev divisor
    mov x17,0                 // number of identical divisors
    mov x13,2                 // first divisor
2:
    cmp x12,1
    beq 10f
    udiv x14,x12,x13          // division
    msub x15,x14,x13,x12      // remainder = x12 -(x13*x14)
    cbnz x15,5f               // if remainder <> zero  x13 not divisor
    mov x12,x14               // quotient -> new dividende
    cmp x13,x16               // same divisor ?
    beq 4f                    // yes
    cbz x16,3f                // yes it is first divisor ?
    madd x11,x18,x19,x1       // no -> store prev divisor in the area
    str x16,[x11,fac_value]
    str x17,[x11,fac_number]  // and store number of same factor
    add x18,x18,1             // increment indice
    mov x17,0                 // raz number of same factor
3:
    mov x16,x13               // save new divisor
4:
    add x17,x17,1             // increment number of same factor
    mov x0,x12                // the new dividende is prime ?
    bl isPrime
    cbnz x0,10f               // yes
    b 2b                      // else loop
5:                            // divisor is not a factor
    cmp x13,2                 // begin ?
    cinc x13,x13,ne           // if divisor <> 2 add 1
    add x13,x13,1
    b 2b                      // and loop

10:                           // new dividende is prime
    cmp x16,x12               // divisor = dividende ?
    cinc x17,x17,eq           //add 1 if last dividende = diviseur
    madd x11,x18,x19,x1
    str x16,[x11,fac_value]   // store divisor in area
    str x17,[x11,fac_number]  // and store number
    add x18,x18,1             // increment indice
    cmp x16,x12               //store last dividende if <> diviseur
    beq 11f
    madd x11,x18,x19,x1
    str x12,[x11,fac_value]   // sinon stockage dans la table
    mov x17,1
    str x17,[x11,fac_number]  // store 1 in number
    add x18,x18,1
11:
    mov x0,x18                // return nb factors
    b 100f
12:
    mov x0,#0                 // number is prime
    b 100f

100:
    ldp x1,lr,[sp],16         // restaur des  2 registres
    ret                       // retour adresse lr x30
/******************************************************************/
/*     prime decomposition                                               */
/******************************************************************/
/* x0 contains the number */
/* x1 contains address factors array */
/* x2 number of factors */
displayFactors:
    stp x1,lr,[sp,-16]!        // save  registres
    mov x19,fac_end            // element area size
    mov x13,x1                 // save area address
    ldr x1,qAdrsZoneConv       // load zone conversion address
    bl conversion10
    ldr x0,qAdrszMessNumber
    bl strInsertAtCharInc                   // insert result at Second @ character
    bl affichageMess
    mov x9,0                   // indice
1:
    madd x10,x9,x19,x13        // compute address area element
    ldr x0,[x10,fac_value]
    ldr x12,[x10,fac_number]
    bl conversion10            // decimal conversion
2:
    mov x0,x1
    bl affichageMess
    ldr x0,qAdrszSpaces
    bl affichageMess
    subs x12,x12,#1
    bgt 2b
    add x9,x9,1
    cmp x9,x2
    blt 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
100:
    ldp x1,lr,[sp],16          // restaur des  2 registres
    ret                        // retour adresse lr x30
qAdrsZoneConv:          .quad sZoneConv
qAdrszSpaces:           .quad szSpaces
qAdrszMessNumber:       .quad szMessNumber
/******************************************************************/
/*     test if number is prime                                    */
/******************************************************************/
/* x0 contains the number  */
/* x0 return 1 if prime else return 0 */
isPrime:
    stp x1,lr,[sp,-16]!       // save  registers
    cmp x0,1                  // <= 1 ?
    ble 98f
    cmp x0,3                  // 2 and 3 prime
    ble 97f
    tst x0,1                  //  even ?
    beq 98f
    mov x9,3                  // first divisor
1:
    udiv x11,x0,x9
    msub x10,x11,x9,x0        // compute remainder
    cbz x10,98f               // end if zero
    add x9,x9,#2              // increment divisor
    cmp x9,x11                // divisors<=quotient ?
    ble 1b                    // loop
97:
    mov x0,1                  // return prime
    b 100f
98:
    mov x0,0                  // not prime
    b 100f
100:
    ldp x1,lr,[sp],16         // restaur  2 registers
    ret                       // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


class ZMLA_ROSETTA definition
  public
  create public .

  public section.

    types:
      enumber         TYPE          N  LENGTH 60,
      listof_enumber  TYPE TABLE OF enumber .

    class-methods FACTORS
      importing
        value(N) type ENUMBER
      exporting
        value(ORET) type LISTOF_ENUMBER .
  protected section.
  private section.
ENDCLASS.

CLASS ZMLA_ROSETTA IMPLEMENTATION.

* <SIGNATURE>---------------------------------------------------------------------------------------+
* | Static Public Method ZMLA_ROSETTA=>FACTORS
* +-------------------------------------------------------------------------------------------------+
* | [--->] N                              TYPE        ENUMBER
* | [<---] ORET                           TYPE        LISTOF_ENUMBER
* +--------------------------------------------------------------------------------------</SIGNATURE>
  method FACTORS.
    CLEAR oret.
    WHILE n mod 2 = 0.
      n = n / 2.
      APPEND 2 to oret.
    ENDWHILE.
    DATA: lim type enumber,
          i   type enumber.
    lim = sqrt( n ).
    i   = 3.
    WHILE i <= lim.
      WHILE n mod i = 0.
        APPEND i to oret.
        n = n / i.
        lim = sqrt( n ).
      ENDWHILE.
      i = i + 2.
    ENDWHILE.
    IF n > 1.
      APPEND n to oret.
    ENDIF.
  endmethod.
ENDCLASS.


(include-book "arithmetic-3/top" :dir :system)

(defun prime-factors-r (n i)
   (declare (xargs :mode :program))
   (cond ((or (zp n) (zp (- n i)) (zp i) (< i 2) (< n 2))
          (list n))
         ((= (mod n i) 0)
          (cons i (prime-factors-r (floor n i) 2)))
         (t (prime-factors-r n (1+ i)))))

(defun prime-factors (n)
   (declare (xargs :mode :program))
   (prime-factors-r n 2))


generic
   type Number is private;
   Zero : Number;
   One  : Number;
   Two  : Number;
   with function "+"   (X, Y : Number) return Number is <>;
   with function "*"   (X, Y : Number) return Number is <>;
   with function "/"   (X, Y : Number) return Number is <>;
   with function "mod" (X, Y : Number) return Number is <>;
   with function ">"   (X, Y : Number) return Boolean is <>;
package Prime_Numbers is
   type Number_List is array (Positive range <>) of Number;
   function Decompose (N : Number) return Number_List;
   function Is_Prime (N : Number) return Boolean;
end Prime_Numbers;


#IF long int possible THEN #

MODE LINT = LONG INT;
LINT lmax int = long max int;
OP LLENG = (INT i)LINT: LENG i,
   LSHORTEN = (LINT i)INT: SHORTEN i;

#ELSE

MODE LINT = INT;
LINT lmax int = max int;
OP LLENG = (INT i)LINT: i,
   LSHORTEN = (LINT i)INT: i;

FI#

OP LLONG = (INT i)LINT: LLENG i;

MODE YIELDLINT = PROC(LINT)VOID;

PROC (LINT, YIELDLINT)VOID gen decompose;

INT upb cache = bits width;

BITS cache := 2r0;
BITS cached := 2r0;

PROC is prime = (LINT n)BOOL: (
    BOOL
        has factor := FALSE,
        out := TRUE;
  # FOR LINT factor IN # gen decompose(n, # ) DO ( #
  ##   (LINT factor)VOID:(
      IF has factor THEN out := FALSE; GO TO done FI;
      has factor := TRUE
  # OD # ));
    done: out
);

PROC is prime cached := (LINT n)BOOL: (
    LINT l half n = n OVER LLONG 2 - LLONG 1;
    IF l half n <= LLENG upb cache THEN
        INT half n = LSHORTEN l half n;
        IF half n ELEM cached THEN
            BOOL(half n ELEM cache)
        ELSE
            BOOL out = is prime(n);
            BITS mask = 2r1 SHL (upb cache - half n);
            cached := cached OR mask;
            IF out THEN cache := cache OR mask FI;
            out
        FI
    ELSE
        is prime(n) # above useful cache limit #
    FI
);

PROC gen primes := (YIELDLINT yield)VOID:(
    yield(LLONG 2);
    LINT n := LLONG 3;
    WHILE n < l maxint - LLONG 2 DO
        yield(n);
        n +:= LLONG 2;
        WHILE n < l maxint - LLONG 2 AND NOT is prime cached(n) DO
            n +:= LLONG 2
        OD
    OD
);

# PROC # gen decompose := (LINT in n, YIELDLINT yield)VOID: (
    LINT n := in n;
  # FOR LINT p IN # gen primes( # ) DO ( #
  ##   (LINT p)VOID:
        IF p*p > n THEN
            GO TO done
        ELSE
            WHILE n MOD p = LLONG 0 DO
                yield(p);
                n := n OVER p
            OD
        FI
  # OD #  );
    done:
    IF n > LLONG 1 THEN
        yield(n)
    FI
);

main:(
# FOR LINT m IN # gen primes( # ) DO ( #
##   (LINT m)VOID:(
      LINT p = LLONG 2 ** LSHORTEN m - LLONG 1;
      print(("2**",whole(m,0),"-1 = ",whole(p,0),", with factors:"));
    # FOR LINT factor IN # gen decompose(p, # ) DO ( #
    ##   (LINT factor)VOID:
          print((" ",whole(factor,0)))
    # OD # );
      print(new line);
      IF m >= LLONG 59 THEN GO TO done FI
# OD #  ));
  done: EMPTY
)


BEGIN

INTEGER I, K, NFOUND;
INTEGER ARRAY FACTORS[1:16];

COMMENT COMPUTE P MOD Q;
INTEGER FUNCTION MOD (P, Q);
INTEGER P, Q;
BEGIN
    MOD := P - Q * (P / Q);
END;

COMMENT
  FIND THE PRIME FACTORS OF N AND STORE IN THE EXTERNAL
  ARRAY "FACTORS", RETURNING THE NUMBER FOUND. IF N IS
  PRIME, IT WILL BE STORED AS THE FIRST AND ONLY FACTOR;

INTEGER FUNCTION PRIMEFACTORS(N);
INTEGER N;
BEGIN
  INTEGER P, COUNT;
  P := 2;
  COUNT := 1;
  WHILE N >= P * P DO
    BEGIN
      IF MOD(N, P) = 0 THEN
        BEGIN
          FACTORS[COUNT] := P;
          COUNT := COUNT + 1;
          N := N / P;
        END
      ELSE
        P := P + 1;
    END;
  FACTORS[COUNT] := N;
  PRIMEFACTORS := COUNT;
END;

COMMENT -- EXERCISE THE ROUTINE;

FOR I := 77 STEP 2 UNTIL 99 DO
  BEGIN
    WRITE(I,":");
    NFOUND := PRIMEFACTORS(I);
    FOR K := 1 STEP 1 UNTIL NFOUND DO
      BEGIN
        WRITEON(FACTORS[K]);
      END;
  END;

END


9040 PF(0) = 0 : SC = 0
9050 FOR CA = 2 TO INT( SQR(I))
9060     IF I = 1 THEN RETURN
9070     IF INT(I / CA) * CA = I THEN GOSUB 9200 : GOTO 9060
9080     CA = CA + SC : SC = 1
9090 NEXT CA
9100 IF I = 1 THEN RETURN
9110 CA = I

9200 PF(0) = PF(0) + 1
9210 PF(PF(0)) = CA
9220 I = I / CA
9230 RETURN


decompose: function [num][
    facts: to [:string] factors.prime num
    print [
        pad.right (to :string num) ++ " = " ++  join.with:" x " facts 30
        "{"++ (join.with:", " unique facts) ++ "}"
    ]
]

loop 2..40 => decompose


MsgBox % factor(8388607)   ; 47 * 178481

factor(n)
{
    if (n = 1)
        return
    f = 2
    while (f <= n)
    {
        if (Mod(n, f) = 0)
        {
            next := factor(n / f)
            return, % f "`n" next
        }
        f++
    }
}


# Usage:  awk -f primefac.awk
function pfac(n,    r, f){
    r = ""; f = 2
    while (f <= n) {
        while(!(n % f)) {
            n = n / f
            r = r " " f
        }
        f = f + 2 - (f == 2)
    }
    return r
}

# For each line of input, print the prime factors.
{ print pfac($1) }


@echo off
::usage: cmd /k primefactor.cmd number
setlocal enabledelayedexpansion

set /a compo=%1
if "%compo%"=="" goto:eof
set list=%compo%= (

set /a div=2 & call :loopdiv
set /a div=3 & call :loopdiv
set /a div=5,inc=2

:looptest
call :loopdiv
set /a div+=inc,inc=6-inc,div2=div*div
if %div2% lss %compo% goto looptest
if %compo% neq 1 set list= %list% %compo%
echo %list%)   & goto:eof

:loopdiv
set /a "res=compo%%div
if %res% neq 0 goto:eof
set list=%list% %div%,
set/a compo/=div
goto:loopdiv


Factor ← { 𝕊n:
  # Prime sieve
  primes ← ↕0
  Sieve ← { p 𝕊 a‿b:
    p(⍋↑⊣)↩√b ⋄ l←b-a
    E ← {↕∘⌈⌾(((𝕩|-a)+𝕩×⊢)⁼)l}        # Indices of multiples of 𝕩
    a + / (1⥊˜l) E⊸{0¨⌾(𝕨⊸⊏)𝕩}´ p     # Primes in segment [a,b)
  }
  # Factor by trial division
  r ← ↕0                              # Result list
  Try ← {
    m ← (1+⌊√n) ⌊ 2×𝕩                 # Upper bound for factors this round
    𝕩<m ?                             # Stop if no factors
    primes ∾↩ np ← primes Sieve 𝕩‿m   # New primes
    {0=𝕩|n? r∾↩𝕩 ⋄ n÷↩𝕩 ⋄ 𝕊𝕩 ;@}¨ np  # Try each one
    𝕊 m                               # Next segment
  ;@}
  Try 2
  r ∾ 1⊸<⊸⥊n
}


#include <inttypes.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <assert.h>

typedef uint32_t pint;
typedef uint64_t xint;
typedef unsigned int uint;
#define PRIuPINT PRIu32     /* printf macro for pint */
#define PRIuXINT PRIu64     /* printf macro for xint */
#define MAX_FACTORS 63      /* because 2^64 is too large for xint */

uint8_t *pbits;

#define MAX_PRIME (~(pint)0)
#define MAX_PRIME_SQ 65535U
#define PBITS (MAX_PRIME / 30 + 1)

pint next_prime(pint);
int is_prime(xint);
void sieve(pint);

uint8_t bit_pos[30] = {
    0, 1<<0, 0, 0, 0,    0,
    0, 1<<1, 0, 0, 0, 1<<2,
    0, 1<<3, 0, 0, 0, 1<<4,
    0, 1<<5, 0, 0, 0, 1<<6,
    0,    0, 0, 0, 0, 1<<7,
};

uint8_t rem_num[] = { 1, 7, 11, 13, 17, 19, 23, 29 };

void init_primes()
{
    FILE *fp;
    pint s, tgt = 4;

    if (!(pbits = malloc(PBITS))) {
        perror("malloc");
        exit(1);
    }

    if ((fp = fopen("primebits", "r"))) {
        fread(pbits, 1, PBITS, fp);
        fclose(fp);
        return;
    }

    memset(pbits, 255, PBITS);
    for (s = 7; s <= MAX_PRIME_SQ; s = next_prime(s)) {
        if (s > tgt) {
            tgt *= 2;
            fprintf(stderr, "sieve %"PRIuPINT"\n", s);
        }
        sieve(s);
    }
    fp = fopen("primebits", "w");
    fwrite(pbits, 1, PBITS, fp);
    fclose(fp);
}

int is_prime(xint x)
{
    pint p;
    if (x > 5) {
        if (x < MAX_PRIME)
            return pbits[x/30] & bit_pos[x % 30];

        for (p = 2; p && (xint)p * p <= x; p = next_prime(p))
            if (x % p == 0) return 0;

        return 1;
    }
    return x == 2 || x == 3 || x == 5;
}

void sieve(pint p)
{
    unsigned char b[8];
    off_t ofs[8];
    int i, q;

    for (i = 0; i < 8; i++) {
        q = rem_num[i] * p;
        b[i] = ~bit_pos[q % 30];
        ofs[i] = q / 30;
    }

    for (q = ofs[1], i = 7; i; i--)
        ofs[i] -= ofs[i-1];

    for (ofs[0] = p, i = 1; i < 8; i++)
        ofs[0] -= ofs[i];

    for (i = 1; q < PBITS; q += ofs[i = (i + 1) & 7])
        pbits[q] &= b[i];
}

pint next_prime(pint p)
{
    off_t addr;
    uint8_t bits, rem;

    if (p > 5) {
        addr = p / 30;
        bits = bit_pos[ p % 30 ] << 1;
        for (rem = 0; (1 << rem) < bits; rem++);
        while (pbits[addr] < bits || !bits) {
            if (++addr >= PBITS) return 0;
            bits = 1;
            rem = 0;
        }
        if (addr >= PBITS) return 0;
        while (!(pbits[addr] & bits)) {
            rem++;
            bits <<= 1;
        }
        return p = addr * 30 + rem_num[rem];
    }

    switch(p) {
        case 2: return 3;
        case 3: return 5;
        case 5: return 7;
    }
    return 2;
}

int decompose(xint n, xint *f)
{
    pint p = 0;
    int i = 0;

    /* check small primes: not strictly necessary */
    if (n <= MAX_PRIME && is_prime(n)) {
        f[0] = n;
        return 1;
    }

    while (n >= (xint)p * p) {
        if (!(p = next_prime(p))) break;
        while (n % p == 0) {
            n /= p;
            f[i++] = p;
        }
    }
    if (n > 1) f[i++] = n;
    return i;
}

int main()
{
    int i, len;
    pint p = 0;
    xint f[MAX_FACTORS], po;

    init_primes();

    for (p = 1; p < 64; p++) {
        po = (1LLU << p) - 1;
        printf("2^%"PRIuPINT" - 1 = %"PRIuXINT, p, po);
        fflush(stdout);
        if ((len = decompose(po, f)) > 1)
            for (i = 0; i < len; i++)
                printf(" %c %"PRIuXINT, i?'x':'=', f[i]);
        putchar('\n');
    }

    return 0;
}


using System;
using System.Collections.Generic;

namespace PrimeDecomposition
{
    class Program
    {
        static void Main(string[] args)
        {
            GetPrimes(12);
        }

        static List<int> GetPrimes(decimal n)
        {
            List<int> storage = new List<int>();
            while (n > 1)
            {
                int i = 1;
                while (true)
                {
                    if (IsPrime(i))
                    {
                        if (((decimal)n / i) == Math.Round((decimal) n / i))
                        {
                            n /= i;
                            storage.Add(i);
                            break;
                        }
                    }
                    i++;
                }
            }
            return storage;
        }

        static bool IsPrime(int n)
        {
            if (n <= 1) return false;
            for (int i = 2; i <= Math.Sqrt(n); i++)
                if (n % i == 0) return false;
            return true;
        }
    }
}


#include <iostream>
#include <gmpxx.h>

// This function template works for any type representing integers or
// nonnegative integers, and has the standard operator overloads for
// arithmetic and comparison operators, as well as explicit conversion
// from int.
//
// OutputIterator must be an output iterator with value_type Integer.
// It receives the prime factors.
template<typename Integer, typename OutputIterator>
 void decompose(Integer n, OutputIterator out)
{
  Integer i(2);

  while (n != 1)
  {
    while (n % i == Integer(0))
    {
      *out++ = i;
      n /= i;
    }
    ++i;
  }
}

// this is an output iterator similar to std::ostream_iterator, except
// that it outputs the separation string *before* the value, but not
// before the first value (i.e. it produces an infix notation).
template<typename T> class infix_ostream_iterator:
  public std::iterator<T, std::output_iterator_tag>
{
  class Proxy;
  friend class Proxy;
  class Proxy
  {
  public:
    Proxy(infix_ostream_iterator& iter): iterator(iter) {}
    Proxy& operator=(T const& value)
    {
      if (!iterator.first)
      {
        iterator.stream << iterator.infix;
      }
      iterator.stream << value;
    }
  private:
    infix_ostream_iterator& iterator;
  };
public:
  infix_ostream_iterator(std::ostream& os, char const* inf):
    stream(os),
    first(true),
    infix(inf)
  {
  }
  infix_ostream_iterator& operator++() { first = false; return *this; }
  infix_ostream_iterator operator++(int)
  {
    infix_ostream_iterator prev(*this);
    ++*this;
    return prev;
  }
  Proxy operator*() { return Proxy(*this); }
private:
  std::ostream& stream;
  bool first;
  char const* infix;
};

int main()
{
  std::cout << "please enter a positive number: ";
  mpz_class number;
  std::cin >> number;

  if (number <= 0)
    std::cout << "this number is not positive!\n;";
  else
  {
    std::cout << "decomposition: ";
    decompose(number, infix_ostream_iterator<mpz_class>(std::cout, " * "));
    std::cout << "\n";
  }
}


;;; No stack consuming algorithm
(defn factors
  "Return a list of factors of N."
  ([n]
    (factors n 2 ()))
  ([n k acc]
    (if (= 1 n)
      acc
      (if (= 0 (rem n k))
        (recur (quot n k) k (cons k acc))
        (recur n (inc k) acc)))))


9000 REM ----- function generate
9010 REM in ... i ... number
9020 REM out ... pf() ... factors
9030 REM mod ... ca ... pf candidate
9040 pf(0)=0 : ca=2 : REM special case
9050 IF i=1 THEN RETURN
9060 IF INT(i/ca)*ca=i THEN GOSUB 9200 : GOTO 9050
9070 FOR ca=3 TO INT( SQR(i)) STEP 2
9080 IF i=1 THEN RETURN
9090 IF INT(i/ca)*ca=i THEN GOSUB 9200 : GOTO 9080
9100 NEXT
9110 IF i>1 THEN ca=i : GOSUB 9200
9120 RETURN
9200 pf(0)=pf(0)+1
9210 pf(pf(0))=ca
9220 i=i/ca
9230 RETURN


;;; Recursive algorithm
(defun factor (n)
  "Return a list of factors of N."
  (when (> n 1)
    (loop with max-d = (isqrt n)
      for d = 2 then (if (evenp d) (+ d 1) (+ d 2)) do
      (cond ((> d max-d) (return (list n))) ; n is prime
        ((zerop (rem n d)) (return (cons d (factor (truncate n d)))))))))