MetaOcaml Priority Queue

The idea today was just to make my OCaml priority queue from yesterday into a metaOcaml queue, so that it could queue tasks written in actual OCaml code.

MetaOCaml might sound redundant, but in fact, it simply adds a feature that is missing: quotation, as it exists in Lisp. A quoted piece of code is not executed until we explicitly evaluate it. The biggest difference is that OCaml type-checks everything, even stuff inside quotes! According to the metaocaml paper, if the type of an expression E is t, the type of a quoted expression (written .<E>.) is:

E code

What I found in my install was that it became:

('a, E) code

I have no idea what that 'a is doing there, and it made life difficult! After I put the priority queue together, I tried to write a function which repeatedly took tasks off of the queue and executed them until none remained. However, the interpreter rejected this as ill-typed, complaining that the 'a parameters might not match (more specifically, that 'a is not generalisable).

Perhaps I'll figure that one out for tomorrow. Here is the code for today:

type 'a task = ('a, unit) code

type 'a priority_queue = {mutable tasklist: (('a task) * float) option array; mutable next: int}

let new_priority_queue = {tasklist = Array.make 2 None; next = 1}

let rec sift_up place pq =
  if (place > 1) then match (pq.tasklist.(place), pq.tasklist.(place/2)) with
      (None, p) -> ()
    | (Some (t1,f1), Some (t2,f2)) when f1 <= f2 -> ()
    | (Some (t1,f1), Some (t2,f2)) when f1 > f2 ->
        pq.tasklist.(place)   <- Some (t2, f2);
        pq.tasklist.(place/2) <- Some (t1, f1);
        sift_up (place/2) pq;
    | (q, r) -> raise (Invalid_argument "sift_up");;

let double_size pq =
  pq.tasklist <- Array.append pq.tasklist (Array.make (Array.length pq.tasklist) None);;

let push_item item priority pq =
  (if not (pq.next < Array.length pq.tasklist) then double_size pq);
  pq.tasklist.(pq.next) <- Some (item, priority);
  sift_up pq.next pq;
  pq.next <- (pq.next + 1);;

let rec sift_down place pq =
  if place*2 < Array.length pq.tasklist then
    if place*2+1 < pq.next then
      let (largervalue,largerplace) =
        (match (pq.tasklist.(place*2), pq.tasklist.(place*2+1)) with
            (Some (t1,f1), Some (t2,f2)) when f1 < f2 -> (f2,place*2+1)
          | (Some (t1,f1), Some (t2,f2))              -> (f1,place*2)
          | _ -> raise (Invalid_argument "sift_down") )
        in
          match pq.tasklist.(place) with
              Some (t,f) when f < largervalue ->
                (pq.tasklist.(place) <- pq.tasklist.(largerplace);
                pq.tasklist.(largerplace) <- Some (t,f);
                sift_down largerplace pq )
            | Some (t,f) -> ()
            | _ -> raise (Invalid_argument "sift_down")
    else if place*2 < pq.next then
      match pq.tasklist.(place) with
          Some (t,f) when f < (match pq.tasklist.(place*2) with Some (t,f) -> f | _ -> 0.0) ->
            (pq.tasklist.(place) <- pq.tasklist.(place*2);
            pq.tasklist.(place*2) <- Some (t,f) )
        | Some (t,f) -> ()
        | _ -> raise (Invalid_argument "sift_down");;


let pop_item pq =
  match pq.tasklist.(1) with Some (t,f) ->
      pq.tasklist.(1) <- pq.tasklist.(pq.next-1);
      pq.tasklist.(pq.next-1) <- None;
      if pq.next > 1 then pq.next <- pq.next-1;
      sift_down 1 pq;
      t;
    | None -> .<()>.;;