Source

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

Full commit
# Copyright (c) 2012 Michele Bini

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# 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;
};