Thread: [pure-lang-svn] SF.net SVN: pure-lang: [7] pure/trunk/lib
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
pure-lang-svn
|
From: <ag...@us...> - 2008-04-30 16:22:33
|
Revision: 7
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=7&view=rev
Author: agraef
Date: 2008-04-30 09:22:40 -0700 (Wed, 30 Apr 2008)
Log Message:
-----------
Comment about impure operations.
Modified Paths:
--------------
pure/trunk/lib/primitives.pure
pure/trunk/lib/strings.pure
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-04-30 16:21:01 UTC (rev 6)
+++ pure/trunk/lib/primitives.pure 2008-04-30 16:22:40 UTC (rev 7)
@@ -21,7 +21,7 @@
/* Throw an exception. */
-extern void pure_throw(expr*);
+extern void pure_throw(expr*); // IMPURE!
throw x = pure_throw x;
/* Predicates to check for the built-in types. */
@@ -276,11 +276,11 @@
get_string x::pointer = pointer_get_string x;
get_pointer x::pointer = pointer_get_pointer x;
-extern void pointer_put_byte(void *ptr, int x);
-extern void pointer_put_int(void *ptr, int x);
-extern void pointer_put_double(void *ptr, double x);
-extern void pointer_put_string(void *ptr, char *x);
-extern void pointer_put_pointer(void *ptr, void *x);
+extern void pointer_put_byte(void *ptr, int x); // IMPURE!
+extern void pointer_put_int(void *ptr, int x); // IMPURE!
+extern void pointer_put_double(void *ptr, double x); // IMPURE!
+extern void pointer_put_string(void *ptr, char *x); // IMPURE!
+extern void pointer_put_pointer(void *ptr, void *x); // IMPURE!
put_byte x::pointer y::int = pointer_put_byte x;
put_int x::pointer y::int = pointer_put_int x;
Modified: pure/trunk/lib/strings.pure
===================================================================
--- pure/trunk/lib/strings.pure 2008-04-30 16:21:01 UTC (rev 6)
+++ pure/trunk/lib/strings.pure 2008-04-30 16:22:40 UTC (rev 7)
@@ -26,7 +26,7 @@
case you will not always get a result expression.) */
extern expr* str(expr*);
-extern expr* eval(char*);
+extern expr* eval(char*); // IMPURE!
/* Convert between Unicode character codes and single character strings. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-05-27 09:17:47
|
Revision: 142
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=142&view=rev
Author: agraef
Date: 2008-05-27 02:17:56 -0700 (Tue, 27 May 2008)
Log Message:
-----------
Overhaul of prelude.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/lib/primitives.pure
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-05-27 08:38:37 UTC (rev 141)
+++ pure/trunk/lib/prelude.pure 2008-05-27 09:17:56 UTC (rev 142)
@@ -28,6 +28,17 @@
nullary failed_match; // failed pattern match (lambda, case, etc.)
nullary stack_fault; // not enough stack space (PURE_STACK limit)
+/* Other exceptions defined by the prelude. Note that some of the list
+ operations require that their list arguments are "proper" lists (ending in
+ []) and will raise a 'bad_list_value xs' exception otherwise; in this case
+ xs denotes the offending tail. Likewise, some operations will raise the
+ 'empty_list' exception if a nonempty list is required. */
+
+nullary out_of_bounds; // tuple or list index is out of bounds (!)
+nullary empty_list; // empty list (head, tail, etc.)
+// bad_list_value xs; // not a proper list value (reverse, etc.)
+// bad_value x; // invalid argument type
+
/* Other constants. */
nullary [] (); // empty list and tuple
@@ -80,11 +91,6 @@
inequality and emptiness, to determine the size of a tuple, for zero-based
indexing, and to reverse a tuple. */
-/* Note: Some of these definitions aren't exactly pretty. They are what they
- are because they are the most efficient (at least asymptotically). In
- particular, we strive for tail-recursive and constant or linear-time
- implementations where this is feasible. */
-
x,() = x;
(),y = y;
(x,y),z = x,(y,z);
@@ -111,6 +117,7 @@
(x,xs)!0 = x;
(x,y,xs)!n::int = (y,xs)!(n-1) if n>0;
(x,y)!1 = y;
+(x,xs)!n::int = throw out_of_bounds;
reverse () = ();
reverse (x,xs) = accum x xs with
@@ -126,10 +133,6 @@
compute the size of a list, for indexing and concatenation, and for
reversing a list. */
-/* Note: Some list operations throw a 'bad_list_value xs' exception if their
- argument is not a "proper" list (i.e., ending in []). In this case xs
- denotes the offending tail of the list. */
-
[]==[] = 1;
(x:xs)==[] = 0;
[]==(x:xs) = 0;
@@ -151,7 +154,9 @@
end;
(x:xs)!0 = x;
-(x:xs)!n::int = xs!(n-1) if n>0;
+(x:xs)!n::int = xs!(n-1) if n>0 && assert (listnp xs) (bad_list_value xs);
+(x:xs)!n::int = throw out_of_bounds;
+[]!n::int = throw out_of_bounds;
[]+ys = ys;
(x:xs)+ys = x : accum ys (reverse xs) with
@@ -187,11 +192,12 @@
structures defined above. */
xs![] = [];
-xs!(n:ns) = accum [] xs (reverse (n:ns)) (#xs) with
- accum ys xs [] m = ys;
- accum ys xs (n::int:ns) m = accum (xs!n:ys) xs ns m if n>=0 && n<m;
- = accum ys xs ns m otherwise;
-end;
+xs!(n:ns) = accum [] (reverse (n:ns)) with
+ accum ys [] = ys;
+ accum ys (n::int:ns) = accum (xs!n:ys) ns if n>=0 && n<m;
+ = accum ys ns otherwise;
+ accum _ (n:_) = throw (bad_value n);
+end when m::int = #xs end;
/* Arithmetic sequences. */
@@ -203,8 +209,9 @@
/* Common list functions. This mostly comes straight from the Q prelude which
in turn was based on the first edition of the Bird/Wadler book, and is very
- similar to what you can find in the Haskell prelude (although some
- functions have slightly different names). */
+ similar to what you can find in the Haskell prelude. Some functions have
+ slightly different names, though, and some of the definitions were massaged
+ to make them tail-recursive. */
all p [] = 1;
all p (x:xs) = p x && all p xs;
@@ -236,11 +243,11 @@
foldr f a [] = a;
foldr f a (x:xs)
- = f x (foldr f a xs);
+ = f x (foldl (flip f) a (reverse xs));
foldr1 f [x] = x;
foldr1 f (x:y:xs)
- = f x (foldr1 f (y:xs));
+ = f x (foldl1 (flip f) (reverse (y:xs)));
head (x:xs) = x;
@@ -255,18 +262,28 @@
scanl f a [] = [a];
scanl f a (x:xs)
- = a:scanl f (f a x) xs;
+ = accum [a] f (f a x) xs with
+ accum ys f a [] = reverse (a:ys);
+ accum ys f a (x:xs) = accum (a:ys) f (f a x) xs;
+ accum _ _ _ xs = throw (bad_list_value xs);
+ end;
scanl1 f [] = [];
scanl1 f (x:xs) = scanl f x xs;
scanr f a [] = [a];
scanr f a (x:xs)
- = f x y:ys when ys = scanr f a xs; y:_ = ys end;
+ = f x y:ys when
+ ys = reverse (scanl (flip f) a (reverse xs));
+ y:_ = ys;
+ end;
scanr1 f [] = [];
scanr1 f [x] = [x];
-scanr1 f (x:xs) = f x y:ys when ys = scanr1 f xs; y:_ = ys end;
+scanr1 f (x:xs) = f x y:ys when
+ ys = reverse (scanl1 (flip f) (reverse xs));
+ y:_ = ys;
+ end;
tail (x:xs) = xs;
@@ -282,6 +299,7 @@
/* Concatenate a list of lists. */
cat [] = [];
+cat [xs] = xs;
cat (xs:xss) = accum (reverse xs) xss with
accum xs [] = reverse xs;
accum xs ([]:yss) = accum xs yss;
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-05-27 08:38:37 UTC (rev 141)
+++ pure/trunk/lib/primitives.pure 2008-05-27 09:17:56 UTC (rev 142)
@@ -24,6 +24,11 @@
extern void pure_throw(expr*); // IMPURE!
throw x = pure_throw x;
+/* Convenience function to ensure a condition p. Returns 1 (true) if p holds,
+ and throws the given exception e otherwise. */
+
+assert p e = if p then 1 else throw e;
+
/* Syntactic equality. */
extern bool same(expr* x, expr* y);
@@ -39,7 +44,7 @@
pointerp x = case x of _::pointer = 1; _ = 0 end;
/* Predicates to check for function objects, global (unbound) variables,
- function applications and proper lists and tuples. */
+ function applications, proper lists, list nodes and tuples. */
extern bool funp(expr*), bool lambdap(expr*), bool varp(expr*),
bool applp(expr*);
@@ -48,6 +53,10 @@
listp (x:xs) = listp xs;
listp _ = 0 otherwise;
+listnp [] = 1;
+listnp (x:xs) = 1;
+listnp _ = 0 otherwise;
+
tuplep () = 1;
tuplep (x,xs) = 1;
tuplep _ = 0 otherwise;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-06-18 07:23:30
|
Revision: 251
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=251&view=rev
Author: agraef
Date: 2008-06-18 00:23:39 -0700 (Wed, 18 Jun 2008)
Log Message:
-----------
Rename '|' -> 'or', '&' -> 'and'.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/lib/primitives.pure
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-06-17 13:44:16 UTC (rev 250)
+++ pure/trunk/lib/prelude.pure 2008-06-18 07:23:39 UTC (rev 251)
@@ -54,8 +54,8 @@
infix 4 === !== ; // syntactic equality
infixr 4 : ; // list cons
infixl 5 << >> ; // bit shifts
-infixl 6 + - | ; // addition, bitwise or
-infixl 7 * / div mod & ; // multiplication, bitwise and
+infixl 6 + - or ; // addition, bitwise or
+infixl 7 * / div mod and ; // multiplication, bitwise and
prefix 7 ~ ; // bitwise not
infixr 8 ^ ; // exponentiation
prefix 8 # ; // size operator
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-06-17 13:44:16 UTC (rev 250)
+++ pure/trunk/lib/primitives.pure 2008-06-18 07:23:39 UTC (rev 251)
@@ -102,12 +102,12 @@
x::int+y::int = x+y;
x::int-y::int = x-y;
-x::int|y::int = x|y;
x::int*y::int = x*y;
x::int/y::int = x/y;
-x::int&y::int = x&y;
x::int div y::int = x div y;
x::int mod y::int = x mod y;
+x::int or y::int = x or y;
+x::int and y::int = x and y;
x::int<y::int = x<y;
x::int>y::int = x>y;
@@ -189,12 +189,12 @@
x::bigint+y::bigint = bigint_add x y;
x::bigint-y::bigint = bigint_sub x y;
-x::bigint|y::bigint = bigint_or x y;
x::bigint*y::bigint = bigint_mul x y;
x::bigint/y::bigint = double x / double y;
-x::bigint&y::bigint = bigint_and x y;
x::bigint div y::bigint = bigint_div x y;
x::bigint mod y::bigint = bigint_mod x y;
+x::bigint or y::bigint = bigint_or x y;
+x::bigint and y::bigint = bigint_and x y;
x::bigint<y::bigint = bigint_cmp x y < 0;
x::bigint>y::bigint = bigint_cmp x y > 0;
@@ -207,12 +207,12 @@
x::int+y::bigint = bigint x+y;
x::int-y::bigint = bigint x-y;
-x::int|y::bigint = bigint x|y;
x::int*y::bigint = bigint x*y;
x::int/y::bigint = double x/y;
-x::int&y::bigint = bigint x&y;
x::int div y::bigint = bigint x div y;
x::int mod y::bigint = bigint x mod y;
+x::int or y::bigint = bigint x or y;
+x::int and y::bigint = bigint x and y;
x::int<y::bigint = bigint x<y;
x::int>y::bigint = bigint x>y;
@@ -223,12 +223,12 @@
x::bigint+y::int = x+bigint y;
x::bigint-y::int = x-bigint y;
-x::bigint|y::int = x|bigint y;
x::bigint*y::int = x*bigint y;
x::bigint/y::int = x/double y;
-x::bigint&y::int = x&bigint y;
x::bigint div y::int = x div bigint y;
x::bigint mod y::int = x mod bigint y;
+x::bigint or y::int = x or bigint y;
+x::bigint and y::int = x and bigint y;
x::bigint<y::int = x<bigint y;
x::bigint>y::int = x>bigint y;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-07-01 11:02:41
|
Revision: 348
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=348&view=rev
Author: agraef
Date: 2008-07-01 04:02:46 -0700 (Tue, 01 Jul 2008)
Log Message:
-----------
Move sqrt function from primitives to math.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-01 10:50:29 UTC (rev 347)
+++ pure/trunk/lib/math.pure 2008-07-01 11:02:46 UTC (rev 348)
@@ -46,6 +46,24 @@
floor x::int | floor x::bigint = x;
ceil x::int | ceil x::bigint = x;
+/* The sqrt function. */
+
+extern double sqrt(double) = c_sqrt;
+
+sqrt x::double = c_sqrt x if x>=0;
+sqrt x::int | sqrt x::bigint = sqrt (double x);
+
+/* Exponential function and logarithms. */
+
+extern double exp(double), double log(double) = c_log;
+
+ln x::double = c_log x if x>=0.0;
+log x::double = c_log x/c_log 10.0 if x>=0.0;
+
+exp x::int | exp x::bigint = exp (double x);
+ln x::int | ln x::bigint = ln (double x);
+log x::int | log x::bigint = log (double x);
+
/* Trigonometric functions. */
extern double sin(double), double cos(double), double tan(double);
@@ -67,17 +85,6 @@
def pi = 4.0*atan 1.0;
-/* Exponential function and logarithms. */
-
-extern double exp(double), double log(double) = c_log;
-
-ln x::double = c_log x if x>=0.0;
-log x::double = c_log x/c_log 10.0 if x>=0.0;
-
-exp x::int | exp x::bigint = exp (double x);
-ln x::int | ln x::bigint = ln (double x);
-log x::int | log x::bigint = log (double x);
-
/* Hyperbolic functions. */
extern double sinh(double), double cosh(double), double tanh(double);
@@ -194,8 +201,6 @@
sqrt (r<:t) = sqrt r <: t/2;
// Complex square roots of negative reals.
-sqrt x::int |
-sqrt x::bigint |
sqrt x::double = 0.0 +: sqrt (-x) if x<0;
/* Complex exponential and logarithms. */
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-07-01 10:50:29 UTC (rev 347)
+++ pure/trunk/lib/primitives.pure 2008-07-01 11:02:46 UTC (rev 348)
@@ -267,15 +267,6 @@
x::double==y::bigint = x==double y;
x::double!=y::bigint = x!=double y;
-/* The sqrt function. Integer arguments get promoted to double and the result
- is always a double. The argument must be nonnegative. */
-
-extern double sqrt(double) = c_sqrt;
-
-sqrt x::int |
-sqrt x::bigint = c_sqrt (double x) if x>=0;
-sqrt x::double = c_sqrt x if x>=0;
-
/* The pow function. Returns a bigint for integer arguments, double if one of
the arguments is double (in the latter case, x may be negative only if y is
integer). */
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: <js...@us...> - 2008-07-09 19:56:09
|
Revision: 429
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=429&view=rev
Author: jspitz
Date: 2008-07-09 12:56:14 -0700 (Wed, 09 Jul 2008)
Log Message:
-----------
Update 'set.pure' and 'dict.pure' with versions that compile faster.
Modified Paths:
--------------
pure/trunk/lib/dict.pure
pure/trunk/lib/set.pure
Modified: pure/trunk/lib/dict.pure
===================================================================
--- pure/trunk/lib/dict.pure 2008-07-09 13:44:01 UTC (rev 428)
+++ pure/trunk/lib/dict.pure 2008-07-09 19:56:14 UTC (rev 429)
@@ -86,26 +86,18 @@
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
@@ -113,8 +105,6 @@
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
@@ -149,21 +139,18 @@
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
@@ -173,11 +160,18 @@
table ( 1) ( 1) = [( 0), 0, 0];
table (-1) (-1) = [( 0), 0, 0];
table (-1) ( 1) = [( 0), 0, 1]
+*/
+
+// table w/o pattern matching
+ table bb::int wi::int = [ba, wti, tbr]
+ when
+ ba = if bb == 0 then -wi else 0;
+ wti = bb == 0;
+ tbr = (bb + wi) == 0;
+ end
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
@@ -186,18 +180,12 @@
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
@@ -207,8 +195,6 @@
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
@@ -216,8 +202,6 @@
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
@@ -311,14 +295,10 @@
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;
@@ -343,8 +323,6 @@
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;
@@ -401,8 +379,6 @@
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;
@@ -429,14 +405,10 @@
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;
@@ -469,8 +441,6 @@
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;
@@ -499,8 +469,6 @@
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);
@@ -528,35 +496,41 @@
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
+ [b1, whatHasChanged, toBeRebalanced] = table 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];
+table ( 0) ( 1) = [( 1), 0, 0];
+table ( 0) (-1) = [(-1), 0, 0];
+table ( 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];
+table ( 1) (-1) = [( 0), 1, 0];
+table (-1) ( 1) = [( 0), 1, 0];
+table (-1) (-1) = [( 0), 1, 1];
// ^^^^
// It depends on the tree pattern in avl_geq whether it really decreases
+*/
+
+// table w/o pattern matching
+ table bb wd = [ba, wtd, tbr]
+ when
+ ba = if bb == 0 then wd else 0;
+ wtd = abs bb;
+ tbr = bb == wd;
+ end
end;
// Single and double tree rotations - these are common for insert and delete
@@ -571,23 +545,13 @@
*/
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]
@@ -595,23 +559,13 @@
[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]
@@ -619,7 +573,16 @@
[b2, b3] = table b1
end;
+/*
table ( 1) = [( 0), (-1)];
table (-1) = [( 1), ( 0)];
table ( 0) = [( 0), ( 0)]
+*/
+
+// table w/o pattern matching
+ table bal = [b1, b2]
+ when
+ b1 = bal == (-1);
+ b2 = -(bal == 1);
+ end
end;
Modified: pure/trunk/lib/set.pure
===================================================================
--- pure/trunk/lib/set.pure 2008-07-09 13:44:01 UTC (rev 428)
+++ pure/trunk/lib/set.pure 2008-07-09 19:56:14 UTC (rev 429)
@@ -78,31 +78,19 @@
bag xs = foldl insert emptybag xs if listp xs;
// insert a new member into a set or bag
-insert (t@Set m) y::int |
-insert (t@Set m) y::string |
insert (t@Set m) y |
-insert (t@Bag m) y::int |
-insert (t@Bag m) y::string |
insert (t@Bag m) y = t ((insert m y)!0)
with
- insert nil key::int |
- insert nil key::string |
insert nil key
= [(bin key ( 0) nil nil), 1];
- insert (bin k::int b::int l r) key::int |
- insert (bin k::string b::int l r) key::string |
insert (bin k b::int l r) key
= [(bin key b l r), 0] if (key == k) && (t === Set);
- insert (bin k::int b::int l r) key::int |
- insert (bin k::string b::int l r) key::string |
insert (bin k b::int l r) key
= adjust leftHasChanged (bin k b newL r) (-1)
when [newL, leftHasChanged] = insert l key end if key < k;
- insert (bin k::int b::int l r) key::int |
- insert (bin k::string b::int l r) key::string |
insert (bin k b::int l r) key
= adjust rightHasChanged (bin k b l newR) ( 1)
when [newR, rightHasChanged] = insert r key end
@@ -111,22 +99,18 @@
adjust 0 oldTree _
= [oldTree, 0];
- adjust 1 (bin key::int b0::int l r) LoR::int |
- adjust 1 (bin key::string b0::int l r) LoR::int |
adjust 1 (bin key b0::int l r) LoR::int
= [rebal toBeRebalanced (bin key b0 l r) b1, whatHasChanged]
when
[b1, whatHasChanged, toBeRebalanced] = table b0 LoR
end;
- rebal 0 (bin k::int _ l r) b |
- rebal 0 (bin k::string _ l r) b |
rebal 0 (bin k _ l r) b
= bin k b l r;
rebal 1 oldTree _
= (Set_avl_geq oldTree)!0;
-
+/*
// Balance rules for insertions
// balance where balance whole tree to be
// before inserted after increased rebalanced
@@ -136,31 +120,30 @@
table ( 1) ( 1) = [( 0), 0, 0];
table (-1) (-1) = [( 0), 0, 0];
table (-1) ( 1) = [( 0), 0, 1];
+*/
+
+// table w/o pattern matching
+ table bb::int wi::int = [ba, wti, tbr]
+ when
+ ba = if bb == 0 then -wi else 0;
+ wti = bb == 0;
+ tbr = (bb + wi) == 0;
+ end
end;
// delete a member by key from the data structure
-delete (t@Set m) y::int |
-delete (t@Set m) y::string |
delete (t@Set m) y |
-delete (t@Bag m) y::int |
-delete (t@Bag m) y::string |
delete (t@Bag m) y
= t ((delete m y)!0)
with
delete nil _ = [nil, 0];
- delete (bin k::int _ nil r) key::int |
- delete (bin k::string _ nil r) key::string |
delete (bin k _ nil r) key
= [r, 1] if key == k;
- delete (bin k::int _ l nil) key::int |
- delete (bin k::string _ l nil) key::string |
delete (bin k _ l nil) key
= [l, 1] if key == k;
- delete (bin k::int b::int x@(bin kl::int bl::int rl ll) r) key::int |
- delete (bin k::string b::int x@(bin kl::string bl::int rl ll) r) key::string |
delete (bin k b::int x@(bin kl bl::int rl ll) r) key
= Set_adjustd leftHasChanged (bin lk b newL r) (-1)
when
@@ -169,8 +152,6 @@
end
if key == k;
- delete (bin k::int b::int l r) key::int |
- delete (bin k::string b::int l r) key::string |
delete (bin k b::int l r) key
= Set_adjustd leftHasChanged (bin k b newL r) (-1)
when
@@ -178,8 +159,6 @@
end
if key < k;
- delete (bin k::int b::int l r) key::int |
- delete (bin k::string b::int l r) key::string |
delete (bin k b::int l r) key
= Set_adjustd rightHasChanged (bin k b l newR) ( 1)
when
@@ -213,18 +192,12 @@
end;
// check whether a key exists in set or bag
-member (Set m) k::int |
-member (Set m) k::string |
member (Set m) k |
-member (Bag m) k::int |
-member (Bag m) k::string |
member (Bag m) k
= member m k
with
member nil _ = 0;
- member (bin x _ m1 m2) y::int |
- member (bin x _ m1 m2) y::string |
member (bin x _ m1 m2) y
= member m1 y if x > y;
= member m2 y if x < y;
@@ -238,8 +211,6 @@
with
members nil = [];
- members (bin x::int _ m1 m2) |
- members (bin x::string _ m1 m2) |
members (bin x _ m1 m2)
= (members m1) + (x : (members m2))
end;
@@ -336,8 +307,6 @@
with
adjust 0 oldTree _ = [oldTree, 0];
- adjust 1 (bin key::int b0::int l r) LoR::int |
- adjust 1 (bin key::string b0::int l r) LoR::int |
adjust 1 (bin key b0::int l r) LoR::int
= rebal toBeRebalanced (bin key b0 l r) b1 whatHasChanged
when
@@ -349,14 +318,13 @@
decide whether the whole tree increases. With deletions it is sometimes not
sufficient and we need to know which kind of tree rotation took place.
*/
- rebal 0 (bin k::int _ l r) b::int whatHasChanged |
- rebal 0 (bin k::string _ l r) b::int whatHasChanged |
rebal 0 (bin k _ l r) b::int whatHasChanged
= [bin k b l r, whatHasChanged];
rebal 1 oldTree _ _ = Set_avl_geq oldTree;
// Balance rules for deletions
+/*
// balance where balance whole tree to be
// before deleted after decreased rebalanced
table ( 0) ( 1) = [( 1), 0, 0];
@@ -370,9 +338,17 @@
table (-1) (-1) = [( 0), 1, 1]
// ^^^^
// It depends on the tree pattern in avl_geq whether it really decreases
+*/
+
+// table w/o pattern matching
+ table bb wd = [ba, wtd, tbr]
+ when
+ ba = if bb == 0 then wd else 0;
+ wtd = abs bb;
+ tbr = bb == wd;
+ end
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
@@ -386,21 +362,13 @@
Set_avl_geq x = avl_geq x
with
- avl_geq (bin a::int (-1) alpha (bin b::int (-1) beta gamma)) |
- avl_geq (bin a::string (-1) alpha (bin b::string (-1) beta gamma)) |
avl_geq (bin a (-1) alpha (bin b (-1) beta gamma))
= [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1];
- avl_geq (bin a::int (-1) alpha (bin b::int ( 0) beta gamma)) |
- avl_geq (bin a::string (-1) alpha (bin b::string ( 0) beta gamma)) |
avl_geq (bin a (-1) alpha (bin b ( 0) beta gamma))
= [bin b ( 1) (bin a (-1) alpha beta) gamma, 0];
// the tree doesn't decrease with this pattern
- avl_geq (bin a::int (-1) alpha
- (bin b::int ( 1) (bin x::int b1 beta gamma) delta)) |
- avl_geq (bin a::string (-1) alpha
- (bin b::string ( 1) (bin x::string b1 beta gamma) delta)) |
avl_geq (bin a (-1) alpha
(bin b ( 1) (bin x b1 beta gamma) delta))
= [bin x ( 0) (bin a b2 alpha beta)
@@ -409,21 +377,13 @@
[b2, b3] = table b1
end;
- avl_geq (bin b::int ( 1) (bin a::int ( 1) alpha beta) gamma) |
- avl_geq (bin b::string ( 1) (bin a::string ( 1) alpha beta) gamma) |
avl_geq (bin b ( 1) (bin a ( 1) alpha beta) gamma)
= [bin a ( 0) alpha (bin b ( 0) beta gamma), 1];
- avl_geq (bin b::int ( 1) (bin a::int ( 0) alpha beta) gamma) |
- avl_geq (bin b::string ( 1) (bin a::string ( 0) alpha beta) gamma) |
avl_geq (bin b ( 1) (bin a ( 0) alpha beta) gamma)
= [bin a (-1) alpha (bin b ( 1) beta gamma), 0];
// the tree doesn't decrease with this pattern
- avl_geq (bin b::int ( 1)
- (bin a::int (-1) alpha (bin x::int b1 beta gamma)) delta) |
- avl_geq (bin b::string ( 1)
- (bin a::string (-1) alpha (bin x::string b1 beta gamma)) delta) |
avl_geq (bin b ( 1)
(bin a (-1) alpha (bin x b1 beta gamma)) delta)
= [bin x ( 0) (bin a b2 alpha beta)
@@ -431,8 +391,16 @@
when
[b2, b3] = table b1
end;
-
+/*
table ( 1) = [( 0), (-1)];
table (-1) = [( 1), ( 0)];
table ( 0) = [( 0), ( 0)]
+*/
+
+// table w/o pattern matching
+ table bal = [b1, b2]
+ when
+ b1 = bal == (-1);
+ b2 = -(bal == 1);
+ end
end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
Thanks for helping keep SourceForge clean.
X