[pure-lang-svn] SF.net SVN: pure-lang: [412] pure/trunk
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
[pure-lang-svn] SF.net SVN: pure-lang: [412] pure/trunk
|
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] |
