[pure-lang-svn] SF.net SVN: pure-lang: [424] pure/trunk/examples/set_test.pure
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
[pure-lang-svn] SF.net SVN: pure-lang: [424] pure/trunk/examples/set_test.pure
|
From: <js...@us...> - 2008-07-08 17:37:49
|
Revision: 424
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=424&view=rev
Author: jspitz
Date: 2008-07-08 10:37:56 -0700 (Tue, 08 Jul 2008)
Log Message:
-----------
Add revamped set to examples as 'set_test.pure'
Added Paths:
-----------
pure/trunk/examples/set_test.pure
Added: pure/trunk/examples/set_test.pure
===================================================================
--- pure/trunk/examples/set_test.pure (rev 0)
+++ pure/trunk/examples/set_test.pure 2008-07-08 17:37:56 UTC (rev 424)
@@ -0,0 +1,389 @@
+/* Pure's set and bag 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
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+
+/* Public operations: ******************************************************
+
+emptyset, emptybag: return the empty set or bag
+set xs, bag xs; create a set or bag from list xs
+setp x, bagp x; check whether x is a set or bag
+
+#m size of set or bag m
+
+null m tests whether m is the empty set or bag
+member m x tests whether m contains x
+members m, list m list members of m in ascending order
+
+first m, last m return first and last member of m
+rmfirst m, rmlast m remove first and last member from m
+insert m x insert x into m (replace existing element)
+delete m x remove x from m
+
+ *************************************************************************/
+
+
+/* Empty tree constant, consider this private. */
+nullary nil;
+
+/*****
+Tree for set and bag is either:
+- nil (empty tree) or
+- bin key Balance Left Right (Left, Right: trees)
+
+
+Balance: ( 1), ( 0), or (-1) denoting |L|-|R| = 1, 0, or -1, respectively
+*****/
+
+// set and bag type checks
+bagp (Bag _) = 1;
+bagp _ = 0;
+
+setp (Set _) = 1;
+setp _ = 0;
+
+// create an empty set or bag
+emptyset = Set nil;
+emptybag = Bag nil;
+
+// create set or bag from a list
+set xs = foldl insert emptyset xs if listp xs;
+bag xs = foldl insert emptybag xs if listp xs;
+
+// insert a new member into a set or bag
+insert (t@Set m) y |
+insert (t@Bag m) y = t ((insert m y)!0)
+with
+ insert nil key
+ = [(bin key ( 0) nil nil), 1];
+
+ insert (bin k b::int l r) key
+ = [(bin key b l r), 0] if (key == k) && (t === Set);
+
+ 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 b::int l r) key
+ = adjust rightHasChanged (bin k b l newR) ( 1)
+ when [newR, rightHasChanged] = insert r key end
+ if ((key > k) && (t === Set)) || ((key >= k) && (t === Bag));
+
+ adjust ToF oldTree _
+ = [oldTree, 0] if ToF == 0;
+
+ adjust ToF (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
+ if ToF == 1;
+
+ rebal ToF (bin k _ l r) b
+ = bin k b l r if ToF == 0;
+
+ rebal ToF oldTree _
+ = (Set_avl_geq oldTree)!0 if ToF == 1;
+
+// Balance rules for insertions
+// balance whole tree to be balance where
+// after increased rebalanced before inserted
+table bb wi
+ = [( 1), 1, 0] if (bb == ( 0)) && (wi == (-1));
+ = [(-1), 1, 0] if (bb == ( 0)) && (wi == ( 1));
+ = [( 0), 0, 1] if (bb == ( 1)) && (wi == (-1));
+ = [( 0), 0, 0] if (bb == ( 1)) && (wi == ( 1));
+ = [( 0), 0, 0] if (bb == (-1)) && (wi == (-1));
+ = [( 0), 0, 1] if (bb == (-1)) && (wi == ( 1));
+end;
+
+// delete a member by key from the data structure
+delete (t@Set m) y |
+delete (t@Bag m) y
+= t ((delete m y)!0)
+with
+ delete nil _ = [nil, 0];
+
+ delete (bin k _ nil r) key
+ = [r, 1] if key == k;
+
+ delete (bin k _ l nil) key
+ = [l, 1] if key == k;
+
+ delete (bin k b::int x@(bin kl bl::int rl ll) r) key
+ = Set_adjustd leftHasChanged (bin lk b newL r) (-1)
+ when
+ lk = last x;
+ [newL, leftHasChanged] = rmlast x
+ end
+ if key == k;
+
+ delete (bin k b::int l r) key
+ = Set_adjustd leftHasChanged (bin k b newL r) (-1)
+ when
+ [newL, leftHasChanged] = delete l key
+ end
+ if key < k;
+
+ delete (bin k b::int l r) key
+ = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
+ when
+ [newR, rightHasChanged] = delete r key
+ end
+ if key > k;
+
+ rmlast nil = [nil, 0];
+ rmlast (bin _ _ l nil) = [l, 1];
+ rmlast (bin k b::int l r )
+ = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
+ when [newR, rightHasChanged] = rmlast r end;
+
+ last (bin x _ _ nil) = x;
+ last (bin _ _ _ m2 ) = last m2
+end;
+
+// check for the empty set or bag
+null (Set nil) = 1;
+null (Set _) = 0;
+
+null (Bag nil) = 1;
+null (Bag _) = 0;
+
+// get a number of members in set or bag
+#(Set m) |
+#(Bag m) = #m
+with
+ #nil = 0;
+ #(bin _ _ m1 m2) = #m1 + #m2 + 1
+end;
+
+// check whether a key exists in set or bag
+member (Set m) k |
+member (Bag m) k
+= member m k
+with
+ member nil _ = 0;
+
+ member (bin x _ m1 m2) y
+ = member m1 y if x > y;
+ = member m2 y if x < y;
+ = 1 if x == y
+end;
+
+// get all members of set or bag as a list
+members (Set m) |
+members (Bag m)
+= members m
+with
+ members nil = [];
+
+ members (bin x _ m1 m2)
+ = (members m1) + (x : (members m2))
+end;
+
+list m@(Set _) |
+list m@(Bag _)
+ = members m;
+
+// get the first member of set or bag
+first (Set m) |
+first (Bag m)
+= first m
+with
+ first (bin x _ nil _) = x;
+ first (bin _ _ m1 _) = first m1
+end;
+
+// get the last member of set or bag
+last (Set m) |
+last (Bag m)
+= last m
+with
+ last (bin x _ _ nil) = x;
+ last (bin _ _ _ m2 ) = last m2
+end;
+
+// remove the first member from set or bag
+rmfirst (t@Set m) |
+rmfirst (t@Bag m)
+= t ((rmfirst m)!0)
+with
+ rmfirst nil = [nil, 0];
+ rmfirst (bin _ _ nil r) = [r, 1];
+ rmfirst (bin k b::int l r)
+ = Set_adjustd leftHasChanged (bin k b newL r) (-1)
+ when [newL, leftHasChanged] = rmfirst l end
+end;
+
+// remove the last member from set or bag
+rmlast (t@Set m) |
+rmlast (t@Bag m)
+= t ((rmlast m)!0)
+with
+ rmlast nil = [nil, 0];
+ rmlast (bin _ _ l nil) = [l, 1];
+ rmlast (bin k b::int l r )
+ = Set_adjustd rightHasChanged (bin k b l newR) ( 1)
+ when [newR, rightHasChanged] = rmlast r end
+end;
+
+// set and bag relations
+m1@(Set _) == m2@(Set _) |
+m1@(Bag _) == m2@(Bag _)
+ = (members m1 == members m2);
+
+m1@(Set _) != m2@(Set _) |
+m1@(Bag _) != m2@(Bag _)
+ = (members m1 != members m2);
+
+m1@(Set _) <= m2@(Set _) = all (member m2) (members m1);
+m1@(Bag _) <= m2@(Bag _) = null (m1 - m2);
+
+m1@(Set _) >= m2@(Set _) = all (member m1) (members m2);
+m1@(Bag _) >= m2@(Bag _) = null (m2 - m1);
+
+m1@(Set _) < m2@(Set _) |
+m1@(Bag _) < m2@(Bag _)
+ = if (m1 <= m2) then (m1 != m2) else 0;
+
+m1@(Set _) > m2@(Set _) |
+m1@(Bag _) > m2@(Bag _)
+ = if (m1 >= m2) then (m1 != m2) else 0;
+
+// set and bag union
+m1@(Set _) + m2@(Set _) |
+m1@(Bag _) + m2@(Bag _)
+ = foldl insert m1 (members m2);
+
+// set and bag difference
+m1@(Set _) - m2@(Set _) |
+m1@(Bag _) - m2@(Bag _)
+ = foldl delete m1 (members m2);
+
+// set and bag intersection
+m1@(Set _) * m2@(Set _) |
+m1@(Bag _) * m2@(Bag _)
+ = m1 - (m1 - m2);
+
+
+/* Private functions, don't invoke these directly. */
+
+Set_adjustd ToF::int tree LoR::int
+ = adjust ToF tree LoR
+with
+ adjust ToF oldTree _ = [oldTree, 0] if ToF == 0;
+
+ adjust ToF (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
+ if ToF == 1;
+/*
+ Note that rebali and rebald are not symmetrical. With insertions it is
+ sufficient to know the original balance and insertion side in order to
+ 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 ToF (bin k _ l r) b::int whatHasChanged
+ = [bin k b l r, whatHasChanged]
+ if ToF == 0;
+
+ rebal ToF oldTree _ _ = Set_avl_geq oldTree if ToF == 1;
+
+// Balance rules for deletions
+// balance whole tree to be balance where
+// after decreased rebalanced before deleted
+table bb wi
+ = [( 1), 0, 0] if (bb == ( 0)) && (wi == ( 1));
+ = [(-1), 0, 0] if (bb == ( 0)) && (wi == (-1));
+ = [( 0), 1, 1] if (bb == ( 1)) && (wi == ( 1));
+// ^^^^
+// It depends on the tree pattern in avl_geq whether it really decreases
+ = [( 0), 1, 0] if (bb == ( 1)) && (wi == (-1));
+ = [( 0), 1, 0] if (bb == (-1)) && (wi == ( 1));
+ = [( 0), 1, 1] if (bb == (-1)) && (wi == (-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.
+*/
+
+Set_avl_geq x = avl_geq x
+with
+ avl_geq (bin a bala alpha (bin b balb beta gamma))
+ = [bin b ( 0) (bin a ( 0) alpha beta) gamma, 1]
+ if (bala == (-1)) && (balb == (-1));
+
+ avl_geq (bin a bala alpha (bin b balb beta gamma))
+ = [bin b ( 1) (bin a (-1) alpha beta) gamma, 0]
+ if (bala == (-1)) && (balb == ( 0));
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin a bala alpha
+ (bin b balb (bin x b1 beta gamma) delta))
+ = [bin x ( 0) (bin a b2 alpha beta)
+ (bin b b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end
+ if (bala == (-1)) && (balb == ( 1));
+
+ avl_geq (bin b balb (bin a bala alpha beta) gamma)
+ = [bin a ( 0) alpha (bin b ( 0) beta gamma), 1]
+ if (balb == ( 1)) && (bala == ( 1));
+
+ avl_geq (bin b balb (bin a bala alpha beta) gamma)
+ = [bin a (-1) alpha (bin b ( 1) beta gamma), 0]
+ if (balb == ( 1)) && (bala == ( 0));
+ // the tree doesn't decrease with this pattern
+
+ avl_geq (bin b balb
+ (bin a bala alpha (bin x b1 beta gamma)) delta)
+ = [bin x ( 0) (bin a b2 alpha beta)
+ (bin b b3 gamma delta), 1]
+ when
+ [b2, b3] = table b1
+ end
+ if (balb == ( 1)) && (bala == (-1));
+
+ table bal = [( 0), (-1)] if bal == ( 1);
+ = [( 1), ( 0)] if bal == (-1);
+ = [( 0), ( 0)] if bal == ( 0);
+end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
