Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

299 lines (230 sloc) 8.281 kb
/*
hashtable.pure
Copyright (c) 2012 by Dubiousjim <dubiousjim@gmail.com>.
BSD License at https://github.com/dubiousjim/unspoiled/blob/master/LICENSE
*/
namespace hashtable;
private H;
type hashtable (H _ _);
const minsize = 3; // default size for empty hashtables
const maxsize = 1073741823; // 2^30 - 1, 2^30 is largest power of 2 that's still a positive signed int, this is maxint >> 1
private nonfix abort notfound;
private new_hashtable new_matrix buckets eq len2;
public emptyhashtable hashtable mkhashtable size null;
public member getk eachk insert delete replace clear;
public do fold members;
// new hashtable (nullary function)
emptyhashtable = new_hashtable minsize;
// create hashtable of specific size >= 1
hashtable siz::int = new_hashtable (max 1 siz);
// create hashtable from list
hashtable xs::list =
::do (insert h) xs $$ h
when h = new_hashtable (max minsize siz) end
if siz >= 0 when siz = len2 xs end; // improper list will return siz < 0
// create hashtable from list of keys and constant value
mkhashtable v xs::list =
::do (\k -> insert h (k=>v)) xs $$ h
when h = new_hashtable (max minsize siz) end
if siz >= 0 when siz = len2 xs end;
// get number of keys, including duplicates
size (H sizeptr _) = get sizeptr;
null (H sizeptr _) = get sizeptr == 0;
member (H sizeptr mptr) k =
mem k (get (m ! (hash k mod #m)))
when
m = get mptr;
end with
mem _ [] = false;
mem k ((xk=>_):xs) = eq k xk || mem k xs;
end;
// unroll the first few steps for performance
getk (H sizeptr mptr) k default =
case get (m ! (hash k mod #m)) of
[] = default; // throw out_of_bounds
(xk=>xv):xs = if eq k xk then xv
else case xs of
[] = default; // throw out_of_bounds
(xk=>xv):xs = if eq k xk then xv else aux k xs;
end;
end when
m = get mptr;
end with
aux k [] = default; // throw out_of_bounds
aux k ((xk=>xv):xs) = if eq k xk then xv else aux k xs;
end;
// The `f (k=>v) = ...` handler for eachk should return one of:
// REPLACE y, stop? --- k=>y replaces k=>v in hashtable
// INSERT y, stop? --- k=>y is inserted into hashtable before k=>v
// DELETE, stop? --- k=>v is removed from hashtable
// stop? --- in all cases, stop? === 0 means continue
// else stop value is returned
public REPLACE INSERT; public nonfix DELETE;
eachk (H sizeptr mptr) f k default =
case aux f nsiz k (get cell) of
nsiz, xs, res = put cell xs $$
put sizeptr nsiz $$
(if nsiz > msiz << 1 then resize h else ()) $$
(if res === notfound
then default // throw out_of_bounds
else res)
end when
m = get mptr;
msiz = #m;
nsiz = get sizeptr;
cell = m ! (hash k mod msiz);
end with
aux f nsiz _ [] = nsiz, [], notfound;
aux f nsiz k xx@(x@(xk=>_):xs) =
if eq k xk then case f x of
REPLACE y, stop = case aux f nsiz k xs of
nsiz, xs, stop = nsiz, (k=>y):xs, stop;
end if stop === 0;
= nsiz, (k=>y):xs, stop otherwise;
INSERT y, stop = case aux f (nsiz+1) k xs of
nsiz, xs, stop = nsiz, (k=>y):x:xs, stop;
end if stop === 0;
= (nsiz+1), (k=>y):xx, stop otherwise;
DELETE, stop = aux f (nsiz-1) k xs if stop === 0;
= (nsiz-1), xs, stop otherwise;
stop = case aux f nsiz k xs of
nsiz, xs, stop = nsiz, x:xs, stop;
end if stop === 0;
= nsiz, xx, stop otherwise;
end else case aux f nsiz k xs of
nsiz, xs, stop = nsiz, x:xs, stop;
end;
end;
// removes newest of duplicate keys
// does nothing if key not in hashtable
delete (H sizeptr mptr) k =
put cell (del sizeptr k (get cell)) $$ ()
when
m = get mptr;
cell = m ! (hash k mod #m);
end with
del _ _ [] = [];
del sizeptr k (x@(xk=>_):xs) =
if eq k xk then put sizeptr (get sizeptr - 1) $$ xs
else x:del sizeptr k xs;
end;
// doesn't delete old bindings for k, just shadows them
insert h@(H sizeptr mptr) new@(k=>_) =
put cell (new:get cell) $$
put sizeptr nsiz $$
(if nsiz > msiz << 1 then resize h else ())
when
m = get mptr;
msiz = #m;
nsiz = get sizeptr + 1;
cell = m ! (hash k mod msiz);
end;
// curried version of insert
// update h k v = insert h (k=>v);
// replaces current binding of k with k=>v
// equivalent to `delete h k $$ insert h (k=>v)`
replace h@(H sizeptr mptr) new@(k=>v) =
catch handle (put cell (repl k (get cell)) $$ ())
with
repl _ [] = throw abort;
repl k (x@(xk=>_):xs) = if eq k xk then (xk=>v):xs else x:repl k xs;
handle abort =
put cell (new:get cell) $$
put sizeptr nsiz $$
(if nsiz > msiz << 1 then resize h else ())
when nsiz = get sizeptr + 1 end;
handle e = throw e;
end when
m = get mptr;
msiz = #m;
cell = m ! (hash k mod msiz);
end;
// order in which (k=>v)s are given to f is unspecified, except
// that duplicate keys are given newest first
// f should have signature: f (k=>v)
do f (H _ mptr) = loop f (#m - 1) m
when
m = get mptr;
end with
loop f i m = aux f (get (m!i)) $$ loop f (i-1) m if i >= 0;
= ();
aux _ [] = ();
aux f (x:xs) = f x $$ aux f xs;
end;
// order in which (k=>v)s are given to f is unspecified, except
// that duplicate keys are given newest first
// f should have signature: f (k=>v) a
fold f a (H _ mptr) = loop f a (#m - 1) m
when
m = get mptr;
end with
loop f a i m = loop f (aux f a (get (m!i))) (i-1) m if i >= 0;
= a;
aux _ a [] = a;
aux f a (x:xs) = aux f (f x a) xs;
end;
public members;
// list members as (k=>v), duplicate keys are listed oldest first
members h = fold (:) [] h;
// keys h
// vals h
// careful: have to prefix with space in interpreter or it will parse as cmd
clear (H sizeptr mptr) =
loop (#m - 1) m $$ put sizeptr 0 $$ ()
when
m = get mptr;
end with
loop i m = put (m!i) [] $$ loop (i-1) m if i >= 0;
= ();
end;
/*
copy (H sizeptr mptr) = H (ref (get sizeptr)) (copy_array (get mptr));
// delete a member by key=>val
public deletekv h (k=>v); // fail silently
// delete all instances of a given key
delete_all (Dict d) x = Dict (avl::deletek d x);
*/
/* Private helper functions. */
eq u v = case u==v of res::int = res; _ = u===v end;
new_matrix siz::int = smatrix (rep siz []) with
rep n::int xs = xs if n <=0;
= rep (n-1) (ref []:xs);
end;
// H (ref #elements) (ref $ smatrix of (ref []))
// hashtable grows as needed
new_hashtable siz::int = H (ref 0) (ref (new_matrix (min maxsize siz)));
// 0 elements take a matrix size 0
// 1..2 elements take a matrix size 1
// 3..6 elements take a matrix size 3
// 7..14 elements take a matrix size 7
len2 xs = aux xs 0 1 - 1 with
aux [] a::int b::int = b;
aux (_:xs) a::int b::int = aux xs (b-1) b when b = 2*b end if a == 0;
= aux xs (a-1) b otherwise;
aux _ _::int _::int = 0; /* improper list */
end;
resize (H _ mptr) = if nsiz ~= msiz then (
loop (msiz - 1) m $$ put mptr n $$ ()
with
loop i m = aux (get (m!i)) $$ loop (i-1) m if i >= 0;
= ();
aux [] = ();
aux (x@(xk=>_):xs) = aux xs $$ /* preserve original order of elements */
(put cell (x:get cell) when cell = n ! (hash xk mod nsiz) end);
end when
n = new_matrix nsiz;
end) else ()
when
m = get mptr;
msiz = #m;
nsiz = min maxsize (2*msiz + 1);
end;
/*
extern expr* matrix_from_int_array(int n, int m, void* p);
extern expr* matrix_int(expr *x);
extern expr* matrix_symbolic(expr *x);
zeromatrix siz = matrix_from_int_array 1 siz NULL;
smatrixp x = case x of _::matrix = matrix_type x==0; _ = 0 end;
smatrix x = y if matrixp y when y = matrix_symbolic x end;
and matrixp y := typep matrix y;
*/
Jump to Line
Something went wrong with that request. Please try again.