Source

Hard real-time queues / real-time-queue--verbatim.pkg

Full commit
# Requires: standard

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

# Purely Functional Data Structures

#          Chris Okasaki
#         September 1996
#          CMU-CS-96-177

# page 43

package real_time_queue__verbatim {
    stipulate

	include lazy;
	package stream {
	    stipulate
		package data {
		    Stream(X) = NIL | CONS(X, Suspension(Stream(X)));
		};
	    herein
		fun from_list(NIL) => data::NIL;
		    from_list(x!r) => data::CONS(x, delay(fn () = from_list(r)));
		end;
		
		include data;
	    end;
	};
	package stm = stream;

    herein
	
	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;
	    isempty _ => FALSE;
	end;
	
	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;
	esac);
	
	fun queue { f, r, s } = case (s)
	     stm::CONS(x, s)  => QUEUE { f, r, s => force(s) };
	     stm::NIL  => {
		 my f' = force(rotate(f, (stm::from_list r), stm::NIL));
		 QUEUE { f => f', r => NIL, s => f' };
	     };
	esac;
	
	fun snoc( QUEUE { f, r, s }, x ) = queue { f, r => x!r, s };
	
	exception EMPTY;
	
	fun head( QUEUE { f => stm::NIL, ... } )    => raise exception EMPTY;
	    head( QUEUE { f => stm::CONS(x, _), ... } )  => x;
	end;
	
	fun tail( QUEUE { f => stm::NIL, ... } )     => raise exception EMPTY;
	    tail( QUEUE { f => stm::CONS(x, f), r, s } )  => queue { f => force(f), r, s };
	end;
    end;
};