hashtable.pure

/*
 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;
*/