pure-lang-svn Mailing List for Pure (Page 19)
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
pure-lang-svn — SVN commits.
You can subscribe to this list here.
| 2008 |
Jan
|
Feb
|
Mar
|
Apr
(5) |
May
(141) |
Jun
(184) |
Jul
(97) |
Aug
(232) |
Sep
(196) |
Oct
|
Nov
|
Dec
|
|---|
|
From: <ag...@us...> - 2008-07-08 10:50:54
|
Revision: 420
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=420&view=rev
Author: agraef
Date: 2008-07-08 03:51:02 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Add basic AVL tree example.
Added Paths:
-----------
pure/trunk/examples/avltree.pure
Added: pure/trunk/examples/avltree.pure
===================================================================
--- pure/trunk/examples/avltree.pure (rev 0)
+++ pure/trunk/examples/avltree.pure 2008-07-08 10:51:02 UTC (rev 420)
@@ -0,0 +1,108 @@
+
+/* avltree.pure: Basic AVL tree example (after Bird/Wadler). */
+
+/* AVL trees are represented using the constructor symbols nil (empty tree)
+ and bin h x t1 t2 (AVL tree with height h, top element x and left and right
+ subtrees t1 and t2). Example:
+
+ > let t1 = avltree [17,5,26,5]; let t2 = avltree [8,17];
+ > members (t1+t2); members (t1-t2); t1-t2;
+ [5,5,8,17,17,26]
+ [5,5,26]
+ bin 2 5 (bin 1 5 nil nil) (bin 1 26 nil nil) */
+
+nullary nil;
+
+/* Public functions. */
+
+avltree xs = foldl insert nil xs;
+
+avltreep nil |
+avltreep (bin _ _ _ _) = 1;
+avltreep _ = 0;
+
+null nil = 1;
+null (bin _ _ _ _) = 0;
+
+#nil = 0;
+#(bin h x t1 t2) = #t1+#t2+1;
+
+members nil = [];
+members (bin h x t1 t2) = members t1 + (x:members t2);
+
+member nil y = 0;
+member (bin h x t1 t2) y
+ = member t1 y if x>y;
+ = member t2 y if x<y;
+ = 1;
+
+insert nil y = bin 1 y nil nil;
+insert (bin h x t1 t2) y
+ = rebal (mknode x (insert t1 y) t2) if x>y;
+ = rebal (mknode x t1 (insert t2 y));
+
+delete nil y = nil;
+delete (bin h x t1 t2) y
+ = rebal (mknode x (delete t1 y) t2) if x>y;
+ = rebal (mknode x t1 (delete t2 y)) if x<y;
+ = join t1 t2;
+
+/* Implement the usual set operations on AVL trees. */
+
+t1 + t2 = foldl insert t1 (members t2) if avltreep t1;
+t1 - t2 = foldl delete t1 (members t2) if avltreep t1;
+t1 * t2 = t1-(t1-t2) if avltreep t1;
+
+t1 <= t2 = all (member t2) (members t1) if avltreep t1;
+t1 >= t2 = all (member t1) (members t2) if avltreep t1;
+
+t1 < t2 = t1<=t2 && not t2<=t1 if avltreep t1;
+t1 > t2 = t1>=t2 && not t2>=t1 if avltreep t1;
+
+t1 == t2 = t1<=t2 && t2<=t1 if avltreep t1;
+t1 != t2 = not t1==t2 if avltreep t1;
+
+/* Private functions. */
+
+join nil t2 = t2;
+join t1@(bin _ _ _ _) t2
+ = rebal (mknode (last t1) (init t1) t2);
+
+init (bin h x t1 nil) = t1;
+init (bin h x t1 t2) = rebal (mknode x t1 (init t2));
+
+last (bin h x t1 nil) = x;
+last (bin h x t1 t2) = last t2;
+
+/* mknode constructs an AVL tree node, computing the height value. */
+
+mknode x t1 t2 = bin (max (height t1) (height t2) + 1) x t1 t2;
+
+/* height and slope compute the height and slope (difference between heights
+ of the left and the right subtree), respectively. */
+
+height nil = 0;
+height (bin h x t1 t2) = h;
+
+slope nil = 0;
+slope (bin h x t1 t2) = height t1 - height t2;
+
+/* rebal rebalances after single insertions and deletions. */
+
+rebal t = shl t if slope t == -2;
+ = shr t if slope t == 2;
+ = t;
+
+/* Rotation operations. */
+
+rol (bin h x1 t1 (bin h2 x2 t2 t3))
+ = mknode x2 (mknode x1 t1 t2) t3;
+
+ror (bin h1 x1 (bin h2 x2 t1 t2) t3)
+ = mknode x2 t1 (mknode x1 t2 t3);
+
+shl (bin h x t1 t2) = rol (mknode x t1 (ror t2)) if slope t2 == 1;
+ = rol (bin h x t1 t2);
+
+shr (bin h x t1 t2) = ror (mknode x t1 (ror t2)) if slope t2 == -1;
+ = ror (bin h x t1 t2);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-08 08:50:45
|
Revision: 419
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=419&view=rev
Author: agraef
Date: 2008-07-08 01:50:53 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Updated ChangeLog.
Modified Paths:
--------------
pure/trunk/ChangeLog
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-08 08:47:45 UTC (rev 418)
+++ pure/trunk/ChangeLog 2008-07-08 08:50:53 UTC (rev 419)
@@ -1,5 +1,9 @@
2008-07-08 Albert Graef <Dr....@t-...>
+ * lib/math.pure: Moved abs, sgn, min, max, pred and succ from
+ math.pure to primitives.pure, so that they are included in the
+ prelude. Make x%0 behave like x div 0 (which raises SIGFPE).
+
* lib/: Jiri Spitz' port of the Q container types were added to
the library (array.pure, dict.pure, heap.pure, set.pure).
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-08 08:47:36
|
Revision: 418
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=418&view=rev
Author: agraef
Date: 2008-07-08 01:47:45 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Handle x%0 like x div 0.
Modified Paths:
--------------
pure/trunk/lib/math.pure
Modified: pure/trunk/lib/math.pure
===================================================================
--- pure/trunk/lib/math.pure 2008-07-08 08:41:12 UTC (rev 417)
+++ pure/trunk/lib/math.pure 2008-07-08 08:47:45 UTC (rev 418)
@@ -361,14 +361,14 @@
/* The '%' operator returns a rational or complex rational for any combination
of integer, rational and complex integer/rational arguments, provided that
- the denominator is nonzero (otherwise it returns a floating point nan or
- infinity, depending on the numerator). Machine int operands are always
- promoted to bigints. For other numeric operands '%' works just like
- '/'. Rational results are normalized so that the sign is always in the
- numerator and numerator and denominator are relatively prime. Hence a
- rational zero is always represented as 1L%0L. */
+ the denominator is nonzero (otherwise it behaves like x div 0, which will
+ raise an exception on most systems). Machine int operands are always
+ promoted to bigints. For other numeric operands '%' works just like '/'.
+ Rational results are normalized so that the sign is always in the numerator
+ and numerator and denominator are relatively prime. Hence a rational zero
+ is always represented as 1L%0L. */
-x::bigint % 0L = x/0;
+x::bigint % 0L = x div 0L;
x::bigint % y::bigint = (-x)%(-y) if y<0;
= (x div d) % (y div d) when d = gcd x y end
if gcd x y > 1;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-08 08:41:03
|
Revision: 417
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=417&view=rev
Author: agraef
Date: 2008-07-08 01:41:12 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Moved abs, sgn, min, max, pred and succ from math.pure to primitives.pure.
Modified Paths:
--------------
pure/trunk/lib/math.pure
pure/trunk/lib/primitives.pure
Modified: pure/trunk/lib/math.pure
===================================================================
--- pure/trunk/lib/math.pure 2008-07-08 01:32:29 UTC (rev 416)
+++ pure/trunk/lib/math.pure 2008-07-08 08:41:12 UTC (rev 417)
@@ -22,23 +22,6 @@
def inf = 1.0e307 * 1.0e307; def nan = inf-inf;
-/* Absolute value and sign of a number. */
-
-abs x::int | abs x::bigint | abs x::double
- = if x>=0 then x else -x;
-sgn x::int | sgn x::bigint | sgn x::double
- = if x>0 then 1 else if x<0 then -1 else 0;
-
-/* Generic min and max functions. */
-
-min x y = if x<=y then x else y;
-max x y = if x>=y then x else y;
-
-/* Generic succ and pred functions. */
-
-succ x = x+1;
-pred x = x-1;
-
/* Rounding functions. */
extern double floor(double), double ceil(double);
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-07-08 01:32:29 UTC (rev 416)
+++ pure/trunk/lib/primitives.pure 2008-07-08 08:41:12 UTC (rev 417)
@@ -94,6 +94,23 @@
pointer x::double |
pointer x::string = pure_pointerval x;
+/* Absolute value and sign of a number. */
+
+abs x::int | abs x::bigint | abs x::double
+ = if x>=0 then x else -x;
+sgn x::int | sgn x::bigint | sgn x::double
+ = if x>0 then 1 else if x<0 then -1 else 0;
+
+/* Generic min and max functions. */
+
+min x y = if x<=y then x else y;
+max x y = if x>=y then x else y;
+
+/* Generic succ and pred functions. */
+
+succ x = x+1;
+pred x = x-1;
+
/* Basic int and double arithmetic. The Pure compiler already knows how to
handle these, we just need to supply rules with the right type tags. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-08 01:32:20
|
Revision: 416
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=416&view=rev
Author: yes
Date: 2008-07-07 18:32:29 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
a bit more tidying up
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-08 00:05:37 UTC (rev 415)
+++ pure/trunk/examples/libor/date.pure 2008-07-08 01:32:29 UTC (rev 416)
@@ -4,9 +4,8 @@
Acknowledgement: thanks to Dr Albert Graef for his "Q" code for the
Julian day and Gregorian dates
- Discrepancies with your local clock may occur when C library's time();
- returns Posix time based on UTC (Universal Temps Coordinat) or TAI
- (Temps Atomique International) rather than local daylight saving time */
+ time; returns Posix time based on UTC (Universal Temps Coordinat) or
+ TAI (Temps Atomique International) rather than local daylight saving time */
using system; // imports printf, time, ctime, gmtime, gettimeofday, strftime
// extern long time(long*) = c_time; // diy time, no longer needed
@@ -39,7 +38,7 @@
mjday epoch::int secs::int| mjday epoch::int secs::bigint |
mjday epoch::int secs::double = epoch+secs/secsinday;// use time or gettimeofday
-// all conversions between Julian (j) Mayan (m) and Posix (p), done in days
+// all conversions between Julian (j) Mayan (m) and Posix (p), in days
// jday mday pday are numbers of days since their relevant origins (epochs)
jday2mday d::int | jday2mday d::double = d - jdayposix + mdayposix;
mday2jday d::int | mday2jday d::double = d - mdayposix + jdayposix;
@@ -55,18 +54,14 @@
hours2days h::int = h / 24;
/* conversions from/to days:hours:minutes:seconds format
- seconds can be int or double. d,h,m are ints */
+ seconds can be int, bigint or double. d,h,m are ints */
dhms2secs (d::int:h::int:m::int:s::int) |
dhms2secs (d::int:h::int:m::int:s::bigint) |
dhms2secs (d::int:h::int:m::int:s::double) = 60*(60*(24*d+h)+m)+s;
secs2dhms secs::int | secs2dhms secs::bigint | secs2dhms secs::double =
d:(h mod 24):(m mod 60):(secs mod 60)
- when
- m::int = int (secs / 60);
- h::int = m div 60;
- d::int = h div 24
- end;
+ when m::int = int (secs / 60); h::int = m div 60; d::int = h div 24 end;
// an arbitrary binary operator applied to two (days:hours:minutes:seconds)
opdhms op (d1::int:h1::int:m1::int:s1)(d2::int:h2::int:m2::int:s2) =
@@ -80,10 +75,7 @@
secs2hms secs::int | secs2hms secs::bigint | secs2hms secs::double =
h:(m mod 60):(secs mod 60)
- when
- m::int = int (secs / 60);
- h::int = m div 60;
- end;
+ when m::int = int (secs / 60); h::int = m div 60 end;
/* New Time Format: hours:3mins:10secs:secs = hours:tres:dicis:secs = h:t:d:s
the normal seconds are now just a single digit 0-9
@@ -96,16 +88,12 @@
secs2htds secs::int | secs2htds secs::bigint | secs2htds secs::double =
h:(t mod 20):(d mod 18):(secs mod 10)
- when
- d::int = int (secs / 10);
- t::int = d div 18;
- h::int = t div 20
- end;
+ when d::int = int (secs / 10); t::int = d div 18; h::int = t div 20 end;
// Mayan 'long count' calendar presentation format
days2mayan d::int = baktun:(katun mod 20):(tun mod 20):(vinal mod 18):(d mod 20)
when
- vinal=d div 20; tun=vinal div 18; katun=tun div 20; baktun=katun div 20
+ vinal=d div 20; tun=vinal div 18; katun=tun div 20; baktun=katun div 20
end;
mayan2days (baktun::int:katun::int:tun::int:vinal::int:kin::int) =
@@ -139,8 +127,9 @@
greg2pdays date@(D::int,M::int,Y::int) = jday2pday (greg2jdays date);
-greg2psecs g hms =
- (days2secs (greg2pdays g)) + (hms2secs hms); // date time -> psecs
+// gregorian date time -> psecs
+greg2psecs g@(D::int,M::int,Y::int) hms =
+ (days2secs (greg2pdays g)) + (hms2secs hms);
jdays2greg N::int =
(E-(153*M+2) div 5+1, M+3-12*(M div 10), 100*B+D-4800+M div 10)
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-08 00:05:29
|
Revision: 415
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=415&view=rev
Author: yes
Date: 2008-07-07 17:05:37 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
date.pure finished: enabled interactive/library use, added conjunctions of Venus, added parsing of gmtime using strings slicing, simplified some polymorphic code. Now there are functions to convert nearly anything to do with time to nearly anything else
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-07 23:03:58 UTC (rev 414)
+++ pure/trunk/examples/libor/date.pure 2008-07-08 00:05:37 UTC (rev 415)
@@ -4,8 +4,6 @@
Acknowledgement: thanks to Dr Albert Graef for his "Q" code for the
Julian day and Gregorian dates
- Usage: pure -x date.pure [-h]
-
Discrepancies with your local clock may occur when C library's time();
returns Posix time based on UTC (Universal Temps Coordinat) or TAI
(Temps Atomique International) rather than local daylight saving time */
@@ -14,9 +12,6 @@
// extern long time(long*) = c_time; // diy time, no longer needed
// diytime = c_time (pointer 0);
-puts "****************************************************************";
-puts "* New Calendar/Clock, Copyright (c) 2008 by Libor Spacek *";
-puts "****************************************************************";
// some constants in whole days
def mdayposix = 1856305;// Mayan day for the posix epoch 1 Jan 1970
def jdayposix = 2440588;// Julian day (since 1 Jan 4713 BC) for the posix epoch
@@ -31,27 +26,30 @@
def venussyn = 50450688;// duration of the Venus synodic cycle
def venusinf = 1187409600;// 18th August 2007, 4am Venus inferior conjunction
-// current values in posix time supplied by C time();
+/* extended mod operator to work on doubles, so that int, bigint and double
+ times can be conveniently used */
+x::double mod y::int =
+ (x - intx) + (intx mod y) when intx = (int x) end; // mod of a double
+
+// can also use secsnow = gettimeofday mod secsinday; double for more accuracy
secsnow = time mod secsinday; // int seconds since midnight
-// strip the inconvenient \n off strings given by ctime, gmtime
-stripnl s::string = init s;
-
// either mayan or julian posix epoch (plus posix seconds), gives a double mjday
-// to get current pday, use simple: secs2days time
-mjday epoch::int secs::int| mjday epoch::int secs::bigint= epoch+secs/secsinday;
+// to get current pday, use simple: (secs2days time) or (secs2days gettimeofday)
+mjday epoch::int secs::int| mjday epoch::int secs::bigint |
+mjday epoch::int secs::double = epoch+secs/secsinday;// use time or gettimeofday
// all conversions between Julian (j) Mayan (m) and Posix (p), done in days
// jday mday pday are numbers of days since their relevant origins (epochs)
-jday2mday day::int | jday2mday day::double = day - jdayposix + mdayposix;
-mday2jday day::int | mday2jday day::double = day - mdayposix + jdayposix;
-jday2pday day::int | jday2pday day::double = day - jdayposix;
-mday2pday day::int | mday2pday day::double = day - mdayposix;
-pday2jday day::int | pday2jday day::double = day + jdayposix;
-pday2mday day::int | pday2mday day::double = day + mdayposix;
+jday2mday d::int | jday2mday d::double = d - jdayposix + mdayposix;
+mday2jday d::int | mday2jday d::double = d - mdayposix + jdayposix;
+jday2pday d::int | jday2pday d::double = d - jdayposix;
+mday2pday d::int | mday2pday d::double = d - mdayposix;
+pday2jday d::int | pday2jday d::double = d + jdayposix;
+pday2mday d::int | pday2mday d::double = d + mdayposix;
// inner units conversions for convenience and readability
-secs2days s::int | secs2days s::bigint | secs2days s::double = (s / secsinday);
+secs2days s::int | secs2days s::bigint | secs2days s::double = s / secsinday;
days2secs d::int | days2secs d::bigint | days2secs d::double = secsinday * d;
days2hours d::int| days2hours d::bigint| days2hours d::double= 24*d;
hours2days h::int = h / 24;
@@ -59,23 +57,17 @@
/* conversions from/to days:hours:minutes:seconds format
seconds can be int or double. d,h,m are ints */
dhms2secs (d::int:h::int:m::int:s::int) |
+dhms2secs (d::int:h::int:m::int:s::bigint) |
dhms2secs (d::int:h::int:m::int:s::double) = 60*(60*(24*d+h)+m)+s;
-secs2dhms secs::int | secs2dhms secs::bigint =
- d:(h mod 24):(m mod 60):(int (secs-60*m))
+secs2dhms secs::int | secs2dhms secs::bigint | secs2dhms secs::double =
+ d:(h mod 24):(m mod 60):(secs mod 60)
when
m::int = int (secs / 60);
h::int = m div 60;
d::int = h div 24
end;
-
-secs2dhms secs::double = d:(h mod 24):(m mod 60):(secs-60*m)
- when
- m::int = int (secs / 60);
- h::int = m div 60;
- d::int = h div 24
- end;
-
+
// an arbitrary binary operator applied to two (days:hours:minutes:seconds)
opdhms op (d1::int:h1::int:m1::int:s1)(d2::int:h2::int:m2::int:s2) =
secs2dhms (op (dhms2secs (d1:h1:m1:s1)) (dhms2secs (d2:h2:m2:s2)));
@@ -83,18 +75,15 @@
/* conversions from/to hours:minutes:seconds format for displaying time of day
hours may be more than 24 but use d:h:m:s for longer periods of time */
hms2secs (h::int:m::int:s::int) |
+hms2secs (h::int:m::int:s::bigint) |
hms2secs (h::int:m::int:s::double) = 60*(60*h+m)+s;
-secs2hms secs::int | secs2hms secs::bigint = h:(m mod 60):(int (secs-60*m))
+secs2hms secs::int | secs2hms secs::bigint | secs2hms secs::double =
+ h:(m mod 60):(secs mod 60)
when
m::int = int (secs / 60);
h::int = m div 60;
end;
-secs2hms secs::double = h:(m mod 60):(secs-60*m)
- when
- m::int = int (secs / 60);
- h::int = m div 60;
- end;
/* New Time Format: hours:3mins:10secs:secs = hours:tres:dicis:secs = h:t:d:s
the normal seconds are now just a single digit 0-9
@@ -102,34 +91,28 @@
tres - multiply by three to get traditional babylonian minutes
hours as usual (24 hour clock) */
htds2secs (h::int:t::int:d::int:s::int)|
+htds2secs (h::int:t::int:d::int:s::bigint)|
htds2secs (h::int:t::int:d::int:s::double) = 10*(18*(20*h+t)+d)+s;
-secs2htds secs::int | secs2htds secs::bigint =
- h:(t mod 20):(d mod 18):(int (secs-10*d))
+secs2htds secs::int | secs2htds secs::bigint | secs2htds secs::double =
+ h:(t mod 20):(d mod 18):(secs mod 10)
when
d::int = int (secs / 10);
t::int = d div 18;
h::int = t div 20
end;
-secs2htds secs::double = h:(t mod 20):(d mod 18):(secs-10*d)
- when
- d::int = int (secs / 10);
- t::int = d div 18;
- h::int = t div 20
- end;
-
// Mayan 'long count' calendar presentation format
days2mayan d::int = baktun:(katun mod 20):(tun mod 20):(vinal mod 18):(d mod 20)
when
- vinal =d div 20; tun =vinal div 18; katun =tun div 20; baktun =katun div 20
+ vinal=d div 20; tun=vinal div 18; katun=tun div 20; baktun=katun div 20
end;
mayan2days (baktun::int:katun::int:tun::int:vinal::int:kin::int) =
20*(18*(20*(20*baktun+katun)+tun)+vinal)+kin;
/* Calculations in Mayan long count format, e.g. addmayan day1 day2
- probably not needed, is the same as: days2mayan day1+day2; */
+ probably not needed, as it is the same as: days2mayan day1+day2; */
addmayan (baktun1::int:katun1::int:tun1::int:vinal1::int:kin1::int)
(baktun2::int:katun2::int:tun2::int:vinal2::int:kin2::int) =
baktun:(katun mod 20):(tun mod 20):(vinal mod 18):(kin mod 20)
@@ -155,6 +138,7 @@
when A = (14-M) div 12; Y = Y+4800-A; M = M+12*A-3 end;
greg2pdays date@(D::int,M::int,Y::int) = jday2pday (greg2jdays date);
+
greg2psecs g hms =
(days2secs (greg2pdays g)) + (hms2secs hms); // date time -> psecs
@@ -166,11 +150,17 @@
end;
pdays2greg N::int = jdays2greg (pday2jday N);
-
-/* phase of a cycle of 'length' from 'init' at time 'now' (must be same units)
+
+//parse gmtime string and extract the components
+nullary wday mon day utc year;
+gmparse wday psecs::int| gmparse wday psecs::bigint= (gmtime psecs)!!(0..2);
+gmparse mon psecs::int | gmparse mon psecs::bigint = (gmtime psecs)!!(4..6);
+gmparse day psecs::int | gmparse day psecs::bigint = (gmtime psecs)!!(8..9);
+gmparse utc psecs::int | gmparse utc psecs::bigint = (gmtime psecs)!!(11..18);
+gmparse year psecs::int| gmparse year psecs::bigint =(gmtime psecs)!!(20..24);
+
+/* phase of any cycle of 'length' from 'init' at time 'now' (must be same units)
this is surprisingly accurate without computing the full orbital elements */
-x::double mod y::int =
- (x - intx) + (intx mod y) when intx = (int x) end; // mod of a double
phase init::int length::int now::int |
phase init::int length::int now::bigint |
phase init::int length::int now::double = ((now-init) mod length)/length;
@@ -180,44 +170,50 @@
completion init::int length::int now::bigint |
completion init::int length::int now::double = length - ((now-init) mod length);
-// for now, let's just do some simple calculations to print
+/******************************************************************************/
+// now let's do some simple calculations
nextfmoon = secs2days (completion fullmoon lunarmonth time); // in seconds
nextvenus = secs2days (completion venusinf venussyn time);
-jdaytoday = int (mjday jdayposix time); // whole julian day
-daytoday = mjday mdayposix time; // double mayan day
+jdaytoday = mjday jdayposix time; // double julian day - could use gettimeofday
+daytoday = mjday mdayposix time; // double mayan day - could use gettimeofday
longtoday = str (days2mayan (int daytoday));
nextcycle = completion 0 cycledays daytoday; // now in days
mayanleft = str (days2mayan (int nextcycle));
complete = 100.0*(phase 0 cycledays daytoday);
-usage = puts "Usage: pure -x date.pure [anyarg]" $
- puts "\tanyarg for help\n";
+// usage = puts "Usage: pure -x date.pure [anyarg]" $
+// puts "\tanyarg for help\n";
-// here are test prints of some facts
-case argc of
- 1 =
- puts ((strftime "%x" time) + "\t Gregorian preferred date") $
+// usage with pure -x commented out to enable interactive and "using" modes
+// case argc of
+// 1 =
+
+puts "****************************************************************";
+puts "* New Calendar/Clock, Copyright (c) 2008 by Libor Spacek *";
+puts "****************************************************************";
+
+ puts ((strftime "%x" time) + "\t Gregorian date") $
puts ((strftime "%X" time) + "\t local time") $
-// puts ((stripnl (gmtime time)) + " UTC Time") $
- printf "%s \t UTC Time\n" (str (secs2hms secsnow)) $
- printf "%s \t UTC Time in h:t:d:s\n" (str (secs2htds secsnow))$
- printf "%d \t Julian day number\n" jdaytoday $
- printf "%d \t Mayan day number\n" (int daytoday) $
+ puts ((gmparse utc time) + "\t UTC time") $
+// printf "%s \t UTC Time in h:t:d:s\n" (str (secs2htds (int secsnow)))$
+ printf "%12.4f \t Julian day\n" jdaytoday $
+ printf "%12.4f \t Mayan day\n" daytoday $
printf "%s\t Mayan long count date\n" longtoday $
- printf "%5.3f \t days till the next full Moon\n" nextfmoon $
- printf "%6.3f \t days till the next inf. conjunction of Venus\n" nextvenus$
- printf "%8.3f \t days till the end of the Mayan cycle\n" nextcycle $
+ printf "%6.4f \t days till the next full Moon\n" nextfmoon $
+ printf "%7.4f \t days till the next inf. conjunction of Venus\n" nextvenus$
+ printf "%9.4f \t days till the end of the Mayan cycle\n" nextcycle $
printf "%s\t long countdown to the end of the cycle\n" mayanleft $
printf "%11.8f %%\t completion of this cycle of >5125 years\n" complete $
puts "****************************************************************";
- 2 =
+// 2 = // another argument was presented -> print help and usage
puts "Mayan long count digits and their ranges of values:" $
puts "Baktun(0-12) : Katun(0-19) : Tun(0-19) : Vinal(0-17) : Kin(0-19)" $
puts "Baktun=144000days Katun=7200days Tun=360days Vinal=20days Kin=day" $
- puts "\nNew clock digits and their ranges of values:" $
- puts "hour(0-23) : tre(0-19) : dici(0-17) : second(0-9)" $
- puts "hour=3600s : tre=180s : dici=10s : s=second\n" $
- puts "Full time spec: Baktun:Katun:Tun:Vinal:Kin hour:tre:dici:second\n" $
- usage;
- n = usage
-end;
+ puts "****************************************************************";
+// puts "\nNew clock digits and their ranges of values:" $
+// puts "hour(0-23) : tre(0-19) : dici(0-17) : second(0-9)" $
+// puts "hour=3600s : tre=180s : dici=10s : s=second\n" $
+// puts "Full time spec: Baktun:Katun:Tun:Vinal:Kin hour:tre:dici:second\n" ;
+// usage;
+// n = usage // any other number of arguments -> just print usage
+//end;
\ No newline at end of file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-07 23:15:25
|
Revision: 414
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=414&view=rev
Author: agraef
Date: 2008-07-07 16:03:58 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Updated ChangeLog.
Modified Paths:
--------------
pure/trunk/ChangeLog
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-07 22:37:56 UTC (rev 413)
+++ pure/trunk/ChangeLog 2008-07-07 23:03:58 UTC (rev 414)
@@ -1,3 +1,8 @@
+2008-07-08 Albert Graef <Dr....@t-...>
+
+ * lib/: Jiri Spitz' port of the Q container types were added to
+ the library (array.pure, dict.pure, heap.pure, set.pure).
+
2008-07-07 Albert Graef <Dr....@t-...>
* lib/strings.pure: Make slicing work with strings.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-07 22:37:47
|
Revision: 413
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=413&view=rev
Author: jspitz
Date: 2008-07-07 15:37:56 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Update logfile for test #15.
Modified Paths:
--------------
pure/trunk/test/test015.log
Modified: pure/trunk/test/test015.log
===================================================================
--- pure/trunk/test/test015.log 2008-07-07 22:07:25 UTC (rev 412)
+++ pure/trunk/test/test015.log 2008-07-07 22:37:56 UTC (rev 413)
@@ -1,4 +1,11 @@
{
+ rule #0: randlist = [52,72,26,78,46,19,44,72,96,75,46,86,13,84,1,94,67,79,14,61,90,77,36,94,88,44,16,42,47,3,60,79,18,52,89,30,94,38,93,91,33,53,70,97,76,75,9,85,17,1,41,29,37,41,13,38,29,2,23,3,22,52,49,88,77,5,11,54,34,45,58,58,6,81,40,58,19,89,17,20,11,15,99,68,81,64,32,73,82,72,65,35,61,41,81,77,27,4,60,51,63,18,27,45,64,74,41,61,61,85,18,30,2,0,95,99,20,60,93,55,54,43,44,30,20,21,4,20,57,91,41,65,35,58,39,3,28,9,44,92,92,60,86,1,68,84,12,5,1,39,86,1,92,88,66,65,7,9,0,52,78,65,54,79,72,25,25,13,48,46,10,50,85,1,82,96,1,92,6,3,19,27,44,64,15,48,64,53,35,39,72,72,30,10,91,74,23,65,36,2,84,4,5,42,47,50,98,60,91,75,71,97,2,26,1,8,15,11,75,93,12,59,12,59,6,25,41,94,35,1,97,76,86,40,86,3,20,42,98,56,57,46,46,76,30,41,9,13,69,18,89,73,30,14,82,44,59,97,50,89,72,26,45,26,96,1,94,90,9,52,8,79,86,9,88,0,20,47,64,93,9,57,50,65,89,73,68,80,24,76,76,54,48,41,7,52,50,75,13,0,76,10,96,8,11,89,74,21,58,24,88,39,5,92,45,87,23,48,57,85,21,92,3,40,5,10,52,57,11,4,50,72,49,34,3,36,91,50,86,92,1,28,23,71,10,77,24,43,59,51,76,72,80,74,50,81,5,57,86,55,82,12,71,0,3,29,67,30,43,27,12,13,10,41,82,26,14,1,22,35,76,42,68,52,32,14,37,74,72,73,17,55,68,87,55,34,53,96,92,75,68,33,36,70,66,39,1,40,66,21,8,61,1,21,20,37,39,29,52,79,39,72,69,63,12,73,16,2,21,17,17,52,31,90,44,7,13,53,64,84,96,34,36,71,4,12,25,96,83,68,68,80,52,58,68,46,75,27,31,6,14,47,23,94,33,26,17,87,86,47,21,77,10,20,23,16,26,80,10,25,87,21,66,62,79,34,63,25,3,80,40,43,75,78,48,71,38,2,41,90,61,83,75,60,86,40,23,58,10,49,84,70,10,69,3,42,73,27,33,31,21,60,57,7,47,16,29,65,99,9,5,2,93,6,71,55,41,98,46,69,68,53,57,54,60,37,89,24,41,57,29,83,26,26,49,6,10,23,61,70,25,80,12,40,80,16,44,69,2,54,50,91,43,86,83,66,87,91,15,9,67,13,89,31,7,58,21,69,30,80,87,74,57,86,84,64,9,62,80,93,44,10,94,85,13,84,68,55,98,34,75,20,42,85,2,25,53,62,77,62,79,11,88,77,85,47,77,28,29,19,29,47,31,40,59,41,86,4,4,76,43,49,53,95,45,96,38,46,3,33,86,94,70,24,19,86,69,16,85,18,6,91,31,19,28,99,24,84,42,45,71,50,30,34,0,82,36,87,27,60,76,21,19,37,65,20,42,43,5,87,66,30,11,92,93,41,21,69,28,29,63,54,58,74,6,95,72,8,96,10,9,44,38,71,93,29,94,17,2,38,94,71,46,33,82,58,89,70,91,89,63,35,6,79,62,45,74,29,62,52,79,69,23,20,57,55,90,98,43,40,1,47,54,4,47,72,23,35,96,7,15,17,67,19,74,8,97,31,70,51,89,91,14,69,82,74,99,83,77,66,66,24,13,58,37,17,99,59,75,99,61,9,8,86,55,56,22,55,81,58,73,29,91,47,15,16,73,82,97,4,7,72,53,92,7,23,92,30,72,99,25,48,12,51,99,85,31,42,59,32,45,46,86,55,63,5,46,21,45,9,72,86,17,76,28,35,96,0,25,26,87,9,89,32,80,72,47,26,48,50,95,63,6,61,43,21,1,43,90,57,35,25,30,89,3,84,5,72,1,15,9,36,55,67,31,51,81,79,84,52,56,40,77,91,66,9,83,39,1,22,72,23,64,0,97,9,6,54,66,18,51,18,99,6,94,59,54,92,8,32,9,24,87,67,67,23,80,56,57,60,53,90,89,57,82,2,45,28,57,21,7,20,76,57,85,80,69,59,31,34,74,83,1,45,31,39,19,69,43,84,6,35,91,52,99,52,86,75,50,21,46,2,0,7,55,50,49,58,13,88,6,91,72,1,89,69,50,83,88,21,54,72,54,82,48,47,2,31,70,39]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let randlist = [52,72,26,78,46,19,44,72,96,75,46,86,13,84,1,94,67,79,14,61,90,77,36,94,88,44,16,42,47,3,60,79,18,52,89,30,94,38,93,91,33,53,70,97,76,75,9,85,17,1,41,29,37,41,13,38,29,2,23,3,22,52,49,88,77,5,11,54,34,45,58,58,6,81,40,58,19,89,17,20,11,15,99,68,81,64,32,73,82,72,65,35,61,41,81,77,27,4,60,51,63,18,27,45,64,74,41,61,61,85,18,30,2,0,95,99,20,60,93,55,54,43,44,30,20,21,4,20,57,91,41,65,35,58,39,3,28,9,44,92,92,60,86,1,68,84,12,5,1,39,86,1,92,88,66,65,7,9,0,52,78,65,54,79,72,25,25,13,48,46,10,50,85,1,82,96,1,92,6,3,19,27,44,64,15,48,64,53,35,39,72,72,30,10,91,74,23,65,36,2,84,4,5,42,47,50,98,60,91,75,71,97,2,26,1,8,15,11,75,93,12,59,12,59,6,25,41,94,35,1,97,76,86,40,86,3,20,42,98,56,57,46,46,76,30,41,9,13,69,18,89,73,30,14,82,44,59,97,50,89,72,26,45,26,96,1,94,90,9,52,8,79,86,9,88,0,20,47,64,93,9,57,50,65,89,73,68,80,24,76,76,54,48,41,7,52,50,75,13,0,76,10,96,8,11,89,74,21,58,24,88,39,5,92,45,87,23,48,57,85,21,92,3,40,5,10,52,57,11,4,50,72,49,34,3,36,91,50,86,92,1,28,23,71,10,77,24,43,59,51,76,72,80,74,50,81,5,57,86,55,82,12,71,0,3,29,67,30,43,27,12,13,10,41,82,26,14,1,22,35,76,42,68,52,32,14,37,74,72,73,17,55,68,87,55,34,53,96,92,75,68,33,36,70,66,39,1,40,66,21,8,61,1,21,20,37,39,29,52,79,39,72,69,63,12,73,16,2,21,17,17,52,31,90,44,7,13,53,64,84,96,34,36,71,4,12,25,96,83,68,68,80,52,58,68,46,75,27,31,6,14,47,23,94,33,26,17,87,86,47,21,77,10,20,23,16,26,80,10,25,87,21,66,62,79,34,63,25,3,80,40,43,75,78,48,71,38,2,41,90,61,83,75,60,86,40,23,58,10,49,84,70,10,69,3,42,73,27,33,31,21,60,57,7,47,16,29,65,99,9,5,2,93,6,71,55,41,98,46,69,68,53,57,54,60,37,89,24,41,57,29,83,26,26,49,6,10,23,61,70,25,80,12,40,80,16,44,69,2,54,50,91,43,86,83,66,87,91,15,9,67,13,89,31,7,58,21,69,30,80,87,74,57,86,84,64,9,62,80,93,44,10,94,85,13,84,68,55,98,34,75,20,42,85,2,25,53,62,77,62,79,11,88,77,85,47,77,28,29,19,29,47,31,40,59,41,86,4,4,76,43,49,53,95,45,96,38,46,3,33,86,94,70,24,19,86,69,16,85,18,6,91,31,19,28,99,24,84,42,45,71,50,30,34,0,82,36,87,27,60,76,21,19,37,65,20,42,43,5,87,66,30,11,92,93,41,21,69,28,29,63,54,58,74,6,95,72,8,96,10,9,44,38,71,93,29,94,17,2,38,94,71,46,33,82,58,89,70,91,89,63,35,6,79,62,45,74,29,62,52,79,69,23,20,57,55,90,98,43,40,1,47,54,4,47,72,23,35,96,7,15,17,67,19,74,8,97,31,70,51,89,91,14,69,82,74,99,83,77,66,66,24,13,58,37,17,99,59,75,99,61,9,8,86,55,56,22,55,81,58,73,29,91,47,15,16,73,82,97,4,7,72,53,92,7,23,92,30,72,99,25,48,12,51,99,85,31,42,59,32,45,46,86,55,63,5,46,21,45,9,72,86,17,76,28,35,96,0,25,26,87,9,89,32,80,72,47,26,48,50,95,63,6,61,43,21,1,43,90,57,35,25,30,89,3,84,5,72,1,15,9,36,55,67,31,51,81,79,84,52,56,40,77,91,66,9,83,39,1,22,72,23,64,0,97,9,6,54,66,18,51,18,99,6,94,59,54,92,8,32,9,24,87,67,67,23,80,56,57,60,53,90,89,57,82,2,45,28,57,21,7,20,76,57,85,80,69,59,31,34,74,83,1,45,31,39,19,69,43,84,6,35,91,52,99,52,86,75,50,21,46,2,0,7,55,50,49,58,13,88,6,91,72,1,89,69,50,83,88,21,54,72,54,82,48,47,2,31,70,39];
+{
rule #0: a = set (1..10)
state 0: #0
<var> state 1
@@ -76,6 +83,10 @@
Set (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 1 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 0 nil nil)))
rmlast c;
Bag (bin 4 (-1) (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 8 1 (bin 6 0 (bin 5 0 nil nil) (bin 7 0 nil nil)) (bin 9 0 nil nil)))
+foldl delete a (1..10);
+Set nil
+foldl delete c (1..10);
+Bag nil
first a;
1
last a;
@@ -96,6 +107,10 @@
1
member c 50;
0
+members a;
+[1,2,3,4,5,6,7,8,9,10]
+members c;
+[1,2,3,4,5,6,7,8,9,10]
a==b;
0
a!=b;
@@ -158,3 +173,397 @@
Bag (bin 4 1 (bin 2 0 (bin 1 0 nil nil) (bin 3 0 nil nil)) (bin 5 0 nil nil))
c+d-d;
Bag (bin 5 0 (bin 2 (-1) (bin 1 0 nil nil) (bin 4 1 (bin 3 0 nil nil) nil)) (bin 8 0 (bin 7 1 (bin 6 0 nil nil) nil) (bin 9 (-1) nil (bin 10 0 nil nil))))
+foldl delete (foldl insert emptyset randlist) randlist;
+Set nil
+foldl delete (foldl insert emptybag randlist) randlist;
+Bag nil
+{
+ rule #0: a = dict (catmap (\i -> [i=>double i]) (1..10))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let a = dict (catmap (\i/*0:*/ -> [i/*0:*/=>double i/*0:*/] {
+ rule #0: i = [i=>double i]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (1..10));
+{
+ rule #0: b = dict (catmap (\i -> [i=>double i]) (11..20))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let b = dict (catmap (\i/*0:*/ -> [i/*0:*/=>double i/*0:*/] {
+ rule #0: i = [i=>double i]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (11..20));
+{
+ rule #0: c = hdict$zipwith (=>) (catmap (\i -> (i,double i,str i):[]) (1..10)) (1..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let c = hdict$zipwith (=>) (catmap (\i/*0:*/ -> (i/*0:*/,double i/*0:*/,str i/*0:*/):[] {
+ rule #0: i = (i,double i,str i):[]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (1..10)) (1..10);
+{
+ rule #0: d = hdict$zipwith (=>) (catmap (\i -> (i,double i,str i):[]) (11..20)) (11..20)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let d = hdict$zipwith (=>) (catmap (\i/*0:*/ -> (i/*0:*/,double i/*0:*/,str i/*0:*/):[] {
+ rule #0: i = (i,double i,str i):[]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (11..20)) (11..20);
+{
+ rule #0: e = dict$zipwith (=>) (map str (1..10)) (map str (1..10))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let e = dict$zipwith (=>) (map str (1..10)) (map str (1..10));
+a;
+Dict (bin 4 4.0 (-1) (bin 2 2.0 0 (bin 1 1.0 0 nil nil) (bin 3 3.0 0 nil nil)) (bin 8 8.0 0 (bin 6 6.0 0 (bin 5 5.0 0 nil nil) (bin 7 7.0 0 nil nil)) (bin 9 9.0 (-1) nil (bin 10 10.0 0 nil nil))))
+b;
+Dict (bin 14 14.0 (-1) (bin 12 12.0 0 (bin 11 11.0 0 nil nil) (bin 13 13.0 0 nil nil)) (bin 18 18.0 0 (bin 16 16.0 0 (bin 15 15.0 0 nil nil) (bin 17 17.0 0 nil nil)) (bin 19 19.0 (-1) nil (bin 20 20.0 0 nil nil))))
+c;
+Hdict (bin 155356 [(4,4.0,"4")=>4] (-1) (bin 124342 [(2,2.0,"2")=>2] 0 (bin 91321 [(1,1.0,"1")=>1] 0 nil nil) (bin 139781 [(3,3.0,"3")=>3] 0 nil nil)) (bin 186472 [(8,8.0,"8")=>8] 0 (bin 170922 [(6,6.0,"6")=>6] 0 (bin 163079 [(5,5.0,"5")=>5] 0 nil nil) (bin 178641 [(7,7.0,"7")=>7] 0 nil nil)) (bin 190279 [(9,9.0,"9")=>9] (-1) nil (bin 193996 [(10,10.0,"10")=>10] 0 nil nil))))
+d;
+Hdict (bin 208912 [(14,14.0,"14")=>14] (-1) (bin 202666 [(12,12.0,"12")=>12] 0 (bin 198291 [(11,11.0,"11")=>11] 0 nil nil) (bin 206661 [(13,13.0,"13")=>13] 0 nil nil)) (bin 222112 [(18,18.0,"18")=>18] 0 (bin 217798 [(16,16.0,"16")=>16] 0 (bin 213295 [(15,15.0,"15")=>15] 0 nil nil) (bin 219731 [(17,17.0,"17")=>17] 0 nil nil)) (bin 224013 [(19,19.0,"19")=>19] (-1) nil (bin 224384 [(20,20.0,"20")=>20] 0 nil nil))))
+e;
+Dict (bin "4" "4" 0 (bin "2" "2" 1 (bin "1" "1" (-1) nil (bin "10" "10" 0 nil nil)) (bin "3" "3" 0 nil nil)) (bin "6" "6" (-1) (bin "5" "5" 0 nil nil) (bin "8" "8" 0 (bin "7" "7" 0 nil nil) (bin "9" "9" 0 nil nil))))
+mkdict 1000 (1..10);
+Dict (bin 4 1000 (-1) (bin 2 1000 0 (bin 1 1000 0 nil nil) (bin 3 1000 0 nil nil)) (bin 8 1000 0 (bin 6 1000 0 (bin 5 1000 0 nil nil) (bin 7 1000 0 nil nil)) (bin 9 1000 (-1) nil (bin 10 1000 0 nil nil))))
+mkhdict 1000 (catmap (\i/*0:*/ -> (i/*0:*/,double i/*0:*/,str i/*0:*/):[] {
+ rule #0: i = (i,double i,str i):[]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (1..10));
+Hdict (bin 155356 [(4,4.0,"4")=>1000] (-1) (bin 124342 [(2,2.0,"2")=>1000] 0 (bin 91321 [(1,1.0,"1")=>1000] 0 nil nil) (bin 139781 [(3,3.0,"3")=>1000] 0 nil nil)) (bin 186472 [(8,8.0,"8")=>1000] 0 (bin 170922 [(6,6.0,"6")=>1000] 0 (bin 163079 [(5,5.0,"5")=>1000] 0 nil nil) (bin 178641 [(7,7.0,"7")=>1000] 0 nil nil)) (bin 190279 [(9,9.0,"9")=>1000] (-1) nil (bin 193996 [(10,10.0,"10")=>1000] 0 nil nil))))
+dictp a;
+1
+dictp c;
+0
+hdictp c;
+1
+hdictp a;
+0
+null emptydict;
+1
+null emptyhdict;
+1
+null a;
+0
+null c;
+0
+rmfirst a;
+Dict (bin 4 4.0 (-1) (bin 2 2.0 (-1) nil (bin 3 3.0 0 nil nil)) (bin 8 8.0 0 (bin 6 6.0 0 (bin 5 5.0 0 nil nil) (bin 7 7.0 0 nil nil)) (bin 9 9.0 (-1) nil (bin 10 10.0 0 nil nil))))
+rmlast a;
+Dict (bin 4 4.0 (-1) (bin 2 2.0 0 (bin 1 1.0 0 nil nil) (bin 3 3.0 0 nil nil)) (bin 8 8.0 1 (bin 6 6.0 0 (bin 5 5.0 0 nil nil) (bin 7 7.0 0 nil nil)) (bin 9 9.0 0 nil nil)))
+first a;
+1=>1.0
+last a;
+10=>10.0
+#a;
+10
+#c;
+10
+member a 5;
+1
+member a 50;
+0
+member e "5";
+1
+member e "50";
+0
+member c (5,5.0,"5");
+1
+member c (50,50.0,"50");
+0
+a!5;
+5.0
+e!"5";
+"5"
+c!(5,5.0,"5");
+5
+a!50;
+<stdin>:166.33-36: unhandled exception 'out_of_bounds' while evaluating 'a!50'
+c!(50,50.0,"50");
+<stdin>:166.39-59: unhandled exception 'out_of_bounds' while evaluating 'c!(50,50.0,"50")'
+a!!(5..15);
+[5.0,6.0,7.0,8.0,9.0,10.0]
+c!!catmap (\i/*0:*/ -> (i/*0:*/,double i/*0:*/,str i/*0:*/):[] {
+ rule #0: i = (i,double i,str i):[]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (5..15);
+[5,6,7,8,9,10]
+members a;
+[1=>1.0,2=>2.0,3=>3.0,4=>4.0,5=>5.0,6=>6.0,7=>7.0,8=>8.0,9=>9.0,10=>10.0]
+members c;
+[(1,1.0,"1")=>1,(2,2.0,"2")=>2,(3,3.0,"3")=>3,(4,4.0,"4")=>4,(5,5.0,"5")=>5,(6,6.0,"6")=>6,(7,7.0,"7")=>7,(8,8.0,"8")=>8,(9,9.0,"9")=>9,(10,10.0,"10")=>10]
+keys a;
+[1,2,3,4,5,6,7,8,9,10]
+keys c;
+(1,1.0,"1"):(2,2.0,"2"):(3,3.0,"3"):(4,4.0,"4"):(5,5.0,"5"):(6,6.0,"6"):(7,7.0,"7"):(8,8.0,"8"):(9,9.0,"9"):(10,10.0,"10"):[]
+vals a;
+[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]
+vals c;
+[1,2,3,4,5,6,7,8,9,10]
+update a 5 5000;
+Dict (bin 4 4.0 (-1) (bin 2 2.0 0 (bin 1 1.0 0 nil nil) (bin 3 3.0 0 nil nil)) (bin 8 8.0 0 (bin 6 6.0 0 (bin 5 5000 0 nil nil) (bin 7 7.0 0 nil nil)) (bin 9 9.0 (-1) nil (bin 10 10.0 0 nil nil))))
+update a 5000 5000;
+Dict (bin 4 4.0 (-1) (bin 2 2.0 0 (bin 1 1.0 0 nil nil) (bin 3 3.0 0 nil nil)) (bin 8 8.0 0 (bin 6 6.0 0 (bin 5 5.0 0 nil nil) (bin 7 7.0 0 nil nil)) (bin 10 10.0 0 (bin 9 9.0 0 nil nil) (bin 5000 5000 0 nil nil))))
+update c (5,5.0,"5") 5000;
+Hdict (bin 155356 [(4,4.0,"4")=>4] (-1) (bin 124342 [(2,2.0,"2")=>2] 0 (bin 91321 [(1,1.0,"1")=>1] 0 nil nil) (bin 139781 [(3,3.0,"3")=>3] 0 nil nil)) (bin 186472 [(8,8.0,"8")=>8] 0 (bin 170922 [(6,6.0,"6")=>6] 0 (bin 163079 [(5,5.0,"5")=>5000] 0 nil nil) (bin 178641 [(7,7.0,"7")=>7] 0 nil nil)) (bin 190279 [(9,9.0,"9")=>9] (-1) nil (bin 193996 [(10,10.0,"10")=>10] 0 nil nil))))
+update c (5000,5000.0,"5000") 5000;
+Hdict (bin 155356 [(4,4.0,"4")=>4] 0 (bin 124342 [(2,2.0,"2")=>2] 1 (bin 91321 [(1,1.0,"1")=>1] 1 (bin (-21709) [(5000,5000.0,"5000")=>5000] 0 nil nil) nil) (bin 139781 [(3,3.0,"3")=>3] 0 nil nil)) (bin 186472 [(8,8.0,"8")=>8] 0 (bin 170922 [(6,6.0,"6")=>6] 0 (bin 163079 [(5,5.0,"5")=>5] 0 nil nil) (bin 178641 [(7,7.0,"7")=>7] 0 nil nil)) (bin 190279 [(9,9.0,"9")=>9] (-1) nil (bin 193996 [(10,10.0,"10")=>10] 0 nil nil))))
+foldl delete a (1..10);
+Dict nil
+delete a 5000;
+Dict (bin 4 4.0 (-1) (bin 2 2.0 0 (bin 1 1.0 0 nil nil) (bin 3 3.0 0 nil nil)) (bin 8 8.0 0 (bin 6 6.0 0 (bin 5 5.0 0 nil nil) (bin 7 7.0 0 nil nil)) (bin 9 9.0 (-1) nil (bin 10 10.0 0 nil nil))))
+foldl delete c (catmap (\i/*0:*/ -> (i/*0:*/,double i/*0:*/,str i/*0:*/):[] {
+ rule #0: i = (i,double i,str i):[]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (1..10));
+Hdict nil
+delete c (5000,5000.0,"5000");
+Hdict (bin 155356 [(4,4.0,"4")=>4] (-1) (bin 124342 [(2,2.0,"2")=>2] 0 (bin 91321 [(1,1.0,"1")=>1] 0 nil nil) (bin 139781 [(3,3.0,"3")=>3] 0 nil nil)) (bin 186472 [(8,8.0,"8")=>8] 0 (bin 170922 [(6,6.0,"6")=>6] 0 (bin 163079 [(5,5.0,"5")=>5] 0 nil nil) (bin 178641 [(7,7.0,"7")=>7] 0 nil nil)) (bin 190279 [(9,9.0,"9")=>9] (-1) nil (bin 193996 [(10,10.0,"10")=>10] 0 nil nil))))
+a==b;
+0
+a!=b;
+1
+a==a;
+1
+a!=a;
+0
+c==d;
+0
+c!=d;
+1
+c==c;
+1
+c!=c;
+0
+foldl delete (mkdict 100 randlist) randlist;
+Dict nil
+foldl delete (mkhdict 100 randlist) randlist;
+Hdict nil
+{
+ rule #0: a = heap (1..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let a = heap (1..10);
+{
+ rule #0: b = heap (11..20)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let b = heap (11..20);
+{
+ rule #0: c = heap (map str (1..10))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let c = heap (map str (1..10));
+{
+ rule #0: d = heap (1.0..10.0)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let d = heap (1.0..10.0);
+a;
+Heap (bin 1 1 (bin 0 2 (bin 1 4 (bin 0 8 nil nil) nil) (bin 1 6 (bin 0 10 nil nil) nil)) (bin 1 3 (bin 1 5 (bin 0 9 nil nil) nil) (bin 0 7 nil nil)))
+c;
+Heap (bin 1 "1" (bin 0 "10" (bin 1 "4" (bin 0 "8" nil nil) nil) (bin 1 "2" (bin 0 "6" nil nil) nil)) (bin 1 "3" (bin 1 "5" (bin 0 "9" nil nil) nil) (bin 0 "7" nil nil)))
+d;
+Heap (bin 1 1.0 (bin 0 2.0 (bin 1 4.0 (bin 0 8.0 nil nil) nil) (bin 1 6.0 (bin 0 10.0 nil nil) nil)) (bin 1 3.0 (bin 1 5.0 (bin 0 9.0 nil nil) nil) (bin 0 7.0 nil nil)))
+heapp a;
+1
+heapp (set (1..10));
+0
+null emptyheap;
+1
+null a;
+0
+rmfirst a;
+Heap (bin 0 2 (bin 1 4 (bin 1 8 (bin 0 10 nil nil) nil) (bin 0 6 nil nil)) (bin 1 3 (bin 1 5 (bin 0 9 nil nil) nil) (bin 0 7 nil nil)))
+first a;
+1
+#a;
+10
+members a;
+[1,2,3,4,5,6,7,8,9,10]
+a==b;
+0
+a!=b;
+1
+a==a;
+1
+a!=a;
+0
+#heap randlist;
+1000
+{
+ rule #0: a = array (1..10)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let a = array (1..10);
+{
+ rule #0: b = array (11..20)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let b = array (11..20);
+{
+ rule #0: c = array2 (catmap (\j -> [catmap (\i -> [str (i+j)]) (j..10)]) (1..10))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let c = array2 (catmap (\j/*0:*/ -> [catmap (\i/*0:*/ -> [str (i/*0:*/+j/*1:*/)] {
+ rule #0: i = [str (i+j)]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (j/*0:*/..10)] {
+ rule #0: j = [catmap (\i -> [str (i+j)]) (j..10)]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (1..10));
+{
+ rule #0: d = array2 (catmap (\j -> [catmap (\i -> [str (i+j)]) (j..10)]) (11..20))
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let d = array2 (catmap (\j/*0:*/ -> [catmap (\i/*0:*/ -> [str (i/*0:*/+j/*1:*/)] {
+ rule #0: i = [str (i+j)]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (j/*0:*/..10)] {
+ rule #0: j = [catmap (\i -> [str (i+j)]) (j..10)]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (11..20));
+a;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip 1) (tip 9)) (tip 5)) (bin 0 (tip 3) (tip 7))) (bin 1 (bin 1 (bin 0 (tip 2) (tip 10)) (tip 6)) (bin 0 (tip 4) (tip 8))))
+b;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip 11) (tip 19)) (tip 15)) (bin 0 (tip 13) (tip 17))) (bin 1 (bin 1 (bin 0 (tip 12) (tip 20)) (tip 16)) (bin 0 (tip 14) (tip 18))))
+c;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip (Array (bin 0 (bin 1 (bin 1 (bin 0 (tip "2") (tip "10")) (tip "6")) (bin 0 (tip "4") (tip "8"))) (bin 1 (bin 1 (bin 0 (tip "3") (tip "11")) (tip "7")) (bin 0 (tip "5") (tip "9")))))) (tip (Array (bin 0 (tip "18") (tip "19"))))) (tip (Array (bin 0 (bin 1 (bin 0 (tip "10") (tip "14")) (tip "12")) (bin 1 (bin 0 (tip "11") (tip "15")) (tip "13")))))) (bin 0 (tip (Array (bin 0 (bin 0 (bin 0 (tip "6") (tip "10")) (bin 0 (tip "8") (tip "12"))) (bin 0 (bin 0 (tip "7") (tip "11")) (bin 0 (tip "9") (tip "13")))))) (tip (Array (bin 0 (bin 0 (tip "14") (tip "16")) (bin 0 (tip "15") (tip "17"))))))) (bin 1 (bin 1 (bin 0 (tip (Array (bin 1 (bin 1 (bin 1 (bin 0 (tip "4") (tip "12")) (tip "8")) (bin 0 (tip "6") (tip "10"))) (bin 0 (bin 0 (tip "5") (tip "9")) (bin 0 (tip "7") (tip "11")))))) (tip (Array (tip "20")))) (tip (Array (bin 1 (bin 1 (bin 0 (tip "12") (tip "16")) (tip "14")) (bin 0 (tip "13") (tip "15")))))) (bin 0 (tip (Array (bin 1 (bin 0 (bin 0 (tip "8") (tip "12")) (bin 0 (tip "10") (tip "14"))) (bin 1 (bin 0 (tip "9") (tip "13")) (tip "11"))))) (tip (Array (bin 1 (bin 0 (tip "16") (tip "18")) (tip "17")))))))
+d;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip (Array nil)) (tip (Array nil))) (tip (Array nil))) (bin 0 (tip (Array nil)) (tip (Array nil)))) (bin 1 (bin 1 (bin 0 (tip (Array nil)) (tip (Array nil))) (tip (Array nil))) (bin 0 (tip (Array nil)) (tip (Array nil)))))
+mkarray 1000 10;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000))) (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000))))
+mkarray2 1000 (5,5);
+Array (bin 1 (bin 1 (bin 0 (tip (Array (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000))))) (tip (Array (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000)))))) (tip (Array (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000)))))) (bin 0 (tip (Array (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000))))) (tip (Array (bin 1 (bin 1 (bin 0 (tip 1000) (tip 1000)) (tip 1000)) (bin 0 (tip 1000) (tip 1000)))))))
+arrayp a;
+1
+arrayp c;
+1
+arrayp (set (1..2));
+0
+null emptyarray;
+1
+null a;
+0
+null c;
+0
+rmfirst a;
+Array (bin 1 (bin 1 (bin 1 (bin 0 (tip 2) (tip 10)) (tip 6)) (bin 0 (tip 4) (tip 8))) (bin 0 (bin 0 (tip 3) (tip 7)) (bin 0 (tip 5) (tip 9))))
+rmlast a;
+Array (bin 1 (bin 1 (bin 1 (bin 0 (tip 1) (tip 9)) (tip 5)) (bin 0 (tip 3) (tip 7))) (bin 0 (bin 0 (tip 2) (tip 6)) (bin 0 (tip 4) (tip 8))))
+rmfirst a;
+Array (bin 1 (bin 1 (bin 1 (bin 0 (tip 2) (tip 10)) (tip 6)) (bin 0 (tip 4) (tip 8))) (bin 0 (bin 0 (tip 3) (tip 7)) (bin 0 (tip 5) (tip 9))))
+rmfirst c;
+Array (bin 1 (bin 1 (bin 1 (bin 0 (tip (Array (bin 1 (bin 1 (bin 1 (bin 0 (tip "4") (tip "12")) (tip "8")) (bin 0 (tip "6") (tip "10"))) (bin 0 (bin 0 (tip "5") (tip "9")) (bin 0 (tip "7") (tip "11")))))) (tip (Array (tip "20")))) (tip (Array (bin 1 (bin 1 (bin 0 (tip "12") (tip "16")) (tip "14")) (bin 0 (tip "13") (tip "15")))))) (bin 0 (tip (Array (bin 1 (bin 0 (bin 0 (tip "8") (tip "12")) (bin 0 (tip "10") (tip "14"))) (bin 1 (bin 0 (tip "9") (tip "13")) (tip "11"))))) (tip (Array (bin 1 (bin 0 (tip "16") (tip "18")) (tip "17")))))) (bin 0 (bin 0 (tip (Array (bin 0 (bin 0 (bin 0 (tip "6") (tip "10")) (bin 0 (tip "8") (tip "12"))) (bin 0 (bin 0 (tip "7") (tip "11")) (bin 0 (tip "9") (tip "13")))))) (tip (Array (bin 0 (bin 0 (tip "14") (tip "16")) (bin 0 (tip "15") (tip "17")))))) (bin 0 (tip (Array (bin 0 (bin 1 (bin 0 (tip "10") (tip "14")) (tip "12")) (bin 1 (bin 0 (tip "11") (tip "15")) (tip "13"))))) (tip (Array (bin 0 (tip "18") (tip "19")))))))
+first a;
+1
+last a;
+10
+first c;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip "2") (tip "10")) (tip "6")) (bin 0 (tip "4") (tip "8"))) (bin 1 (bin 1 (bin 0 (tip "3") (tip "11")) (tip "7")) (bin 0 (tip "5") (tip "9"))))
+last c;
+Array (tip "20")
+#a;
+10
+#c;
+10
+a!5;
+6
+c!(2,3);
+"9"
+a!50;
+<stdin>:292.18-21: unhandled exception 'out_of_bounds' while evaluating 'a!50'
+c!(20,30);
+<stdin>:292.24-36: unhandled exception 'out_of_bounds' while evaluating 'c!(20,30)'
+a!!(5..15);
+[6,7,8,9,10]
+c!!catmap (\i/*0:*/ -> catmap (\j/*0:*/ -> (i/*1:*/,j/*0:*/):[] {
+ rule #0: j = (i,j):[]
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (3..15) {
+ rule #0: i = catmap (\j -> (i,j):[]) (3..15)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) (3..15);
+["11","12","13","14","13","14","15","15","16","17"]
+members a;
+[1,2,3,4,5,6,7,8,9,10]
+members c;
+[Array (bin 0 (bin 1 (bin 1 (bin 0 (tip "2") (tip "10")) (tip "6")) (bin 0 (tip "4") (tip "8"))) (bin 1 (bin 1 (bin 0 (tip "3") (tip "11")) (tip "7")) (bin 0 (tip "5") (tip "9")))),Array (bin 1 (bin 1 (bin 1 (bin 0 (tip "4") (tip "12")) (tip "8")) (bin 0 (tip "6") (tip "10"))) (bin 0 (bin 0 (tip "5") (tip "9")) (bin 0 (tip "7") (tip "11")))),Array (bin 0 (bin 0 (bin 0 (tip "6") (tip "10")) (bin 0 (tip "8") (tip "12"))) (bin 0 (bin 0 (tip "7") (tip "11")) (bin 0 (tip "9") (tip "13")))),Array (bin 1 (bin 0 (bin 0 (tip "8") (tip "12")) (bin 0 (tip "10") (tip "14"))) (bin 1 (bin 0 (tip "9") (tip "13")) (tip "11"))),Array (bin 0 (bin 1 (bin 0 (tip "10") (tip "14")) (tip "12")) (bin 1 (bin 0 (tip "11") (tip "15")) (tip "13"))),Array (bin 1 (bin 1 (bin 0 (tip "12") (tip "16")) (tip "14")) (bin 0 (tip "13") (tip "15"))),Array (bin 0 (bin 0 (tip "14") (tip "16")) (bin 0 (tip "15") (tip "17"))),Array (bin 1 (bin 0 (tip "16") (tip "18")) (tip "17")),Array (bin 0 (tip "18") (tip "19")),Array (tip "20")]
+members2 c;
+[["2","3","4","5","6","7","8","9","10","11"],["4","5","6","7","8","9","10","11","12"],["6","7","8","9","10","11","12","13"],["8","9","10","11","12","13","14"],["10","11","12","13","14","15"],["12","13","14","15","16"],["14","15","16","17"],["16","17","18"],["18","19"],["20"]]
+update a 5 5000;
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip 1) (tip 9)) (tip 5)) (bin 0 (tip 3) (tip 7))) (bin 1 (bin 1 (bin 0 (tip 2) (tip 10)) (tip 5000)) (bin 0 (tip 4) (tip 8))))
+update2 c (2,3) "5000";
+Array (bin 0 (bin 1 (bin 1 (bin 0 (tip (Array (bin 0 (bin 1 (bin 1 (bin 0 (tip "2") (tip "10")) (tip "6")) (bin 0 (tip "4") (tip "8"))) (bin 1 (bin 1 (bin 0 (tip "3") (tip "11")) (tip "7")) (bin 0 (tip "5") (tip "9")))))) (tip (Array (bin 0 (tip "18") (tip "19"))))) (tip (Array (bin 0 (bin 1 (bin 0 (tip "10") (tip "14")) (tip "12")) (bin 1 (bin 0 (tip "11") (tip "15")) (tip "13")))))) (bin 0 (tip (Array (bin 0 (bin 0 (bin 0 (tip "6") (tip "10")) (bin 0 (tip "8") (tip "12"))) (bin 0 (bin 0 (tip "7") (tip "11")) (bin 0 (tip "5000") (tip "13")))))) (tip (Array (bin 0 (bin 0 (tip "14") (tip "16")) (bin 0 (tip "15") (tip "17"))))))) (bin 1 (bin 1 (bin 0 (tip (Array (bin 1 (bin 1 (bin 1 (bin 0 (tip "4") (tip "12")) (tip "8")) (bin 0 (tip "6") (tip "10"))) (bin 0 (bin 0 (tip "5") (tip "9")) (bin 0 (tip "7") (tip "11")))))) (tip (Array (tip "20")))) (tip (Array (bin 1 (bin 1 (bin 0 (tip "12") (tip "16")) (tip "14")) (bin 0 (tip "13") (tip "15")))))) (bin 0 (tip (Array (bin 1 (bin 0 (bin 0 (tip "8") (tip "12")) (bin 0 (tip "10") (tip "14"))) (bin 1 (bin 0 (tip "9") (tip "13")) (tip "11"))))) (tip (Array (bin 1 (bin 0 (tip "16") (tip "18")) (tip "17")))))))
+insert a 5000;
+Array (bin 1 (bin 0 (bin 1 (bin 0 (tip 5000) (tip 8)) (tip 4)) (bin 1 (bin 0 (tip 2) (tip 10)) (tip 6))) (bin 1 (bin 1 (bin 0 (tip 1) (tip 9)) (tip 5)) (bin 0 (tip 3) (tip 7))))
+append a 5000;
+Array (bin 1 (bin 0 (bin 1 (bin 0 (tip 1) (tip 9)) (tip 5)) (bin 1 (bin 0 (tip 3) (tip 5000)) (tip 7))) (bin 1 (bin 1 (bin 0 (tip 2) (tip 10)) (tip 6)) (bin 0 (tip 4) (tip 8))))
+a==b;
+0
+a!=b;
+1
+a==a;
+1
+a!=a;
+0
+c==d;
+0
+c!=d;
+1
+c==c;
+1
+c!=c;
+0
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-07 22:07:17
|
Revision: 412
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=412&view=rev
Author: jspitz
Date: 2008-07-07 15:07:25 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Move array, dict and heap from examples to lib, update test #15.
Modified Paths:
--------------
pure/trunk/test/test015.pure
Added Paths:
-----------
pure/trunk/lib/array.pure
pure/trunk/lib/dict.pure
pure/trunk/lib/heap.pure
Removed Paths:
-------------
pure/trunk/examples/array.pure
pure/trunk/examples/dict.pure
pure/trunk/examples/heap.pure
Deleted: pure/trunk/examples/array.pure
===================================================================
--- pure/trunk/examples/array.pure 2008-07-07 20:46:37 UTC (rev 411)
+++ pure/trunk/examples/array.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -1,233 +0,0 @@
-
-/* array.pure: integer-indexed arrays implemented as size-balanced
- binary trees. */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
-
- This file is part of the Pure programming language and system.
-
- Pure 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.
-
- Pure 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 script implements an efficient variable-sized array data structure
- which allows to access and update individual array members, as well as
- to add and remove elements at the beginning and end of an array. All these
- operations are carried out in logarithmic time. */
-
-/* Public operations: ******************************************************
-
- emptyarray return the empty array
- array xs create an array from a list xs
- array2 xs create a two-dimensional array from a list of lists
- mkarray x n create an array consisting of n x's
- mkarray2 x (n,m) create a 2D array of n*m x's
- arrayp x check whether x is an array
-
- #a size of a
- a!i return ith member of a
- a!(i,j) two-dimensional subscript
-
- a!!is slicing (get a list of values from a list
- indices
- a!!ijs slicing of two-dimensional array (from a given
- list of pairs (i, j):...:[])
-
- null a tests whether a is the empty array
- members a list of values stored in a
- members2 a list of members in a two-dimensional array
-
- first a, last a first and last member of A
- rmfirst a, rmlast a remove first and last member from a
- insert a x insert x at the beginning of a
- append a x append x to the end of a
- update a i x replace the ith member of a by x
- update2 a (i,j) x update two-dimensional array
-
- *************************************************************************/
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-// array type check
-arrayp (Array _) = 1;
-arrayp _ = 0;
-
-// create an empty array
-emptyarray = Array nil;
-
-// create an array from a list
-array xs = foldl append emptyarray xs if listp xs;
-
-// create a two-dimensional array from a two-dimensional list
-array2 xs = array (map array xs);
-
-// create an array of a given size filled with a constant value
-mkarray x n::int = Array (mkarray x n)
-with
- mkarray x n::int = nil if n <= 0;
- = tip x if n == 1;
- = array_mkbin (n mod 2)
- (mkarray x (n - n div 2))
- (mkarray x (n div 2));
-end;
-
-// create a 2D array of given dimensions filled with a constant value
-mkarray2 x (n::int, m::int) = mkarray (mkarray x m) n;
-
-// get array size
-#(Array a) = #a
-with
- #nil = 0;
- #(tip _) = 1;
- #(bin 0 a1 _) = #a1 * 2;
- #(bin 1 a1 _) = #a1 * 2 - 1;
-end;
-
-// get value by index
-(Array a)!i::int = a!i
-with
- (tip x)!0 = x;
- (bin _ a1 a2)!i::int = a1!(i div 2) if i mod 2 == 0;
- = a2!(i div 2) if i mod 2 == 1;
- _ ! _ = throw out_of_bounds;
-end;
-
-// get value by indices from two-dimensional array
-x@(Array _)!(i::int, j::int) = x!i!j;
-
-// slicing (get list of values from list of indices)
-a@(Array _)!!is@(_::int:_) = [a!i; i = is; (i >= 0) && (i < (#a))];
-
-// slicing of two-dimensional array
-a@(Array _)!!ijs@((_::int, _::int):_)
- = [a!(i, j); (i, j) = ijs; (i >= 0) && (i < (#a))
- && (j >= 0) && (j < (#(a!i)))];
-
-// check for an empty array
-null (Array nil) = 1;
-null (Array _) = 0;
-
-// get all array members in list form
-members (Array a) = members a
-with
- members nil = [];
- members (tip x) = [x];
- members (bin _ a1 a2) = merge (members a1) (members a2);
- // merge lists xs (even elements) and ys (odd elements)
- merge [] ys = ys;
- merge (x:xs) ys = x:merge ys xs;
-end;
-
-// get all members of an two-dimensional array in list form
-members2 x@(Array _) = map members (members x);
-
-// get the first array member
-first (Array a) = first a
-with
- first (tip x) = x;
- first (bin _ a1 _) = first a1;
-end;
-
-// get the last array member
-last (Array a) = last a
-with
- last (tip x) = x;
- last (bin 0 _ a2) = last a2;
- last (bin 1 a1 _) = last a1;
-end;
-
-// remove the first member from an array
-rmfirst (Array a) = Array (rmfirst a)
-with
- rmfirst (tip _) = nil;
- rmfirst (bin 0 a1 a2) = array_mkbin 1 a2 (rmfirst a1);
- rmfirst (bin 1 a1 a2) = array_mkbin 0 a2 (rmfirst a1);
-end;
-
-// remove the last member from an array
-rmlast (Array a) = Array (rmlast a)
-with
- rmlast (tip _) = nil;
- rmlast (bin 0 a1 a2) = array_mkbin 1 a1 (rmlast a2);
- rmlast (bin 1 a1 a2) = array_mkbin 0 (rmlast a1) a2;
-end;
-
-// insert a new member at the beginning of an array
-insert (Array a) y = Array (insert a y)
-with
- insert nil y = tip y;
- insert (tip x) y = bin 0 (tip y) (tip x);
- insert (bin 0 a1 a2) y = array_mkbin 1 (insert a2 y) a1;
- insert (bin 1 a1 a2) y = array_mkbin 0 (insert a2 y) a1;
-end;
-
-// append a new member at the end of an array
-append (Array a) y = Array (append a y)
-with
- append nil y = tip y;
- append (tip x) y = bin 0 (tip x) (tip y);
- append (bin 0 a1 a2) y = array_mkbin 1 (append a1 y) a2;
- append (bin 1 a1 a2) y = array_mkbin 0 a1 (append a2 y);
-end;
-
-// update a given array position with a new value
-update (Array a) i::int y = Array (update a i y)
-with
- update (tip _) 0 y = tip y;
- update (bin b::int a1 a2) i::int y
- = bin b (update a1 (i div 2) y) a2
- if i mod 2 == 0;
- = bin b a1 (update a2 (i div 2) y)
- if i mod 2 == 1;
-end;
-
-// update a given position of a two-dimensional array with a new value
-update2 x@(Array a) (i::int, j::int) y
- = update x i (update (x!i) j y);
-
-// compare two arrays for equality
-Array a == Array b = eq a b
-with
- eq nil nil = 1;
- eq nil (tip _) = 0;
- eq nil (bin _ _ _) = 0;
- eq (tip _) nil = 0;
- eq (tip x) (tip y) = x == y;
- eq (tip _) (bin _ _ _) = 0;
- eq (bin _ _ _) nil = 0;
- eq (bin _ _ _) (tip _) = 0;
- eq (bin b1::int a1 a2) (bin b2::int a3 a4)
- = b1 == b2 && eq a1 a3 && eq a2 a4;
-end;
-
-// compare two arrays for inequality
-Array a != Array b = neq a b
-with
- neq nil nil = 0;
- neq nil (tip _) = 1;
- neq nil (bin _ _ _) = 1;
- neq (tip _) nil = 1;
- neq (tip x) (tip y) = x != y;
- neq (tip _) (bin _ _ _) = 1;
- neq (bin _ _ _) nil = 1;
- neq (bin _ _ _) (tip _) = 1;
- neq (bin b1::int a1 a2) (bin b2::int a3 a4)
- = b1 != b2 || neq a1 a3 || neq a2 a4;
-end;
-
-/* Private functions, don't invoke these directly. */
-
-// construct a binary array node
-array_mkbin _ nil a2 = a2;
-array_mkbin _ a1 nil = a1;
-array_mkbin b::int a1 a2 = bin b a1 a2;
Deleted: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-07 20:46:37 UTC (rev 411)
+++ pure/trunk/examples/dict.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -1,625 +0,0 @@
-/* Pure's dict and hdict data types based on AVL trees. */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
- Copyright (c) 2008 by Jiri Spitz <jir...@bl...>.
-
- This file is part of the Pure programming language and system.
-
- Pure 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.
-
- Pure 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/>. */
-
-
-/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- The used algorithm of AVL trees has its origin in the SWI-Prolog
- implementation of association lists. The original file was created by
- R. A. O'Keefe and updated for the SWI-Prolog by Jan Wielemaker. For the
- original file see http://www.swi-prolog.org.
-
- The port from SWI-Prolog and the deletion stuff (rmfirst, rmlast, delete)
- missing in the original file was provided by Jiri Spitz
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-/*****
-Tree for dict and hdict is either:
-- nil (empty tree) or
-- bin Key value Balance Left Right (Left, Right: trees)
-
-Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
-*****/
-
-
-/* Public operations: ******************************************************
-
-emptydict, emptyhdict: return the empty dict or bag
-dict xs, hdict xs; create a dict or hdict from list xs
-dictp d, hdictp d; check whether x is a dict or hdict
-mkdict y xs, mkhdict y xs: create dict or hdict from a list of keys and
- a constant value
-
-#d size of dict or hdict d
-d!x: get value from d by key x
-d!!xs slicing (get a list of values
- from a list of keys)
-
-null d tests whether d is the empty dict or hdict
-member d x tests whether d contains member with key x
-members d, list d list members of d (in ascending order fo dict)
-keys d: lists keys of d (in ascending order fo dict)
-values d: list values of d
-
-first d, last d return first and last member of dict
-rmfirst d, rmlast d remove first and last member from dict
-insert d xy insert x into d (replace existing element)
-update d x y fully curried version of insert
-delete d x remove x from d
-
- *************************************************************************/
-
-
-// Dict and hdict type checks
-dictp (Dict _) = 1;
-dictp _ = 0;
-
-hdictp (Hdict _) = 1;
-hdictp _ = 0;
-
-// create an empty dict or hdict
-emptydict = Dict nil;
-emptyhdict = Hdict nil;
-
-// create dict or hdict from a list
-dict xys = foldl insert emptydict xys if listp xys;
-hdict xys = foldl insert emptyhdict xys if listp xys;
-
-// insert a new member into the dict or hdict
-insert (t@Dict d) (x::int => y) |
-insert (t@Dict d) (x::string => y) |
-insert (t@Dict d) (x => y) |
-insert (t@Hdict d) (x => y)
- = if t === Dict
- then t ((insertd d x y)!0)
- else t ((inserth d (hash x) x y)!0)
-with
- insertd nil key::int val |
- insertd nil key::string val |
- insertd nil key val
- = [(bin key val ( 0) nil nil), 1];
-
- insertd (bin k::int _ b l r) key::int val |
- insertd (bin k::string _ b l r) key::string val |
- insertd (bin k _ b l r) key val
- = [(bin key val b l r), 0] if key == k;
-
- insertd (bin k::int v b l r) key::int val |
- insertd (bin k::string v b l r) key::string val |
- insertd (bin k v b l r) key val
- = adjust leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = insertd l key val
- end
- if key < k;
-
- insertd (bin k::int v b l r) key::int val |
- insertd (bin k::string v b l r) key::string val |
- insertd (bin k v b l r) key val
- = adjust rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = insertd r key val
- end
- if key > k;
-
- inserth nil k::int x y = [(bin k [x => y] ( 0) nil nil), 1];
-
- inserth (bin k::int v b l r) key::int x y
- = [(bin k (inserth2 v x y) b l r), 0] if k == key;
-
- inserth (bin k::int v b l r) key::int x y
- = adjust leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = inserth l key x y
- end
- if key < k;
-
- inserth (bin k::int v b l r) key::int x y
- = adjust rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = inserth r key x y
- end
- if key > k;
-
- inserth2 [] x y = [x => y];
- inserth2 ((x1 => y):xys) x2 y1
- = ((x1 => y1):xys) if x1 === x2;
- inserth2 ((x => y):xys) x1 y1
- = ((x => y ):(inserth2 xys x1 y1));
-
- adjust 0 oldTree _ = [oldTree, 0];
-
- adjust 1 (bin key::int val b0 l r) LoR |
- adjust 1 (bin key::string val b0 l r) LoR |
- adjust 1 (bin key val b0 l r) LoR
- = [rebal toBeRebalanced (bin key val b0 l r) b1, whatHasChanged]
- when
- [b1, whatHasChanged, toBeRebalanced] = table b0 LoR
- end;
-
- rebal 0 (bin k::int v _ l r) b |
- rebal 0 (bin k::string v _ l r) b |
- rebal 0 (bin k v _ l r) b
- = bin k v b l r;
-
- rebal 1 oldTree _ = (Dict_avl_geq oldTree)!0;
-
-// Balance rules for insertions
-// balance where balance whole tree to be
-// before inserted after increased rebalanced
-table ( 0) (-1) = [( 1), 1, 0];
-table ( 0) ( 1) = [(-1), 1, 0];
-table ( 1) (-1) = [( 0), 0, 1];
-table ( 1) ( 1) = [( 0), 0, 0];
-table (-1) (-1) = [( 0), 0, 0];
-table (-1) ( 1) = [( 0), 0, 1]
-end;
-
-// delete a member by key from the dict or hdict
-delete (t@Dict d) x::int |
-delete (t@Dict d) x::string |
-delete (t@Dict d) x |
-delete (t@Hdict d) x
- = if t === Dict
- then t ((deleted d x)!0)
- else t ((deleteh d (hash x) x)!0)
-with
- deleted nil _ = [nil, 0];
-
- deleted (bin k::int _ _ nil r ) key::int |
- deleted (bin k::string _ _ nil r ) key::string |
- deleted (bin k _ _ nil r ) key
- = [r, 1] if key == k;
-
- deleted (bin k::int _ _ l nil) key::int |
- deleted (bin k::string _ _ l nil) key::string |
- deleted (bin k _ _ l nil) key
- = [l, 1] if key == k;
-
- deleted (bin k::int _ b (bin kl::int vl bl rl ll) r ) key::int |
- deleted (bin k::string _ b (bin kl::string vl bl rl ll) r ) key::string |
- deleted (bin k _ b (bin kl vl bl rl ll) r ) key
- = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
- when
- [lastk, lastv] = last (bin kl vl bl rl ll);
- [newl, leftHasChanged]
- = rmlast (bin kl vl bl rl ll)
- end
- if key == k;
-
- deleted (bin k::int v b l r) key::int |
- deleted (bin k::string v b l r) key::string |
- deleted (bin k v b l r) key
- = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = deleted l key
- end
- if key < k;
-
- deleted (bin k::int v b l r) key::int |
- deleted (bin k::string v b l r) key::string |
- deleted (bin k v b l r) key
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = deleted r key
- end
- if key > k;
-
- deleteh nil _ _ = [nil, 0];
-
- deleteh (bin k::int xys b nil r ) key::int x
- = (if (newxys == [])
- then [r, 1]
- else [bin k newxys b nil r, 0])
- when
- newxys = deleteh2 xys x
- end
- if k == key;
-
- deleteh (bin k::int xys b l nil) key::int x
- = (if (newxys == [])
- then [l, 1]
- else [bin k newxys b l nil, 0])
- when
- newxys = deleteh2 xys x
- end
- if k == key;
-
- deleteh (bin k::int xys b (bin kl vl bl rl ll) r) key::int x
- = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
- when
- [lastk, lastv] = last (bin kl vl bl rl ll);
- [newl, leftHasChanged] = rmlast (bin kl vl bl rl ll)
- end
- if (k == key) && ((deleteh2 xys x) == []);
-
- deleteh (bin k::int xys b l r) key::int x
- = [bin key (deleteh2 xys x) b l r, 0]
- if k == key;
-
- deleteh (bin k::int v b l r) key::int x
- = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = deleteh l key x
- end
- if key < k;
-
- deleteh (bin k::int v b l r) key::int x
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = deleteh r key x
- end
- if key > k;
-
- deleteh2 [] _ = [];
- deleteh2 ((x1 => _) : xys) x2 = xys if x1 === x2;
- deleteh2 ((x => y) : xys) x1 = (x => y) : (deleteh2 xys x1);
-
- rmlast nil = [nil, 0];
- rmlast (bin _ _ _ l nil) = [l, 1];
- rmlast (bin k v b::int l r )
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when [newr, rightHasChanged] = rmlast r end;
-
- last (bin x y _ _ nil) = [x, y];
- last (bin _ _ _ _ d2 ) = last d2
-end;
-
-
-// create dict or hdict from a list of keys and a constant value
-mkdict y xs = dict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
-mkhdict y xs = hdict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
-
-// check for the empty dict or hdict
-null (Dict nil) = 1;
-null (Dict _) = 0;
-
-null (Hdict nil) = 1;
-null (Hdict _) = 0;
-
-// get a number of members in dict or hdict
-#(Dict d) = #d
-with
- #nil = 0;
- #(bin _ _ _ d1 d2) = #d1 + #d2 + 1
-end;
-
-#(Hdict d) = size d
-with
- size nil = 0;
- size (bin _ xys _ d1 d2) = size d1 + size d2 + #xys
-end;
-
-// check whether a key in dict or hdict
-member (Dict d) k::int |
-member (Dict d) k::string |
-member (Dict d) k = member d k
-with
- member nil _ = 0;
-
- member (bin x _ _ d1 d2) y::int |
- member (bin x _ _ d1 d2) y::string |
- member (bin x _ _ d1 d2) y
- = member d1 y if x > y;
- = member d2 y if x < y;
- = 1 if x == y
-end;
-
-member (Hdict d) k = member d (hash k) k
-with
- member nil _ _ = 0;
- member (bin k::int xys _ d1 d2) k1::int x1
- = member d1 k1 x1 if k > k1;
- = member d2 k1 x1 if k < k1;
- = memberk xys x1;
-
- memberk [] _ = 0;
- memberk ((x1 => y):_ ) x2 = 1 if x1 === x2;
- memberk ( _:xys) x2 = memberk xys x2
-end;;
-
-// get all members of dict or hdict
-members (Dict d) = members d
-with
- members nil = [];
-
- members (bin x::int y _ d1 d2) |
- members (bin x::string y _ d1 d2) |
- members (bin x y _ d1 d2)
- = members d1 + ((x => y) : (members d2))
-end;
-
-members (Hdict d) = members d
-with
- members nil = [];
- members (bin _ xys _ d1 d2) = members d1 + xys + members d2
-end;
-
-list d@(Dict _) |
-list d@(Hdict _) = members d;
-
-// get the first member of a dict
-first (Dict d) = first d
-with
- first (bin x y _ nil _) = (x => y);
- first (bin _ _ _ d1 _) = first d1
-end;
-
-// get the last member of a dict
-last (Dict d) = last d
-with
- last (bin x y _ _ nil) = (x => y);
- last (bin _ _ _ _ d2 ) = last d2
-end;
-
-// remove the first member from a dict
-rmfirst (Dict d) = Dict ((rmfirst d)!0)
-with
- rmfirst nil = [nil, 0];
- rmfirst (bin _ _ _ nil r) = [r, 1];
- rmfirst (bin k v b l r)
- = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
- when
- [newl, leftHasChanged] = rmfirst l
- end
-end;
-
-// remove the last member from a dict
-rmlast (Dict d) = Dict ((rmlast d)!0)
-with
- rmlast nil = [nil 0];
- rmlast (bin _ _ _ l nil) = [l, 1];
- rmlast (bin k v b l r)
- = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
- when
- [newr, rightHasChanged] = rmlast r
- end
-end;
-
-// get a list of all keys from dict or hdict
-keys (Dict d) = keys d
-with
- keys nil = [];
-
- keys (bin x::int _ _ d1 d2) |
- keys (bin x::string _ _ d1 d2) |
- keys (bin x _ _ d1 d2)
- = keys d1 + (x : (keys d2))
-end;
-
-keys (Hdict d) = keys d
-with
- keys nil = [];
- keys (bin _ xys _ d1 d2) = keys d1 + map (\(key => _) -> key) xys + keys d2
-end;
-
-// get a list of all values from dict or hdict
-vals (Dict d) = vals d
-with
- vals nil = [];
- vals (bin _ y _ d1 d2) = vals d1 + (y : (vals d2))
-end;
-
-vals (Hdict d) = vals d
-with
- vals nil = [];
- vals (bin _ xys _ d1 d2) = vals d1 +
- map (\(_ => val) -> val) xys +
- vals d2
-end;
-
-// get a value by key from dict or hdict
-(Dict d)!k::int |
-(Dict d)!k::string |
-(Dict d)!k = d!k
-with
- nil!_ = throw out_of_bounds;
-
- (bin x::int y _ d1 d2)!x1::int |
- (bin x::string y _ d1 d2)!x1::string |
- (bin x y _ d1 d2)!x1
- = d1!x1 if x1 < x;
- = d2!x1 if x1 > x;
- = y
-end;
-
-(Hdict d)!k = lookup d (hash k) k
-with
- lookup nil _ _ = throw out_of_bounds;
-
- lookup (bin k::int xys _ d1 d2) k1::int x1
- = lookup d1 k1 x1 if k > k1;
- = lookup d2 k1 x1 if k < k1;
- = lookupk xys x1;
-
- lookupk [] _ = throw out_of_bounds;
- lookupk ((xa => y):_ ) xb = y if xa === xb;
- lookupk ( _ :xys) x = lookupk xys x
-end;
-
-// slicing (get list of values from list of keys)
-(Dict d)!!xs = slice d [] xs
-with
- slice d ys (x:xs) = slice d
- (case mbr of nil = ys;
- (nonil y) = (y:ys) end) xs
- when
- mbr = d!x
- end;
- slice d ys [] = reverse ys;
-
- nil!_ = nil;
- (bin x::int y _ d1 d2)!x1::int |
- (bin x::string y _ d1 d2)!x1::string |
- (bin x y _ d1 d2)!x1
- = d1!x1 if x1 < x;
- = d2!x1 if x1 > x;
- = nonil y
-end;
-
-(Hdict d)!!xs = slice d [] xs
-with
- slice d ys (x:xs) = slice d
- (case mbr of nil = ys;
- (nonil y) = (y:ys) end) xs
- when
- mbr = lookup d (hash x) x
- end;
- slice d ys [] = reverse ys;
-
- lookup nil _ _ = nil;
- lookup (bin k::int xys _ d1 d2) k1::int x1
- = lookup d1 k1 x1 if k > k1;
- = lookup d2 k1 x1 if k < k1;
- = lookupk xys x1;
-
- lookupk [] _ = nil;
- lookupk ((xa => y):_ ) xb = nonil y if xa === xb;
- lookupk ( _ :xys) x = lookupk xys x
-end;
-
-// curried version of insert for dict and hdict
-update d@(Dict _) x::int y |
-update d@(Dict _) x::string y |
-update d@(Dict _) x y |
-update d@(Hdict _) x y
- = insert d (x => y);
-
-// equality checks for dict and hdict
-d1@(Dict _) == d2@(Dict _) = (members d1) == (members d2);
-
-d1@(Hdict _) == d2@(Hdict _)
- = if (all (member d1) (keys d2))
- then
- if (all (member d2) (keys d1))
- then (vals d1) == (map ((!)d2) (keys d1))
- else 0
- else 0;
-
-
-// inequality checks for dict and hdict
-d1@(Dict _) != d2@(Dict _) = (members d1) != (members d2);
-d1@(Hdict _) != d2@(Hdict _) = not (d1 == d2);
-
-/* Private functions, don't invoke these directly. */
-
-Dict_adjustd ToF::int tree LoR::int
- = adjust ToF tree LoR
-with
- adjust 0 oldTree _ = [oldTree, 0];
-
- adjust 1 (bin key::int val b0 l r) LoR |
- adjust 1 (bin key::string val b0 l r) LoR |
- adjust 1 (bin key val b0 l r) LoR
- = rebal toBeRebalanced (bin key val b0 l r) b1 whatHasChanged
- when
- [b1, whatHasChanged, toBeRebalanced] = tabled b0 LoR
- end;
-
- rebal 0 (bin k::int v _ l r) b whatHasChanged |
- rebal 0 (bin k::string v _ l r) b whatHasChanged |
- rebal 0 (bin k v _ l r) b whatHasChanged
- = [bin k v b l r, whatHasChanged];
-
- rebal 1 oldTree _ _ = Dict_avl_geq oldTree;
-
-// Balance rules for deletions
-// balance where balance whole tree to be
-// before deleted after decreased rebalanced
-tabled ( 0) ( 1) = [( 1), 0, 0];
-tabled ( 0) (-1) = [(-1), 0, 0];
-tabled ( 1) ( 1) = [( 0), 1, 1];
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-
-tabled ( 1) (-1) = [( 0), 1, 0];
-tabled (-1) ( 1) = [( 0), 1, 0];
-tabled (-1) (-1) = [( 0), 1, 1];
-// ^^^^
-// It depends on the tree pattern in avl_geq whether it really decreases
-end;
-
-// Single and double tree rotations - these are common for insert and delete
-/*
- The patterns (-1)-(-1), (-1)-( 1), ( 1)-( 1) and ( 1)-(-1) on the LHS always
- change the tree height and these are the only patterns which can happen
- after an insertion. That's the reason why we can use tablei only to decide
- the needed changes.
- The patterns (-1)-( 0) and ( 1)-( 0) do not change the tree height. After a
- deletion any pattern can occur and so we return 1 or 0 as a flag of
- a height change.
-*/
-Dict_avl_geq d = avl_geq d
-with
- avl_geq (bin a::int va (-1) alpha (bin b::int vb (-1) beta gamma)) |
- avl_geq (bin a::string va (-1) alpha (bin b::string vb (-1) beta gamma)) |
- avl_geq (bin a va (-1) alpha (bin b vb (-1) beta gamma))
- = [bin b vb ( 0) (bin a va ( 0) alpha beta) gamma, 1];
-
- avl_geq (bin a::int va (-1) alpha (bin b::int vb ( 0) beta gamma)) |
- avl_geq (bin a::string va (-1) alpha (bin b::string vb ( 0) beta gamma)) |
- avl_geq (bin a va (-1) alpha (bin b vb ( 0) beta gamma))
- = [bin b vb ( 1) (bin a va (-1) alpha beta) gamma, 0];
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin a::int va (-1) alpha
- (bin b::int vb ( 1)
- (bin x::int vx b1 beta gamma) delta)) |
- avl_geq (bin a::string va (-1) alpha
- (bin b::string vb ( 1)
- (bin x::string vx b1 beta gamma) delta)) |
- avl_geq (bin a va (-1) alpha
- (bin b vb ( 1) (bin x vx b1 beta gamma) delta))
- = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
- when
- [b2, b3] = table b1
- end;
-
- avl_geq (bin b::int vb ( 1) (bin a::int va ( 1) alpha beta) gamma) |
- avl_geq (bin b::string vb ( 1) (bin a::string va ( 1) alpha beta) gamma) |
- avl_geq (bin b vb ( 1) (bin a va ( 1) alpha beta) gamma)
- = [bin a va ( 0) alpha (bin b vb ( 0) beta gamma), 1];
-
- avl_geq (bin b::int vb ( 1) (bin a::int va ( 0) alpha beta) gamma) |
- avl_geq (bin b::string vb ( 1) (bin a::string va ( 0) alpha beta) gamma) |
- avl_geq (bin b vb ( 1) (bin a va ( 0) alpha beta) gamma)
- = [bin a va (-1) alpha (bin b vb ( 1) beta gamma), 0];
- // the tree doesn't decrease with this pattern
-
- avl_geq (bin b::int vb ( 1)
- (bin a::int va (-1) alpha
- (bin x::int vx b1 beta gamma)) delta) |
- avl_geq (bin b::string vb ( 1)
- (bin a::string va (-1) alpha
- (bin x::string vx b1 beta gamma)) delta) |
- avl_geq (bin b vb ( 1)
- (bin a va (-1) alpha (bin x vx b1 beta gamma)) delta)
- = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
- when
- [b2, b3] = table b1
- end;
-
- table ( 1) = [( 0), (-1)];
- table (-1) = [( 1), ( 0)];
- table ( 0) = [( 0), ( 0)]
-end;
Deleted: pure/trunk/examples/heap.pure
===================================================================
--- pure/trunk/examples/heap.pure 2008-07-07 20:46:37 UTC (rev 411)
+++ pure/trunk/examples/heap.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -1,182 +0,0 @@
-/* Pure's priority queue data structure implemented as binary trees */
-
-/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
-
- This file is part of the Pure programming language and system.
-
- Pure 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.
-
- Pure 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/>. */
-
-
-/* Heaps allow quick (constant time) access to the smallest member, and to
- remove the smallest nember and insert new elements in logarithmic time.
- This implementation does not allow quick update of heap members; if
- such functionality is required, bags should be used instead
- (see bag in set.pure).
-
- Heap members must be ordered by the <= predicate. Multiple instances
- of the same element may be stored in a heap; however, the order in
- which equal elements are retrieved is not specified. */
-
-/* Public operations: ******************************************************
-
-// #h // size of a heap
-
-// null h // tests whether h is the empty heap
-// list h, members h // lists members of h in ascending order
-
-// first h // first (i.e. smallest) member of h
-// rmfirst h // remove smallest member from h
-// insert h x // insert h into x
-
- *************************************************************************/
-
-/* Empty tree constant, consider this private. */
-nullary nil;
-
-// create an empty heap
-emptyheap = Heap nil;
-
-// create a heap from a list
-heap xs = foldl insert emptyheap xs if listp xs;
-
-// check whether h is a heap
-heapp (Heap _) = 1;
-heapp _ = 0 otherwise;
-
-// get size of a heap
-#(Heap h) = #h
-with
- #nil = 0;
- #bin 0 _ h1 _ = #h1 * 2 + 1;
- #bin 1 _ h1 _ = #h1 * 2
-end;
-
-// test for an empty heap
-null (Heap nil) = 1;
-null (Heap _) = 0 otherwise;
-
-// get members of a heap as an ordered list
-members h@(Heap _) = [] if null h;
- = accum [first h] (rmfirst h)
-with
- accum ys h = reverse ys if null h;
- = accum ((first h):ys) (rmfirst h)
-end;
-
-list h@(Heap _) = members h;
-
-// get the first (smallest) member of a heap
-first (Heap (bin _ x _ _)) = x;
-
-// remove the first (smallest) member of a heap
-rmfirst (Heap h) = Heap (rmfirst h)
-with
- rmfirst (bin 0 _ nil nil) = nil;
- rmfirst (bin 0 _ h1 h2 ) = update (bin 1 (last h2) h1 (rmlast h2));
- rmfirst (bin 1 _ h1 h2 ) = update (bin 0 (last h1) (rmlast h1) h2);
-
- last (bin 0 x::int nil nil) |
- last (bin 0 x::string nil nil) |
- last (bin 0 x nil nil)
- = x;
- last (bin 0 _ _ h2) = last h2;
- last (bin 1 _ h1 _) = last h1;
-
- update (bin 0 x::int nil nil) |
- update (bin 0 x::string nil nil) |
- update (bin 0 x nil nil)
- = bin 0 x nil nil;
- update (bin 1 x::int (bin b1::int x1::int h1 h2) nil) |
- update (bin 1 x::string (bin b1::int x1::string h1 h2) nil) |
- update (bin 1 x (bin b1::int x1 h1 h2) nil)
- = bin 1 x (bin b1 x1 h1 h2) nil
- if x <= x1;
- = bin 1 x1 (update (bin b1 x h1 h2))
- nil otherwise;
- update (bin b::int x::int (bin b1::int x1::int h1 h2)
- (bin b2::int x2::int h3 h4)) |
- update (bin b::int x::string (bin b1::int x1::string h1 h2)
- (bin b2::int x2::string h3 h4)) |
- update (bin b::int x (bin b1::int x1 h1 h2)
- (bin b2::int x2 h3 h4))
- = bin b x (bin b1 x1 h1 h2) (bin b2 x2 h3 h4)
- if (x <= x1) && (x <= x2);
- = bin b x1 (update (bin b1 x h1 h2))
- (bin b2 x2 h3 h4)
- if x1 <= x2;
- = bin b x2 (bin b1 x1 h1 h2)
- (update (bin b2 x h3 h4))
- otherwise;
-
- rmlast (bin 0 _ nil nil) = nil;
- rmlast (bin 0 x h1 h2 ) = bin 1 x h1 (rmlast h2);
- rmlast (bin 1 x h1 h2 ) = bin 0 x (rmlast h1) h2;
-end;
-
-// insert a new member into a heap
-insert (Heap h) y::int |
-insert (Heap h) y::string |
-insert (Heap h) y = Heap (insert h y)
-with
- insert nil y::int |
- insert nil y::string |
- insert nil y = bin 0 y nil nil;
-
- insert (bin 0 x::int h1 h2) y::int |
- insert (bin 0 x::string h1 h2) y::string |
- insert (bin 0 x h1 h2) y
- = bin 1 x (insert h1 y) h2 if x <= y;
- = bin 1 y (insert h1 x) h2 otherwise;
- insert (bin 1 x::int h1 h2) y::int |
- insert (bin 1 x::string h1 h2) y::string |
- insert (bin 1 x h1 h2) y
- = bin 0 x h1 (insert h2 y) if x <= y;
- = bin 0 y h1 (insert h2 x) otherwise
-end;
-
-// equality test
-(Heap h1) == (Heap h2) = eq h1 h2
-with
- eq nil nil = 1;
- eq nil (bin _ _ _ _) = 0;
- eq (bin _ _ _ _) nil = 0;
- eq (bin b1::int x1::int h1 h2) (bin b2::int x2::int h3 h4) |
- eq (bin b1::int x1::string h1 h2) (bin b2::int x2::string h3 h4) |
- eq (bin b1::int x1 h1 h2) (bin b2::int x2 h3 h4)
- = if (b1 == b2)
- then if (x1 == x2)
- then if eq h1 h3
- then eq h2 h4
- else 0
- else 0
- else 0
-end;;
-
-// inequaliy test
-(Heap h1) != (Heap h2) = neq h1 h2
-with
- neq nil nil = 0;
- neq nil (bin _ _ _ _) = 1;
- neq (bin _ _ _ _) nil = 1;
- neq (bin b1::int x1::int h1 h2) (bin b2::int x2::int h3 h4) |
- neq (bin b1::int x1::string h1 h2) (bin b2::int x2::string h3 h4) |
- neq (bin b1::int x1 h1 h2) (bin b2::int x2 h3 h4)
- = if (b1 != b2)
- then 1
- else if (x1 != x2)
- then 1
- else if neq h1 h3
- then 1
- else neq h2 h4
-end;
Copied: pure/trunk/lib/array.pure (from rev 411, pure/trunk/examples/array.pure)
===================================================================
--- pure/trunk/lib/array.pure (rev 0)
+++ pure/trunk/lib/array.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -0,0 +1,233 @@
+
+/* array.pure: integer-indexed arrays implemented as size-balanced
+ binary trees. */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure 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.
+
+ Pure 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 script implements an efficient variable-sized array data structure
+ which allows to access and update individual array members, as well as
+ to add and remove elements at the beginning and end of an array. All these
+ operations are carried out in logarithmic time. */
+
+/* Public operations: ******************************************************
+
+ emptyarray return the empty array
+ array xs create an array from a list xs
+ array2 xs create a two-dimensional array from a list of lists
+ mkarray x n create an array consisting of n x's
+ mkarray2 x (n,m) create a 2D array of n*m x's
+ arrayp x check whether x is an array
+
+ #a size of a
+ a!i return ith member of a
+ a!(i,j) two-dimensional subscript
+
+ a!!is slicing (get a list of values from a list
+ indices
+ a!!ijs slicing of two-dimensional array (from a given
+ list of pairs (i, j):...:[])
+
+ null a tests whether a is the empty array
+ members a list of values stored in a
+ members2 a list of members in a two-dimensional array
+
+ first a, last a first and last member of A
+ rmfirst a, rmlast a remove first and last member from a
+ insert a x insert x at the beginning of a
+ append a x append x to the end of a
+ update a i x replace the ith member of a by x
+ update2 a (i,j) x update two-dimensional array
+
+ *************************************************************************/
+
+/* Empty tree constant, consider this private. */
+nullary nil;
+
+// array type check
+arrayp (Array _) = 1;
+arrayp _ = 0;
+
+// create an empty array
+emptyarray = Array nil;
+
+// create an array from a list
+array xs = foldl append emptyarray xs if listp xs;
+
+// create a two-dimensional array from a two-dimensional list
+array2 xs = array (map array xs);
+
+// create an array of a given size filled with a constant value
+mkarray x n::int = Array (mkarray x n)
+with
+ mkarray x n::int = nil if n <= 0;
+ = tip x if n == 1;
+ = array_mkbin (n mod 2)
+ (mkarray x (n - n div 2))
+ (mkarray x (n div 2));
+end;
+
+// create a 2D array of given dimensions filled with a constant value
+mkarray2 x (n::int, m::int) = mkarray (mkarray x m) n;
+
+// get array size
+#(Array a) = #a
+with
+ #nil = 0;
+ #(tip _) = 1;
+ #(bin 0 a1 _) = #a1 * 2;
+ #(bin 1 a1 _) = #a1 * 2 - 1;
+end;
+
+// get value by index
+(Array a)!i::int = a!i
+with
+ (tip x)!0 = x;
+ (bin _ a1 a2)!i::int = a1!(i div 2) if i mod 2 == 0;
+ = a2!(i div 2) if i mod 2 == 1;
+ _ ! _ = throw out_of_bounds;
+end;
+
+// get value by indices from two-dimensional array
+x@(Array _)!(i::int, j::int) = x!i!j;
+
+// slicing (get list of values from list of indices)
+a@(Array _)!!is@(_::int:_) = [a!i; i = is; (i >= 0) && (i < (#a))];
+
+// slicing of two-dimensional array
+a@(Array _)!!ijs@((_::int, _::int):_)
+ = [a!(i, j); (i, j) = ijs; (i >= 0) && (i < (#a))
+ && (j >= 0) && (j < (#(a!i)))];
+
+// check for an empty array
+null (Array nil) = 1;
+null (Array _) = 0;
+
+// get all array members in list form
+members (Array a) = members a
+with
+ members nil = [];
+ members (tip x) = [x];
+ members (bin _ a1 a2) = merge (members a1) (members a2);
+ // merge lists xs (even elements) and ys (odd elements)
+ merge [] ys = ys;
+ merge (x:xs) ys = x:merge ys xs;
+end;
+
+// get all members of an two-dimensional array in list form
+members2 x@(Array _) = map members (members x);
+
+// get the first array member
+first (Array a) = first a
+with
+ first (tip x) = x;
+ first (bin _ a1 _) = first a1;
+end;
+
+// get the last array member
+last (Array a) = last a
+with
+ last (tip x) = x;
+ last (bin 0 _ a2) = last a2;
+ last (bin 1 a1 _) = last a1;
+end;
+
+// remove the first member from an array
+rmfirst (Array a) = Array (rmfirst a)
+with
+ rmfirst (tip _) = nil;
+ rmfirst (bin 0 a1 a2) = array_mkbin 1 a2 (rmfirst a1);
+ rmfirst (bin 1 a1 a2) = array_mkbin 0 a2 (rmfirst a1);
+end;
+
+// remove the last member from an array
+rmlast (Array a) = Array (rmlast a)
+with
+ rmlast (tip _) = nil;
+ rmlast (bin 0 a1 a2) = array_mkbin 1 a1 (rmlast a2);
+ rmlast (bin 1 a1 a2) = array_mkbin 0 (rmlast a1) a2;
+end;
+
+// insert a new member at the beginning of an array
+insert (Array a) y = Array (insert a y)
+with
+ insert nil y = tip y;
+ insert (tip x) y = bin 0 (tip y) (tip x);
+ insert (bin 0 a1 a2) y = array_mkbin 1 (insert a2 y) a1;
+ insert (bin 1 a1 a2) y = array_mkbin 0 (insert a2 y) a1;
+end;
+
+// append a new member at the end of an array
+append (Array a) y = Array (append a y)
+with
+ append nil y = tip y;
+ append (tip x) y = bin 0 (tip x) (tip y);
+ append (bin 0 a1 a2) y = array_mkbin 1 (append a1 y) a2;
+ append (bin 1 a1 a2) y = array_mkbin 0 a1 (append a2 y);
+end;
+
+// update a given array position with a new value
+update (Array a) i::int y = Array (update a i y)
+with
+ update (tip _) 0 y = tip y;
+ update (bin b::int a1 a2) i::int y
+ = bin b (update a1 (i div 2) y) a2
+ if i mod 2 == 0;
+ = bin b a1 (update a2 (i div 2) y)
+ if i mod 2 == 1;
+end;
+
+// update a given position of a two-dimensional array with a new value
+update2 x@(Array a) (i::int, j::int) y
+ = update x i (update (x!i) j y);
+
+// compare two arrays for equality
+Array a == Array b = eq a b
+with
+ eq nil nil = 1;
+ eq nil (tip _) = 0;
+ eq nil (bin _ _ _) = 0;
+ eq (tip _) nil = 0;
+ eq (tip x) (tip y) = x == y;
+ eq (tip _) (bin _ _ _) = 0;
+ eq (bin _ _ _) nil = 0;
+ eq (bin _ _ _) (tip _) = 0;
+ eq (bin b1::int a1 a2) (bin b2::int a3 a4)
+ = b1 == b2 && eq a1 a3 && eq a2 a4;
+end;
+
+// compare two arrays for inequality
+Array a != Array b = neq a b
+with
+ neq nil nil = 0;
+ neq nil (tip _) = 1;
+ neq nil (bin _ _ _) = 1;
+ neq (tip _) nil = 1;
+ neq (tip x) (tip y) = x != y;
+ neq (tip _) (bin _ _ _) = 1;
+ neq (bin _ _ _) nil = 1;
+ neq (bin _ _ _) (tip _) = 1;
+ neq (bin b1::int a1 a2) (bin b2::int a3 a4)
+ = b1 != b2 || neq a1 a3 || neq a2 a4;
+end;
+
+/* Private functions, don't invoke these directly. */
+
+// construct a binary array node
+array_mkbin _ nil a2 = a2;
+array_mkbin _ a1 nil = a1;
+array_mkbin b::int a1 a2 = bin b a1 a2;
Copied: pure/trunk/lib/dict.pure (from rev 411, pure/trunk/examples/dict.pure)
===================================================================
--- pure/trunk/lib/dict.pure (rev 0)
+++ pure/trunk/lib/dict.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -0,0 +1,625 @@
+/* Pure's dict and hdict data types based on AVL trees. */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+ Copyright (c) 2008 by Jiri Spitz <jir...@bl...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure 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.
+
+ Pure 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/>. */
+
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ The used algorithm of AVL trees has its origin in the SWI-Prolog
+ implementation of association lists. The original file was created by
+ R. A. O'Keefe and updated for the SWI-Prolog by Jan Wielemaker. For the
+ original file see http://www.swi-prolog.org.
+
+ The port from SWI-Prolog and the deletion stuff (rmfirst, rmlast, delete)
+ missing in the original file was provided by Jiri Spitz
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+/* Empty tree constant, consider this private. */
+nullary nil;
+
+/*****
+Tree for dict and hdict is either:
+- nil (empty tree) or
+- bin Key value Balance Left Right (Left, Right: trees)
+
+Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
+*****/
+
+
+/* Public operations: ******************************************************
+
+emptydict, emptyhdict: return the empty dict or bag
+dict xs, hdict xs; create a dict or hdict from list xs
+dictp d, hdictp d; check whether x is a dict or hdict
+mkdict y xs, mkhdict y xs: create dict or hdict from a list of keys and
+ a constant value
+
+#d size of dict or hdict d
+d!x: get value from d by key x
+d!!xs slicing (get a list of values
+ from a list of keys)
+
+null d tests whether d is the empty dict or hdict
+member d x tests whether d contains member with key x
+members d, list d list members of d (in ascending order fo dict)
+keys d: lists keys of d (in ascending order fo dict)
+values d: list values of d
+
+first d, last d return first and last member of dict
+rmfirst d, rmlast d remove first and last member from dict
+insert d xy insert x into d (replace existing element)
+update d x y fully curried version of insert
+delete d x remove x from d
+
+ *************************************************************************/
+
+
+// Dict and hdict type checks
+dictp (Dict _) = 1;
+dictp _ = 0;
+
+hdictp (Hdict _) = 1;
+hdictp _ = 0;
+
+// create an empty dict or hdict
+emptydict = Dict nil;
+emptyhdict = Hdict nil;
+
+// create dict or hdict from a list
+dict xys = foldl insert emptydict xys if listp xys;
+hdict xys = foldl insert emptyhdict xys if listp xys;
+
+// insert a new member into the dict or hdict
+insert (t@Dict d) (x::int => y) |
+insert (t@Dict d) (x::string => y) |
+insert (t@Dict d) (x => y) |
+insert (t@Hdict d) (x => y)
+ = if t === Dict
+ then t ((insertd d x y)!0)
+ else t ((inserth d (hash x) x y)!0)
+with
+ insertd nil key::int val |
+ insertd nil key::string val |
+ insertd nil key val
+ = [(bin key val ( 0) nil nil), 1];
+
+ insertd (bin k::int _ b l r) key::int val |
+ insertd (bin k::string _ b l r) key::string val |
+ insertd (bin k _ b l r) key val
+ = [(bin key val b l r), 0] if key == k;
+
+ insertd (bin k::int v b l r) key::int val |
+ insertd (bin k::string v b l r) key::string val |
+ insertd (bin k v b l r) key val
+ = adjust leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = insertd l key val
+ end
+ if key < k;
+
+ insertd (bin k::int v b l r) key::int val |
+ insertd (bin k::string v b l r) key::string val |
+ insertd (bin k v b l r) key val
+ = adjust rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = insertd r key val
+ end
+ if key > k;
+
+ inserth nil k::int x y = [(bin k [x => y] ( 0) nil nil), 1];
+
+ inserth (bin k::int v b l r) key::int x y
+ = [(bin k (inserth2 v x y) b l r), 0] if k == key;
+
+ inserth (bin k::int v b l r) key::int x y
+ = adjust leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = inserth l key x y
+ end
+ if key < k;
+
+ inserth (bin k::int v b l r) key::int x y
+ = adjust rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = inserth r key x y
+ end
+ if key > k;
+
+ inserth2 [] x y = [x => y];
+ inserth2 ((x1 => y):xys) x2 y1
+ = ((x1 => y1):xys) if x1 === x2;
+ inserth2 ((x => y):xys) x1 y1
+ = ((x => y ):(inserth2 xys x1 y1));
+
+ adjust 0 oldTree _ = [oldTree, 0];
+
+ adjust 1 (bin key::int val b0 l r) LoR |
+ adjust 1 (bin key::string val b0 l r) LoR |
+ adjust 1 (bin key val b0 l r) LoR
+ = [rebal toBeRebalanced (bin key val b0 l r) b1, whatHasChanged]
+ when
+ [b1, whatHasChanged, toBeRebalanced] = table b0 LoR
+ end;
+
+ rebal 0 (bin k::int v _ l r) b |
+ rebal 0 (bin k::string v _ l r) b |
+ rebal 0 (bin k v _ l r) b
+ = bin k v b l r;
+
+ rebal 1 oldTree _ = (Dict_avl_geq oldTree)!0;
+
+// Balance rules for insertions
+// balance where balance whole tree to be
+// before inserted after increased rebalanced
+table ( 0) (-1) = [( 1), 1, 0];
+table ( 0) ( 1) = [(-1), 1, 0];
+table ( 1) (-1) = [( 0), 0, 1];
+table ( 1) ( 1) = [( 0), 0, 0];
+table (-1) (-1) = [( 0), 0, 0];
+table (-1) ( 1) = [( 0), 0, 1]
+end;
+
+// delete a member by key from the dict or hdict
+delete (t@Dict d) x::int |
+delete (t@Dict d) x::string |
+delete (t@Dict d) x |
+delete (t@Hdict d) x
+ = if t === Dict
+ then t ((deleted d x)!0)
+ else t ((deleteh d (hash x) x)!0)
+with
+ deleted nil _ = [nil, 0];
+
+ deleted (bin k::int _ _ nil r ) key::int |
+ deleted (bin k::string _ _ nil r ) key::string |
+ deleted (bin k _ _ nil r ) key
+ = [r, 1] if key == k;
+
+ deleted (bin k::int _ _ l nil) key::int |
+ deleted (bin k::string _ _ l nil) key::string |
+ deleted (bin k _ _ l nil) key
+ = [l, 1] if key == k;
+
+ deleted (bin k::int _ b (bin kl::int vl bl rl ll) r ) key::int |
+ deleted (bin k::string _ b (bin kl::string vl bl rl ll) r ) key::string |
+ deleted (bin k _ b (bin kl vl bl rl ll) r ) key
+ = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
+ when
+ [lastk, lastv] = last (bin kl vl bl rl ll);
+ [newl, leftHasChanged]
+ = rmlast (bin kl vl bl rl ll)
+ end
+ if key == k;
+
+ deleted (bin k::int v b l r) key::int |
+ deleted (bin k::string v b l r) key::string |
+ deleted (bin k v b l r) key
+ = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = deleted l key
+ end
+ if key < k;
+
+ deleted (bin k::int v b l r) key::int |
+ deleted (bin k::string v b l r) key::string |
+ deleted (bin k v b l r) key
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = deleted r key
+ end
+ if key > k;
+
+ deleteh nil _ _ = [nil, 0];
+
+ deleteh (bin k::int xys b nil r ) key::int x
+ = (if (newxys == [])
+ then [r, 1]
+ else [bin k newxys b nil r, 0])
+ when
+ newxys = deleteh2 xys x
+ end
+ if k == key;
+
+ deleteh (bin k::int xys b l nil) key::int x
+ = (if (newxys == [])
+ then [l, 1]
+ else [bin k newxys b l nil, 0])
+ when
+ newxys = deleteh2 xys x
+ end
+ if k == key;
+
+ deleteh (bin k::int xys b (bin kl vl bl rl ll) r) key::int x
+ = Dict_adjustd leftHasChanged (bin lastk lastv b newl r) (-1)
+ when
+ [lastk, lastv] = last (bin kl vl bl rl ll);
+ [newl, leftHasChanged] = rmlast (bin kl vl bl rl ll)
+ end
+ if (k == key) && ((deleteh2 xys x) == []);
+
+ deleteh (bin k::int xys b l r) key::int x
+ = [bin key (deleteh2 xys x) b l r, 0]
+ if k == key;
+
+ deleteh (bin k::int v b l r) key::int x
+ = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = deleteh l key x
+ end
+ if key < k;
+
+ deleteh (bin k::int v b l r) key::int x
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = deleteh r key x
+ end
+ if key > k;
+
+ deleteh2 [] _ = [];
+ deleteh2 ((x1 => _) : xys) x2 = xys if x1 === x2;
+ deleteh2 ((x => y) : xys) x1 = (x => y) : (deleteh2 xys x1);
+
+ rmlast nil = [nil, 0];
+ rmlast (bin _ _ _ l nil) = [l, 1];
+ rmlast (bin k v b::int l r )
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when [newr, rightHasChanged] = rmlast r end;
+
+ last (bin x y _ _ nil) = [x, y];
+ last (bin _ _ _ _ d2 ) = last d2
+end;
+
+
+// create dict or hdict from a list of keys and a constant value
+mkdict y xs = dict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
+mkhdict y xs = hdict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
+
+// check for the empty dict or hdict
+null (Dict nil) = 1;
+null (Dict _) = 0;
+
+null (Hdict nil) = 1;
+null (Hdict _) = 0;
+
+// get a number of members in dict or hdict
+#(Dict d) = #d
+with
+ #nil = 0;
+ #(bin _ _ _ d1 d2) = #d1 + #d2 + 1
+end;
+
+#(Hdict d) = size d
+with
+ size nil = 0;
+ size (bin _ xys _ d1 d2) = size d1 + size d2 + #xys
+end;
+
+// check whether a key in dict or hdict
+member (Dict d) k::int |
+member (Dict d) k::string |
+member (Dict d) k = member d k
+with
+ member nil _ = 0;
+
+ member (bin x _ _ d1 d2) y::int |
+ member (bin x _ _ d1 d2) y::string |
+ member (bin x _ _ d1 d2) y
+ = member d1 y if x > y;
+ = member d2 y if x < y;
+ = 1 if x == y
+end;
+
+member (Hdict d) k = member d (hash k) k
+with
+ member nil _ _ = 0;
+ member (bin k::int xys _ d1 d2) k1::int x1
+ = member d1 k1 x1 if k > k1;
+ = member d2 k1 x1 if k < k1;
+ = memberk xys x1;
+
+ memberk [] _ = 0;
+ memberk ((x1 => y):_ ) x2 = 1 if x1 === x2;
+ memberk ( _:xys) x2 = memberk xys x2
+end;;
+
+// get all members of dict or hdict
+members (Dict d) = members d
+with
+ members nil = [];
+
+ members (bin x::int y _ d1 d2) |
+ members (bin x::string y _ d1 d2) |
+ members (bin x y _ d1 d2)
+ = members d1 + ((x => y) : (members d2))
+end;
+
+members (Hdict d) = members d
+with
+ members nil = [];
+ members (bin _ xys _ d1 d2) = members d1 + xys + members d2
+end;
+
+list d@(Dict _) |
+list d@(Hdict _) = members d;
+
+// get the first member of a dict
+first (Dict d) = first d
+with
+ first (bin x y _ nil _) = (x => y);
+ first (bin _ _ _ d1 _) = first d1
+end;
+
+// get the last member of a dict
+last (Dict d) = last d
+with
+ last (bin x y _ _ nil) = (x => y);
+ last (bin _ _ _ _ d2 ) = last d2
+end;
+
+// remove the first member from a dict
+rmfirst (Dict d) = Dict ((rmfirst d)!0)
+with
+ rmfirst nil = [nil, 0];
+ rmfirst (bin _ _ _ nil r) = [r, 1];
+ rmfirst (bin k v b l r)
+ = Dict_adjustd leftHasChanged (bin k v b newl r) (-1)
+ when
+ [newl, leftHasChanged] = rmfirst l
+ end
+end;
+
+// remove the last member from a dict
+rmlast (Dict d) = Dict ((rmlast d)!0)
+with
+ rmlast nil = [nil 0];
+ rmlast (bin _ _ _ l nil) = [l, 1];
+ rmlast (bin k v b l r)
+ = Dict_adjustd rightHasChanged (bin k v b l newr) ( 1)
+ when
+ [newr, rightHasChanged] = rmlast r
+ end
+end;
+
+// get a list of all keys from dict or hdict
+keys (Dict d) = keys d
+with
+ keys nil = [];
+
+ keys (bin x::int _ _ d1 d2) |
+ keys (bin x::string _ _ d1 d2) |
+ keys (bin x _ _ d1 d2)
+ = keys d1 + (x : (keys d2))
+end;
+
+keys (Hdict d) = keys d
+with
+ keys nil = [];
+ keys (bin _ xys _ d1 d2) = keys d1 + map (\(key => _) -> key) xys + keys d2
+end;
+
+// get a list of all values from dict or hdict
+vals (Dict d) = vals d
+with
+ vals nil = [];
+ vals (bin _ y _ d1 d2) = vals d1 + (y : (vals d2))
+end;
+
+vals (Hdict d) = vals d
+with
+ vals nil = [];
+ vals (bin _ xys _ d1 d2) = vals d1 +
+ map (\(_ => val) -> val) xys +
+ vals d2
+end;
+
+// get a value by key from dict or hdict
+(Dict d)!k::int |
+(Dict d)!k::string |
+(Dict d)!k = d!k
+with
+ nil!_ = throw out_of_bounds;
+
+ (bin x::int y _ d1 d2)!x1::int |
+ (bin x::string y _ d1 d2)!x1::string |
+ (bin x y _ d1 d2)!x1
+ = d1!x1 if x1 < x;
+ = d2!x1 if x1 > x;
+ = y
+end;
+
+(Hdict d)!k = lookup d (hash k) k
+with
+ lookup nil _ _ = throw out_of_bounds;
+
+ lookup (bin k::int xys _ d1 d2) k1::int x1
+ = lookup d1 k1 x1 if k > k1;
+ = lookup d2 k1 x1 if k < k1;
+ = lookupk xys x1;
+
+ lookupk [] _ = throw out_of_bounds;
+ lookupk ((xa => y):_ ) xb = y if xa === xb;
+ lookupk ( _ :xys) x = lookupk xys x
+end;
+
+// slicing (get list of values from list of keys)
+(Dict d)!!xs = slice d [] xs
+with
+ slice d ys (x:xs) = slice d
+ (case mbr of nil = ys;
+ (nonil y) = (y:ys) end) xs
+ when
+ mbr = d!x
+ end;
+ slice d ys [] = reverse ys;
+
+ nil!_ = nil;
+ (bin x::int y _ d1 d2)!x1::int |
+ (bin x::string y _ d1 d2)!x1::string |
+ (bin x y _ d1 d2)!x1
+ = d1!x1 if x1 < x;
+ = d2!x1 if x1 > x;
+ = nonil y
+end;
+
+(Hdict d)!!xs = slice d [] xs
+with
+ slice d ys (x:xs) = slice d
+ (case mbr of nil = ys;
+ (nonil y) = (y:ys) end) xs
+ when
+ mbr = lookup d (hash x) x
+ end;
+ slice d ys [] = reverse ys;
+
+ lookup nil _ _ = nil;
+ lookup (bin k::int xys _ d1 d2) k1::int x1
+ = lookup d1 k1 x1 if k > k1;
+ = lookup d2 k1 x1 if k < k1;
+ = lookupk xys x1;
+
+ lookupk [] _ = nil;
+ lookupk ((xa => y):_ ) xb = nonil y if xa === xb;
+ lookupk ( _ :xys) x = lookupk xys x
+end;
+
+// curried version of insert for dict and hdict
+update d@(Dict _) x::int y |
+update d@(Dict _) x::string y |
+update d@(Dict _) x y |
+update d@(Hdict _) x y
+ = insert d (x => y);
+
+// equality checks for dict and hdict
+d1@(Dict _) == d2@(Dict _) = (members d1) == (members d2);
+
+d1@(Hdict _) == d2@(Hdict _)
+ = if (all (member d1) (keys d2))
+ then
+ if (all (member d2) (keys d1))
+ then (vals d1) == (map ((!)d2) (keys d1))
+ else 0
+ else 0;
+
+
+// inequality checks for dict and hdict
+d1@(Dict _) != d2@(Dict _) = (members d1) != (members d2);
+d1@(Hdict _) != d2@(Hdict _) = not (d1 == d2);
+
+/* Private functions, don't invoke these directly. */
+
+Dict_adjustd ToF::int tree LoR::int
+ = adjust ToF tree LoR
+with
+ adjust 0 oldTree _ = [oldTree, 0];
+
+ adjust 1 (bin key::int val b0 l r) LoR |
+ adjust 1 (bin key::string val b0 l r) LoR |
+ adjust 1 (bin key val b0 l r) LoR
+ = rebal toBeRebalanced (bin key val b0 l r) b1 whatHasChanged
+ when
+ [b1, whatHasChanged, toBeRebalanced] = tabled b0 LoR
+ end;
+
+ rebal 0 (bin k::int v _ l r) b whatHasChanged |
+ rebal 0 (bin k::string v _ l r) b whatHasChanged |
+ rebal 0 (bin k v _ l r) b whatHasChanged
+ = [bin k v b l r, whatHasChanged];
+
+ rebal 1 oldTree _ _ = Dict_avl_geq oldTree;
+
+// Balance rules for deletions
+// balance where balance whole tree to be
+// before deleted after decreased rebalanced
+tabled ( 0) ( 1) = [( 1), 0, 0];
+tabled ( 0) (-1) = [(-1), 0, 0];
+tabled ( 1) ( 1) = [( 0), 1, 1];
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+
+tabled ( 1) (-1) = [( 0), 1, 0];
+tabled (-1) ( 1) = [( 0), 1, 0];
+tabled (-1) (-1) = [( 0), 1, 1];
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+end;
+
+// Single and double tree rotations - these are common for insert and delete
+/*
+ The patterns (-1)-(-1), (-1)-( 1), ( 1)-( 1) and ( 1)-(-1) on the LHS always
+ change the tree height and these are the only patterns which can happen
+ after an insertion. That's the reason why we can use tablei only to decide
+ the needed changes.
+ The patterns (-1)-( 0) and ( 1)-( 0) do not change the tree height. After a
+ deletion any pattern can occur and so we return 1 or 0 as a flag of
+ a height change.
+*/
+Dict_avl_geq d = avl_geq d
+with
+ avl_geq (bin a::int va (-1) alpha (bin b::int vb (-1) beta gamma)) |
+ avl_geq (bin a::string va (-1) alpha (bin b::string vb (-1) beta gamma)) |
+ avl_geq (bin a va (-1) alpha (bin b vb (-1) beta gamma))
+ = [bin b vb ( 0) (bin a va ( 0) alpha beta) gamma, 1];
+
+ avl_geq (bin a::int va (-1) alpha (bin b::int vb ( 0) beta gamma)) |
+ avl_geq (bin a::string va (-1) alpha (bin b::string vb ( 0) beta gamma)) |
+ avl_geq (bin a va (-1) alpha (bin b vb ( 0) beta gamma))
+ = [bin b vb ( 1) (bin a va (-1) alpha beta) gamma, 0];
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin a::int va (-1) alpha
+ (bin b::int vb ( 1)
+ (bin x::int vx b1 beta gamma) delta)) |
+ avl_geq (bin a::string va (-1) alpha
+ (bin b::string vb ( 1)
+ (bin x::string vx b1 beta gamma) delta)) |
+ avl_geq (bin a va (-1) alpha
+ (bin b vb ( 1) (bin x vx b1 beta gamma) delta))
+ = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end;
+
+ avl_geq (bin b::int vb ( 1) (bin a::int va ( 1) alpha beta) gamma) |
+ avl_geq (bin b::string vb ( 1) (bin a::string va ( 1) alpha beta) gamma) |
+ avl_geq (bin b vb ( 1) (bin a va ( 1) alpha beta) gamma)
+ = [bin a va ( 0) alpha (bin b vb ( 0) beta gamma), 1];
+
+ avl_geq (bin b::int vb ( 1) (bin a::int va ( 0) alpha beta) gamma) |
+ avl_geq (bin b::string vb ( 1) (bin a::string va ( 0) alpha beta) gamma) |
+ avl_geq (bin b vb ( 1) (bin a va ( 0) alpha beta) gamma)
+ = [bin a va (-1) alpha (bin b vb ( 1) beta gamma), 0];
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin b::int vb ( 1)
+ (bin a::int va (-1) alpha
+ (bin x::int vx b1 beta gamma)) delta) |
+ avl_geq (bin b::string vb ( 1)
+ (bin a::string va (-1) alpha
+ (bin x::string vx b1 beta gamma)) delta) |
+ avl_geq (bin b vb ( 1)
+ (bin a va (-1) alpha (bin x vx b1 beta gamma)) delta)
+ = [bin x vx ( 0) (bin a va b2 alpha beta) (bin b vb b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end;
+
+ table ( 1) = [( 0), (-1)];
+ table (-1) = [( 1), ( 0)];
+ table ( 0) = [( 0), ( 0)]
+end;
Copied: pure/trunk/lib/heap.pure (from rev 411, pure/trunk/examples/heap.pure)
===================================================================
--- pure/trunk/lib/heap.pure (rev 0)
+++ pure/trunk/lib/heap.pure 2008-07-07 22:07:25 UTC (rev 412)
@@ -0,0 +1,182 @@
+/* Pure's priority queue data structure implemented as binary trees */
+
+/* Copyright (c) 2008 by Albert Graef <Dr....@t-...>.
+
+ This file is part of the Pure programming language and system.
+
+ Pure 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.
+
+ Pure is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied w...
[truncated message content] |
|
From: <js...@us...> - 2008-07-07 20:46:28
|
Revision: 411
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=411&view=rev
Author: jspitz
Date: 2008-07-07 13:46:37 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Add slicing operation
Modified Paths:
--------------
pure/trunk/examples/array.pure
pure/trunk/examples/dict.pure
Modified: pure/trunk/examples/array.pure
===================================================================
--- pure/trunk/examples/array.pure 2008-07-07 14:22:07 UTC (rev 410)
+++ pure/trunk/examples/array.pure 2008-07-07 20:46:37 UTC (rev 411)
@@ -37,6 +37,11 @@
a!i return ith member of a
a!(i,j) two-dimensional subscript
+ a!!is slicing (get a list of values from a list
+ indices
+ a!!ijs slicing of two-dimensional array (from a given
+ list of pairs (i, j):...:[])
+
null a tests whether a is the empty array
members a list of values stored in a
members2 a list of members in a two-dimensional array
@@ -100,6 +105,14 @@
// get value by indices from two-dimensional array
x@(Array _)!(i::int, j::int) = x!i!j;
+// slicing (get list of values from list of indices)
+a@(Array _)!!is@(_::int:_) = [a!i; i = is; (i >= 0) && (i < (#a))];
+
+// slicing of two-dimensional array
+a@(Array _)!!ijs@((_::int, _::int):_)
+ = [a!(i, j); (i, j) = ijs; (i >= 0) && (i < (#a))
+ && (j >= 0) && (j < (#(a!i)))];
+
// check for an empty array
null (Array nil) = 1;
null (Array _) = 0;
Modified: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-07 14:22:07 UTC (rev 410)
+++ pure/trunk/examples/dict.pure 2008-07-07 20:46:37 UTC (rev 411)
@@ -52,6 +52,8 @@
#d size of dict or hdict d
d!x: get value from d by key x
+d!!xs slicing (get a list of values
+ from a list of keys)
null d tests whether d is the empty dict or hdict
member d x tests whether d contains member with key x
@@ -421,7 +423,9 @@
vals (Hdict d) = vals d
with
vals nil = [];
- vals (bin _ xys _ d1 d2) = vals d1 + map (\(_ => val) -> val) xys + vals d2
+ vals (bin _ xys _ d1 d2) = vals d1 +
+ map (\(_ => val) -> val) xys +
+ vals d2
end;
// get a value by key from dict or hdict
@@ -453,6 +457,47 @@
lookupk ( _ :xys) x = lookupk xys x
end;
+// slicing (get list of values from list of keys)
+(Dict d)!!xs = slice d [] xs
+with
+ slice d ys (x:xs) = slice d
+ (case mbr of nil = ys;
+ (nonil y) = (y:ys) end) xs
+ when
+ mbr = d!x
+ end;
+ slice d ys [] = reverse ys;
+
+ nil!_ = nil;
+ (bin x::int y _ d1 d2)!x1::int |
+ (bin x::string y _ d1 d2)!x1::string |
+ (bin x y _ d1 d2)!x1
+ = d1!x1 if x1 < x;
+ = d2!x1 if x1 > x;
+ = nonil y
+end;
+
+(Hdict d)!!xs = slice d [] xs
+with
+ slice d ys (x:xs) = slice d
+ (case mbr of nil = ys;
+ (nonil y) = (y:ys) end) xs
+ when
+ mbr = lookup d (hash x) x
+ end;
+ slice d ys [] = reverse ys;
+
+ lookup nil _ _ = nil;
+ lookup (bin k::int xys _ d1 d2) k1::int x1
+ = lookup d1 k1 x1 if k > k1;
+ = lookup d2 k1 x1 if k < k1;
+ = lookupk xys x1;
+
+ lookupk [] _ = nil;
+ lookupk ((xa => y):_ ) xb = nonil y if xa === xb;
+ lookupk ( _ :xys) x = lookupk xys x
+end;
+
// curried version of insert for dict and hdict
update d@(Dict _) x::int y |
update d@(Dict _) x::string y |
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-07 14:22:00
|
Revision: 410
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=410&view=rev
Author: yes
Date: 2008-07-07 07:22:07 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
generalised computation of all kinds of cycles, added use of strftime, improved comments, moreless complete now
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-07 11:19:13 UTC (rev 409)
+++ pure/trunk/examples/libor/date.pure 2008-07-07 14:22:07 UTC (rev 410)
@@ -10,25 +10,25 @@
returns Posix time based on UTC (Universal Temps Coordinat) or TAI
(Temps Atomique International) rather than local daylight saving time */
-using system; // import printf, time, ctime, gmtime, gettimeofday
-// extern long time(long*) = c_time; //diy time, no longer needed
+using system; // imports printf, time, ctime, gmtime, gettimeofday, strftime
+// extern long time(long*) = c_time; // diy time, no longer needed
// diytime = c_time (pointer 0);
puts "****************************************************************";
puts "* New Calendar/Clock, Copyright (c) 2008 by Libor Spacek *";
puts "****************************************************************";
-// def posixepoch = (12:17:16:7:5); // Mayan long count date of the posix epoch
-def mdayposix = 1856305;// Mayan day for the posix epoch Jan 1 1970
-def jdayposix = 2440588;// Julian day for the posix epoch
+// some constants in whole days
+def mdayposix = 1856305;// Mayan day for the posix epoch 1 Jan 1970
+def jdayposix = 2440588;// Julian day (since 1 Jan 4713 BC) for the posix epoch
def cycledays = 1872000;// end of cycle: total days in 13 Baktuns
-
+// some constants in whole seconds
def secsinday = 86400; // number of seconds in a day
-def trueyear = 31556941;// (in seconds) divisible by 13 = current true year
+def trueyear = 31556941;// current true year (divisible by 13)
def myyear = 31556943;// div by 2277, secsinday compatible, 365.2424 days
def gregyear = 31556952;// div by 40824, mean gregorian year, 365.2425 days
-def lunarmonth = 2551443; // lunar (synodic) month to the nearest second
-def newmoon = 1215051540;// 3rd July 2008, 2:19 am, new moon in posix seconds
-def venussyn = 50450688;// seconds in a Venus synodic cycle
+def lunarmonth = 2551443; // duration of the lunar synodic month
+def fullmoon = 1213810200;// 18th June 2008, 17:30, full moon in posix seconds
+def venussyn = 50450688;// duration of the Venus synodic cycle
def venusinf = 1187409600;// 18th August 2007, 4am Venus inferior conjunction
// current values in posix time supplied by C time();
@@ -37,10 +37,12 @@
// strip the inconvenient \n off strings given by ctime, gmtime
stripnl s::string = init s;
-// either mayan or julian posix epoch (and posix time) as a mjday number
-mjday epoch::int secs::int |mjday epoch::int secs::bigint= epoch+secs/secsinday;
+// either mayan or julian posix epoch (plus posix seconds), gives a double mjday
+// to get current pday, use simple: secs2days time
+mjday epoch::int secs::int| mjday epoch::int secs::bigint= epoch+secs/secsinday;
-// first some simple day conversions
+// all conversions between Julian (j) Mayan (m) and Posix (p), done in days
+// jday mday pday are numbers of days since their relevant origins (epochs)
jday2mday day::int | jday2mday day::double = day - jdayposix + mdayposix;
mday2jday day::int | mday2jday day::double = day - mdayposix + jdayposix;
jday2pday day::int | jday2pday day::double = day - jdayposix;
@@ -54,8 +56,8 @@
days2hours d::int| days2hours d::bigint| days2hours d::double= 24*d;
hours2days h::int = h / 24;
-// conversions from/to days:hours:minutes:seconds format
-// seconds can be int or double. d,h,m are ints
+/* conversions from/to days:hours:minutes:seconds format
+ seconds can be int or double. d,h,m are ints */
dhms2secs (d::int:h::int:m::int:s::int) |
dhms2secs (d::int:h::int:m::int:s::double) = 60*(60*(24*d+h)+m)+s;
@@ -74,15 +76,15 @@
d::int = h div 24
end;
-// an arbitrary binary operator applied to two (days:hours:minutes:seconds)
+// an arbitrary binary operator applied to two (days:hours:minutes:seconds)
opdhms op (d1::int:h1::int:m1::int:s1)(d2::int:h2::int:m2::int:s2) =
secs2dhms (op (dhms2secs (d1:h1:m1:s1)) (dhms2secs (d2:h2:m2:s2)));
-// conversions from/to hours:minutes:seconds format for displaying time of day.
-// hours may be more than 24 but use d:h:m:s for longer periods of time
+/* conversions from/to hours:minutes:seconds format for displaying time of day
+ hours may be more than 24 but use d:h:m:s for longer periods of time */
hms2secs (h::int:m::int:s::int) |
hms2secs (h::int:m::int:s::double) = 60*(60*h+m)+s;
-
+
secs2hms secs::int | secs2hms secs::bigint = h:(m mod 60):(int (secs-60*m))
when
m::int = int (secs / 60);
@@ -94,11 +96,11 @@
h::int = m div 60;
end;
-// New Time Format! hours:3mins:10secs:secs = hours:tres:dicis:secs = h:t:d:s
-// the normal seconds are now just a single digit 0-9
-// dicis:secs are easy to read: 6:0 means 60 seconds, 12:5 125 seconds etc.
-// tres - multiply by three to get traditional babylonian minutes
-// hours as usual (24 hour clock)
+/* New Time Format: hours:3mins:10secs:secs = hours:tres:dicis:secs = h:t:d:s
+ the normal seconds are now just a single digit 0-9
+ dicis:secs are easy to read: 6:0 means 60 seconds, 12:5 125 seconds etc.
+ tres - multiply by three to get traditional babylonian minutes
+ hours as usual (24 hour clock) */
htds2secs (h::int:t::int:d::int:s::int)|
htds2secs (h::int:t::int:d::int:s::double) = 10*(18*(20*h+t)+d)+s;
@@ -117,7 +119,17 @@
h::int = t div 20
end;
-// not used yet but could be, as in: addmayan posixepoch (days2mayan posixdays)
+// Mayan 'long count' calendar presentation format
+days2mayan d::int = baktun:(katun mod 20):(tun mod 20):(vinal mod 18):(d mod 20)
+ when
+ vinal =d div 20; tun =vinal div 18; katun =tun div 20; baktun =katun div 20
+ end;
+
+mayan2days (baktun::int:katun::int:tun::int:vinal::int:kin::int) =
+ 20*(18*(20*(20*baktun+katun)+tun)+vinal)+kin;
+
+/* Calculations in Mayan long count format, e.g. addmayan day1 day2
+ probably not needed, is the same as: days2mayan day1+day2; */
addmayan (baktun1::int:katun1::int:tun1::int:vinal1::int:kin1::int)
(baktun2::int:katun2::int:tun2::int:vinal2::int:kin2::int) =
baktun:(katun mod 20):(tun mod 20):(vinal mod 18):(kin mod 20)
@@ -127,26 +139,24 @@
baktun = baktun1+baktun2+(katun div 20)
end;
-days2mayan d::int = baktun:(katun mod 20):(tun mod 20):(vinal mod 18):(d mod 20)
- when
- vinal =d div 20; tun =vinal div 18; katun =tun div 20; baktun =katun div 20
- end;
-
-mayan2days (baktun::int:katun::int:tun::int:vinal::int:kin::int) =
- 20*(18*(20*(20*baktun+katun)+tun)+vinal)+kin;
-
-/* Julian day number for Gregorian dates (D,M,Y). These count the number of
- days since 1 January 4713 BC in the Julian calendar. */
-
+/* Gregorian calendar presentation format: (D,M,Y)
+ unlike the Mayan long count, these dates are historically correct only after
+ the introduction of Gregorian calendar in 1582 (much later in non-catholic
+ countries). Ten days had been 'deleted' by pope Gregory. However, due to
+ ignoring 'pagan' advice, the corrected drift now builds up over the periods
+ of 4,100,200,400 years. This buildup is currently 2.15 days between 1900 and
+ 2100! On top of that, an uncorrected drift still remains, estimated as the
+ minimum of 8 days by the year 12000.
+ These reasons make the Gregorian calendar dates useless for astronomical
+ purposes. Julian days (acknowledgement to Julius Caesar) are still used
+ and conversions to either Julian days or Mayan days are necessary. */
greg2jdays (D::int,M::int,Y::int) =
D+(153*M+2) div 5+365*Y+Y div 4-Y div 100+Y div 400-32045
when A = (14-M) div 12; Y = Y+4800-A; M = M+12*A-3 end;
greg2pdays date@(D::int,M::int,Y::int) = jday2pday (greg2jdays date);
-
-/* Gregorian date (D,M,Y) for Julian day number. Please note that these dates
- are historically correct only after the introduction of the Gregorian
- calendar in 1582 (even much later in some countries). */
+greg2psecs g hms =
+ (days2secs (greg2pdays g)) + (hms2secs hms); // date time -> psecs
jdays2greg N::int =
(E-(153*M+2) div 5+1, M+3-12*(M div 10), 100*B+D-4800+M div 10)
@@ -157,22 +167,28 @@
pdays2greg N::int = jdays2greg (pday2jday N);
-// conjunction phase (of Moon and Venus for now) at psecs (posix seconds) time
-// expressed as percentage: inferior conjunction = 0% (new moon), superior=100%
-phase init::int length::int psecs::int |
-phase init::int length::int psecs::bigint =
- if (mf > 0.5) then 200.0*(1.0-mf) else 200.0*mf
- when mf = ((psecs-init) mod length)/length end;
+/* phase of a cycle of 'length' from 'init' at time 'now' (must be same units)
+ this is surprisingly accurate without computing the full orbital elements */
+x::double mod y::int =
+ (x - intx) + (intx mod y) when intx = (int x) end; // mod of a double
+phase init::int length::int now::int |
+phase init::int length::int now::bigint |
+phase init::int length::int now::double = ((now-init) mod length)/length;
+
+// same as above but returns dhms till the completion
+completion init::int length::int now::int |
+completion init::int length::int now::bigint |
+completion init::int length::int now::double = length - ((now-init) mod length);
// for now, let's just do some simple calculations to print
-moonpercent = phase newmoon lunarmonth time;
-vp = phase venusinf venussyn time;
-daytoday = mjday mdayposix time; // mayan day (double)
-mayantoday = days2mayan (int daytoday); // as above but in the long count format
-daysleft = cycledays - daytoday;
-mayanleft = days2mayan ((int daysleft));
-timeleft = secs2htds (secsinday - secsnow);
-percentcomplete = 100.0*daytoday/cycledays;
+nextfmoon = secs2days (completion fullmoon lunarmonth time); // in seconds
+nextvenus = secs2days (completion venusinf venussyn time);
+jdaytoday = int (mjday jdayposix time); // whole julian day
+daytoday = mjday mdayposix time; // double mayan day
+longtoday = str (days2mayan (int daytoday));
+nextcycle = completion 0 cycledays daytoday; // now in days
+mayanleft = str (days2mayan (int nextcycle));
+complete = 100.0*(phase 0 cycledays daytoday);
usage = puts "Usage: pure -x date.pure [anyarg]" $
puts "\tanyarg for help\n";
@@ -180,21 +196,19 @@
// here are test prints of some facts
case argc of
1 =
- puts ((stripnl (ctime time)) + " Local Timestamp") $
- puts ((stripnl (gmtime time)) + " UTC Timestamp") $
-// printf "%s \tToday's Gregorian Date\n"(str(date(mday2jday(int daytoday))))$
-// printf "%s \tUTC Time in h:m:s\n" (str (secs2hms secsnow)) $
-// printf "%s \tUTC Time in h:t:d:s\n" (str (secs2htds secsnow))$
- printf "%7.4f %%\t\t Fullness of the Moon\n" moonpercent $
- printf "%7.4f %%\t\t Venus between inf. and sup. conjunction\n" vp $
- printf "%d \t\t Mayan day number\n" (int daytoday) $
- printf "%d \t\t Julian day number\n" (int (mjday jdayposix time)) $
- printf "%s\t\t Mayan long count date for today\n" (str mayantoday) $
- printf "%s\t\t Long countdown to the end of this cycle\n"
- (str mayanleft) $
-// printf "%s \tTime (h:t:d:s) countdown of today\n" (str timeleft) $
- printf "%11.8f %%\t\t Completion of this cycle of >5125 years\n"
- percentcomplete $
+ puts ((strftime "%x" time) + "\t Gregorian preferred date") $
+ puts ((strftime "%X" time) + "\t local time") $
+// puts ((stripnl (gmtime time)) + " UTC Time") $
+ printf "%s \t UTC Time\n" (str (secs2hms secsnow)) $
+ printf "%s \t UTC Time in h:t:d:s\n" (str (secs2htds secsnow))$
+ printf "%d \t Julian day number\n" jdaytoday $
+ printf "%d \t Mayan day number\n" (int daytoday) $
+ printf "%s\t Mayan long count date\n" longtoday $
+ printf "%5.3f \t days till the next full Moon\n" nextfmoon $
+ printf "%6.3f \t days till the next inf. conjunction of Venus\n" nextvenus$
+ printf "%8.3f \t days till the end of the Mayan cycle\n" nextcycle $
+ printf "%s\t long countdown to the end of the cycle\n" mayanleft $
+ printf "%11.8f %%\t completion of this cycle of >5125 years\n" complete $
puts "****************************************************************";
2 =
puts "Mayan long count digits and their ranges of values:" $
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-07 11:19:03
|
Revision: 409
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=409&view=rev
Author: agraef
Date: 2008-07-07 04:19:13 -0700 (Mon, 07 Jul 2008)
Log Message:
-----------
Make slicing work with strings.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/strings.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-07 00:32:43 UTC (rev 408)
+++ pure/trunk/ChangeLog 2008-07-07 11:19:13 UTC (rev 409)
@@ -1,5 +1,7 @@
2008-07-07 Albert Graef <Dr....@t-...>
+ * lib/strings.pure: Make slicing work with strings.
+
* lib/prelude.pure: Fixed a bug in init function. Reported by
Libor Spacek.
Modified: pure/trunk/lib/strings.pure
===================================================================
--- pure/trunk/lib/strings.pure 2008-07-07 00:32:43 UTC (rev 408)
+++ pure/trunk/lib/strings.pure 2008-07-07 11:19:13 UTC (rev 409)
@@ -143,6 +143,11 @@
end;
end when m = #delim end if not null delim;
+/* Slicing. */
+
+s::string!!ns = strcat [s!n; n=ns; n>=0 && n<m]
+ when m::int = #s end;
+
/* Define the customary list operations on strings, so that these can mostly
be used as if they were lists. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-07 00:32:34
|
Revision: 408
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=408&view=rev
Author: yes
Date: 2008-07-06 17:32:43 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
use init in date.pure, improve some indentation in myutils.pure
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
pure/trunk/examples/libor/myutils.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-07 00:14:35 UTC (rev 407)
+++ pure/trunk/examples/libor/date.pure 2008-07-07 00:32:43 UTC (rev 408)
@@ -35,7 +35,7 @@
secsnow = time mod secsinday; // int seconds since midnight
// strip the inconvenient \n off strings given by ctime, gmtime
-stripnl s::string = reverse (tail (reverse s));
+stripnl s::string = init s;
// either mayan or julian posix epoch (and posix time) as a mjday number
mjday epoch::int secs::int |mjday epoch::int secs::bigint= epoch+secs/secsinday;
Modified: pure/trunk/examples/libor/myutils.pure
===================================================================
--- pure/trunk/examples/libor/myutils.pure 2008-07-07 00:14:35 UTC (rev 407)
+++ pure/trunk/examples/libor/myutils.pure 2008-07-07 00:32:43 UTC (rev 408)
@@ -1,7 +1,5 @@
-/* General Utilities
- Copyright (c) 2008 by Libor Spacek */
+/* General Utilities Copyright (c) 2008 by Libor Spacek */
-//(1) Mathematics
//General mathematical iterators over one and two indices
MathIter1 op i1 i2 f = foldl1 op (map f (i1..i2));
@@ -10,14 +8,12 @@
//Examples on how to use the mathematical iterators
Sigma i1 i2 f = MathIter1 (+) i1 i2 f;
-
Pi i1 i2 f = MathIter1 (*) i1 i2 f;
-
Factorial n = Pi 1L n id;
//Binomial using (k, n-k) symmetry and bignum division
Binomial n k = (Pi (k+1L) n id) div (Pi 2L (n-k) id) if n-k < k;
- = (Pi (n-k+1L) n id) div (Pi 2L k id);
+ = (Pi (n-k+1L) n id) div (Pi 2L k id);
// Euclid's recursive greatest common factor algorithm for ints and bignums
Gcf x 0 | Gcf x 0L = x;
@@ -34,5 +30,7 @@
// rotate n items, cf. "rotate n bits instruction" (n can now also be negative)
// example applied to clocks: >head (nrotate (-33) (0..23));
// what time is 33 hrs before midnight? Answer: 15 hrs.
-nrotate n::int l = protate nm l when ll = #l; nm = ll + (n mod ll) end if n<0;
- = protate nm l when nm = n mod #l end;
+nrotate n::int l
+ = protate nm l when ll = #l; nm = ll + (n mod ll) end if n<0;
+ = protate nm l when nm = n mod #l end;
+
\ No newline at end of file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-07 00:14:25
|
Revision: 407
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=407&view=rev
Author: agraef
Date: 2008-07-06 17:14:35 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Updated ChangeLog.
Modified Paths:
--------------
pure/trunk/ChangeLog
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-07 00:14:10 UTC (rev 406)
+++ pure/trunk/ChangeLog 2008-07-07 00:14:35 UTC (rev 407)
@@ -1,5 +1,10 @@
2008-07-07 Albert Graef <Dr....@t-...>
+ * lib/prelude.pure: Fixed a bug in init function. Reported by
+ Libor Spacek.
+
+ * runtime.cc/h, lib/system.pure: Added strftime function.
+
* printer.cc: Add missing parens around low-precedence elements in
proper lists. Reported by Jiri Spitz.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-07 00:14:00
|
Revision: 406
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=406&view=rev
Author: agraef
Date: 2008-07-06 17:14:10 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Bugfix in init function.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-07-06 23:58:01 UTC (rev 405)
+++ pure/trunk/lib/prelude.pure 2008-07-07 00:14:10 UTC (rev 406)
@@ -263,7 +263,7 @@
init [x] = [];
init (x:xs) = accum [x] xs with
- accum ys [] = reverse ys;
+ accum ys [x] = reverse ys;
accum ys (x:xs) = accum (x:ys) xs;
accum ys xs = reverse ys+init xs;
end;
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-07-06 23:58:01 UTC (rev 405)
+++ pure/trunk/test/prelude.log 2008-07-07 00:14:10 UTC (rev 406)
@@ -355,37 +355,37 @@
foldr1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*0:01*/ x/*0:101*/ (foldl1 (flip f/*0:01*/) (reverse xs/*0:11*/));
head (x/*0:101*/:xs/*0:11*/) = x/*0:101*/;
init [x/*0:101*/] = [];
-init (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ [] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+init xs/*0:1*/ {
- rule #0: accum ys [] = reverse ys
+init (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ [x/*0:101*/] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+init xs/*0:1*/ {
+ rule #0: accum ys [x] = reverse ys
rule #1: accum ys (x:xs) = accum (x:ys) xs
rule #2: accum ys xs = reverse ys+init xs
state 0: #0 #1 #2
<var> state 1
state 1: #0 #1 #2
<var> state 2
- [] state 3
- <app> state 4
+ <app> state 3
state 2: #2
- state 3: #0 #2
- state 4: #1 #2
+ state 3: #0 #1 #2
+ <var> state 4
+ <app> state 6
+ state 4: #2
<var> state 5
- <app> state 7
state 5: #2
- <var> state 6
- state 6: #2
- state 7: #1 #2
+ state 6: #0 #1 #2
+ <var> state 7
+ : state 10
+ state 7: #2
<var> state 8
- : state 11
state 8: #2
<var> state 9
state 9: #2
- <var> state 10
- state 10: #2
- state 11: #1 #2
+ state 10: #0 #1 #2
+ <var> state 11
+ state 11: #0 #1 #2
<var> state 12
+ [] state 13
state 12: #1 #2
- <var> state 13
- state 13: #1 #2
+ state 13: #0 #1 #2
} end;
last [x/*0:101*/] = x/*0:101*/;
last (x/*0:101*/:xs/*0:11*/) = last xs/*0:11*/;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 23:57:54
|
Revision: 405
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=405&view=rev
Author: agraef
Date: 2008-07-06 16:58:01 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Added strftime to system.pure.
Modified Paths:
--------------
pure/trunk/lib/system.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/lib/system.pure
===================================================================
--- pure/trunk/lib/system.pure 2008-07-06 22:49:06 UTC (rev 404)
+++ pure/trunk/lib/system.pure 2008-07-06 23:58:01 UTC (rev 405)
@@ -49,14 +49,19 @@
/* Time functions. 'time' reports the current time in seconds since the
"epoch" a.k.a. 00:00:00 UTC, Jan 1 1970. The result is always a bigint (in
- fact, the time value is already 64 bit on many OSes nowadays). The ctime
- and gmtime functions convert a time value to a string in either local time
- or UTC. (Note that the latter is actually a combination of the C gmtime()
- and asctime() functions.) */
+ fact, the time value is already 64 bit on many OSes nowadays). */
extern long pure_time() = time;
+
+/* Functions to format a time value as a string. The ctime and gmtime
+ functions convert a time value to a string in either local time or UTC.
+ The strftime function also formats a time value as local time, using a
+ format specification supplied by the user. See ctime(3), gmtime(3) and
+ strftime(3) for details. */
+
extern char* pure_ctime(long) = ctime;
extern char* pure_gmtime(long) = gmtime;
+extern char* pure_strftime(char* format, long t) = strftime;
/* The gettimeofday function also returns wallclock time as seconds since the
epoch, but theoretically offers resolutions in the microsec range (actual
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-07-06 22:49:06 UTC (rev 404)
+++ pure/trunk/runtime.cc 2008-07-06 23:58:01 UTC (rev 405)
@@ -2349,6 +2349,9 @@
return (int64_t)time(NULL);
}
+/* Note that the following are not thread-safe as they use statically
+ allocated buffers. */
+
extern "C"
char *pure_ctime(int64_t t)
{
@@ -2363,6 +2366,20 @@
return asctime(gmtime(&time));
}
+extern "C"
+char *pure_strftime(const char *format, int64_t t)
+{
+ time_t time = (time_t)t;
+ static char buf[1024];
+ if (!strftime(buf, 1024, format, localtime(&time)))
+ /* The interface to strftime is rather brain-damaged since it returns zero
+ both in case of a buffer overflow and when the resulting string is
+ empty. We just pretend that there cannot be any errors and return an
+ empty string in both cases. */
+ buf[0] = 0;
+ return buf;
+}
+
#ifdef HAVE_GETTIMEOFDAY
#include <sys/time.h>
extern "C"
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-07-06 22:49:06 UTC (rev 404)
+++ pure/trunk/runtime.h 2008-07-06 23:58:01 UTC (rev 405)
@@ -550,11 +550,16 @@
platform incompatibilities. The result is always int64_t, as time_t
nowadays is a 64 bit type on many OSes. We also provide wrappers for
ctime() and gmtime() which convert a time value to a string, using either
- local or UTC time. */
+ the local timezone or UTC. */
int64_t pure_time(void);
+
+/* The following routines allow you to convert a time value to a string, using
+ different formats. See ctime(3), gmtime(3) and strftime(3) for details. */
+
char *pure_ctime(int64_t t);
char *pure_gmtime(int64_t t);
+char *pure_strftime(const char *format, int64_t t);
/* gettimeofday() interface. This may actually be implemented using different
system functions, depending on what's available on the host OS. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-06 22:48:56
|
Revision: 404
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=404&view=rev
Author: yes
Date: 2008-07-06 15:49:06 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
added Venus conjunctions, Gregorian dates, and Julian days
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-06 22:48:40 UTC (rev 403)
+++ pure/trunk/examples/libor/date.pure 2008-07-06 22:49:06 UTC (rev 404)
@@ -2,7 +2,7 @@
Copyright (c) 2008 by Libor Spacek
Acknowledgement: thanks to Dr Albert Graef for his "Q" code for the
- Gregorian date calculation
+ Julian day and Gregorian dates
Usage: pure -x date.pure [-h]
@@ -10,36 +10,47 @@
returns Posix time based on UTC (Universal Temps Coordinat) or TAI
(Temps Atomique International) rather than local daylight saving time */
-using system;
-// extern long time(long*) = c_time; // Now replaced by time in system
+using system; // import printf, time, ctime, gmtime, gettimeofday
+// extern long time(long*) = c_time; //diy time, no longer needed
+// diytime = c_time (pointer 0);
puts "****************************************************************";
puts "* New Calendar/Clock, Copyright (c) 2008 by Libor Spacek *";
puts "****************************************************************";
// def posixepoch = (12:17:16:7:5); // Mayan long count date of the posix epoch
-def mdayposix = 1856305; // Mayan day for the posix epoch Jan 1 1970
-def jdayposix = 2440588; // Julian day for the posix epoch
-// def endofcycle = (13:0:0:0:0); // The end of the cycle
-def cycledays = 1872000; // Total days in 13 Baktuns
-def secsinday = 86400; // number of seconds in a day
+def mdayposix = 1856305;// Mayan day for the posix epoch Jan 1 1970
+def jdayposix = 2440588;// Julian day for the posix epoch
+def cycledays = 1872000;// end of cycle: total days in 13 Baktuns
+
+def secsinday = 86400; // number of seconds in a day
def trueyear = 31556941;// (in seconds) divisible by 13 = current true year
def myyear = 31556943;// div by 2277, secsinday compatible, 365.2424 days
def gregyear = 31556952;// div by 40824, mean gregorian year, 365.2425 days
-def lunarmonth = 2551443; // lunar (synodic) month to the nearest second
-def newmoondhms= (14063:2:19:0); // 3rd July 08 new moon in posix dhms
+def lunarmonth = 2551443; // lunar (synodic) month to the nearest second
+def newmoon = 1215051540;// 3rd July 2008, 2:19 am, new moon in posix seconds
+def venussyn = 50450688;// seconds in a Venus synodic cycle
+def venusinf = 1187409600;// 18th August 2007, 4am Venus inferior conjunction
// current values in posix time supplied by C time();
secsnow = time mod secsinday; // int seconds since midnight
+
+// strip the inconvenient \n off strings given by ctime, gmtime
+stripnl s::string = reverse (tail (reverse s));
-// either mayan or julian day (and time) as a day number (::double)
+// either mayan or julian posix epoch (and posix time) as a mjday number
mjday epoch::int secs::int |mjday epoch::int secs::bigint= epoch+secs/secsinday;
-// first some simple conversions
+// first some simple day conversions
jday2mday day::int | jday2mday day::double = day - jdayposix + mdayposix;
-mday2jday day::int | mday2jday day::double = day - mdayposix + jdayposix;
-
+mday2jday day::int | mday2jday day::double = day - mdayposix + jdayposix;
+jday2pday day::int | jday2pday day::double = day - jdayposix;
+mday2pday day::int | mday2pday day::double = day - mdayposix;
+pday2jday day::int | pday2jday day::double = day + jdayposix;
+pday2mday day::int | pday2mday day::double = day + mdayposix;
+
+// inner units conversions for convenience and readability
secs2days s::int | secs2days s::bigint | secs2days s::double = (s / secsinday);
-days2secs d::int | days2secs d::bigint | deys2secs d::double = secsinday * d;
+days2secs d::int | days2secs d::bigint | days2secs d::double = secsinday * d;
days2hours d::int| days2hours d::bigint| days2hours d::double= 24*d;
hours2days h::int = h / 24;
@@ -124,24 +135,38 @@
mayan2days (baktun::int:katun::int:tun::int:vinal::int:kin::int) =
20*(18*(20*(20*baktun+katun)+tun)+vinal)+kin;
-/* Gregorian date for Julian day number. Please note that these dates are
- historically correct only after the introduction of the Gregorian calendar
- in 1582 (even much later in some countries). */
+/* Julian day number for Gregorian dates (D,M,Y). These count the number of
+ days since 1 January 4713 BC in the Julian calendar. */
-date N::int = (E-(153*M+2) div 5+1, M+3-12*(M div 10), 100*B+D-4800+M div 10)
- when A = N+32044; B = (4*A+3) div 146097;
- C = A-146097*B div 4; D = (4*C+3) div 1461;
- E = C-1461*D div 4; M = (5*E+2) div 153 end;
+greg2jdays (D::int,M::int,Y::int) =
+ D+(153*M+2) div 5+365*Y+Y div 4-Y div 100+Y div 400-32045
+ when A = (14-M) div 12; Y = Y+4800-A; M = M+12*A-3 end;
+
+greg2pdays date@(D::int,M::int,Y::int) = jday2pday (greg2jdays date);
+
+/* Gregorian date (D,M,Y) for Julian day number. Please note that these dates
+ are historically correct only after the introduction of the Gregorian
+ calendar in 1582 (even much later in some countries). */
+
+jdays2greg N::int =
+ (E-(153*M+2) div 5+1, M+3-12*(M div 10), 100*B+D-4800+M div 10)
+ when A = N+32044; B = (4*A+3) div 146097;
+ C = A-146097*B div 4; D = (4*C+3) div 1461;
+ E = C-1461*D div 4; M = (5*E+2) div 153
+ end;
+pdays2greg N::int = jdays2greg (pday2jday N);
-// moon calculations
-moonphase psecs::int | moonphase psecs::bigint =
- ((psecs-(dhms2secs newmoondhms))mod lunarmonth)/lunarmonth;
-// full moon percentage at psecs posix seconds
-fullmoon psecs::int | fullmoon psecs::bigint =
- if mf > 0.5 then 200.0*(1.0-mf) else 200.0*mf when mf = moonphase psecs end;
+// conjunction phase (of Moon and Venus for now) at psecs (posix seconds) time
+// expressed as percentage: inferior conjunction = 0% (new moon), superior=100%
+phase init::int length::int psecs::int |
+phase init::int length::int psecs::bigint =
+ if (mf > 0.5) then 200.0*(1.0-mf) else 200.0*mf
+ when mf = ((psecs-init) mod length)/length end;
// for now, let's just do some simple calculations to print
+moonpercent = phase newmoon lunarmonth time;
+vp = phase venusinf venussyn time;
daytoday = mjday mdayposix time; // mayan day (double)
mayantoday = days2mayan (int daytoday); // as above but in the long count format
daysleft = cycledays - daytoday;
@@ -152,18 +177,23 @@
usage = puts "Usage: pure -x date.pure [anyarg]" $
puts "\tanyarg for help\n";
+// here are test prints of some facts
case argc of
1 =
- printf "%s \tToday's Gregorian Date\n"(str(date(mday2jday(int daytoday))))$
- printf "%s \tUTC Time in h:m:s\n" (str (secs2hms secsnow)) $
- printf "%s \tUTC Time in h:t:d:s\n" (str (secs2htds secsnow))$
- printf "%7.4f %% \tFullness of the Moon\n" (fullmoon time) $
- printf "%d \tMayan day number\n" (int daytoday) $
- printf "%s \tMayan long count notation for this day\n" (str mayantoday) $
- printf "%s \tLong countdown of days to the end of this cycle\n"
+ puts ((stripnl (ctime time)) + " Local Timestamp") $
+ puts ((stripnl (gmtime time)) + " UTC Timestamp") $
+// printf "%s \tToday's Gregorian Date\n"(str(date(mday2jday(int daytoday))))$
+// printf "%s \tUTC Time in h:m:s\n" (str (secs2hms secsnow)) $
+// printf "%s \tUTC Time in h:t:d:s\n" (str (secs2htds secsnow))$
+ printf "%7.4f %%\t\t Fullness of the Moon\n" moonpercent $
+ printf "%7.4f %%\t\t Venus between inf. and sup. conjunction\n" vp $
+ printf "%d \t\t Mayan day number\n" (int daytoday) $
+ printf "%d \t\t Julian day number\n" (int (mjday jdayposix time)) $
+ printf "%s\t\t Mayan long count date for today\n" (str mayantoday) $
+ printf "%s\t\t Long countdown to the end of this cycle\n"
(str mayanleft) $
- printf "%s \tTime (h:t:d:s) countdown of today\n" (str timeleft) $
- printf "%11.8f %%\tCompletion of the Mayan cycle of over 5125 years\n"
+// printf "%s \tTime (h:t:d:s) countdown of today\n" (str timeleft) $
+ printf "%11.8f %%\t\t Completion of this cycle of >5125 years\n"
percentcomplete $
puts "****************************************************************";
2 =
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 22:48:31
|
Revision: 403
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=403&view=rev
Author: agraef
Date: 2008-07-06 15:48:40 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Bugfix in pretty-printing.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/printer.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-06 21:20:06 UTC (rev 402)
+++ pure/trunk/ChangeLog 2008-07-06 22:48:40 UTC (rev 403)
@@ -1,3 +1,8 @@
+2008-07-07 Albert Graef <Dr....@t-...>
+
+ * printer.cc: Add missing parens around low-precedence elements in
+ proper lists. Reported by Jiri Spitz.
+
2008-07-06 Albert Graef <Dr....@t-...>
* lib/prelude.pure: Added new "mapsto" constructor. Requested by
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-07-06 21:20:06 UTC (rev 402)
+++ pure/trunk/printer.cc 2008-07-06 22:48:40 UTC (rev 403)
@@ -250,11 +250,21 @@
prec_t p;
if (x.is_list(xs)) {
// proper list value
+ size_t n = xs.size();
os << "[";
- for (exprl::const_iterator it = xs.begin(); it != xs.end(); ) {
- printx(os, *it, pat);
- if (++it != xs.end()) os << ",";
- }
+ if (n>1) {
+ // list elements at a precedence not larger than ',' have to be
+ // parenthesized
+ p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
+ for (exprl::const_iterator it = xs.begin(); it != xs.end(); ) {
+ os << paren(p, *it, pat);
+ if (++it != xs.end()) os << ",";
+ }
+ } else
+ for (exprl::const_iterator it = xs.begin(); it != xs.end(); ) {
+ printx(os, *it, pat);
+ if (++it != xs.end()) os << ",";
+ }
return os << "]";
} else if (x.is_app(u, v)) {
if (u.ftag() > 0 && (p = sym_nprec(u.ftag())) < 100 && p%10 >= 3) {
@@ -669,12 +679,23 @@
prec_t p;
if (pure_is_list(x, xs)) {
// proper list value
+ size_t n = xs.size();
os << "[";
- for (list<const pure_expr*>::const_iterator it = xs.begin();
- it != xs.end(); ) {
- os << *it;
- if (++it != xs.end()) os << ",";
- }
+ if (n>1) {
+ // list elements at a precedence not larger than ',' have to be
+ // parenthesized
+ p = sym_nprec(interpreter::g_interp->symtab.pair_sym().f) + 1;
+ for (list<const pure_expr*>::const_iterator it = xs.begin();
+ it != xs.end(); ) {
+ os << pure_paren(p, *it);
+ if (++it != xs.end()) os << ",";
+ }
+ } else
+ for (list<const pure_expr*>::const_iterator it = xs.begin();
+ it != xs.end(); ) {
+ os << *it;
+ if (++it != xs.end()) os << ",";
+ }
return os << "]";
}
const pure_expr *u = x->data.x[0], *v = x->data.x[1], *w, *y;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-06 21:20:08
|
Revision: 402
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=402&view=rev
Author: jspitz
Date: 2008-07-06 14:20:06 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Bugfix of 'mkdict', 'mkhdict' and 'update' to use '=>' operator.
Modified Paths:
--------------
pure/trunk/examples/dict.pure
Modified: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-06 17:37:53 UTC (rev 401)
+++ pure/trunk/examples/dict.pure 2008-07-06 21:20:06 UTC (rev 402)
@@ -285,8 +285,8 @@
// create dict or hdict from a list of keys and a constant value
-mkdict y xs = dict (zip xs (repeat (#xs) y)) if listp xs;
-mkhdict y xs = hdict (zip xs (repeat (#xs) y)) if listp xs;
+mkdict y xs = dict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
+mkhdict y xs = hdict (zipwith (=>) xs (repeat (#xs) y)) if listp xs;
// check for the empty dict or hdict
null (Dict nil) = 1;
@@ -458,7 +458,7 @@
update d@(Dict _) x::string y |
update d@(Dict _) x y |
update d@(Hdict _) x y
- = insert d [x, y];
+ = insert d (x => y);
// equality checks for dict and hdict
d1@(Dict _) == d2@(Dict _) = (members d1) == (members d2);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-06 17:37:49
|
Revision: 401
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=401&view=rev
Author: jspitz
Date: 2008-07-06 10:37:53 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Revert changes to equality/inequality tests after moving '=>' to prelude, fix typo.
Modified Paths:
--------------
pure/trunk/examples/dict.pure
Modified: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-06 10:50:05 UTC (rev 400)
+++ pure/trunk/examples/dict.pure 2008-07-06 17:37:53 UTC (rev 401)
@@ -47,7 +47,7 @@
emptydict, emptyhdict: return the empty dict or bag
dict xs, hdict xs; create a dict or hdict from list xs
dictp d, hdictp d; check whether x is a dict or hdict
-mkdict y xs, mkhdixt y xs: create dict or hdict from a list of keys and
+mkdict y xs, mkhdict y xs: create dict or hdict from a list of keys and
a constant value
#d size of dict or hdict d
@@ -461,19 +461,8 @@
= insert d [x, y];
// equality checks for dict and hdict
-d1@(Dict _) == d2@(Dict _) = eq (members d1) (members d2)
-with
- eq [] [] = 1;
- eq (x:xs) [] = 0;
- eq [] (x:xs) = 0;
- eq (x:xs) (y:ys) = if eq x y then eq xs ys else 0;
+d1@(Dict _) == d2@(Dict _) = (members d1) == (members d2);
- eq (x1::int => y1) (x2::int => y2) |
- eq (x1::string => y1) (x2::string => y2) |
- eq (x1 => y1) (x2 => y2)
- = x1 == x2 && y1 == y2
-end;
-
d1@(Hdict _) == d2@(Hdict _)
= if (all (member d1) (keys d2))
then
@@ -484,19 +473,7 @@
// inequality checks for dict and hdict
-d1@(Dict _) != d2@(Dict _) = neq (members d1) (members d2)
-with
- neq [] [] = 0;
- neq (x:xs) [] = 1;
- neq [] (x:xs) = 1;
- neq (x:xs) (y:ys) = if neq x y then 1 else neq xs ys;
-
- neq (x1::int => y1) (x2::int => y2) |
- neq (x1::string => y1) (x2::string => y2) |
- neq (x1 => y1) (x2 => y2)
- = x1 != x2 || y1 != y2
-end;
-
+d1@(Dict _) != d2@(Dict _) = (members d1) != (members d2);
d1@(Hdict _) != d2@(Hdict _) = not (d1 == d2);
/* Private functions, don't invoke these directly. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 10:50:04
|
Revision: 400
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=400&view=rev
Author: agraef
Date: 2008-07-06 03:50:05 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Move '=>' constructor from dict.pure to prelude.pure.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/examples/dict.pure
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/ChangeLog 2008-07-06 10:50:05 UTC (rev 400)
@@ -1,5 +1,8 @@
2008-07-06 Albert Graef <Dr....@t-...>
+ * lib/prelude.pure: Added new "mapsto" constructor. Requested by
+ Jiri Spitz.
+
* runtime.cc (pure_sys_vars): Turn system constants into real
constant definitions.
Modified: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/examples/dict.pure 2008-07-06 10:50:05 UTC (rev 400)
@@ -33,10 +33,6 @@
/* Empty tree constant, consider this private. */
nullary nil;
-/* Definition of the mapsto operator used for key=>value pairs */
-infix 2 => ;
-
-
/*****
Tree for dict and hdict is either:
- nil (empty tree) or
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/lib/prelude.pure 2008-07-06 10:50:05 UTC (rev 400)
@@ -47,6 +47,7 @@
infixr 0 $ ; // right-associative application
infixr 1 , ; // pair (tuple)
+infix 2 => ; // mapsto constructor
infixr 2 || ; // logical or (short-circuit)
infixr 3 && ; // logical and (short-circuit)
prefix 3 not ; // logical negation
@@ -89,6 +90,13 @@
uncurry3 f (x,y,z)
= f x y z;
+/* "Mapsto" operator. This constructor is declared here so that it can be used
+ in other standard library modules to denote special kind of pairs which map
+ keys to values. Here we only define equality of such pairs. */
+
+(x=>v)==(y=>w) = if x==y then v==w else 0;
+(x=>v)!=(y=>w) = if x!=y then 1 else v!=w;
+
/* Poor man's tuples(TM). These are constructed with the pairing operator ',',
are always flat and associate to the right. The empty tuple, denoted (), is
neutral with respect to ','. Operations are provided to test for equality/
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-07-06 10:06:08 UTC (rev 399)
+++ pure/trunk/test/prelude.log 2008-07-06 10:50:05 UTC (rev 400)
@@ -10,6 +10,8 @@
curry3 f/*0:0001*/ x/*0:001*/ y/*0:01*/ z/*0:1*/ = f/*0:0001*/ (x/*0:001*/,y/*0:01*/,z/*0:1*/);
uncurry f/*0:01*/ (x/*0:101*/,y/*0:11*/) = f/*0:01*/ x/*0:101*/ y/*0:11*/;
uncurry3 f/*0:01*/ (x/*0:101*/,y/*0:1101*/,z/*0:111*/) = f/*0:01*/ x/*0:101*/ y/*0:1101*/ z/*0:111*/;
+(x/*0:0101*/=>v/*0:011*/)==(y/*0:101*/=>w/*0:11*/) = if x/*0:0101*/==y/*0:101*/ then v/*0:011*/==w/*0:11*/ else 0;
+(x/*0:0101*/=>v/*0:011*/)!=(y/*0:101*/=>w/*0:11*/) = if x/*0:0101*/!=y/*0:101*/ then 1 else v/*0:011*/!=w/*0:11*/;
x/*0:01*/,() = x/*0:01*/;
(),y/*0:1*/ = y/*0:1*/;
(x/*0:0101*/,y/*0:011*/),z/*0:1*/ = x/*0:0101*/,y/*0:011*/,z/*0:1*/;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 10:05:59
|
Revision: 399
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=399&view=rev
Author: agraef
Date: 2008-07-06 03:06:08 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Cosmetic changes.
Modified Paths:
--------------
pure/trunk/lib/math.pure
Modified: pure/trunk/lib/math.pure
===================================================================
--- pure/trunk/lib/math.pure 2008-07-06 08:54:21 UTC (rev 398)
+++ pure/trunk/lib/math.pure 2008-07-06 10:06:08 UTC (rev 399)
@@ -237,9 +237,9 @@
tan (x+:y) = (sin (2*x) +: sinh (2*y)) / (cos (2*x)+cosh (2*y));
// These are best computed in rect and then converted back to polar.
-sin z@(r<:t) = polar $ sin $ rect z;
-cos z@(r<:t) = polar $ cos $ rect z;
-tan z@(r<:t) = polar $ tan $ rect z;
+sin z@(r<:t) = polar (sin (rect z));
+cos z@(r<:t) = polar (cos (rect z));
+tan z@(r<:t) = polar (tan (rect z));
// Use complex logarithms for the inverses.
asin z@(x+:y) |
@@ -257,9 +257,9 @@
cosh (x+:y) = cosh x*cos y +: sinh x*sin y;
tanh (x+:y) = (sinh (2*x) +: sin (2*y)) / (cosh (2*x)+cos (2*y));
-sinh z@(r<:t) = polar $ sinh $ rect z;
-cosh z@(r<:t) = polar $ cosh $ rect z;
-tanh z@(r<:t) = polar $ tanh $ rect z;
+sinh z@(r<:t) = polar (sinh (rect z));
+cosh z@(r<:t) = polar (cosh (rect z));
+tanh z@(r<:t) = polar (tanh (rect z));
asinh z@(x+:y) |
asinh z@(r<:t) = ln (z+sqrt (z*z+1));
@@ -280,10 +280,10 @@
-(r<:t) = r <: t+pi;
(x1+:y1) + (x2+:y2) = x1+x2 +: y1+y2;
-z1@(r1<:t1)+z2@(r2<:t2) = polar $ rect z1 + rect z2;
+z1@(r1<:t1)+z2@(r2<:t2) = polar (rect z1 + rect z2);
(x1+:y1) - (x2+:y2) = x1-x2 +: y1-y2;
-z1@(r1<:t1)-z2@(r2<:t2) = polar $ rect z1 - rect z2;
+z1@(r1<:t1)-z2@(r2<:t2) = polar (rect z1 - rect z2);
(x1+:y1) * (x2+:y2) = x1*x2-y1*y2 +: x1*y2+y1*x2;
(r1<:t1) * (r2<:t2) = r1*r2 <: t1+t2;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-06 08:54:11
|
Revision: 398
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=398&view=rev
Author: agraef
Date: 2008-07-06 01:54:21 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Bugfix: copy strings in constant definitions. Reported by Eddie Rucker.
Modified Paths:
--------------
pure/trunk/interpreter.cc
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-07-06 07:44:56 UTC (rev 397)
+++ pure/trunk/interpreter.cc 2008-07-06 08:54:21 UTC (rev 398)
@@ -606,7 +606,7 @@
case EXPR::DBL:
return expr(EXPR::DBL, x->data.d);
case EXPR::STR:
- return expr(EXPR::STR, x->data.s);
+ return expr(EXPR::STR, strdup(x->data.s));
case EXPR::PTR:
if (x->data.p != 0)
// Only null pointer constants permitted right now.
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <js...@us...> - 2008-07-06 07:44:49
|
Revision: 397
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=397&view=rev
Author: jspitz
Date: 2008-07-06 00:44:56 -0700 (Sun, 06 Jul 2008)
Log Message:
-----------
Change dict to use '=>' operator; bugfixes in equality/inequality tests.
Modified Paths:
--------------
pure/trunk/examples/dict.pure
Modified: pure/trunk/examples/dict.pure
===================================================================
--- pure/trunk/examples/dict.pure 2008-07-06 01:36:57 UTC (rev 396)
+++ pure/trunk/examples/dict.pure 2008-07-06 07:44:56 UTC (rev 397)
@@ -33,6 +33,10 @@
/* Empty tree constant, consider this private. */
nullary nil;
+/* Definition of the mapsto operator used for key=>value pairs */
+infix 2 => ;
+
+
/*****
Tree for dict and hdict is either:
- nil (empty tree) or
@@ -46,7 +50,7 @@
emptydict, emptyhdict: return the empty dict or bag
dict xs, hdict xs; create a dict or hdict from list xs
-dictp x, hdictp x; check whether x is a dict or hdict
+dictp d, hdictp d; check whether x is a dict or hdict
mkdict y xs, mkhdixt y xs: create dict or hdict from a list of keys and
a constant value
@@ -59,10 +63,11 @@
keys d: lists keys of d (in ascending order fo dict)
values d: list values of d
-first m, last m return first and last member of dict
-rmfirst m, rmlast m remove first and last member from dict
-insert m x insert x into d (replace existing element)
-delete m x remove x from d
+first d, last d return first and last member of dict
+rmfirst d, rmlast d remove first and last member from dict
+insert d xy insert x into d (replace existing element)
+update d x y fully curried version of insert
+delete d x remove x from d
*************************************************************************/
@@ -83,10 +88,10 @@
hdict xys = foldl insert emptyhdict xys if listp xys;
// insert a new member into the dict or hdict
-insert (t@Dict d) [x::int, y] |
-insert (t@Dict d) [x::string, y] |
-insert (t@Dict d) [x, y] |
-insert (t@Hdict d) [x, y]
+insert (t@Dict d) (x::int => y) |
+insert (t@Dict d) (x::string => y) |
+insert (t@Dict d) (x => y) |
+insert (t@Hdict d) (x => y)
= if t === Dict
then t ((insertd d x y)!0)
else t ((inserth d (hash x) x y)!0)
@@ -119,7 +124,7 @@
end
if key > k;
- inserth nil k::int x y = [(bin k [[x, y]] ( 0) nil nil), 1];
+ inserth nil k::int x y = [(bin k [x => y] ( 0) nil nil), 1];
inserth (bin k::int v b l r) key::int x y
= [(bin k (inserth2 v x y) b l r), 0] if k == key;
@@ -138,9 +143,11 @@
end
if key > k;
- inserth2 [] x y = [x, y]:[];
- inserth2 ([x1, y] :xys) x2 y1 = ([x1, y1]:xys) if x1 === x2;
- inserth2 ([x, y] :xys) x1 y1 = ([x, y]:(inserth2 xys x1 y1));
+ inserth2 [] x y = [x => y];
+ inserth2 ((x1 => y):xys) x2 y1
+ = ((x1 => y1):xys) if x1 === x2;
+ inserth2 ((x => y):xys) x1 y1
+ = ((x => y ):(inserth2 xys x1 y1));
adjust 0 oldTree _ = [oldTree, 0];
@@ -267,8 +274,8 @@
if key > k;
deleteh2 [] _ = [];
- deleteh2 ([x1 ,_] : xys) x2 = xys if x1 === x2;
- deleteh2 ([x, y] : xys) x1 = [x, y] : (deleteh2 xys x1);
+ deleteh2 ((x1 => _) : xys) x2 = xys if x1 === x2;
+ deleteh2 ((x => y) : xys) x1 = (x => y) : (deleteh2 xys x1);
rmlast nil = [nil, 0];
rmlast (bin _ _ _ l nil) = [l, 1];
@@ -329,8 +336,8 @@
= memberk xys x1;
memberk [] _ = 0;
- memberk ([x1, y]:_ ) x2 = 1 if x1 === x2;
- memberk ( _:xys) x2 = memberk xys x2
+ memberk ((x1 => y):_ ) x2 = 1 if x1 === x2;
+ memberk ( _:xys) x2 = memberk xys x2
end;;
// get all members of dict or hdict
@@ -341,7 +348,7 @@
members (bin x::int y _ d1 d2) |
members (bin x::string y _ d1 d2) |
members (bin x y _ d1 d2)
- = members d1 + ([x, y] : (members d2))
+ = members d1 + ((x => y) : (members d2))
end;
members (Hdict d) = members d
@@ -356,14 +363,14 @@
// get the first member of a dict
first (Dict d) = first d
with
- first (bin x y _ nil _) = [x, y];
+ first (bin x y _ nil _) = (x => y);
first (bin _ _ _ d1 _) = first d1
end;
// get the last member of a dict
last (Dict d) = last d
with
- last (bin x y _ _ nil) = [x, y];
+ last (bin x y _ _ nil) = (x => y);
last (bin _ _ _ _ d2 ) = last d2
end;
@@ -405,7 +412,7 @@
keys (Hdict d) = keys d
with
keys nil = [];
- keys (bin _ xys _ d1 d2) = keys d1 + map (\d -> d!0) xys + keys d2
+ keys (bin _ xys _ d1 d2) = keys d1 + map (\(key => _) -> key) xys + keys d2
end;
// get a list of all values from dict or hdict
@@ -418,7 +425,7 @@
vals (Hdict d) = vals d
with
vals nil = [];
- vals (bin _ xys _ d1 d2) = vals d1 + map (\d -> d!1) xys + vals d2
+ vals (bin _ xys _ d1 d2) = vals d1 + map (\(_ => val) -> val) xys + vals d2
end;
// get a value by key from dict or hdict
@@ -446,8 +453,8 @@
= lookupk xys x1;
lookupk [] _ = throw out_of_bounds;
- lookupk ([xa,y]: _) xb = y if xa === xb;
- lookupk ( _ :xys) x = lookupk xys x
+ lookupk ((xa => y):_ ) xb = y if xa === xb;
+ lookupk ( _ :xys) x = lookupk xys x
end;
// curried version of insert for dict and hdict
@@ -458,9 +465,20 @@
= insert d [x, y];
// equality checks for dict and hdict
-(Dict d1) == (Dict d2) = (members d1) == (members d2);
+d1@(Dict _) == d2@(Dict _) = eq (members d1) (members d2)
+with
+ eq [] [] = 1;
+ eq (x:xs) [] = 0;
+ eq [] (x:xs) = 0;
+ eq (x:xs) (y:ys) = if eq x y then eq xs ys else 0;
-(Hdict d1) == (Hdict d2)
+ eq (x1::int => y1) (x2::int => y2) |
+ eq (x1::string => y1) (x2::string => y2) |
+ eq (x1 => y1) (x2 => y2)
+ = x1 == x2 && y1 == y2
+end;
+
+d1@(Hdict _) == d2@(Hdict _)
= if (all (member d1) (keys d2))
then
if (all (member d2) (keys d1))
@@ -470,10 +488,21 @@
// inequality checks for dict and hdict
-(Dict d1) != (Dict d2) = (members d1) != (members d2);
-(Hdict d1) != (Hdict d2) = not (d1 == d2);
+d1@(Dict _) != d2@(Dict _) = neq (members d1) (members d2)
+with
+ neq [] [] = 0;
+ neq (x:xs) [] = 1;
+ neq [] (x:xs) = 1;
+ neq (x:xs) (y:ys) = if neq x y then 1 else neq xs ys;
+ neq (x1::int => y1) (x2::int => y2) |
+ neq (x1::string => y1) (x2::string => y2) |
+ neq (x1 => y1) (x2 => y2)
+ = x1 != x2 || y1 != y2
+end;
+d1@(Hdict _) != d2@(Hdict _) = not (d1 == d2);
+
/* Private functions, don't invoke these directly. */
Dict_adjustd ToF::int tree LoR::int
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ye...@us...> - 2008-07-06 01:36:47
|
Revision: 396
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=396&view=rev
Author: yes
Date: 2008-07-05 18:36:57 -0700 (Sat, 05 Jul 2008)
Log Message:
-----------
updated, using the pure system time function
Modified Paths:
--------------
pure/trunk/examples/libor/date.pure
Modified: pure/trunk/examples/libor/date.pure
===================================================================
--- pure/trunk/examples/libor/date.pure 2008-07-06 00:58:50 UTC (rev 395)
+++ pure/trunk/examples/libor/date.pure 2008-07-06 01:36:57 UTC (rev 396)
@@ -10,8 +10,8 @@
returns Posix time based on UTC (Universal Temps Coordinat) or TAI
(Temps Atomique International) rather than local daylight saving time */
-using system; // this is needed just to get C printf
-extern long time(long*) = c_time; // makes available the C function time();
+using system;
+// extern long time(long*) = c_time; // Now replaced by time in system
puts "****************************************************************";
puts "* New Calendar/Clock, Copyright (c) 2008 by Libor Spacek *";
@@ -29,8 +29,7 @@
def newmoondhms= (14063:2:19:0); // 3rd July 08 new moon in posix dhms
// current values in posix time supplied by C time();
-posixsecsnow = c_time (pointer 0); // each call refreshes to the current second
-secsnow = posixsecsnow mod secsinday; // int seconds since midnight
+secsnow = time mod secsinday; // int seconds since midnight
// either mayan or julian day (and time) as a day number (::double)
mjday epoch::int secs::int |mjday epoch::int secs::bigint= epoch+secs/secsinday;
@@ -143,7 +142,7 @@
if mf > 0.5 then 200.0*(1.0-mf) else 200.0*mf when mf = moonphase psecs end;
// for now, let's just do some simple calculations to print
-daytoday = mjday mdayposix posixsecsnow; // mayan day (double)
+daytoday = mjday mdayposix time; // mayan day (double)
mayantoday = days2mayan (int daytoday); // as above but in the long count format
daysleft = cycledays - daytoday;
mayanleft = days2mayan ((int daysleft));
@@ -158,7 +157,7 @@
printf "%s \tToday's Gregorian Date\n"(str(date(mday2jday(int daytoday))))$
printf "%s \tUTC Time in h:m:s\n" (str (secs2hms secsnow)) $
printf "%s \tUTC Time in h:t:d:s\n" (str (secs2htds secsnow))$
- printf "%7.4f %% \tFullness of the Moon\n" (fullmoon posixsecsnow) $
+ printf "%7.4f %% \tFullness of the Moon\n" (fullmoon time) $
printf "%d \tMayan day number\n" (int daytoday) $
printf "%s \tMayan long count notation for this day\n" (str mayantoday) $
printf "%s \tLong countdown of days to the end of this cycle\n"
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
