1/*  Part of CHR (Constraint Handling Rules)
    2
    3    Author:        Tom Schrijvers
    4    E-mail:        Tom.Schrijvers@cs.kuleuven.be
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2004-2013, K.U. Leuven
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35% author: Tom Schrijvers
   36% email:  Tom.Schrijvers@cs.kuleuven.be
   37% copyright: K.U.Leuven, 2004
   38
   39:- module(chr_hashtable_store,
   40	[ new_ht/1,
   41	  lookup_ht/3,
   42	  lookup_ht1/4,
   43	  lookup_ht2/4,
   44	  insert_ht/3,
   45	  insert_ht1/4,
   46	  insert_ht/4,
   47	  delete_ht/3,
   48	  delete_ht1/4,
   49	  delete_first_ht/3,
   50	  value_ht/2,
   51	  stats_ht/1,
   52	  stats_ht/1
   53	]).   54
   55:- use_module(pairlist).   56:- use_module(library(dialect/hprolog)).   57:- use_module(library(lists)).   58
   59:- multifile user:goal_expansion/2.   60:- dynamic user:goal_expansion/2.   61
   62initial_capacity(89).
   63
   64new_ht(HT) :-
   65	initial_capacity(Capacity),
   66	new_ht(Capacity,HT).
   67
   68new_ht(Capacity,HT) :-
   69	functor(T1,t,Capacity),
   70	HT = ht(Capacity,0,Table),
   71	Table = T1.
   72
   73lookup_ht(HT,Key,Values) :-
   74	term_hash(Key,Hash),
   75	lookup_ht1(HT,Hash,Key,Values).
   76/*
   77	HT = ht(Capacity,_,Table),
   78	Index is (Hash mod Capacity) + 1,
   79	arg(Index,Table,Bucket),
   80	nonvar(Bucket),
   81	( Bucket = K-Vs ->
   82	    K == Key,
   83	    Values = Vs
   84	;
   85	    lookup(Bucket,Key,Values)
   86	).
   87*/
   88
   89% :- load_foreign_library(chr_support).
   90
   91/*
   92lookup_ht1(HT,Hash,Key,Values) :-
   93	( lookup_ht1_(HT,Hash,Key,Values) ->
   94		true
   95	;
   96		( lookup_ht1__(HT,Hash,Key,Values) ->
   97			writeln(lookup_ht1(HT,Hash,Key,Values)),
   98			throw(error)
   99		;
  100			fail
  101		)
  102	).
  103*/
  104
  105lookup_ht1(HT,Hash,Key,Values) :-
  106	HT = ht(Capacity,_,Table),
  107	Index is (Hash mod Capacity) + 1,
  108	arg(Index,Table,Bucket),
  109	nonvar(Bucket),
  110	( Bucket = K-Vs ->
  111	    K == Key,
  112	    Values = Vs
  113	;
  114	    lookup(Bucket,Key,Values)
  115	).
  116
  117lookup_ht2(HT,Key,Values,Index) :-
  118	term_hash(Key,Hash),
  119	HT = ht(Capacity,_,Table),
  120	Index is (Hash mod Capacity) + 1,
  121	arg(Index,Table,Bucket),
  122	nonvar(Bucket),
  123	( Bucket = K-Vs ->
  124	    K == Key,
  125	    Values = Vs
  126	;
  127	    lookup(Bucket,Key,Values)
  128	).
  129
  130lookup_pair_eq([P | KVs],Key,Pair) :-
  131	P = K-_,
  132	( K == Key ->
  133		P = Pair
  134	;
  135		lookup_pair_eq(KVs,Key,Pair)
  136	).
  137
  138insert_ht(HT,Key,Value) :-
  139	term_hash(Key,Hash),
  140	HT = ht(Capacity0,Load,Table0),
  141	LookupIndex is (Hash mod Capacity0) + 1,
  142	arg(LookupIndex,Table0,LookupBucket),
  143	( var(LookupBucket) ->
  144		LookupBucket = Key - [Value]
  145	; LookupBucket = K-Values ->
  146		( K == Key ->
  147			setarg(2,LookupBucket,[Value|Values])
  148		;
  149			setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
  150		)
  151	;
  152		( lookup_pair_eq(LookupBucket,Key,Pair) ->
  153			Pair = _-Values,
  154			setarg(2,Pair,[Value|Values])
  155		;
  156			setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
  157		)
  158	),
  159	NLoad is Load + 1,
  160	setarg(2,HT,NLoad),
  161	( Load == Capacity0 ->
  162		expand_ht(HT,_Capacity)
  163	;
  164		true
  165	).
  166
  167insert_ht1(HT,Key,Hash,Value) :-
  168	HT = ht(Capacity0,Load,Table0),
  169	LookupIndex is (Hash mod Capacity0) + 1,
  170	arg(LookupIndex,Table0,LookupBucket),
  171	( var(LookupBucket) ->
  172		LookupBucket = Key - [Value]
  173	; LookupBucket = K-Values ->
  174		( K == Key ->
  175			setarg(2,LookupBucket,[Value|Values])
  176		;
  177			setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
  178		)
  179	;
  180		( lookup_pair_eq(LookupBucket,Key,Pair) ->
  181			Pair = _-Values,
  182			setarg(2,Pair,[Value|Values])
  183		;
  184			setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
  185		)
  186	),
  187	NLoad is Load + 1,
  188	setarg(2,HT,NLoad),
  189	( Load == Capacity0 ->
  190		expand_ht(HT,_Capacity)
  191	;
  192		true
  193	).
  194
  195% LDK: insert version with extra argument denoting result
  196
  197insert_ht(HT,Key,Value,Result) :-
  198	HT = ht(Capacity,Load,Table),
  199	term_hash(Key,Hash),
  200	LookupIndex is (Hash mod Capacity) + 1,
  201	arg(LookupIndex,Table,LookupBucket),
  202	(   var(LookupBucket)
  203	->  Result = [Value],
  204	    LookupBucket = Key - Result,
  205	    NewLoad is Load + 1
  206	;   LookupBucket = K - V
  207	->  (   K = Key
  208	    ->  Result = [Value|V],
  209		setarg(2,LookupBucket,Result),
  210		NewLoad = Load
  211	    ;   Result = [Value],
  212		setarg(LookupIndex,Table,[Key - Result,LookupBucket]),
  213		NewLoad is Load + 1
  214	    )
  215	;   (   lookup_pair_eq(LookupBucket,Key,Pair)
  216	    ->  Pair = _-Values,
  217		Result = [Value|Values],
  218		setarg(2,Pair,Result),
  219		NewLoad = Load
  220	    ;   Result = [Value],
  221		setarg(LookupIndex,Table,[Key - Result|LookupBucket]),
  222		NewLoad is Load + 1
  223	    )
  224	),
  225	setarg(2,HT,NewLoad),
  226	(   NewLoad > Capacity
  227	->  expand_ht(HT,_)
  228	;   true
  229	).
  230
  231% LDK: deletion of the first element of a bucket
  232delete_first_ht(HT,Key,Values) :-
  233	HT = ht(Capacity,Load,Table),
  234	term_hash(Key,Hash),
  235	Index is (Hash mod Capacity) + 1,
  236	arg(Index,Table,Bucket),
  237	(   Bucket = _-[_|Values]
  238	->  (   Values = []
  239	    ->  setarg(Index,Table,_),
  240		NewLoad is Load - 1
  241	    ;   setarg(2,Bucket,Values),
  242		NewLoad = Load
  243	    )
  244	;   lookup_pair_eq(Bucket,Key,Pair)
  245	->  Pair = _-[_|Values],
  246	    (   Values = []
  247	    ->  pairlist_delete_eq(Bucket,Key,NewBucket),
  248		(   NewBucket = []
  249		->  setarg(Index,Table,_)
  250		;   NewBucket = [OtherPair]
  251		->  setarg(Index,Table,OtherPair)
  252		;   setarg(Index,Table,NewBucket)
  253		),
  254		NewLoad is Load - 1
  255	    ;   setarg(2,Pair,Values),
  256		NewLoad = Load
  257	    )
  258	),
  259	setarg(2,HT,NewLoad).
  260
  261delete_ht(HT,Key,Value) :-
  262	HT = ht(Capacity,Load,Table),
  263	NLoad is Load - 1,
  264	term_hash(Key,Hash),
  265	Index is (Hash mod Capacity) + 1,
  266	arg(Index,Table,Bucket),
  267	( /* var(Bucket) ->
  268		true
  269	; */ Bucket = _K-Vs ->
  270		( /* _K == Key, */
  271		  delete_first_fail(Vs,Value,NVs) ->
  272			setarg(2,HT,NLoad),
  273			( NVs == [] ->
  274				setarg(Index,Table,_)
  275			;
  276				setarg(2,Bucket,NVs)
  277			)
  278		;
  279			true
  280		)
  281	;
  282		( lookup_pair_eq(Bucket,Key,Pair),
  283		  Pair = _-Vs,
  284		  delete_first_fail(Vs,Value,NVs) ->
  285			setarg(2,HT,NLoad),
  286			( NVs == [] ->
  287				pairlist_delete_eq(Bucket,Key,NBucket),
  288				( NBucket = [Singleton] ->
  289					setarg(Index,Table,Singleton)
  290				;
  291					setarg(Index,Table,NBucket)
  292				)
  293			;
  294				setarg(2,Pair,NVs)
  295			)
  296		;
  297			true
  298		)
  299	).
  300
  301delete_first_fail([X | Xs], Y, Zs) :-
  302	( X == Y ->
  303		Zs = Xs
  304	;
  305		Zs = [X | Zs1],
  306		delete_first_fail(Xs, Y, Zs1)
  307	).
  308
  309delete_ht1(HT,Key,Value,Index) :-
  310	HT = ht(_Capacity,Load,Table),
  311	NLoad is Load - 1,
  312	% term_hash(Key,Hash),
  313	% Index is (Hash mod _Capacity) + 1,
  314	arg(Index,Table,Bucket),
  315	( /* var(Bucket) ->
  316		true
  317	; */ Bucket = _K-Vs ->
  318		( /* _K == Key, */
  319		  delete_first_fail(Vs,Value,NVs) ->
  320			setarg(2,HT,NLoad),
  321			( NVs == [] ->
  322				setarg(Index,Table,_)
  323			;
  324				setarg(2,Bucket,NVs)
  325			)
  326		;
  327			true
  328		)
  329	;
  330		( lookup_pair_eq(Bucket,Key,Pair),
  331		  Pair = _-Vs,
  332		  delete_first_fail(Vs,Value,NVs) ->
  333			setarg(2,HT,NLoad),
  334			( NVs == [] ->
  335				pairlist_delete_eq(Bucket,Key,NBucket),
  336				( NBucket = [Singleton] ->
  337					setarg(Index,Table,Singleton)
  338				;
  339					setarg(Index,Table,NBucket)
  340				)
  341			;
  342				setarg(2,Pair,NVs)
  343			)
  344		;
  345			true
  346		)
  347	).
  348%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  349value_ht(HT,Value) :-
  350	HT = ht(Capacity,_,Table),
  351	value_ht(1,Capacity,Table,Value).
  352
  353value_ht(I,N,Table,Value) :-
  354	I =< N,
  355	arg(I,Table,Bucket),
  356	(
  357		nonvar(Bucket),
  358		( Bucket = _-Vs ->
  359			true
  360		;
  361			member(_-Vs,Bucket)
  362		),
  363		member(Value,Vs)
  364	;
  365		J is I + 1,
  366		value_ht(J,N,Table,Value)
  367	).
  368
  369%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  370
  371expand_ht(HT,NewCapacity) :-
  372	HT = ht(Capacity,_,Table),
  373	NewCapacity is Capacity * 2 + 1,
  374	functor(NewTable,t,NewCapacity),
  375	setarg(1,HT,NewCapacity),
  376	setarg(3,HT,NewTable),
  377	expand_copy(Table,1,Capacity,NewTable,NewCapacity).
  378
  379expand_copy(Table,I,N,NewTable,NewCapacity) :-
  380	( I > N ->
  381		true
  382	;
  383		arg(I,Table,Bucket),
  384		( var(Bucket) ->
  385			true
  386		; Bucket = Key - Value ->
  387			expand_insert(NewTable,NewCapacity,Key,Value)
  388		;
  389			expand_inserts(Bucket,NewTable,NewCapacity)
  390		),
  391		J is I + 1,
  392		expand_copy(Table,J,N,NewTable,NewCapacity)
  393	).
  394
  395expand_inserts([],_,_).
  396expand_inserts([K-V|R],Table,Capacity) :-
  397	expand_insert(Table,Capacity,K,V),
  398	expand_inserts(R,Table,Capacity).
  399
  400expand_insert(Table,Capacity,K,V) :-
  401	term_hash(K,Hash),
  402	Index is (Hash mod Capacity) + 1,
  403	arg(Index,Table,Bucket),
  404	( var(Bucket) ->
  405		Bucket = K - V
  406	; Bucket = _-_ ->
  407		setarg(Index,Table,[K-V,Bucket])
  408	;
  409		setarg(Index,Table,[K-V|Bucket])
  410	).
  411%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  412stats_ht(HT) :-
  413	HT = ht(Capacity,Load,Table),
  414	format('HT load = ~w / ~w\n',[Load,Capacity]),
  415	( between(1,Capacity,Index),
  416		arg(Index,Table,Entry),
  417		( var(Entry)  -> Size = 0
  418		; Entry = _-_ -> Size = 1
  419		; length(Entry,Size)
  420		),
  421		format('~w : ~w\n',[Index,Size]),
  422		fail
  423	;
  424		true
  425	)