Source

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

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