+load "../fingerdeque/finger-deque.lib";

+# A first, near-verbatim implementation of Real-Time Queues from:

+# Purely Functional Data Structures

+package real_time_queue__verbatim {

+ Stream(X) = NIL | CONS(X, Suspension(Stream(X)));

+ fun from_list(NIL) => data::NIL;

+ from_list(x!r) => data::CONS(x, delay(fn () = from_list(r)));

+ Queue(X) = QUEUE { f: stm::Stream(X), r: List(X), s: stm::Stream(X) };

+ empty = QUEUE { f => stm::NIL, r => [], s => stm::NIL };

+ fun isempty(QUEUE { f => stm::NIL, ... }) => TRUE;

+ exception INTERNAL_ERROR;

+ fun rotate(f, r, a) = delay(fn () = case (f, r)

+ (stm::NIL, stm::CONS(y, _)) => stm::CONS(y, delay(fn () = a));

+ (stm::CONS(x, f'), stm::CONS(y, r')) => stm::CONS(x, rotate(force(f'), force(r'), stm::CONS(y, delay(fn () = a))));

+ _ => raise exception INTERNAL_ERROR;

+ fun queue { f, r, s } = case (s)

+ stm::CONS(x, s) => QUEUE { f, r, s => force(s) };

+ my f' = force(rotate(f, (stm::from_list r), stm::NIL));

+ QUEUE { f => f', r => NIL, s => f' };

+ fun snoc( QUEUE { f, r, s }, x ) = queue { f, r => x!r, s };

+ fun head( QUEUE { f => stm::NIL, ... } ) => raise exception EMPTY;

+ head( QUEUE { f => stm::CONS(x, _), ... } ) => x;

+ fun tail( QUEUE { f => stm::NIL, ... } ) => raise exception EMPTY;

+ tail( QUEUE { f => stm::CONS(x, f), r, s } ) => queue { f => force(f), r, s };

+package real_time_queue {

+ Stream(X) = NIL | CONS(X, Suspension(Stream(X)));

+ fun from_list(NIL) => data::NIL;

+ from_list(x!r) => data::CONS(x, delay(fn () = from_list(r)));

+ Queue(X) = QUEUE { f: stm::Stream(X), r: List(X), s: stm::Stream(X) };

+ empty = QUEUE { f => stm::NIL, r => [], s => stm::NIL };

+ # fun make_empty () = QUEUE { f => stm::NIL, r => [], s => stm::NIL };

+ # empty = make_empty();

+ fun isempty(QUEUE { f => stm::NIL, ... }) => TRUE;

+ exception REAL_TIME_QUEUE_INTERNAL_ERROR;

+ fun rotate(f, r, a) = delay(fn () = case (f, r)

+ (stm::NIL, stm::CONS(y, _)) => stm::CONS(y, delay(fn () = a));

+ (stm::CONS(x, f'), stm::CONS(y, r')) => stm::CONS(x, rotate(force(f'), force(r'), stm::CONS(y, delay(fn () = a))));

+ _ => raise exception REAL_TIME_QUEUE_INTERNAL_ERROR;

+ fun queue { f, r, s } = case (s)

+ stm::CONS(x, s) => QUEUE { f, r, s => force(s) };

+ my f' = force(rotate(f, (stm::from_list r), stm::NIL));

+ QUEUE { f => f', r => NIL, s => f' };

+ fun snoc( QUEUE { f, r, s }, x ) = queue { f, r => x!r, s };

+ fun head( QUEUE { f => stm::NIL, ... } ) => raise exception EMPTY;

+ head( QUEUE { f => stm::CONS(x, _), ... } ) => x;

+ fun tail( QUEUE { f => stm::NIL, ... } ) => raise exception EMPTY;

+ tail( QUEUE { f => stm::CONS(x, f), r, s } ) => queue { f => force(f), r, s };

+# Augmentation of the former with complexity analisys

+package real_time_queue__complexity {

+ package sst = string_map;

+ recorded_complexities = REF (sst::empty : sst::Map(Int));

+ complexity_counter = REF(0);

+ # To evaluate complexity, annotate all recursive calls with

+ # the following operator:

+ # Example: fun loop (FOO) => loop / (BAR); ...

+ # This operator does not break tail recursion.

+ complexity_counter := *complexity_counter + 1;

+ # Record measurement of complexity for function f

+ fun record (name, f) x = {

+ my c = *complexity_counter;

+ my c = *complexity_counter - c;

+ if (case (sst::get(*recorded_complexities, name))

+ recorded_complexities :=

+ sst::set(*recorded_complexities, name, c);

+ # Pretty print per-function statistics:

+ apply (fn (k, v) = printf "Recorded worst-case complexity for '%s' is %d\n" k v)

+ (sst::keyvals_list(*recorded_complexities));

+ recorded_complexities := sst::empty;

+ complexity_counter := 0;

+ Stream(X) = NIL | CONS(X, Suspension(Stream(X)));

+ fun from_list(NIL) => data::NIL;

+ from_list(x!r) => data::CONS(x, delay(fn () = from_list / (r)));

+ Queue(X) = QUEUE { f: stm::Stream(X), r: List(X), s: stm::Stream(X) };

+ empty = QUEUE { f => stm::NIL, r => [], s => stm::NIL };

+ # fun make_empty () = QUEUE { f => stm::NIL, r => [], s => stm::NIL };

+ # empty = make_empty();

+ fun isempty(QUEUE { f => stm::NIL, ... }) => TRUE;

+ fun rotate(f, r, a) = delay(fn () = case (f, r)

+ (stm::NIL, stm::CONS(y, _)) => stm::CONS(y, delay(fn () = a));

+ (stm::CONS(x, f'), stm::CONS(y, r')) => stm::CONS(x, rotate / (force(f'), force(r'), stm::CONS(y, delay(fn () = a))));

+ _ => raise exception INTERNAL;

+ fun queue { f, r, s } = case (s)

+ stm::CONS(x, s) => QUEUE { f, r, s => force(s) };

+ my f' = force(rotate(f, (stm::from_list r), stm::NIL));

+ QUEUE { f => f', r => NIL, s => f' };

+ fun snoc( QUEUE { f, r, s }, x ) = queue { f, r => x!r, s };

+ fun head( QUEUE { f => stm::NIL, ... } ) => raise exception EMPTY;

+ head( QUEUE { f => stm::CONS(x, _), ... } ) => x;

+ fun tail( QUEUE { f => stm::NIL, ... } ) => raise exception EMPTY;

+ tail( QUEUE { f => stm::CONS(x, f), r, s } ) => queue { f => force(f), r, s };

+ snoc = fn x = complexity::record ("snoc", snoc) x;

+ tail = fn x = complexity::record ("tail", tail) x;

+ timer = cpu_timer::get_cpu_timer();

+ fun sec () = cpu_timer::get_elapsed_cpu_seconds(timer);

+package float = eight_byte_float;

+ package que = finger_deque;

+ printf "\nFinger deque: inserting and removing %d elements: " n;

+ my q = { for (q = que::empty_queue, c = 0; c < n; q = que::push(q, c), ++c; q) { }; };

+ my q = { for (q = q, c = 0; c < n; q = que::push(#1(que::pull(q)), c), ++c; q) { }; };

+ { for (q = q; !(que::queue_is_empty(q)); q = #1(que::pull(q))) { }; };

+ printf "%f s total, %f average microsec/element\n" sec (sec * 1000000.0 // float::from_int(n));

+ block_test(30*30*30*15);

+ block_test(30*30*30*30);

+ block_test(30*30*30*30*5);

+ package que = real_time_queue;

+ printf "\nReal time queue: inserting and removing %d elements: " n;

+ my q = { for (q = que::empty, c = 0; c < n; q = que::snoc(q, c), ++c; q) { }; };

+ my q = { for (q = q, c = 0; c < n; q = que::snoc(que::tail(q), c), ++c; q) { }; };

+ { for (q = q; !(que::isempty(q)); q = que::tail(q)) { }; };

+ printf "%f s total, %f average microsec/element\n" sec (sec * 1000000.0 // float::from_int(n));

+ block_test(30*30*30*10);

+ block_test(30*30*30*30);

+ block_test(30*30*30*30*5);

+ package que = real_time_queue__complexity;

+ printf "\nReal time queue: now inserting and removing %d elements:\n" n;

+ my q = { for (q = que::empty, c = 0; c < n; q = que::snoc(q, c), ++c; q) { }; };

+ { for (q = q; !(que::isempty(q)); q = que::tail(q)) { }; };

+ que::complexity::stats();

+ que::complexity::reset();

+ block_test(40*40*40*40);