Source

Hard real-time queues / real-time-queue--complexity.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

# Augmentation of package real_time_queue with a worst-case complexity meter
package real_time_queue__complexity {
    infix val (-/-);
    package 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 (-/-) operator.
	
	# Example: fun loop (FOO) => loop -/- (BAR); ...
	# This operator does not break tail recursion.
	fun f -/- x = {
	    complexity_counter := *complexity_counter + 1;
	    f(x);
	};

	# Record measurement of complexity for function f
	fun record (name, f) x = {
	    my c = *complexity_counter;
	    my r = f(x);
	    my c = *complexity_counter - c;
	    if (case (sst::get(*recorded_complexities, name))
			NULL => TRUE;
			THE(p) => (c > p);
		 esac)
		 recorded_complexities :=
		     sst::set(*recorded_complexities, name, c);
		 ();
	    fi;
	    r;
	};

	fun stats () = {
	    # 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));
	};

	# Reset statistics
	fun reset() = {
	    recorded_complexities  := sst::empty;
	    complexity_counter     := 0;
	};
    };
    (-/-) = complexity::(-/-);
    
    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 make_empty () = QUEUE { f => stm::NIL, r => [], s => stm::NIL };
	
	# empty = make_empty();
	
	fun isempty(QUEUE { f => stm::NIL, ... }) => TRUE;
	    isempty _ => FALSE;
	end;
	
	exception INTERNAL;
	
	stipulate	
	    exception INTERNAL;

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

	snoc = fn x = complexity::record ("snoc", snoc) x;
	tail = fn x = complexity::record ("tail", tail) x;
	
    end;
};