Source

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

Full commit
# Copyright (c) 2012 Michele Bini

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is furnished
# to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
# THE SOFTWARE.

# This is an adaptation to Mythryl of an implementation of purely
# functional, hard real-time queues, based on lazy lists and
# memoization, as presented in:

# Purely Functional Data Structures

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

# Requires: standard

package real_time_queue {
    include lazy;
    stipulate
	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;
	
	stipulate	
	    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;
	    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;	    
	herein
	    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;
    end;
};