Author: hannes
Date: Mon May 15 21:42:54 2006
New Revision: 10739
Added:
trunk/libraries/priority-queue/
trunk/libraries/priority-queue/library.dylan (contents, props changed)
trunk/libraries/priority-queue/priority-queue.dylan (contents, props
changed)
trunk/libraries/priority-queue/priority-queue.lid (contents, props changed)
trunk/libraries/registry/generic/priority-queue (contents, props changed)
trunk/libraries/registry/generic/timer (contents, props changed)
trunk/libraries/timer/
trunk/libraries/timer/timer-exports.dylan (contents, props changed)
trunk/libraries/timer/timer-test.dylan (contents, props changed)
trunk/libraries/timer/timer.dylan (contents, props changed)
trunk/libraries/timer/timer.lid (contents, props changed)
Modified:
trunk/libraries/libsdl-dylan/Makefile
Log:
Bug: 7299
*implement a priority-queue (from ftp/pub/gd/contributions by andreas)
*implement timer
Modified: trunk/libraries/libsdl-dylan/Makefile
==============================================================================
--- trunk/libraries/libsdl-dylan/Makefile (original)
+++ trunk/libraries/libsdl-dylan/Makefile Mon May 15 21:42:54 2006
@@ -3,7 +3,7 @@
MELANGE=melange --framework SDL --framework OpenGL --d2c
else
LIDFILE=sdl.lid
- MELANGE=melange -I/usr/local/sdl/include --d2c
+ MELANGE=melange -I/usr/local/include --d2c
endif
sdl.lib.du: $(LIDFILE) sdl.dylan
@@ -12,7 +12,7 @@
endif
d2c $(LIDFILE)
-sdl.lid: sdl-exports.dylan sdl-intr.dylan sdl-glut-intr.dylan
+sdl.lid: sdl-exports.dylan sdl.intr
touch $@
sdl.dylan: sdl.intr
Added: trunk/libraries/priority-queue/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/priority-queue/library.dylan Mon May 15 21:42:54 2006
@@ -0,0 +1,13 @@
+module: dylan-user
+
+define library priority-queue
+ use common-dylan;
+
+ export priority-queue;
+end library;
+
+define module priority-queue
+ use common-dylan;
+
+ export <priority-queue>;
+end module priority-queue;
Added: trunk/libraries/priority-queue/priority-queue.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/priority-queue/priority-queue.dylan Mon May 15 21:42:54 2006
@@ -0,0 +1,90 @@
+module: priority-queue
+author: Andreas Bogk <ich@xxxxxxxxxxx>
+copyright: LGPL
+
+// A priority queue uses the relation \< to order the entries
+
+define class <priority-queue> (<deque>, <stretchy-collection>)
+ constant slot heap :: <vector> = make(<stretchy-vector>);
+ constant slot comparison-function :: <function>,
+ init-value: \<, init-keyword: comparison-function:;
+ virtual slot size :: <integer>, init-value: 0;
+end class;
+
+define method size (pq :: <priority-queue>) => (size :: <object>)
+ pq.heap.size;
+end method size;
+
+define method size-setter (size :: <integer>, pq :: <priority-queue>)
+ => (new-size :: <integer>);
+ size-setter(size, pq.heap);
+end;
+
+define method remove!(pq :: <priority-queue>, my-element, #key test = \==,
count = 0)
+ => (pq :: <priority-queue>)
+ let coll = pq.heap;
+ let index = find-key(coll, curry(test, my-element), skip: count);
+ coll[index] := coll[pq.size - 1];
+ coll.size := coll.size - 1;
+ if (coll.size > 0)
+ top-down(pq, index);
+ end;
+ pq;
+end;
+
+define method add!(pq :: <priority-queue>, value) => (pq :: <priority-queue>)
+ let index :: <integer> = pq.size;
+
+ pq.size := pq.size + 1;
+ pq.heap[index] := value;
+ bottom-up(pq, index);
+ pq;
+end method add!;
+
+define method bottom-up(pq :: <priority-queue>, index :: <integer>) => ();
+ let bubble = pq.heap[index];
+ let super-index :: <integer> = ash(index, -1);
+
+ while(index > 0 & pq.comparison-function(pq.heap[super-index], bubble))
+ pq.heap[index] := pq.heap[super-index];
+ index := super-index;
+ super-index := ash(index + 1, -1) - 1;
+ end while;
+
+ pq.heap[index] := bubble;
+end method bottom-up;
+
+define method pop(pq :: <priority-queue>) => (first-element :: <object>);
+ let first-element = pq.heap[0];
+
+ pq.heap[0] := pq.heap[pq.size - 1];
+ pq.size := pq.size - 1;
+ if(pq.size > 1)
+ top-down(pq, 0);
+ end if;
+ first-element;
+end method pop;
+
+define method top-down(pq :: <priority-queue>, index :: <integer>) => ();
+ let bubble = pq.heap[index];
+ let sub-index = ash(index + 1, 1) - 1;
+
+ block(return)
+ while(sub-index + 1 < pq.size)
+ if(pq.comparison-function(pq.heap[sub-index], pq.heap[sub-index + 1]))
+ sub-index := sub-index + 1;
+ end if;
+ if(pq.comparison-function(pq.heap[sub-index], bubble))
+ return();
+ end if;
+ pq.heap[index] := pq.heap[sub-index];
+ index := sub-index;
+ sub-index := ash(index + 1, 1) - 1;
+ end while;
+ if(sub-index < pq.size & pq.comparison-function(bubble,
pq.heap[sub-index]))
+ pq.heap[index] := pq.heap[sub-index];
+ index := sub-index;
+ end if;
+ end block;
+ pq.heap[index] := bubble;
+end method top-down;
Added: trunk/libraries/priority-queue/priority-queue.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/priority-queue/priority-queue.lid Mon May 15 21:42:54 2006
@@ -0,0 +1,3 @@
+library: priority-queue
+files: library
+ priority-queue
\ No newline at end of file
Added: trunk/libraries/registry/generic/priority-queue
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/priority-queue Mon May 15 21:42:54 2006
@@ -0,0 +1 @@
+abstract://dylan/priority-queue/priority-queue.lid
Added: trunk/libraries/registry/generic/timer
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/timer Mon May 15 21:42:54 2006
@@ -0,0 +1 @@
+abstract://dylan/timer/timer.lid
Added: trunk/libraries/timer/timer-exports.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/timer/timer-exports.dylan Mon May 15 21:42:54 2006
@@ -0,0 +1,20 @@
+module: dylan-user
+
+define library timer
+ use common-dylan;
+ use io;
+ use priority-queue;
+ use system;
+
+ export timer;
+end library;
+
+define module timer
+ use common-dylan;
+ use format-out;
+ use priority-queue;
+ use date;
+ use threads;
+
+ export foo;
+end module;
Added: trunk/libraries/timer/timer-test.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/timer/timer-test.dylan Mon May 15 21:42:54 2006
@@ -0,0 +1,24 @@
+module: timer
+
+define method main ()
+ let date = current-date();
+ let timer1 = make(<timer>,
+ timestamp: date + make(<day/time-duration>, seconds: 1),
+ event: print-date);
+ let timer3 = make(<timer>,
+ timestamp: date + make(<day/time-duration>, seconds: 3),
+ event: print-date);
+ let timer10 = make(<timer>,
+ timestamp: date + make(<day/time-duration>, seconds: 10),
+ event: print-date);
+end;
+
+define method print-date ()
+ let date = current-date();
+ format-out("%s\n", as-iso8601-string(date));
+end;
+
+begin
+ main();
+ sleep(23.5);
+end;
\ No newline at end of file
Added: trunk/libraries/timer/timer.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/timer/timer.dylan Mon May 15 21:42:54 2006
@@ -0,0 +1,75 @@
+module: timer
+synopsis:
+author:
+copyright:
+
+define class <timer> (<object>)
+ slot timestamp :: <date>, required-init-keyword: timestamp:;
+ slot event :: <function>, required-init-keyword: event:;
+end;
+
+define method initialize (timer :: <timer>,
+ #next next-method,
+ #rest rest, #key,
+ #all-keys)
+ next-method();
+ with-lock($timer-manager.lock)
+ add!($timer-manager.queue, timer);
+ release($timer-manager.notification);
+ end;
+end;
+
+define method cancel (timer :: <timer>)
+ with-lock($timer-manager.lock)
+ remove!($timer-manager.queue, timer)
+ end;
+end;
+
+
+define class <timer-manager> (<object>)
+ slot queue :: <priority-queue>
+ = make(<priority-queue>,
+ comparison-function: method (a, b)
+ a.timestamp < b.timestamp
+ end);
+ slot lock :: <lock> = make(<lock>);
+ slot notification :: <notification>;
+end;
+
+define method initialize (timer-manager :: <timer-manager>,
+ #next next-method,
+ #rest rest, #key,
+ #all-keys)
+ next-method();
+ timer-manager.notification := make(<notification>, lock: timer-manager.lock);
+ let worker = make(<thread>,
+ function: curry(worker-function, timer-manager));
+end;
+
+define constant $timer-manager = make(<timer-manager>);
+
+define function decode-seconds (day/time-duration :: <day/time-duration>)
+ => (seconds :: <real>)
+ let (days, hours, minutes, seconds, microseconds)
+ = decode-duration(day/time-duration);
+ minutes * 60 + seconds + microseconds / 1000.0;
+end;
+
+define function worker-function (timer-manager :: <timer-manager>)
+ wait-for(timer-manager.lock);
+ while (#t)
+ let time = current-date();
+ let timeout = if (timer-manager.queue.size > 0)
+ decode-seconds(timer-manager.queue.first.timestamp - time);
+ end;
+ wait-for(timer-manager.notification, timeout: timeout);
+ while (timer-manager.queue.size > 0 &
+ time > timer-manager.queue.first.timestamp)
+ let timer = pop(timer-manager.queue);
+ release(timer-manager.lock);
+ timer.event();
+ wait-for(timer-manager.lock);
+ end;
+ end;
+ release(timer-manager.lock);
+end;
Added: trunk/libraries/timer/timer.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/timer/timer.lid Mon May 15 21:42:54 2006
@@ -0,0 +1,4 @@
+library: timer
+files: timer-exports
+ timer
+ timer-test
--
Gd-chatter mailing list
Gd-chatter@xxxxxxxxxxxxxxxx
https://www.gwydiondylan.org/mailman/listinfo/gd-chatter
|
