├── .fileheader ├── .gitignore ├── Makefile ├── README.md ├── batched_worklist.pl ├── double_linked_list.pl ├── global_worklist.pl ├── table_datastructure.pl ├── table_link_manager.pl ├── table_print.pl ├── table_utils.pl ├── tabling.pl ├── test_tabling.pl ├── test_trie.pl ├── testlib.pl ├── testlib2.pl ├── trie.pl └── wrapper.pl /.fileheader: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) %Y, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .gdbinit 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | check:: 2 | swipl -g test_tabling,halt test_tabling.pl -t 'halt(1)' 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Tabling as a Library with Delimited Control 2 | =========================================== 3 | 4 | This library is described in the paper "Tabling as Library with Delimited 5 | Control" by Benoit Desouter, Marko van Dooren and Tom Schrijvers. 6 | 7 | Email: Benoit dot Desouter at UGent dot be 8 | 9 | ## SWI-Prolog port 10 | 11 | ### Usage 12 | 13 | - Include `:- use_module('/path/to/tabling_library/tabling').` 14 | - Use :- table name/arity, ... . 15 | 16 | ### Changes for this port 17 | 18 | This repository contains the port to SWI-Prolog. Summary of changes: 19 | 20 | - Added modules to files 21 | - Used SWI-Prolog libraries (assoc, gensym) 22 | - Some nb_link{arg,val} changes. Use duplicate_term/2 rather 23 | than copy_term/2. 24 | - Avoid using common names for global variables 25 | - Initialize global variables lazily, so it works in any thread. 26 | - Added automatic wrapper generation 27 | - Turned examples into test_tabling.pl and added `make check` 28 | - Added XSB abolish_all_tables/0 29 | 30 | Requires GIT version (https://github.com/SWI-Prolog/swipl-devel.pl) 31 | 32 | ### Status 33 | 34 | Pretty experimental. 35 | 36 | - Using nb_{set,link}{arg,val} to manage the tables on the stack is 37 | fragile. At this moment, **tabling goes wrong if the debugger is 38 | enabled**. 39 | - Exceptions while solving a tabled predicate leaves incomplete 40 | tables. Use `?- abolish_all_tables.` before continuing. 41 | 42 | 43 | ### Plans 44 | 45 | - Move table/trie store to C for performance and to get rid of 46 | the ill defined behaviour on backtracking. 47 | - Deal with exceptions 48 | - Add more table management predicates from XSB. 49 | - Much more 50 | 51 | ### Branches 52 | 53 | - **master** contains a minimal port. Runs with the `master` 54 | branch of `swipl-devel.git`. 55 | - **builtin-trie** uses a C implementation of the tries to 56 | store answers. Requires the branch `trie` of `swipl-devel.git`. 57 | Tries are also in the newer `worklist` branch of `swipl-devel.git`, 58 | which is probably a better choice. 59 | - **builtin-worklist** uses both the builtin tries and a builtin 60 | representation for the worklist, storing all non-backtrackable 61 | data in C. Requires the `worklist` branch of `swipl-devel.git`. 62 | This version is between 4 and 15 times faster than the **master** 63 | version above and uses a lot less memory. 64 | -------------------------------------------------------------------------------- /batched_worklist.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(batched_worklist, 35 | [ wkl_add_answer/2, % +WorkList, +Answer 36 | wkl_add_suspension/2, % +Worklist, +Suspension 37 | wkl_new_worklist/2, % +TableID, -WorkList 38 | unset_flag_executing_all_work/1, % +WorkList 39 | unset_global_worklist_presence_flag/1, % +WorkList 40 | set_flag_executing_all_work/1, % +WorkList 41 | wkl_p_get_rightmost_inner_answer_cluster_pointer/2, % +WorkList, -Cluster 42 | wkl_p_swap_answer_continuation/3, % +WorkList, +Cluster1, +Cluster2 43 | wkl_worklist_work_done/1 % +WorkList 44 | ]). 45 | :- use_module(global_worklist). 46 | :- use_module(double_linked_list). 47 | :- use_module(library(lists)). 48 | 49 | /** Tabling Worklist management 50 | 51 | A batched worklist: a worklist that clusters suspensions and answers as 52 | much as possible. The idea is to minimize the number of swaps. This 53 | should be more efficient than the worklist implementation without 54 | clustering. 55 | 56 | Argument positions for nb_setarg: 57 | 58 | 1. double linked list 59 | 2. pointer to the list entry of the rightmost inner answer cluster 60 | 3. flag indicating the execution of wkl_unfolded_do_all_work 61 | 4. flag indicating whether the table identifier associated with this 62 | worklist is already in the global worklist. This is because more 63 | than one answer can be added due to the execution of other 64 | worklists. 5: table identifier for the table this worklist belongs 65 | to 66 | 67 | Contents of a batched worklist: 68 | 69 | - wkl_answer_cluster([Answer|RestAnswers]). 70 | - wkl_suspension([Suspension|RestSuspension]). 71 | 72 | The difficulty is that you should not add new entries to a cluster once 73 | you started its execution. Probably the simplest way to do so is by 74 | swapping the answer cluster AC and suspension cluster SC before you take 75 | the cartesian product of all answers in AC with all suspensions in SC. 76 | 77 | Illustration why you may need a complex procedure for finding the future 78 | rightmost inner answer cluster. 79 | 80 | ssume all clusters have 2 entries. 81 | 82 | 1. AA1 CC1 83 | 2. AA2 CC1 AA1 CC2 (swapped AA1 and CC1) 84 | 3. AA2 CC1 CC2 AA1 (swapped AA1 and CC2) 85 | 4. AA3 CC1 AA2 CC2 AA1 CC3 (swapped AA2 and CC1) 86 | 87 | Now AA1 is the RIAC, but AA2 is the future RIAC. 88 | 89 | Can you find the future RIAC smarter than by walking back? If you don't, 90 | then it doesn't make sense to use a future RIAC at all. You could use a 91 | stack, which should not grow too large because you use batches. But 92 | walking back also should not take too long, since you use batches. 93 | 94 | So let's not use a future RIAC in the first place, and just walk back 95 | when we need a new RIAC. This is easy to implement, hence we can test 96 | more quickly. 97 | 98 | Abbreviations: 99 | 100 | - RIAC = rightmost inner answer cluster 101 | - FUTRIAC = future rightmost inner answer cluster 102 | */ 103 | 104 | %% wkl_new_worklist(+TableID, -WorkList) is det. 105 | % 106 | % Create a new worklist for TableID and add it to the global 107 | % worklist list (global variable `table_global_worklist`. 108 | 109 | wkl_new_worklist(TableIdentifier, wkl_worklist(List,List,false,true,TableIdentifier)) :- 110 | dll_new_double_linked_list(List), 111 | % We set the RIAC to the dummy element at the start of the double linked list, which is List. 112 | % Don't set all the rest for now. 113 | add_to_global_worklist(TableIdentifier). 114 | 115 | %% wkl_worklist_work_done(+WorkList) is semidet. 116 | % 117 | % The work is done if the RIAC pointer points to the unused cell 118 | % at the beginning. The work is also done if the RIAC pointer 119 | % points to the sole answer cluster in a list dll_start - 120 | % wkl_answer_cluster, because in that case there are no 121 | % suspensions to swap with. This is a special case, which we only 122 | % discovered by testing. You can detect it by checking whether the 123 | % NEXT-pointer of the RIAC is the dummy pointer. 124 | 125 | wkl_worklist_work_done(Worklist) :- 126 | wkl_p_get_rightmost_inner_answer_cluster_pointer(Worklist,RiacPointer), 127 | ( wkl_is_dummy_pointer(Worklist,RiacPointer) -> 128 | true 129 | ; 130 | dll_get_pointer_to_next(RiacPointer,NextPointer), 131 | wkl_is_dummy_pointer(Worklist,NextPointer) 132 | ). 133 | 134 | set_flag_executing_all_work(Worklist) :- 135 | nb_setarg(3,Worklist,true). 136 | 137 | unset_flag_executing_all_work(Worklist) :- 138 | nb_setarg(3,Worklist,false). 139 | 140 | % Swap answer cluster and the adjacent continuation cluster. 141 | % Mode: + + - 142 | wkl_p_swap_answer_continuation(Worklist,InnerAnswerClusterPointer,SuspensionClusterPointer) :- 143 | % You can have a worklist containing only an answer cluster, but no continuations. 144 | % In that case SuspensionClusterPointer will be dll_start. We must take our precautions elsewhere. 145 | % Do not forget that the list of answers and the list of suspensions is wrapped in a predicate! 146 | dll_get_pointer_to_next(InnerAnswerClusterPointer,SuspensionClusterPointer), 147 | % For reasons of speed we don't use dll_swap: we only swap adjacent elements and we can be sure that they are in the order A,B. 148 | % Therefore we can use dll_p_swap_adjacent_elements_ 149 | dll_p_swap_adjacent_elements_(InnerAnswerClusterPointer,SuspensionClusterPointer), 150 | % Update the necessary pointers 151 | wkl_p_update_righmost_inner_answer_cluster_pointer(Worklist,InnerAnswerClusterPointer). 152 | 153 | % Update the pointer if the answer cluster it points to is no longer the rightmost inner answer cluster. 154 | wkl_p_update_righmost_inner_answer_cluster_pointer(Worklist,InnerAnswerClusterPointer) :- 155 | ( wkl_p_answer_cluster_currently_moved_completely(Worklist,InnerAnswerClusterPointer) -> 156 | wkl_p_find_new_rightmost_inner_answer_cluster_pointer(Worklist,InnerAnswerClusterPointer,NewRiacPointer), 157 | wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,NewRiacPointer) 158 | ; 159 | true 160 | ). 161 | 162 | % Rationale for this implementation: see the top of the file. 163 | % Unify NewRiacPointer to the first pointer satisfying the following conditions: 164 | % - left of StartPointer (when viewing the list as DUMMY-ELEM POINTER POINTER POINTER START-POINTER) 165 | % - either an anwer pointer or the dummy element 166 | % When StartPointer is the dummy element, NewRiacPointer is also the dummy element. We never look "in front of" the dummy element. 167 | wkl_p_find_new_rightmost_inner_answer_cluster_pointer(Worklist,StartPointer,NewRiacPointer) :- 168 | ( wkl_is_dummy_pointer(Worklist,StartPointer) -> 169 | NewRiacPointer = StartPointer 170 | ; 171 | dll_get_pointer_to_previous(StartPointer,FirstCandidatePointer), 172 | wkl_p_find_new_riac_helper(Worklist,FirstCandidatePointer,NewRiacPointer) 173 | ). 174 | 175 | wkl_p_find_new_riac_helper(Worklist,CandidatePointer,NewRiacPointer) :- 176 | ( is_answer_cluster_or_dummy_pointer(Worklist,CandidatePointer) -> 177 | NewRiacPointer = CandidatePointer 178 | ; 179 | dll_get_pointer_to_previous(CandidatePointer,NewCandidate), 180 | wkl_p_find_new_riac_helper(Worklist,NewCandidate,NewRiacPointer) 181 | ). 182 | 183 | is_answer_cluster_or_dummy_pointer(Worklist,Pointer) :- 184 | ( wkl_is_dummy_pointer(Worklist,Pointer) -> 185 | true 186 | ; 187 | wkl_p_dereference_pointer(Worklist,Pointer,A), 188 | wkl_p_is_answer_cluster(A) 189 | ). 190 | 191 | % Failure-driven loop 192 | wkl_clusters_cartesian_product(AnswerCluster,SuspensionCluster) :- 193 | ( member(Answer,AnswerCluster), 194 | member(Suspension,SuspensionCluster), 195 | % The meat 196 | run_worklist_helper(Suspension,Answer), 197 | % Trigger loop 198 | fail 199 | ; 200 | % Loop base case 201 | true 202 | ). 203 | 204 | run_worklist_helper(_Suspension, _Answer) :- % FIXME: just silense 205 | throw('not implemented'). 206 | 207 | wkl_both_flags_unset(wkl_worklist(_Dll,_Riac,false,false,_TableIdentifier)). 208 | 209 | set_global_worklist_presence_flag(Worklist) :- 210 | nb_setarg(4,Worklist,true). 211 | 212 | unset_global_worklist_presence_flag(Worklist) :- 213 | nb_setarg(4,Worklist,false). 214 | 215 | potentially_add_to_global_worklist(Worklist) :- 216 | ( wkl_both_flags_unset(Worklist) -> 217 | % Set the flag for presence in the metaworklist 218 | set_global_worklist_presence_flag(Worklist), 219 | % Should add to the metaworklist 220 | arg(5,Worklist,TableIdentifier), 221 | add_to_global_worklist(TableIdentifier) 222 | ; 223 | % Nothing to do. 224 | true 225 | ). 226 | 227 | wkl_add_answer(Worklist,Answer) :- 228 | % Add to global worklist if not executing during wkl_unfolded_do_all_work and not there yet as well. 229 | potentially_add_to_global_worklist(Worklist), 230 | ( wkl_p_leftmost_cluster_is_answer_cluster(Worklist) -> 231 | wkl_add_to_existing_answer_cluster(Worklist,Answer) 232 | % If you add to an existing cluster, then obviously you should not change the RIAC. 233 | ; 234 | wkl_add_to_new_answer_cluster(Worklist,Answer,AnswerClusterPointer), 235 | % If the RIAC is the dummy pointer, we need to change that. 236 | wkl_p_update_rightmost_inner_answer_cluster_pointer(Worklist,AnswerClusterPointer) 237 | ). 238 | 239 | wkl_p_update_rightmost_inner_answer_cluster_pointer(Worklist,NewAnswerClusterPointer) :- 240 | wkl_p_get_rightmost_inner_answer_cluster_pointer(Worklist,CurrentRiac), 241 | ( wkl_is_dummy_pointer(Worklist,CurrentRiac) -> 242 | wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,NewAnswerClusterPointer) 243 | ; 244 | % Nothing to do. 245 | true 246 | ). 247 | 248 | wkl_add_suspension(Worklist,Suspension) :- 249 | % Add to global worklist if not executing during wkl_unfolded_do_all_work and not there yet as well. 250 | potentially_add_to_global_worklist(Worklist), 251 | ( wkl_p_rightmost_cluster_is_suspension_cluster(Worklist) -> 252 | wkl_add_to_existing_suspension_cluster(Worklist,Suspension) 253 | ; 254 | wkl_add_to_new_suspension_cluster(Worklist,Suspension,SuspensionClusterPointer), 255 | % If added to a new suspension cluster, we may need to change the righmost inner answer pointer 256 | wkl_p_potential_rias_update_add_contin(Worklist,SuspensionClusterPointer) 257 | ). 258 | 259 | % This predicate should not fail. 260 | wkl_p_potential_rias_update_add_contin(Worklist,SuspensionClusterPointer) :- 261 | % Look back one entry of the freshly inserted SuspensionClusterPointer 262 | dll_get_pointer_to_previous(SuspensionClusterPointer,PotentialNewRiacPointer), 263 | ( wkl_p_is_answer_cluster_pointer(Worklist,PotentialNewRiacPointer) -> 264 | % We must indeed update the rightmost inner answer cluster pointer. 265 | wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,PotentialNewRiacPointer) 266 | ; 267 | % Nothing to do, but we should not fail. 268 | true 269 | ). 270 | 271 | wkl_add_to_existing_answer_cluster(Worklist, Answer) :- 272 | arg(1,Worklist,Dll), 273 | dll_get_pointer_to_next(Dll,AnswerClusterPointer), 274 | wkl_p_dereference_pointer(Worklist,AnswerClusterPointer,AnswerCluster), 275 | AnswerCluster = wkl_answer_cluster(AnswersAlreadyInCluster), 276 | nb_linkarg(1,AnswerCluster,[Answer|AnswersAlreadyInCluster]). 277 | 278 | wkl_add_to_new_answer_cluster( 279 | wkl_worklist(Dll,_Ria,_FlagExecutingWork,_AlreadyInMetaworklist,_TableIdentifier), 280 | Answer,AnswerClusterPointer 281 | ) :- 282 | dll_append_left(Dll,wkl_answer_cluster([Answer]),AnswerClusterPointer). 283 | 284 | wkl_add_to_existing_suspension_cluster(Worklist, Suspension) :- 285 | arg(1,Worklist,Dll), 286 | dll_get_pointer_to_previous(Dll,SuspensionClusterPointer), 287 | wkl_p_dereference_pointer(Worklist,SuspensionClusterPointer,SuspensionCluster), 288 | SuspensionCluster = wkl_suspension_cluster(SuspensionsAlreadyInCluster), 289 | nb_linkarg(1,SuspensionCluster,[Suspension|SuspensionsAlreadyInCluster]). 290 | 291 | wkl_add_to_new_suspension_cluster( 292 | wkl_worklist(Dll,_Ria,_FlagExecutingWork,_AlreadyInMetaworklist,_TableIdentifier), 293 | Suspension, 294 | SuspensionClusterPointer 295 | ) :- 296 | dll_append_right(Dll,wkl_suspension_cluster([Suspension]),SuspensionClusterPointer). 297 | 298 | wkl_p_is_answer_cluster(CandidateAnswerCluster) :- 299 | nonvar(CandidateAnswerCluster), 300 | CandidateAnswerCluster = wkl_answer_cluster(_). 301 | 302 | wkl_p_is_suspension_cluster(CandidateSuspensionCluster) :- 303 | nonvar(CandidateSuspensionCluster), 304 | CandidateSuspensionCluster = wkl_suspension_cluster(_). 305 | 306 | wkl_p_leftmost_cluster_is_answer_cluster(Worklist) :- 307 | arg(1,Worklist,Dll), 308 | dll_get_pointer_to_next(Dll,CandidateAnswerClusterPointer), 309 | wkl_p_is_answer_cluster_pointer(Worklist,CandidateAnswerClusterPointer). 310 | 311 | wkl_p_rightmost_cluster_is_suspension_cluster(Worklist) :- 312 | arg(1,Worklist,Dll), 313 | dll_get_pointer_to_previous(Dll,CandidateSuspensionClusterPointer), 314 | wkl_p_is_suspension_cluster_pointer(Worklist,CandidateSuspensionClusterPointer). 315 | 316 | 317 | wkl_p_get_rightmost_inner_answer_cluster_pointer(wkl_worklist(_Dll,InnerAnswerClusterPointer,_FlagExecutingWork,_AlreadyInMetaworklist,_TableIdentifier), InnerAnswerClusterPointer). 318 | 319 | % Succeed if there are currently no more continuation clusters on the right of the given position: 320 | % Why 'currently' in the name? Another continuation can be added. 321 | wkl_p_answer_cluster_currently_moved_completely(Worklist,AnswerClusterPointer) :- 322 | ( wkl_p_at_right(Worklist,AnswerClusterPointer) -> 323 | true 324 | ; 325 | wkl_p_answer_cluster_on_right(Worklist,AnswerClusterPointer) 326 | ). 327 | 328 | % Succeeds if the given pointer points to the last element in the list. That is, if its next pointer is the dummy element in the double linked list. 329 | wkl_p_at_right(Worklist,Pointer) :- 330 | dll_get_pointer_to_next(Pointer,NextPointer), 331 | wkl_is_dummy_pointer(Worklist,NextPointer). 332 | 333 | wkl_p_answer_cluster_on_right(Worklist,Pointer) :- 334 | dll_get_pointer_to_next(Pointer,NextPointer), 335 | wkl_p_is_answer_cluster_pointer(Worklist,NextPointer). 336 | 337 | wkl_is_dummy_pointer(Worklist,Pointer) :- 338 | wkl_p_get_double_linked_list(Worklist,Dll), 339 | dll_is_dummy_pointer(Dll,Pointer). 340 | 341 | wkl_p_is_answer_cluster_pointer(Worklist,PointerCandidateAnswerCluster) :- 342 | ( wkl_is_dummy_pointer(Worklist,PointerCandidateAnswerCluster) -> 343 | % Certainly not an answer cluster, should not dereference this 344 | fail 345 | ; 346 | wkl_p_dereference_pointer(Worklist,PointerCandidateAnswerCluster,CandidateAnswerCluster), 347 | wkl_p_is_answer_cluster(CandidateAnswerCluster) 348 | ). 349 | 350 | wkl_p_is_suspension_cluster_pointer(Worklist,PointerCandidateSuspensionCluster) :- 351 | ( wkl_is_dummy_pointer(Worklist,PointerCandidateSuspensionCluster) -> 352 | % Certainly not an answer cluster, should not dereference this 353 | fail 354 | ; 355 | wkl_p_dereference_pointer(Worklist,PointerCandidateSuspensionCluster,CandidateSuspensionCluster), 356 | wkl_p_is_suspension_cluster(CandidateSuspensionCluster) 357 | ). 358 | 359 | wkl_p_get_double_linked_list(Worklist,Dll) :- 360 | arg(1,Worklist,Dll). 361 | 362 | % One should not attempt to dereference the dummy pointer in the double linked list. 363 | wkl_p_dereference_pointer(_Worklist,Pointer,Data) :- 364 | dll_get_data(Pointer,Data). 365 | 366 | % SETTING POINTERS 367 | %%%%%%%%%%%%%%%%%% 368 | 369 | wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,AnswerClusterPointer) :- 370 | nb_linkarg(2,Worklist,AnswerClusterPointer). 371 | -------------------------------------------------------------------------------- /double_linked_list.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(double_linkedlist, 35 | [ dll_new_double_linked_list/1, % -List 36 | dll_append_right/2, % !List, +Element 37 | dll_append_left/2, % !List, +Element 38 | dll_append_right/3, % !List, +Element, -Pointer 39 | dll_append_left/3, % !List, +Element, -Pointer 40 | dll_get_data/2, % +List, -Head 41 | dll_get_pointer_to_next/2, % +List, -Pointer 42 | dll_get_pointer_to_previous/2, % +List, -Pointer 43 | dll_is_dummy_pointer/2, % +List, +Pointer 44 | dll_p_swap_adjacent_elements_/2 % +Pointer1, +Pointer2 45 | ]). 46 | 47 | % A circular double linked list 48 | % ============================= 49 | 50 | % Always have a unused-cell at the beginning. 51 | 52 | % I do not always inline unifications because the head is then more readable for users who don't need to know the details. 53 | 54 | % Due to lack of modules in hProlog, the following predicate names should not be used elsewhere: 55 | % - the heads of all following rules (starting with dll_, I reserve "the namespace"!) 56 | 57 | % dll_cell(Element,Next,Previous) 58 | 59 | % The following is perhaps odd: 60 | % 61 | % Next link = more to the front (the left) 62 | % Previous link = more to the back (the right) 63 | % 64 | % List structure 65 | % -------------- 66 | % front-of-the-list | ... | back-of-the-list 67 | 68 | dll_new_double_linked_list(List) :- 69 | % Nonused cell dll_start at the beginning, points to itself (this is easy when adding elements). 70 | List = dll_cell(dll_start,List,List). 71 | 72 | dll_append_right(List,Element) :- 73 | dll_append_right(List,Element,_Pointer). 74 | 75 | dll_append_left(List,Element) :- 76 | dll_append_left(List,Element,_Pointer). 77 | 78 | % Append at the back of the list 79 | % Mode: + + - 80 | dll_append_right(List,Element,Pointer) :- 81 | % Get pointer to cell currently at the back. Done by taking the previous element from the unused element representing the list. 82 | dll_get_pointer_to_previous(List,OldBack), 83 | % Make the new cell point to OldBack as predecessor 84 | % Make the new cell point to the unused cell as successor. 85 | Pointer = dll_cell(Element,List,OldBack), 86 | % Make OldBack point to the new cell as successor 87 | dll_p_set_next_pointer(OldBack,Pointer), 88 | % Make the unused cell point to the new cell as predecessor 89 | dll_p_set_previous_pointer(List,Pointer). 90 | 91 | % Add to the front of the list 92 | % Mode: + + - 93 | dll_append_left(List,Element,Pointer) :- 94 | % Get pointer to cell currently at the front. Done by taking the next element from the unused element representing the list. 95 | dll_get_pointer_to_next(List,OldFront), 96 | % Make the new cell point to OldFront as successor 97 | % Make the new cell point to the unused cell as predecessor 98 | Pointer = dll_cell(Element,OldFront,List), 99 | % Make OldFront point to the new cell as predecessor 100 | dll_p_set_previous_pointer(OldFront,Pointer), 101 | % Make the unused cell point to the new cell as successor 102 | dll_p_set_next_pointer(List,Pointer). 103 | 104 | % get_next_cell? 105 | dll_get_pointer_to_next(dll_cell(_Data,PointerNext,_PointerPrevious),PointerNext). 106 | 107 | % get_previous_cell? 108 | dll_get_pointer_to_previous(dll_cell(_Data,_PointerNext,PointerPrevious),PointerPrevious). 109 | 110 | % Will happily give you the "data" from the unused cell at the beginning. (We use this odd behaviour below, f.e. in dll_p_foreach_element_/2.) 111 | dll_get_data(dll_cell(Data,_PointerNext,_PointerPrevious),Data). 112 | 113 | dll_is_dummy_pointer(List,Pointer) :- 114 | \+ Pointer \= List. 115 | 116 | % Special case of swapping - used in dll_swap/2. 117 | % This is also the case used for swapping a freshly created list with itself. 118 | % 119 | % Sketch: APrevious <-> PointerA <-> PointerB <-> BNext etc. 120 | dll_p_swap_adjacent_elements(PointerA,PointerB) :- 121 | % Order B A? 122 | ( dll_get_pointer_to_next(PointerB,PointerA) -> 123 | dll_p_swap_adjacent_elements_(PointerB,PointerA) 124 | ; 125 | % Order A B! 126 | dll_p_swap_adjacent_elements_(PointerA,PointerB) 127 | ). 128 | 129 | % Assumes the order A B. 130 | dll_p_swap_adjacent_elements_(PointerA,PointerB) :- 131 | % Get A's previous and B's next 132 | dll_get_pointer_to_previous(PointerA,PointerAPrevious), 133 | dll_get_pointer_to_next(PointerB,PointerBNext), 134 | % Set A's previous to B 135 | dll_p_set_previous_pointer(PointerA,PointerB), 136 | % Set B's next to A 137 | dll_p_set_next_pointer(PointerB,PointerA), 138 | % Set A's next to BNext 139 | dll_p_set_next_pointer(PointerA,PointerBNext), 140 | % Set B's previous to APrevious 141 | dll_p_set_previous_pointer(PointerB,PointerAPrevious), 142 | % Set APrevious' next to B !! 143 | dll_p_set_next_pointer(PointerAPrevious,PointerB), 144 | % Set BNext's previous to A !! 145 | dll_p_set_previous_pointer(PointerBNext,PointerA). 146 | 147 | % Private 148 | % Careful: make sure this is called on the actual cell, and not some copy. 149 | % Mode: + + 150 | dll_p_set_previous_pointer(Cell,PointerToNewPrevious) :- 151 | nb_linkarg(3,Cell,PointerToNewPrevious). 152 | 153 | % Private 154 | % Careful: make sure this is called on the actual cell, and not some copy. 155 | % Mode: + + 156 | dll_p_set_next_pointer(Cell,PointerToNewNext) :- 157 | nb_linkarg(2,Cell,PointerToNewNext). 158 | -------------------------------------------------------------------------------- /global_worklist.pl: -------------------------------------------------------------------------------- 1 | :- module(global_worklist, 2 | [ add_to_global_worklist/1, 3 | worklist_empty/0, 4 | pop_worklist/1 5 | ]). 6 | 7 | add_to_global_worklist(TableIdentifier) :- 8 | nb_getval(table_global_worklist,L1), 9 | nb_linkval(table_global_worklist,[TableIdentifier|L1]). 10 | 11 | worklist_empty :- 12 | nb_getval(table_global_worklist,[]). 13 | 14 | pop_worklist(TableIdentifier) :- 15 | nb_getval(table_global_worklist,L1), 16 | L1 = [TableIdentifier|L2], 17 | nb_linkval(table_global_worklist,L2). 18 | -------------------------------------------------------------------------------- /table_datastructure.pl: -------------------------------------------------------------------------------- 1 | :- module(table_datastructure, 2 | [ table_datastructure_initialize/0, 3 | get_answer/2, % +TableID, -Answer 4 | add_answer/2, % +TableID, +Answer 5 | get_call_variant/2, % +TableID, -CallVariant 6 | set_complete_status/1, % +TableID 7 | set_active_status/1, % +TableID 8 | tbd_table_status/2, % +TableID, -Status 9 | table_for_variant/2, % +Variant, -TableID 10 | get_worklist/2, % +TableID, -WorkList 11 | store_dependency/2, % +TableID, +Suspension 12 | cleanup_after_complete/1, % +TableID 13 | get_newly_created_table_identifiers/2, % NewlyCreatedTableIDs, NumIDs 14 | reset_newly_created_table_identifiers/0, 15 | answers_for_variant/2 % +Variant, -Answers 16 | ]). 17 | :- use_module(table_link_manager). 18 | :- use_module(trie). 19 | /* Part of SWI-Prolog 20 | 21 | Author: Benoit Desouter 22 | Jan Wielemaker (SWI-Prolog port) 23 | Copyright (c) 2016, Benoit Desouter 24 | All rights reserved. 25 | 26 | Redistribution and use in source and binary forms, with or without 27 | modification, are permitted provided that the following conditions 28 | are met: 29 | 30 | 1. Redistributions of source code must retain the above copyright 31 | notice, this list of conditions and the following disclaimer. 32 | 33 | 2. Redistributions in binary form must reproduce the above copyright 34 | notice, this list of conditions and the following disclaimer in 35 | the documentation and/or other materials provided with the 36 | distribution. 37 | 38 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 39 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 40 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 41 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 42 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 43 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 44 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 45 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 46 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 47 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 48 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 49 | POSSIBILITY OF SUCH DAMAGE. 50 | */ 51 | 52 | :- use_module(batched_worklist). 53 | :- use_module(library(gensym)). 54 | 55 | % This file defines the table datastructure. 56 | % 57 | % The table datastructure contains the following sub-structures: 58 | % - the answer trie 59 | % - the worklist 60 | % 61 | % Structure for tables: 62 | % table(CallVariant,Status,AnswerTrie,Worklist) or complete_table(CallVariant,AnswerTrie). 63 | % where AnswerTrie contains a trie of unique answers 64 | % 65 | % Remember that a table may also be nonexistent! 66 | % nb_getval(nonexistent,X) then gives []. 67 | 68 | % Initialization! 69 | % This predicate should be called exactly once. 70 | % It throws an exception if it is called more than once. 71 | 72 | %% table_datastructure_initialize 73 | % 74 | % Initializes the global variable 75 | % `newly_created_table_identifiers` and calls 76 | % table_link_manager_initialize/0 to create `trie_table_link`. 77 | % Normally called by user:exception/3. 78 | 79 | table_datastructure_initialize :- 80 | table_link_manager_initialize, 81 | reset_newly_created_table_identifiers. % Put default value in global variable 82 | 83 | % Returns a list of newly created table identifiers since the last call to reset_newly_created_table_identifiers/0, as well as the length of the list. 84 | get_newly_created_table_identifiers(NewlyCreatedTableIdentifiers,NumIdentifiers) :- 85 | nb_getval(newly_created_table_identifiers,NewlyCreatedTableIdentifiers-NumIdentifiers). 86 | 87 | reset_newly_created_table_identifiers :- 88 | nb_linkval(newly_created_table_identifiers,[]-0). 89 | 90 | add_to_newly_created_table_identifiers(TableIdentifier) :- 91 | nb_getval(newly_created_table_identifiers,L1-Num1), 92 | Num2 is Num1 + 1, 93 | nb_linkval(newly_created_table_identifiers,[TableIdentifier|L1]-Num2). 94 | 95 | % PRIVATE 96 | % Mode: + - 97 | % 98 | % Created in the fresh status. 99 | p_create_table(CallVariant,TableIdentifier) :- 100 | % We use a copy_term here so that we can be sure not to corrupt our table if CallVariant is "changed" afterwards. 101 | duplicate_term(CallVariant,CallVariant2), 102 | % Generate a table identifier, create the table and do bookkeeping. 103 | gensym(table,TableIdentifier), 104 | % Create a trie and a worklist. 105 | trie_new(EmptyTrie), 106 | wkl_new_worklist(TableIdentifier,NewWorklist), 107 | nb_linkval(TableIdentifier,table(CallVariant2,fresh,EmptyTrie,NewWorklist)), 108 | p_link_variant_identifier(CallVariant2,TableIdentifier), 109 | add_to_newly_created_table_identifiers(TableIdentifier). 110 | 111 | % Get the Status for table TableIdentifier 112 | % Throws exception if this table does not exist. 113 | tbd_table_status(TableIdentifier,Status) :- 114 | p_get_table_for_identifier(TableIdentifier,Table), 115 | tbd_table_status_(Table,Status). 116 | 117 | % Is also used in other predicates than tbd_table_status. 118 | tbd_table_status_(table(_CallVariant,Status,_Trie,_Worklist),Status). 119 | tbd_table_status_(complete_table(_,_),complete). 120 | 121 | % PRIVATE 122 | % Table must already exist. 123 | p_get_table_for_identifier(TableIdentifier,Table) :- 124 | nb_getval(TableIdentifier,Table). 125 | 126 | % Get the table identifier (!!) for call variant V, creating a new one if necessary. 127 | % 128 | % More costly than directly passing the table identifier for already existing tables. 129 | % 130 | % Since this creates a new table, this predicate is NOT meant for users who should get access to existing tables - f.e. benchmark shortest_path.P 131 | % 132 | table_for_variant(V,TableIdentifier) :- 133 | ( p_existing_table(V,TableIdentifier) -> 134 | true 135 | ; 136 | p_create_table(V,TableIdentifier) 137 | ). 138 | 139 | % Get call variant for this table 140 | get_call_variant(TableIdentifier,CallVariant) :- 141 | p_get_table_for_identifier(TableIdentifier,Table), 142 | get_call_variant_(Table,CallVariant). 143 | 144 | get_call_variant_(table(CallVariant,_Status,_Trie,_Worklist),CallVariant). 145 | get_call_variant_(complete_table(CallVariant,_AnswerTrie),CallVariant). 146 | 147 | add_answer(TableIdentifier,A) :- 148 | p_get_table_for_identifier(TableIdentifier,Table), 149 | % arg(1,Table,CallVariant), 150 | arg(3,Table,AnswerTrie), 151 | arg(4,Table,Worklist), 152 | duplicate_term(A,A2), 153 | % This predicate succeeds if the answer was new, otherwise it fails. 154 | trie_insert(AnswerTrie,A2,A2), % Use answer both as key and as value. Having it as value uses memory, but greatly simplifies getting all the answers. 155 | % We got here, so trie_insert added a new answer. 156 | % We must also insert this answer in the worklist 157 | wkl_add_answer(Worklist,A2). 158 | 159 | get_answer(TableIdentifier,A) :- 160 | p_get_table_for_identifier(TableIdentifier,Table), 161 | get_answer_trie_(Table,AnswerTrie), 162 | % The trick is that we have stored the answers as values of the trie and that there is a method to get all the values. 163 | trie_get_all_values(AnswerTrie,A). 164 | 165 | % get_answer_trie_(TableOrCompleteTable,AnswerTrie). 166 | % First argument is not a TableIdentifier. 167 | get_answer_trie_(table(_CallVariant,_Status,AnswerTrie,_Worklist),AnswerTrie). 168 | get_answer_trie_(complete_table(_CallVariant,AnswerTrie),AnswerTrie). 169 | 170 | % Get a list of answers for the given call variant. 171 | % Used in compare_expected_for_variant/3 in testlib.pl 172 | % IMPORTANT: table must be filled already, this is not done in this predicate! Therefore can be called during execution. 173 | % V = variant 174 | % LA = list of answers. 175 | % 176 | % More costly operation than directly giving the table identifier. 177 | answers_for_variant(V,LA) :- 178 | table_for_variant(V,TableIdentifier), 179 | p_get_table_for_identifier(TableIdentifier,Table), 180 | get_answer_trie_(Table,AnswerTrie), 181 | findall(Value,trie_get_all_values(AnswerTrie,Value),LA). 182 | 183 | % Set status of table TableIdentifier to active 184 | set_active_status(TableIdentifier) :- 185 | tbd_status_transition(TableIdentifier,active,fresh,'set_active_status'). 186 | 187 | cleanup_after_complete(TableIdentifier) :- 188 | p_get_table_for_identifier(TableIdentifier,Table), 189 | cleanup_after_complete_(Table,TableIdentifier). 190 | 191 | % Clause for a (noncomplete) table. 192 | cleanup_after_complete_( 193 | table(CallVariant,_ActualOldStatus,AnswerTrie,_Worklist), 194 | TableIdentifier 195 | ) :- 196 | nb_linkval(TableIdentifier,complete_table(CallVariant,AnswerTrie)). 197 | % If necessary for debugging add second clause for complete_table. 198 | 199 | % Set status of table TableIdentifier to complete. 200 | set_complete_status(TableIdentifier) :- 201 | % The transition must be active to complete, otherwise we have an invalid status transition. 202 | % Preexisting tables should have been cleaned-up, thus not have the form table/5 anymore, thus complete -> complete is not possible there. 203 | p_get_table_for_identifier(TableIdentifier,Table), 204 | set_complete_status_(Table,TableIdentifier). 205 | 206 | % set_complete_status_(Table,TableIdentifier). 207 | set_complete_status_(table(_CallVariant,_OldStatus,_AnswerTrie,_Worklist),TableIdentifier) :- 208 | tbd_status_transition(TableIdentifier,complete,active,'set_complete_status'). 209 | 210 | tbd_status_transition_no_check(TableIdentifier,NewStatus) :- 211 | p_get_table_for_identifier(TableIdentifier,Table), 212 | tbd_status_transition_no_check_(TableIdentifier,Table,NewStatus). 213 | 214 | tbd_status_transition_no_check_(_TableIdentifier,Table,NewStatus) :- 215 | nb_setarg(2,Table,NewStatus). 216 | 217 | % Set Table's status to NewStatus if current status is RequiredOldStatus, otherwise throw an exception mentioning CallerAsString: attempt to set NewStatus for table TableIdentifier, but current status was ActualOldStatus instead of RequiredOldStatus 218 | tbd_status_transition(TableIdentifier,NewStatus,_RequiredOldStatus,_CallerAsString) :- 219 | p_get_table_for_identifier(TableIdentifier,Table), 220 | tbd_status_transition_no_check_(TableIdentifier,Table,NewStatus). 221 | 222 | store_dependency(TableIdentifier,Suspension) :- 223 | p_get_table_for_identifier(TableIdentifier,table(_CallVariant,_Status,_AnswerTrie,Worklist)), 224 | duplicate_term(Suspension,SuspensionCopy), 225 | wkl_add_suspension(Worklist,SuspensionCopy). 226 | 227 | % Get the worklist from the table identified by TableIdentifier 228 | get_worklist(TableIdentifier,Worklist) :- 229 | p_get_table_for_identifier(TableIdentifier,Table), 230 | ( arg(4,Table,Worklist) -> 231 | true 232 | ; 233 | throw('get_worklist called on complete table!') 234 | ). 235 | -------------------------------------------------------------------------------- /table_link_manager.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(table_link_manager, 35 | [ table_link_manager_initialize/0, 36 | get_existing_tables/1, % -Tables 37 | p_existing_table/2, % +Variant, -TableID 38 | p_link_variant_identifier/2, % +Variant, -TableID 39 | num_tables/1 % -Count 40 | ]). 41 | :- use_module(trie). 42 | 43 | % This file defines a call pattern trie. 44 | % 45 | % This data structure keeps the relation between a variant and the corresponding table identifier using a trie. The trick is to make a canonical representation of a given variant using the numbervars/3 predicate. The trie uses this canonical representation as key, and the table identifier as value. 46 | 47 | % Uses the (private) global variable trie_table_link 48 | 49 | % This predicate should be called exactly once. 50 | % It throws an exception if it is called more than once. 51 | 52 | %% table_link_manager_initialize 53 | % 54 | % Initializes the global variables `trie_table_link`. Normally 55 | % called from table_datastructure_initialize/0. 56 | 57 | table_link_manager_initialize :- 58 | trie_new(EmptyTrie), 59 | nb_linkval(trie_table_link,EmptyTrie). 60 | 61 | % PRIVATE 62 | % mode: + - 63 | % Variant is not modified 64 | variant_canonical_representation(Variant,CanonicalRepresentation) :- 65 | duplicate_term(Variant,CanonicalRepresentation), 66 | numbervars(CanonicalRepresentation,0,_N). 67 | 68 | % Succeeds if there is a table TableIdentifier in existance for the given call variant Variant. 69 | p_existing_table(Variant,TableIdentifier) :- 70 | nb_getval(trie_table_link,Trie), 71 | variant_canonical_representation(Variant,CanonicalRepresentation), 72 | trie_lookup(Trie,CanonicalRepresentation,TableIdentifier). 73 | 74 | % Important remark: we cannot use an out-of-the-box association list, because we need a lookup based on variant checking, which is not available for such lists. Converting the association list to a regular list => why would you use an association list in the first place... 75 | p_link_variant_identifier(Variant,TableIdentifier) :- 76 | nb_getval(trie_table_link,Trie), 77 | variant_canonical_representation(Variant,CanonicalRepresentation), 78 | trie_insert_succeed(Trie,CanonicalRepresentation,TableIdentifier), 79 | nb_linkval(trie_table_link,Trie). 80 | 81 | % Returns a list of existing table identifiers. 82 | % Rather costly. 83 | get_existing_tables(Ts) :- 84 | nb_getval(trie_table_link,Trie), 85 | findall(T,trie_get_all_values(Trie,T),Ts). 86 | 87 | % A very unefficient way of implementing this predicate. But it is only used for unit testing, so it doesn't really matter. 88 | % Also, it doesn't require any additional bookkeeping during the actual execution. 89 | num_tables(N) :- 90 | get_existing_tables(Ts), 91 | length(Ts,N). 92 | -------------------------------------------------------------------------------- /table_print.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(table_print, 35 | [ print_existing_tables/0, 36 | print_answers_for_all_tables/0, 37 | print_answers_for_table/1, % +Table 38 | print_answers_for_table/2, % +Table, +Prefix 39 | print_answers_for_variant/1, % +Variant 40 | print_answers_for_variant/2 % +Variant, +Prefix 41 | ]). 42 | :- use_module(table_link_manager). 43 | :- use_module(table_datastructure). 44 | :- use_module(table_utils). 45 | :- use_module(library(lists)). 46 | 47 | % Routines for printing the table datastructure. 48 | % To assist in debugging and for output. 49 | 50 | print_existing_tables :- 51 | get_existing_tables(Ts), 52 | format('EXISTING TABLES~n',[]), 53 | format('===============~n',[]), 54 | ( 55 | member(T,Ts), 56 | get_call_variant(T,V), 57 | format('~q: ~t~10|~p~n',[T, V]), 58 | fail 59 | ; 60 | format('==~n',[]) 61 | ). 62 | 63 | print_answers_for_table(T,PrefixText) :- 64 | get_call_variant(T,V), 65 | tbd_table_status(T,S), 66 | format('ANSWERS FOR TABLE ~q (~p)~n',[T, V]), 67 | format('================================~n',[]), 68 | format('Status: ~w~n',[S]), 69 | forall(get_answer(T,A), 70 | format('~w~p~n', [PrefixText, A])), 71 | format('==~n',[]). 72 | 73 | print_answers_for_table(T) :- 74 | print_answers_for_table(T,''). 75 | 76 | print_answers_for_variant(V,PrefixText) :- 77 | table_for_variant(V,T), 78 | print_answers_for_table(T,PrefixText). 79 | 80 | print_answers_for_variant(V) :- 81 | print_answers_for_variant(V,''). 82 | 83 | print_answers_for_all_tables :- 84 | foreach_table_with_print(print_answers_for_table). 85 | 86 | % Print a continuation C in human readable form. 87 | % At the moment: print the first two components. 88 | print_readable_continuation(Suspension) :- 89 | format('Suspension: ~w\n',[Suspension]). 90 | 91 | print_continuations_for_table(_T) :- 92 | throw('call to deprecated predicate print_continuations for table - use print_worklist from table_datastructure.pl'). 93 | 94 | print_continuations_for_variant(V) :- 95 | table_for_variant(V,T), 96 | print_continuations_for_table(T). 97 | 98 | print_continuations_for_all_tables :- 99 | foreach_table_with_print(print_continuations_for_table). 100 | -------------------------------------------------------------------------------- /table_utils.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(table_utils, 35 | [ print_trail_size/1, % +Message 36 | foreach_table/1, % +Goal 37 | foreach_table_with_print/1, % +Goal 38 | list_to_tuple/2, % +List, -Tuple 39 | predicate_to_tuple/2, % +Term, -Tuple 40 | predicate_list_to_tuple_list/2 % +ListOfTerms, -ListOfTuples 41 | ]). 42 | :- use_module(table_link_manager). 43 | :- use_module(library(lists)). 44 | :- use_module(library(apply)). 45 | :- meta_predicate 46 | foreach_table(1), 47 | foreach_table_with_print(1). 48 | 49 | % Predicates of a general nature that may be useful in a lot of places. 50 | 51 | print_trail_size(Message) :- 52 | write(Message), write(' '), 53 | print_trail_size. 54 | 55 | % Debugging the trail stack 56 | print_trail_size :- 57 | trail_size(S), 58 | format('Trail size is now ~w~n',[S]). 59 | 60 | :- if(current_predicate(sysh:internalstat/5)). 61 | trail_size(S) :- 62 | sysh:internalstat(3,_,S,_,x). 63 | :- else. 64 | trail_size(S) :- 65 | statistics(trailused, S). 66 | :- endif. 67 | 68 | % Utility function to construct internal sanity checks, only done in DEBUG mode. 69 | % Throws an exception when called outside of DEBUG mode. 70 | assert_initialized(_InitializedCheckPredicate,CheckDescription,_ContextualInfo) :- 71 | format:format('call to assert_initialized in nondebug mode: ~w~n',[CheckDescription]), 72 | throw('call to assert_initialized in nondebug mode'). 73 | 74 | formatln(X,Y) :- 75 | format:format(X,Y), 76 | write('\n'). 77 | 78 | assert_empty_list(ExpectedEmptyList,CallerErrorMessageForThrow,CallerGoalOnError) :- 79 | ( \+ ExpectedEmptyList \= [] -> 80 | true % is indeed empty 81 | ; 82 | call(CallerGoalOnError), 83 | throw(CallerErrorMessageForThrow) 84 | ). 85 | 86 | % delete/3 with SWI-Prolog behaviour. 87 | % delete/3 in library(lists) uses == to compare the elements 88 | % example with a different behaviour: delete([p(a,_)],p(a,_),X). 89 | delete_alt([], _,[]). 90 | delete_alt([H|T], X, L) :- 91 | ( \+ X \= H -> 92 | delete_alt(T, X, L) 93 | ; 94 | L=[H|RT], 95 | delete_alt(T, X, RT) 96 | ). 97 | 98 | assert_ground(X) :- 99 | ( ground(X) -> 100 | true 101 | ; 102 | format:format('BUG: ~w should have been ground, but it was not. Throwing exception~n',[X]), 103 | throw('BUG: got a nonground term, where we expected a ground one') 104 | ). 105 | 106 | assert_nonvar(X) :- 107 | ( nonvar(X) -> 108 | true 109 | ; 110 | throw('BUG: we got a free variable, where we expected a nonvar') 111 | ). 112 | 113 | % CustomException will be printed with format/2, and get no arguments. 114 | assert_nonvar_with_custom_exception(X,CustomException) :- 115 | ( nonvar(X) -> 116 | true 117 | ; 118 | format:format(CustomException,[]), 119 | throw('BUG: we got a free variable, where we expected a nonvar') 120 | ). 121 | 122 | assert_true(Goal) :- 123 | ( call(Goal) -> 124 | true 125 | ; 126 | format:format('ASSERTION FAILED: assert_true(~w)~n',[Goal]), 127 | throw('ASSERTION FAILED: we expected the Goal of assert_true to be true') 128 | ). 129 | 130 | % Copy paste programming, but better error message 131 | assert_false(Goal) :- 132 | ( call(Goal) -> 133 | format:format('ASSERTION FAILED: assert_false(~w)~n',[Goal]), 134 | throw('ASSERTION FAILED: we expected the Goal of assert_false to be false') 135 | ; 136 | true 137 | ). 138 | 139 | % Perform goal for all existing tables, first printing 140 | % >FOR EACH TABLE 141 | % >END FOR EACH TABLE 142 | % Goal should take 1 parameter: the name of the table. 143 | foreach_table_with_print(Goal) :- 144 | % Prefixing with module name ('format:') is a hack. I suspect hProlog does not implement modules and meta_predicate completely correct. 145 | foreach_table(Goal, 146 | format('>FOR EACH TABLE\n',[]), 147 | format('>END FOR EACH TABLE\n', [])). 148 | 149 | % Perform goal for all existing tables 150 | % Goal should take 1 parameter: the name of the table. 151 | foreach_table(Goal) :- 152 | foreach_table(Goal,true,true). 153 | 154 | % Perform goal for all existing tables 155 | % Goal should take 1 parameter: the name of the table. 156 | % PreForeachGoal and PostForeachGoal should not take any more parameters. 157 | % SWI-Prolog :- meta_predicate foreach_table(1,0,0). 158 | foreach_table(Goal,PreForeachGoal,PostForeachGoal) :- 159 | call(PreForeachGoal), 160 | get_existing_tables(Ts), 161 | ( 162 | member(T,Ts), 163 | call(Goal,T), 164 | fail 165 | ; 166 | call(PostForeachGoal) 167 | ). 168 | 169 | test_map_component :- 170 | map_component(2,[1-a,2-b,3-c],L), 171 | format('test_map_component: ~w~n',[L]). 172 | 173 | test_map_component2 :- 174 | map_component(2,[],L), 175 | format('test_map_component: ~w~n',[L]). 176 | 177 | % Given a list of pairs, returns a list of the n-th components of the pairs where we start counting from 1 178 | map_component(N,PairsList,ComponentList) :- 179 | % Partial application of arg/3 180 | maplist(arg(N),PairsList,ComponentList). 181 | 182 | % Calls Goal/2 with arguments X and Y. 183 | % Useful for partial application when the arguments of Goal are in the wrong order. 184 | flip(Goal,Y,X) :- 185 | call(Goal,X,Y). 186 | 187 | % any: Succeeds if Goal/1 succeeds for any element in the list 188 | any(Goal,[El]) :- !, 189 | call(Goal,El). 190 | any(Goal,[El|Rest]) :- 191 | ( 192 | call(Goal,El), ! % If successful, cut choicepoint 193 | ; 194 | any(Goal,Rest) 195 | ). 196 | 197 | % Expected: true; works fine 198 | test_any_true_bool :- 199 | any_true_bool([false,false,false,true,false]). 200 | 201 | % Expected: fail; works fine 202 | test2_any_true_bool :- 203 | any_true_bool([false,false,false]). 204 | 205 | % any_true_bool: Succeeds if at least one element of the list is the atom 'true'. 206 | any_true_bool(List) :- 207 | any(is_true_bool,List). 208 | 209 | % Helper predicate 210 | is_true_bool(Bool) :- 211 | Bool = true. 212 | 213 | % Testing purposes. Works fine. 214 | test_predicate_list_to_tuple_list :- 215 | predicate_list_to_tuple_list([f(1,2),f(3,4)],TL), 216 | format('Test result: ~w~n',[TL]). 217 | 218 | test2_predicate_list_to_tuple_list :- 219 | predicate_list_to_tuple_list([f(1,2)],TL), 220 | format('Test result: ~w~n',[TL]). 221 | 222 | % Convert [f(X,Y,...), ...] to [X-Y-...,...] 223 | % There is no check on the function symbol 224 | predicate_list_to_tuple_list(PL,TL) :- 225 | maplist(predicate_to_tuple,PL,TL). 226 | 227 | % f(X,Y) -> X-Y 228 | % Does not work on facts. 229 | predicate_to_tuple(P,T) :- 230 | P =.. [_Functor|Args], 231 | list_to_tuple(Args,T). 232 | 233 | % [X,Y,Z] -> X-Y-Z 234 | % Empty list. No sensible behaviour. Throw exception. 235 | list_to_tuple([],_) :- 236 | throw('list_to_tuple called on empty list'). 237 | % List with at least one element. 238 | list_to_tuple([First|Rest],Tuple) :- 239 | foldl(to_tuple,Rest,First,Tuple). 240 | 241 | % E = 'element' 242 | % Ai = 'accumulator in' 243 | to_tuple(E,Ai,Ai-E). 244 | 245 | % Succeeds if L1 and L2 have the same length and their elements are pairwise unifiable. 246 | % Unificiation on the elements is undone after the test (by using \+ \=) 247 | % Test results: seems to work OK. 248 | equal_lists([],[]). 249 | equal_lists([E1|R1],[E2|R2]) :- 250 | \+ E1 \= E2, 251 | equal_lists(R1,R2). 252 | 253 | % Expect true. 254 | test_equal_lists1 :- 255 | equal_lists([1,2,3],[1,2,3]). 256 | 257 | % Expect false. 258 | test_equal_lists2 :- 259 | equal_lists([1,2,3],[1,2,4]). 260 | 261 | % Expect false. 262 | test_equal_lists3 :- 263 | equal_lists([1,2,3],[1,2]). 264 | 265 | % Expect true. 266 | test_equal_lists4 :- 267 | equal_lists([_X,2],[_Y,2]). 268 | -------------------------------------------------------------------------------- /tabling.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(tabling, 35 | [ start_tabling/2, % +Wrapper, :Worker. 36 | 37 | abolish_all_tables/0, 38 | 39 | (table)/1, % +PI ... 40 | op(1150, fx, table) 41 | ]). 42 | :- use_module(double_linked_list). 43 | :- use_module(table_datastructure). 44 | :- use_module(batched_worklist). 45 | :- use_module(wrapper). 46 | :- use_module(global_worklist). 47 | :- use_module(library(lists)). 48 | :- use_module(library(debug)). 49 | 50 | :- meta_predicate 51 | start_tabling(+, 0). 52 | 53 | %% user:exception(+Exception, +Var, -Action) 54 | % 55 | % Realises lazy initialization of table variables. 56 | 57 | user:exception(undefined_global_variable, Var, retry) :- 58 | ( table_gvar(Var) 59 | -> true 60 | ; format('Creating global var ~q~n', [Var]), 61 | nb_setval(Var, []) 62 | ). 63 | 64 | table_gvar(trie_table_link) :- 65 | table_datastructure_initialize. 66 | table_gvar(newly_created_table_identifiers) :- 67 | table_datastructure_initialize. 68 | table_gvar(table_global_worklist) :- 69 | nb_setval(table_global_worklist, []). 70 | table_gvar(table_leader) :- 71 | nb_setval(table_leader, []). 72 | 73 | %% abolish_all_tables 74 | % 75 | % Remove all tables. Should not be called when tabling is in 76 | % progress. 77 | % 78 | % @bug Check whether tabling is in progress 79 | 80 | abolish_all_tables :- 81 | nb_delete(trie_table_link), 82 | nb_delete(newly_created_table_identifiers), 83 | nb_delete(table_global_worklist), 84 | nb_delete(table_leader). 85 | 86 | 87 | % Find table and status for the given call variant. 88 | % 89 | table_and_status_for_variant(V,T,S) :- 90 | % Order of the two calls really important: first create, then get status 91 | table_for_variant(V,T), 92 | tbd_table_status(T,S). 93 | 94 | start_tabling(Wrapper,Worker) :- 95 | table_and_status_for_variant(Wrapper,T,S), 96 | ( S == complete -> 97 | get_answer(T,Wrapper) 98 | ; 99 | ( exists_scheduling_component -> 100 | run_leader(Wrapper,Worker,T), 101 | % Now answer the original query! 102 | get_answer(T,Wrapper) 103 | ; 104 | run_follower(S,Wrapper,Worker,T) 105 | ) 106 | ). 107 | 108 | run_follower(fresh,Wrapper,Worker,T) :- 109 | activate(Wrapper,Worker,T), 110 | shift(call_info(Wrapper,T)). 111 | 112 | run_follower(active,Wrapper,_Worker,T) :- 113 | shift(call_info(Wrapper,T)). 114 | 115 | run_leader(Wrapper,Worker,T) :- 116 | create_scheduling_component, 117 | activate(Wrapper,Worker,T), 118 | completion, 119 | unset_scheduling_component. 120 | 121 | exists_scheduling_component :- 122 | nb_getval(table_leader,Leader), 123 | Leader == []. 124 | 125 | create_scheduling_component :- 126 | nb_setval(table_leader,leaderCreated). 127 | 128 | unset_scheduling_component :- 129 | nb_setval(table_leader,[]). 130 | 131 | set_all_complete :- 132 | get_newly_created_table_identifiers(Ts,_NumIdentifiers), 133 | set_all_complete_(Ts). 134 | 135 | set_all_complete_([]). 136 | set_all_complete_([T|Ts]) :- 137 | set_complete_status(T), 138 | set_all_complete_(Ts). 139 | 140 | cleanup_all_complete :- 141 | get_newly_created_table_identifiers(Ts,_NumIdentifiers), 142 | cleanup_all_complete_(Ts). 143 | 144 | cleanup_all_complete_([]). 145 | cleanup_all_complete_([T|Ts]) :- 146 | cleanup_after_complete(T), 147 | cleanup_all_complete_(Ts). 148 | 149 | activate(Wrapper,Worker,T) :- 150 | set_active_status(T), 151 | ( 152 | delim(Wrapper,Worker,T), 153 | fail 154 | ; 155 | true 156 | ). 157 | 158 | delim(Wrapper,Worker,Table) :- 159 | debug(tabling, 'ACT: ~p on ~p', [Wrapper, Table]), 160 | reset(Worker,SourceCall,Continuation), 161 | ( Continuation == 0 -> 162 | ( add_answer(Table,Wrapper) 163 | -> debug(tabling, 'ADD: ~p', [Wrapper]) 164 | ; debug(tabling, 'DUP: ~p', [Wrapper]), 165 | fail 166 | ) 167 | ; 168 | SourceCall = call_info(_,SourceTable), 169 | TargetCall = call_info(Wrapper,Table), 170 | Dependency = dependency(SourceCall,Continuation,TargetCall), 171 | debug(tabling, 'DEP: ~p: ~p', [SourceTable,Dependency]), 172 | store_dependency(SourceTable,Dependency) 173 | ). 174 | 175 | completion :- 176 | ( worklist_empty -> 177 | set_all_complete, 178 | cleanup_all_complete, 179 | % The place of the call to reset is really important: it must happen after the completion. If you do it before, you will wrongly remove yourself from the list of newly created table identifiers. On starting hProlog there are no newly created table identifiers, and nb_getval gives [] which is the perfect value. 180 | reset_newly_created_table_identifiers 181 | ; 182 | pop_worklist(Table), 183 | completion_step(Table), 184 | completion 185 | ). 186 | 187 | completion_step(SourceTable) :- 188 | ( 189 | table_get_work(SourceTable,Answer,dependency(Source,Continuation,Target)), 190 | Source = call_info(Answer,_), 191 | Target = call_info(Wrapper,TargetTable), 192 | delim(Wrapper,Continuation,TargetTable), 193 | fail 194 | ; 195 | true 196 | ). 197 | 198 | table_get_work(Table,Answer,Dependency) :- 199 | get_worklist(Table,Worklist), 200 | % NOT IN PAPER (could be part of the definition of pop_worklist): 201 | unset_global_worklist_presence_flag(Worklist), 202 | set_flag_executing_all_work(Worklist), 203 | table_get_work_(Worklist,Answer,Dependency). 204 | 205 | table_get_work_(Worklist,Answer,Dependency) :- 206 | worklist_do_all_work(Worklist,Answer,Dependency0), % This will eventually fail 207 | duplicate_term(Dependency0,Dependency). 208 | table_get_work_(Worklist,_Answer,_Dependency) :- 209 | unset_flag_executing_all_work(Worklist), 210 | fail. 211 | 212 | worklist_do_all_work(Worklist,Answer,Dependency) :- 213 | ( wkl_worklist_work_done(Worklist) -> 214 | fail 215 | ; 216 | worklist_do_step(Worklist,Answer,Dependency) 217 | ; 218 | worklist_do_all_work(Worklist,Answer,Dependency) 219 | ). 220 | 221 | worklist_do_step(Worklist,Answer,Dependency) :- 222 | wkl_p_get_rightmost_inner_answer_cluster_pointer(Worklist,ACP), 223 | wkl_p_swap_answer_continuation(Worklist,ACP,SCP), 224 | dll_get_data(ACP,wkl_answer_cluster(AList)), 225 | dll_get_data(SCP,wkl_suspension_cluster(SList)), 226 | member(Answer,AList), 227 | member(Dependency,SList). 228 | -------------------------------------------------------------------------------- /test_tabling.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(test_tabling, 35 | [ test_tabling/0 36 | ]). 37 | :- use_module(tabling). 38 | :- use_module(testlib). 39 | :- use_module(testlib2). 40 | :- use_module(library(plunit)). 41 | :- use_module(library(debug)). 42 | 43 | test_tabling :- 44 | run_tests([ tabling_ex1, 45 | tabling_ex2, 46 | tabling_ex3, 47 | tabling_ex4, 48 | tabling_ex5, 49 | tabling_ex6, 50 | tabling_ex7, 51 | tabling_ex8, 52 | tabling_ex9a, 53 | tabling_ex9b, 54 | tabling_ex9c, 55 | tabling_ex9d, 56 | tabling_ex9e, 57 | tabling_ex10, 58 | tabling_ex11, 59 | tabling_ex12, 60 | tabling_ex13, 61 | tabling_ex14, 62 | tabling_ex15, 63 | tabling_ex16, 64 | tabling_ex17 65 | ]). 66 | 67 | /******************************* 68 | * EXAMPLE 1 * 69 | *******************************/ 70 | 71 | :- begin_tests(tabling_ex1, [cleanup(abolish_all_tables)]). 72 | 73 | expected_variants([a(2,_),a(3,_),a(_,_)]). 74 | % Note: a(3,_) is an empty table, but it is there... 75 | expected_answers_for_variant(a(_,_),[a(1,2),a(2,3),a(1,3)]). 76 | expected_answers_for_variant(a(2,_),[a(2,3)]). 77 | expected_answers_for_variant(a(3,_),[]). 78 | 79 | a_expected_answers([1-2,2-3,1-3]). 80 | 81 | a_compare_answers :- 82 | compare_real_expected_answers(a,2,a_expected_answers), 83 | test_expected_variants_present, 84 | test_answers_expected_tables. 85 | 86 | :- table a/2. 87 | 88 | a(X,Y) :- before, a(X,Z), between, a(Z,Y). 89 | a(X,Y) :- e(X,Y). 90 | 91 | e(1,2). 92 | e(2,3). 93 | 94 | test(ex1) :- 95 | a_compare_answers. 96 | 97 | :- end_tests(tabling_ex1). 98 | 99 | /******************************* 100 | * EXAMPLE 2 * 101 | *******************************/ 102 | 103 | :- begin_tests(tabling_ex2, [cleanup(abolish_all_tables)]). 104 | % Meerdere recursieve calls met zelfde callpattern: 105 | % b(X,Y) :- b(X,Z), b(Q,Y). 106 | % For two given facts e(1,2) and e(2,3), there are four (!) solutions to b(X,Y): 107 | % 1,2 108 | % 2,3 109 | % 1,3 110 | % 2,2 111 | 112 | expected_variants([b(_,_)]). 113 | expected_answers_for_variant(b(_,_),[b(1,2),b(2,3),b(1,3),b(2,2)]). 114 | 115 | % The answers we expect for example 2, returned as a list with entries of the form X-Y. The order does not matter. 116 | b_expected_answers([1-2,2-3,1-3,2-2]). 117 | 118 | % TEST: Tests answers of example 2. 119 | b_compare_answers :- 120 | compare_real_expected_answers(b,2,b_expected_answers). 121 | 122 | go :- 123 | once(b(_X,_Y)). 124 | 125 | :- table b/2. 126 | 127 | b(X,Y) :- before, b(X,_Z), between, b(_Q,Y). 128 | b(X,Y) :- e(X,Y). 129 | 130 | % Test facts 131 | e(1,2). 132 | e(2,3). 133 | 134 | test(ex2) :- 135 | b_compare_answers, 136 | test_expected_variants_present, 137 | test_answers_expected_tables. 138 | 139 | :- end_tests(tabling_ex2). 140 | 141 | /******************************* 142 | * EXAMPLE 3 * 143 | *******************************/ 144 | 145 | :- begin_tests(tabling_ex3, [cleanup(abolish_all_tables)]). 146 | % Answers: all integers between -10 and 10 (included). 147 | % 148 | % Consider the execution of the query {\tt ?- p$_g$(Y).} which 149 | % succeeds for all integers between {\tt -10} and {\tt 10} (included) 150 | % against the following tabled program: 151 | % :- table p/1. \\ 152 | % p(X) :- p$_{c_1}$(Y), 0 =< Y, Y < 10, X is -Y - 1. \\ 153 | % p(X) :- p$_{c_2}$(Y), -10 < Y, Y =< 0, X is -Y + 1. \\ 154 | % p(0). 155 | % The two consumers that are encountered have been given an index for 156 | % ease of reference. The abstract machine needs to alternate between 157 | % consumers {\tt p$_{c_1}$(Y)} and {\tt p$_{c_2}$(Y)} multiple times 158 | % before all answers have been generated. 159 | 160 | expected_variants([c(_)]). 161 | expected_answers_for_variant(c(_),L) :- 162 | findall(c(X),between(-10,10,X),L). 163 | 164 | c_expected_answers(L) :- 165 | findall(X,between(-10,10,X),L). 166 | 167 | c_compare_answers :- 168 | compare_real_expected_answers(c,1,c_expected_answers). 169 | 170 | :- table c/1. 171 | 172 | c(X) :- before(1), c(Y), feedback('after recusive 1: Y is ~w, and X is ~w',[Y,X]), 173 | 0 =< Y, Y < 10, X is -Y-1, end(1). 174 | c(X) :- before(2), c(Y), feedback('after recusive 2: Y is ~w, and X is ~w',[Y,X]), 175 | -10 < Y, Y =< 0, X is -Y+1, end(2). 176 | c(0). 177 | 178 | test(ex3) :- 179 | c_compare_answers, 180 | test_expected_variants_present, 181 | test_answers_expected_tables. 182 | 183 | :- end_tests(tabling_ex3). 184 | 185 | 186 | /******************************* 187 | * EXAMPLE 4 * 188 | *******************************/ 189 | 190 | :- begin_tests(tabling_ex4, [cleanup(abolish_all_tables)]). 191 | % Two mutually recursive predicates: 192 | % d(X) :- e(Y), Y < 5, X is Y + 1. 193 | % d(0). 194 | % 195 | % e(X) :- d(Y), Y < 5, X is Y + 1. 196 | % e(0). 197 | 198 | expected_variants([d(_), e(_)]). 199 | expected_answers_for_variant(d(_),L) :- 200 | findall(d(X),between(0,5,X),L). 201 | expected_answers_for_variant(e(_),L) :- 202 | findall(e(X),between(0,5,X),L). 203 | 204 | de_expected_answers(L) :- 205 | findall(X,between(0,5,X),L). 206 | 207 | :- table d/1, e/1. 208 | 209 | d(X) :- 210 | feedback('d/1: before calling e(Y)'), 211 | e(Y), 212 | feedback('d/1: after calling e(Y)'), 213 | feedback('d/1: Y is ~w~n',[Y]), 214 | Y < 5, 215 | feedback('d/1: Y < 5 OK\n'), 216 | ( X is Y + 1 217 | -> feedback('d/1: is OK\n') 218 | ; feedback('d/1: ~w is ~w + 1 NOT ok\n',[X,Y]) 219 | ), 220 | feedback('d/1: X is ~w~n', [X]). 221 | d(0). 222 | 223 | e(X) :- 224 | feedback('e/1: before calling d(Y)'), 225 | d(Y), 226 | feedback('e/1: after calling d(Y)'), 227 | feedback('e/1: Y is ~w~n',[Y]), 228 | Y < 5, 229 | feedback('e/1: Y < 5 OK\n', []), 230 | ( X is Y + 1 231 | -> feedback('e/1: is OK\n',[]) 232 | ; feedback('e/1: ~w is ~w + 1 NOT ok\n',[X,Y]) 233 | ), 234 | feedback('e/1: X is ~w~n',[X]). 235 | e(0). 236 | 237 | test(ex4) :- 238 | compare_real_expected_answers(d,1,de_expected_answers), 239 | compare_real_expected_answers(e,1,de_expected_answers), 240 | test_expected_variants_present, 241 | test_answers_expected_tables. 242 | 243 | :- end_tests(tabling_ex4). 244 | 245 | 246 | /******************************* 247 | * EXAMPLE 5 * 248 | *******************************/ 249 | 250 | :- begin_tests(tabling_ex5, [cleanup(abolish_all_tables)]). 251 | % Variation on example 1 but with a cycle. This is an important example 252 | % for tabling. 253 | 254 | expected_variants([f(1,_),f(2,_),f(3,_),f(_,_)]). 255 | expected_answers_for_variant(f(_,_),L) :- 256 | findall(f(X,Y),(between(1,3,X),between(1,3,Y)),L). 257 | expected_answers_for_variant(f(1,_),L) :- 258 | findall(f(1,X),between(1,3,X),L). 259 | expected_answers_for_variant(f(2,_),L) :- 260 | findall(f(2,X),between(1,3,X),L). 261 | expected_answers_for_variant(f(3,_),L) :- 262 | findall(f(3,X),between(1,3,X),L). 263 | 264 | % The answers we expect for example 5, returned as a list with entries 265 | % of the form X-Y. The order does not matter. We expect nine answers. 266 | f_expected_answers([1-1,1-2,1-3,2-1,2-2,2-3,3-1,3-2,3-3]). 267 | 268 | :- table f/2. 269 | 270 | f(X,Y) :- before, f(X,Z), between, f(Z,Y). 271 | f(X,Y) :- e2(X,Y). 272 | 273 | e2(1,2). 274 | e2(2,3). 275 | e2(3,1). 276 | 277 | test(ex5) :- 278 | findall(_,f(_,_),_), 279 | compare_real_expected_answers(f,2,f_expected_answers), 280 | test_expected_variants_present, 281 | test_answers_expected_tables. 282 | 283 | :- end_tests(tabling_ex5). 284 | 285 | 286 | /******************************* 287 | * EXAMPLE 6 * 288 | *******************************/ 289 | 290 | :- begin_tests(tabling_ex6, [cleanup(abolish_all_tables)]). 291 | % Nested tabling: a tabled predicate calls another tabled predicate, but not mutually recursive. 292 | % g(X) <- h(Y), X is Y + 1. 293 | % 294 | % h(X) <- h(Y), X is Y + 1, X < 5. 295 | % h(0). 296 | 297 | expected_variants([g(_),h(_)]). 298 | expected_answers_for_variant(g(_),L) :- 299 | findall(g(X),between(1,5,X),L). 300 | expected_answers_for_variant(h(_),L) :- 301 | findall(h(X),between(0,4,X),L). 302 | 303 | g_expected_answers([1,2,3,4,5]). 304 | h_expected_answers([0,1,2,3,4]). 305 | 306 | :- table g/1, h/1. 307 | 308 | g(X) :- 309 | feedback('g_aux: before calling h(Y)'), 310 | h(Y), 311 | feedback('g_aux: after calling h(Y)'), 312 | X is Y + 1. 313 | 314 | h(X) :- 315 | feedback('h_aux: before calling h(Y)'), 316 | h(Y), 317 | feedback('h_aux: after calling h(Y)'), 318 | X is Y + 1, 319 | X < 5. 320 | h(0). 321 | 322 | test(ex6) :- 323 | compare_real_expected_answers(g,1,g_expected_answers), 324 | compare_real_expected_answers(h,1,h_expected_answers), 325 | test_expected_variants_present, 326 | test_answers_expected_tables. 327 | 328 | :- end_tests(tabling_ex6). 329 | 330 | 331 | /******************************* 332 | * EXAMPLE 7 * 333 | *******************************/ 334 | 335 | :- begin_tests(tabling_ex7, [cleanup(abolish_all_tables)]). 336 | % A more complicated graph example: 337 | % 338 | % i1 339 | % | 340 | % +--+---+ 341 | % | | 342 | % v v 343 | % i2 i3 344 | % | 345 | % +--+---+ 346 | % | | 347 | % v v 348 | % i4 --> i5 349 | % 350 | % i1(X) :- i2(Y), X is Y + 1. 351 | % i1(X) :- i3(Y), X is Y + 1. 352 | % 353 | % i2(X) :- i4(Y), X is Y + 1. 354 | % i2(X) :- i5(Y), X is Y + 4. % !! + 4 355 | % 356 | % i4(X) :- i5(Y), X is Y + 1. % !! TABLE table7d 357 | % 358 | % i3(X) :- between(0,1,X). % !! TABLE table7c 359 | % 360 | % i5(Y) :- between(2,3,X). 361 | 362 | expected_variants([i1(_),i2(_),i3(_),i4(_),i5(_)]). 363 | expected_answers_for_variant(i1(_),[i1(5),i1(6),i1(7),i1(8),i1(1),i1(2)]). 364 | expected_answers_for_variant(i2(_),[i2(4),i2(5),i2(6),i2(7)]). 365 | expected_answers_for_variant(i3(_),[i3(0),i3(1)]). 366 | expected_answers_for_variant(i4(_),[i4(3),i4(4)]). 367 | expected_answers_for_variant(i5(_),[i5(2),i5(3)]). 368 | 369 | i1_expected_answers([5,6,7,8,1,2]). 370 | i2_expected_answers([4,5,6,7]). 371 | i3_expected_answers([0,1]). 372 | i4_expected_answers([3,4]). 373 | i5_expected_answers([2,3]). 374 | 375 | :- table i1/1, i2/1, i3/1, i4/1, i5/1. 376 | 377 | i1(X) :- 378 | feedback('i1_aux 1: before'), i2(Y), 379 | feedback('i1_aux 1: after'), X is Y + 1. 380 | i1(X) :- 381 | feedback('i1_aux 2: before'), i3(Y), 382 | feedback('i1_aux 2: after'), X is Y + 1. 383 | i2(X) :- 384 | feedback('i2_aux 1: before'), i4(Y), 385 | feedback('i2_aux 1: after'), X is Y + 1. 386 | i2(X) :- 387 | feedback('i2_aux 2: before'), i5(Y), 388 | feedback('i2_aux 2: after'), X is Y + 4. 389 | i4(X) :- 390 | feedback('i4_aux 1: before'), i5(Y), 391 | feedback('i4_aux 1: after'), X is Y + 1. 392 | i3(X) :- between(0,1,X). 393 | i5(X) :- between(2,3,X). 394 | 395 | test(ex7) :- 396 | compare_real_expected_answers(i1,1,i1_expected_answers), 397 | compare_real_expected_answers(i2,1,i2_expected_answers), 398 | compare_real_expected_answers(i3,1,i3_expected_answers), 399 | compare_real_expected_answers(i4,1,i4_expected_answers), 400 | compare_real_expected_answers(i5,1,i5_expected_answers), 401 | test_expected_variants_present, 402 | test_answers_expected_tables. 403 | 404 | :- end_tests(tabling_ex7). 405 | 406 | 407 | /******************************* 408 | * EXAMPLE 8 * 409 | *******************************/ 410 | 411 | :- begin_tests(tabling_ex8, [cleanup(abolish_all_tables)]). 412 | % Example specifically designed to test whether we can get a new 413 | % continuation in the last iteration of run_contins. This is indeed the 414 | % case. Thus in run_contins we also need to look at the number of 415 | % continuations to determine whether we can stop. However we had some 416 | % questions: we might need to look whether the new continuation is a 417 | % variant of a continuation that is already present (to avoid infinite 418 | % loops). 419 | % 420 | % j(a,b). 421 | % j(X,Y) :- j(_,_), j(Y,X). 422 | 423 | expected_variants([j(_,_)]). 424 | expected_answers_for_variant(j(_,_),[j(a,b),j(b,a)]). 425 | j_expected_answers([a-b,b-a]). 426 | 427 | :- table j/2. 428 | 429 | j(a,b) :- 430 | feedback('j 1: give answer'). % TODO: check why we don*t have to save this answer here explicitly. 431 | j(X,Y) :- 432 | feedback('j 2: before'), 433 | j(_,_), 434 | feedback('j 2: between'), 435 | j(Y,X), 436 | feedback('j 2: after'). 437 | 438 | test(ex8) :- 439 | compare_real_expected_answers(j,2,j_expected_answers), 440 | test_expected_variants_present, 441 | test_answers_expected_tables. 442 | 443 | :- end_tests(tabling_ex8). 444 | 445 | 446 | /******************************* 447 | * EXAMPLE 9A * 448 | *******************************/ 449 | 450 | :- begin_tests(tabling_ex9a, [cleanup(abolish_all_tables)]). 451 | % The reachability predicate can be written in several variants. 452 | % Example 1: a 453 | % p(X,Y) :- p(X,Z), p(Z,Y). 454 | % p(X,Y) :- e(X,Y). 455 | % 456 | % Example 9a: 457 | % p(X,Y) :- p(X,Z), e(Z,Y). 458 | % p(X,Y) :- e(X,Y). 459 | % 460 | % Example 9b: 461 | % p(X,Y) :- e(X,Z), p(Z,Y). 462 | % p(X,Y) :- e(X,Y). 463 | % 464 | % Example 9c: 465 | % p(X,Y) :- e(X,Y). 466 | % p(X,Y) :- p(X,Z), p(Z,Y). 467 | % 468 | % Example 9d: 469 | % p(X,Y) :- e(X,Y). 470 | % p(X,Y) :- p(X,Z), e(Z,Y). 471 | % 472 | % Example 9e: 473 | % p(X,Y) :- e(X,Y). 474 | % p(X,Y) :- e(X,Z), p(Z,Y). 475 | 476 | expected_variants([a(_,_)]). 477 | expected_answers_for_variant(a(_,_),[a(1,2),a(2,3),a(1,3)]). 478 | 479 | % The answers we expect for reachability variants, returned as a list 480 | % with entries of the form X-Y. The order does not matter. 481 | 482 | reachability_expected_answers([1-2,2-3,1-3]). 483 | 484 | :- table a/2. 485 | 486 | a(X,Y) :- 487 | feedback('before'), 488 | a(X,Z), 489 | feedback('between: prove ~w~n',[e(Z,Y)]), 490 | e(Z,Y). 491 | a(X,Y) :- 492 | e(X,Y). 493 | 494 | % Test facts for examples 1 and 2. 495 | e(1,2). 496 | e(2,3). 497 | 498 | test(ex9a) :- 499 | compare_real_expected_answers(a,2,reachability_expected_answers), 500 | test_expected_variants_present, 501 | test_answers_expected_tables. 502 | :- end_tests(tabling_ex9a). 503 | 504 | 505 | /******************************* 506 | * EXAMPLE 9B * 507 | *******************************/ 508 | 509 | :- begin_tests(tabling_ex9b, [cleanup(abolish_all_tables)]). 510 | expected_variants([a(3,_),a(2,_),a(_,_)]). 511 | % Note: a(3,_) is an empty table, but it is there... 512 | expected_answers_for_variant(a(_,_),[a(1,2),a(2,3),a(1,3)]). 513 | expected_answers_for_variant(a(3,_),[]). 514 | expected_answers_for_variant(a(2,_),[a(2,3)]). 515 | reachability_expected_answers([1-2,2-3,1-3]). 516 | 517 | :- table a/2. 518 | 519 | a(X,Y) :- 520 | feedback('before'), 521 | e(X,Z), 522 | feedback('between: prove ~w~n',[a(Z,Y)]), 523 | a(Z,Y). 524 | a(X,Y) :- 525 | e(X,Y). 526 | 527 | e(1,2). 528 | e(2,3). 529 | 530 | test(ex9b) :- 531 | compare_real_expected_answers(a,2,reachability_expected_answers), 532 | test_expected_variants_present, 533 | test_answers_expected_tables. 534 | 535 | :- end_tests(tabling_ex9b). 536 | 537 | 538 | 539 | /******************************* 540 | * EXAMPLE 9C * 541 | *******************************/ 542 | 543 | :- begin_tests(tabling_ex9c, [cleanup(abolish_all_tables)]). 544 | expected_variants([a(2,_),a(3,_),a(_,_)]). 545 | % Note: a(3,_) is an empty table, but it is there... 546 | expected_answers_for_variant(a(_,_),[a(1,2),a(2,3),a(1,3)]). 547 | expected_answers_for_variant(a(2,_),[a(2,3)]). 548 | expected_answers_for_variant(a(3,_),[]). 549 | 550 | reachability_expected_answers([1-2,2-3,1-3]). 551 | 552 | :- table a/2. 553 | 554 | a(X,Y) :- e(X,Y). 555 | a(X,Y) :- feedback('before'), a(X,Z), feedback('between'), a(Z,Y). 556 | 557 | e(1,2). 558 | e(2,3). 559 | 560 | test(ex9c) :- 561 | compare_real_expected_answers(a,2,reachability_expected_answers), 562 | test_expected_variants_present, 563 | test_answers_expected_tables. 564 | 565 | :- end_tests(tabling_ex9c). 566 | 567 | 568 | /******************************* 569 | * EXAMPLE 9D * 570 | *******************************/ 571 | 572 | :- begin_tests(tabling_ex9d, [cleanup(abolish_all_tables)]). 573 | expected_variants([a(_,_)]). 574 | expected_answers_for_variant(a(_,_),[a(1,2),a(2,3),a(1,3)]). 575 | 576 | reachability_expected_answers([1-2,2-3,1-3]). 577 | 578 | :- table a/2. 579 | 580 | a(X,Y) :- e(X,Y). 581 | a(X,Y) :- feedback('before'), a(X,Z), feedback('between'), e(Z,Y). 582 | 583 | e(1,2). 584 | e(2,3). 585 | 586 | test(ex9d) :- 587 | compare_real_expected_answers(a,2,reachability_expected_answers), 588 | test_expected_variants_present, 589 | test_answers_expected_tables. 590 | 591 | :- end_tests(tabling_ex9d). 592 | 593 | 594 | /******************************* 595 | * EXAMPLE 9E * 596 | *******************************/ 597 | 598 | :- begin_tests(tabling_ex9e, [cleanup(abolish_all_tables)]). 599 | expected_variants([a(3,_),a(2,_),a(_,_)]). 600 | % Note: a(3,_) is an empty table, but it is there 601 | expected_answers_for_variant(a(_,_),[a(1,2),a(2,3),a(1,3)]). 602 | expected_answers_for_variant(a(3,_),[]). 603 | expected_answers_for_variant(a(2,_),[a(2,3)]). 604 | 605 | reachability_expected_answers([1-2,2-3,1-3]). 606 | 607 | :- table a/2. 608 | 609 | a(X,Y) :- e(X,Y). 610 | a(X,Y) :- feedback('before'), e(X,Z), feedback('between'), a(Z,Y). 611 | 612 | e(1,2). 613 | e(2,3). 614 | 615 | test(ex9d) :- 616 | compare_real_expected_answers(a,2,reachability_expected_answers), 617 | test_expected_variants_present, 618 | test_answers_expected_tables. 619 | 620 | :- end_tests(tabling_ex9e). 621 | 622 | 623 | /******************************* 624 | * EXAMPLE 10 * 625 | *******************************/ 626 | 627 | :- begin_tests(tabling_ex10, [cleanup(abolish_all_tables)]). 628 | %d(X) <- e(Y), Y < 5, X is Y + 1. % Will never run, because e doesn't have any facts 629 | %d(X) <- d(Y), Y < 20, X is Y + 5. % Should run 630 | %d(0). 631 | %e(X) <- d(Y), Y < 5, X is Y + 1. 632 | %% No facts for e 633 | 634 | expected_variants([d(_),e(_)]). 635 | expected_answers_for_variant(d(_),[d(0),d(2),d(4),d(5),d(7),d(9), 636 | d(10),d(12),d(14),d(15),d(17),d(19), 637 | d(20),d(22),d(24)]). 638 | expected_answers_for_variant(e(_),[e(5),e(3),e(1)]). 639 | 640 | d_expected_answers([0,2,4,5,7,9,10,12,14,15,17,19,20,22,24]). 641 | e_expected_answers([5,3,1]). 642 | 643 | :- table d/1, e/1. 644 | 645 | d(X) :- e(Y), Y < 5, X is Y + 1. % Will never run, because e doesn't have any facts (initially) 646 | d(X) :- d(Y), Y < 20, X is Y + 5. % Should run 647 | d(0). 648 | e(X) :- d(Y), Y < 5, X is Y + 1. 649 | % No facts for e 650 | 651 | test(ex10) :- 652 | compare_real_expected_answers(d,1,d_expected_answers), 653 | compare_real_expected_answers(e,1,e_expected_answers), 654 | test_expected_variants_present, 655 | test_answers_expected_tables. 656 | 657 | :- end_tests(tabling_ex10). 658 | 659 | 660 | /******************************* 661 | * EXAMPLE 11 * 662 | *******************************/ 663 | 664 | :- begin_tests(tabling_ex11, [cleanup(abolish_all_tables)]). 665 | % Expected answers: 666 | % d(0), d(2), d(4) 667 | % e(1), e(3), e(5) 668 | 669 | expected_variants([d(_),e(_)]). 670 | expected_answers_for_variant(d(_),[d(0),d(2),d(4)]). 671 | expected_answers_for_variant(e(_),[e(1),e(3),e(5)]). 672 | 673 | d_expected_answers([0,2,4]). 674 | e_expected_answers([1,3,5]). 675 | 676 | :- table d/1, e/1. 677 | 678 | d(X) :- e(Y), Y < 5, X is Y + 1. 679 | d(0). 680 | e(X) :- d(Y), Y < 5, X is Y + 1. 681 | % No facts for e 682 | 683 | test(ex11) :- 684 | compare_real_expected_answers(d,1,d_expected_answers), 685 | compare_real_expected_answers(e,1,e_expected_answers), 686 | test_expected_variants_present, 687 | test_answers_expected_tables. 688 | 689 | :- end_tests(tabling_ex11). 690 | 691 | 692 | /******************************* 693 | * EXAMPLE 12 * 694 | *******************************/ 695 | 696 | :- begin_tests(tabling_ex12, [cleanup(abolish_all_tables)]). 697 | expected_variants([f(4),f(3),f(2),f(0),f(1),e(_),d(_),f(_)]). 698 | % Note: f(4) and f(0) are empty tables, but they are there... 699 | expected_answers_for_variant(d(_),L) :- 700 | findall(d(X),between(0,4,X),L). 701 | expected_answers_for_variant(f(4),[]). 702 | expected_answers_for_variant(f(3),[f(3)]). 703 | expected_answers_for_variant(f(2),[f(2)]). 704 | expected_answers_for_variant(f(0),[]). 705 | expected_answers_for_variant(f(1),[f(1)]). 706 | expected_answers_for_variant(e(_),L) :- 707 | findall(e(X),between(0,3,X),L). 708 | expected_answers_for_variant(f(_),L) :- % JW: Added 709 | findall(f(X),between(1,3,X),L). 710 | 711 | d_expected_answers([0,1,2,3,4]). 712 | e_expected_answers([0,1,2,3]). 713 | f_expected_answers([1,2,3]). 714 | 715 | :- table d/1, e/1, f/1. 716 | 717 | % Something like: 718 | d(X) :- e(Y), feedback('d_aux: after e(Y): ~w\n',[e(Y)]), X is Y + 1, X < 5. 719 | d(0). 720 | % Number of predicates involved in mutual recursion will increase at runtime 721 | e(X) :- d(X), f(X), 722 | feedback('e_aux: at end of clause; head is now ~w\n',[e_aux(X)]). 723 | e(0) :- feedback('using fact e(0)\n',[]). 724 | f(X) :- e(Y), X is Y + 1, X < 4. 725 | 726 | test(ex12) :- 727 | compare_real_expected_answers(d,1,d_expected_answers), 728 | compare_real_expected_answers(e,1,e_expected_answers), 729 | compare_real_expected_answers(f,1,f_expected_answers), 730 | test_expected_variants_present, 731 | test_answers_expected_tables. 732 | 733 | :- end_tests(tabling_ex12). 734 | 735 | /******************************* 736 | * EXAMPLE 13 * 737 | *******************************/ 738 | 739 | :- begin_tests(tabling_ex13, [cleanup(abolish_all_tables)]). 740 | expected_variants([p(2,_),p(1,_),p(_,_)]). 741 | expected_answers_for_variant(p(_,_),L) :- 742 | findall(p(X,Y),(between(1,2,X),between(1,2,Y)),L). 743 | expected_answers_for_variant(p(2,_),L) :- 744 | findall(p(2,X),between(1,2,X),L). 745 | expected_answers_for_variant(p(1,_),L) :- 746 | findall(p(1,X),between(1,2,X),L). 747 | 748 | % The answers we expect for example 13, returned as a list with entries of the form X-Y. The order does not matter. 749 | % We expect four answers. 750 | p_expected_answers([1-2,2-1,1-1,2-2]). 751 | 752 | :- table p/2. 753 | 754 | p(X,Y) :- 755 | feedback('before'), p(X,Z), feedback('between'), p(Z,Y). 756 | p(X,Y) :- e2(X,Y). 757 | 758 | e2(1,2). 759 | e2(2,1). 760 | 761 | test(ex12) :- 762 | compare_real_expected_answers(p,2,p_expected_answers), 763 | test_expected_variants_present, 764 | test_answers_expected_tables. 765 | 766 | :- end_tests(tabling_ex13). 767 | 768 | 769 | /******************************* 770 | * EXAMPLE 14 * 771 | *******************************/ 772 | 773 | :- begin_tests(tabling_ex14, [cleanup(abolish_all_tables)]). 774 | % Simpler example than example12.pl, but the number of predicates involved in mutual recursion will also increase at runtime. 775 | 776 | expected_variants([p(3,_),p(2,_),q(2,_),q(3,_),p(_,_),q(_,_)]). 777 | % Note: p(3,_) and q(3,_) are empty tables, but they are there. 778 | expected_answers_for_variant(p(_,_),[p(1,2),p(2,3),p(1,3)]). 779 | expected_answers_for_variant(p(3,_),[]). 780 | expected_answers_for_variant(p(2,_),[p(2,3)]). 781 | expected_answers_for_variant(q(_,_),[q(1,2),q(1,3),q(2,3)]). 782 | expected_answers_for_variant(q(2,_),[q(2,3)]). 783 | expected_answers_for_variant(q(3,_),[]). 784 | 785 | p_expected_answers([1-2,2-3,1-3]). 786 | q_expected_answers([1-2,1-3,2-3]). % JW: added 787 | 788 | go :- 789 | once(p(_X,_Y)). 790 | 791 | :- table p/2, q/2. 792 | 793 | p(X,Y) :- p(X,Z), q(Z,Y). 794 | p(X,Y) :- e(X,Y). 795 | q(X,Y) :- p(X,Y). 796 | 797 | e(1,2). 798 | e(2,3). 799 | 800 | test(ex14) :- 801 | compare_real_expected_answers(p,2,p_expected_answers), 802 | compare_real_expected_answers(q,2,q_expected_answers), 803 | test_expected_variants_present, 804 | test_answers_expected_tables. 805 | 806 | :- end_tests(tabling_ex14). 807 | 808 | 809 | /******************************* 810 | * EXAMPLE 15 * 811 | *******************************/ 812 | 813 | :- begin_tests(tabling_ex15, [cleanup(abolish_all_tables)]). 814 | % Example designed to test whether the true in fresh status works fine 815 | % in case only a continuation is saved. See issue 55. 816 | 817 | expected_variants([d(_),e(_)]). 818 | expected_answers_for_variant(d(_),L) :- 819 | findall(d(X),between(0,5,X),L). 820 | expected_answers_for_variant(e(_),L) :- 821 | findall(e(X),between(0,5,X),L). 822 | 823 | d_expected_answers([0,1,2,3,4,5]). 824 | e_expected_answers([0,1,2,3,4,5]). 825 | 826 | :- table d/1, e/1. 827 | 828 | d(X) :- e(Y), Y < 5, X is Y + 1. 829 | d(0). 830 | e(X) :- d(Y), e(_), Y < 5, X is Y + 1. 831 | e(0). 832 | 833 | test(ex15) :- 834 | compare_real_expected_answers(d,1,d_expected_answers), 835 | compare_real_expected_answers(e,1,e_expected_answers), 836 | test_expected_variants_present, 837 | test_answers_expected_tables. 838 | 839 | :- end_tests(tabling_ex15). 840 | 841 | 842 | /******************************* 843 | * EXAMPLE 16 * 844 | *******************************/ 845 | 846 | :- begin_tests(tabling_ex16, [cleanup(abolish_all_tables)]). 847 | % Expected outcome: there should not be a crash because d was already complete 848 | 849 | expected_variants([d(_),e(_),f(_),g(_)]). 850 | expected_answers_for_variant(d(_),L) :- 851 | findall(d(X),between(0,5,X),L). 852 | expected_answers_for_variant(e(_),L) :- 853 | findall(e(X),between(0,5,X),L). 854 | expected_answers_for_variant(f(_),L) :- 855 | findall(f(X),between(0,5,X),L). 856 | expected_answers_for_variant(g(_),L) :- 857 | findall(g(X),between(0,5,X),L). 858 | 859 | % Two mutually recursive predicates: 860 | % d(X) :- e(Y), Y < 5, X is Y + 1. 861 | % d(0). 862 | % 863 | % e(X) :- d(Y), Y < 5, X is Y + 1. 864 | % e(0). 865 | 866 | :- table d/1, e/1, f/1, g/1. 867 | 868 | d(X) :- 869 | feedback('d_aux: before calling e(Y)'), 870 | e(Y), 871 | feedback('d_aux: after calling e(Y)'), 872 | feedback('d_aux: Y is ~w~n',[Y]), 873 | Y < 5, 874 | feedback('d_aux: Y < 5 OK\n',[]), 875 | ( X is Y + 1 876 | -> feedback('d_aux: is OK\n',[]) 877 | ; feedback('d_aux: ~w is ~w + 1 NOT ok\n',[X,Y]) 878 | ), 879 | feedback('d_aux: X is ~w~n',[X]). 880 | d(0). 881 | 882 | e(X) :- 883 | feedback('e_aux: before calling d(Y)'), 884 | d(Y), 885 | feedback('e_aux: after calling d(Y)'), 886 | feedback('e_aux: Y is ~w~n',[Y]), 887 | Y < 5, 888 | feedback('e_aux: Y < 5 OK\n', []), 889 | ( X is Y + 1 890 | -> feedback('e_aux: is OK\n',[]) 891 | ; feedback('e_aux: ~w is ~w + 1 NOT ok\n',[X,Y]) 892 | ), 893 | feedback('e_aux: X is ~w~n',[X]). 894 | e(0). 895 | 896 | f(X) :- g(Y), Y < 5, X is Y + 1. 897 | f(0). 898 | 899 | g(X) :- f(Y), Y < 5, X is Y + 1. 900 | g(0). 901 | 902 | test(ex16) :- 903 | once((d(_X), f(_Y))). 904 | 905 | :- end_tests(tabling_ex16). 906 | 907 | 908 | /******************************* 909 | * EXAMPLE 17 * 910 | *******************************/ 911 | 912 | :- begin_tests(tabling_ex17, [cleanup(abolish_all_tables)]). 913 | % Smaller version of example 10. 914 | 915 | % Expected answers 916 | 917 | expected_variants([d(_),e(_)]). 918 | expected_answers_for_variant(d(_),[d(0), d(2), d(5)]). 919 | expected_answers_for_variant(e(_),[e(1)]). 920 | 921 | :- table d/1, e/1. 922 | 923 | d(X) :- e(Y), Y < 2, X is Y + 1. % Will never run, because e doesn't have any facts (initially) 924 | d(X) :- d(Y), Y < 2 , X is Y + 5. % Should run 925 | d(0). 926 | e(X) :- d(Y), Y < 2, X is Y + 1. 927 | % No facts for e 928 | 929 | test(ex17) :- 930 | once(d(_)), 931 | test_expected_variants_present, 932 | test_answers_expected_tables. 933 | 934 | :- end_tests(tabling_ex17). 935 | 936 | 937 | /******************************* 938 | * COMMON * 939 | *******************************/ 940 | 941 | before :- debug(tabling, 'before', []). 942 | before(I) :- debug(tabling, 'before ~w', [I]). 943 | between :- debug(tabling, 'between', []). 944 | feedback(Fmt) :- debug(tabling, Fmt, []). 945 | feedback(Fmt,Args) :- debug(tabling, Fmt, Args). 946 | end :- debug(tabling, 'end', []). 947 | end(I) :- debug(tabling, 'end ~w', [I]). 948 | -------------------------------------------------------------------------------- /test_trie.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(test_trie, 35 | [ test_trie/0 36 | ]). 37 | :- use_module(trie). 38 | :- use_module(library(plunit)). 39 | :- use_module(library(debug)). 40 | 41 | test_trie :- 42 | run_tests([ trie 43 | ]). 44 | 45 | :- begin_tests(trie). 46 | 47 | test(insert, T2 =@= T) :- 48 | T = a(1,2), 49 | trie_new(Trie), 50 | trie_insert(Trie, T, T), 51 | trie_lookup(Trie, T, T2). 52 | test(insert_bt, T2 =@= T) :- 53 | T = a(1,2), 54 | trie_new(Trie), 55 | freeze_stack, 56 | ( trie_insert(Trie, T, T), 57 | trie_lookup(Trie, T, T2), 58 | assertion(T2 =@= T), 59 | fail 60 | ; trie_lookup(Trie, T, T2), 61 | assertion(T2 =@= T) 62 | ). 63 | 64 | freeze_stack :- 65 | numlist(1, 1000, L), 66 | nb_setval(x, L). 67 | 68 | :- end_tests(trie). 69 | 70 | 71 | -------------------------------------------------------------------------------- /testlib.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(testlib, 35 | [ expect_fail/1, % +Goal 36 | expect_true/1, % +Goal 37 | compare_real_expected_answers/3, % :Name, +Arity, :E 38 | compare_expected_all_variants/1 % +AllExpectedAnswers 39 | ]). 40 | :- use_module(library(lists)). 41 | :- use_module(table_utils). 42 | :- use_module(library(dialect/hprolog)). 43 | :- use_module(table_datastructure). 44 | 45 | :- meta_predicate 46 | expect_fail(0), 47 | expect_true(0), 48 | compare_real_expected_answers(:,+,1). 49 | 50 | % Notes about testing: 51 | % - name of a test should start with t_, optionally followed by a number 52 | % (starting from 1), and followed by the name of the predicate it tests. 53 | % - TODO: exceptions to this rule exist. 54 | % - fully automated tests are marked with autotest(<>). 55 | % - for now, nothing is done with the autotest facts. 56 | 57 | % Helper predicates for testing: 58 | 59 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 60 | % Requires format/2. 61 | expect_fail(G) :- 62 | (call(G) -> 63 | format('BUG: expected failure for goal ~w but it succeeded!~n',[G]) 64 | ; 65 | writeln('Success: failure expected.') 66 | ). 67 | 68 | % Requires format/2. 69 | expect_true(G) :- 70 | (call(G) -> 71 | writeln('Success: true expected.') 72 | ; 73 | format('BUG: expected success for goal ~w but it failed!~n',[G]) 74 | ). 75 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 76 | 77 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 78 | % E = list that has the expected number of elements 79 | % A = list that has the actual number of elements 80 | expect_same_size(E,A,Result) :- 81 | length(E,Es), 82 | length(A,As), 83 | ( Es == As 84 | -> Result = true 85 | ; print_message(error, 86 | format('expected list to have ~d elements but it had ~d~n', 87 | [Es,As])), 88 | Result = false 89 | ). 90 | 91 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 92 | 93 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 94 | % Both lists are turned into sets first! 95 | % E = list having expected elements 96 | % A = list having actual elements 97 | expect_lists_equal_sets(E,A,True) :- 98 | list_to_set(E,Es), % SWI: list_to_set 99 | list_to_set(A,As), 100 | ( ( list_difference_eq(As,Es,[]), 101 | list_difference_eq(Es,As,[]) 102 | ) 103 | -> True = true 104 | ; print_message(error, format('lists do not represent equal sets. \c 105 | Expected list was ~p, actual list was ~p',[E,A])) 106 | ). 107 | 108 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 109 | 110 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 111 | % G = Name of goal to obtain real answers. Should take A free variables. 112 | % A = Arity of goal to obtain real answers. 113 | % E = Name of goal to obtain list of expected answers. Should take one argument. 114 | compare_real_expected_answers(M:G,A,E) :- 115 | call(E,E2), 116 | length(FreeVarsList,A), 117 | G2 =.. [G|FreeVarsList], 118 | list_to_tuple(FreeVarsList,FreeVarsTuple), 119 | findall(FreeVarsTuple,M:G2,R), 120 | expect_same_size(E2,R,Ok1), 121 | expect_lists_equal_sets(E2,R,Ok2), 122 | Ok1 == true, Ok2 == true. 123 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 124 | 125 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 126 | % Potential replacement for compare_real_expected_answers/3? 127 | % TODO: finish and test it on nonbinary predicates. Update tests once it works. 128 | % Potential pitfall: AllExpectedAnswers is not a callable predicate but a list. It is easy to add a small variation. 129 | compare_expected_all_variants(AllExpectedAnswers) :- 130 | % order of arguments of compare_expected_for_variant/2 is unfortunate but logical therefore use flip/3 partially applied. 131 | %foreach_table(flip(compare_expected_for_variant,AllExpectedAnswers)). 132 | % Print some information identifying the table 133 | foreach_table(compare_expected_all_variants_(AllExpectedAnswers)). 134 | % TODO: now check whether you have had all tables you expected to be there. 135 | 136 | compare_expected_all_variants_(AllExpectedAnswers,Table) :- 137 | get_call_variant(Table,Variant), 138 | format('Testing table ~w~n',[Variant]), 139 | format('=============================~n',[]), 140 | compare_expected_for_variant(Variant,AllExpectedAnswers). 141 | 142 | % TODO: test and make sure it also works in nonbinary cases! Seems to work allright in binary cases. 143 | % [foreach_table from utils.pl will help apply this on all call_variants!] 144 | % Compare expected answers for a particular call variant 145 | % IMPORTANT: at this point tables must be filled already, this is not done in this predicate! 146 | % Uses expected_starting_with/3 to select the expected answers for that variant from all expected answers. 147 | % V = The particular call variant 148 | % AE = All expected answers no matter the call variant 149 | compare_expected_for_variant(V,AE) :- 150 | answers_for_variant(V,AA1), % AA1 = actual answers, format: [f(1,2)] 151 | format('answers_for_variant ~w: ~w~n',[V,AA1]), 152 | V =.. [_F,StartWith|_Rest], % Won't work for nonbinary predicates. 153 | format('startWith = ~w, all (expected) answers = ~w~n',[StartWith,AE]), 154 | expected_starting_with(StartWith,AE,ExpectedForVariant), % format: list of tuples... 155 | format('expected_starting_with: ~w~n',[ExpectedForVariant]), 156 | predicate_list_to_tuple_list(AA1,AA2), 157 | format('tuple_list: ~w~n',[AA2]), 158 | expect_same_size(ExpectedForVariant,AA2,Ok1), 159 | expect_lists_equal_sets(ExpectedForVariant,AA2, Ok2), 160 | Ok1 == true, Ok2 == true. 161 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 162 | 163 | % OK 164 | test_expected_starting_with :- 165 | expected_starting_with(1,[1-2,2-1,1-3,3-1],E), 166 | writeln(E). 167 | 168 | % TODO: works for binary predicates for which you specify the first argument. Generalize for a more general case! 169 | % 1) First element of tuple 170 | % 2) All answers 171 | % 3) Answers starting with first element of tuple 172 | expected_starting_with(S,A,E) :- 173 | expected_starting_with_(A,S,E-[]). 174 | 175 | expected_starting_with_([],_A,E-E). 176 | expected_starting_with_([X-_C2|Xs],A,H-T) :- 177 | X \= A, !, % cut should not be earlier 178 | expected_starting_with_(Xs,A,H-T). 179 | expected_starting_with_([A-C2|Xs],A,H-T) :- 180 | expected_starting_with_(Xs,A,H-T2), 181 | T2 = [A-C2|T]. 182 | -------------------------------------------------------------------------------- /testlib2.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(testlib2, 35 | [ test_expected_variants_present/0, 36 | test_tables_cleaned/0, 37 | test_answers_expected_tables/0, 38 | test_answers_for_expected_variant/1 39 | ]). 40 | :- use_module(table_link_manager). 41 | :- use_module(table_datastructure). 42 | :- use_module(library(terms)). 43 | 44 | :- module_transparent 45 | test_expected_variants_present/0, 46 | test_tables_cleaned/0, 47 | test_answers_expected_tables/0. 48 | :- meta_predicate 49 | test_answers_for_expected_variant(:). 50 | 51 | % requires a predicate expected_variants(-List) in the example 52 | test_expected_variants_present :- 53 | context_module(M), 54 | test_expected_variants_present(M). 55 | 56 | test_expected_variants_present(M) :- 57 | M:expected_variants(Xs0), 58 | maplist(mqualify(M), Xs0, Xs), 59 | test_expected_variants_present_(Xs, True), 60 | True \== false, 61 | % now all expected variants are present. 62 | % next, we check whether there aren't any more present. 63 | length(Xs,NumExpected), 64 | num_tables(NumActual), 65 | assert_equal(NumExpected,NumActual,'test_expected_variants_present'). 66 | 67 | mqualify(M,T,M:T). 68 | 69 | % uses "private" predicate from table_datastructure.gpp or table_link_manager.gpp depending on the version. 70 | test_expected_variants_present_([], _). 71 | test_expected_variants_present_([X|Xs], True) :- 72 | ( p_existing_table(X,_) 73 | -> true 74 | ; print_message(error, format('Missing table for variant ~p',[X])), 75 | True = false 76 | ), 77 | test_expected_variants_present_(Xs, True). 78 | 79 | % test whether all expected tables have received proper cleanup, that is: having the form complete_table/3 80 | % uses "private" predicate from table_datastructure.gpp or table_link_manager.gpp depending on the version. 81 | test_tables_cleaned :- 82 | context_module(M), 83 | M:expected_variants(Xs), 84 | test_tables_cleaned_(Xs), 85 | % if we get here, write a note to show that we did the test. 86 | format:format('test_tables_cleaned succeeded~n',[]). 87 | 88 | test_tables_cleaned_([]). 89 | test_tables_cleaned_([X|Xs]) :- 90 | ( p_existing_table(X,TableIdentifier), 91 | nb_getval(TableIdentifier,Table), 92 | functor(Table,complete_table,2), ! % CUT ALTERNATIVE 93 | ; 94 | format:format('test_tables_cleaned: table for variant ~w did not receive proper cleanup~n',[X]), 95 | throw('test_tables_cleaned: a table did not receive proper cleanup') 96 | ), 97 | test_tables_cleaned_(Xs). 98 | 99 | test_answers_expected_tables :- 100 | context_module(M), 101 | test_answers_expected_tables(M). 102 | 103 | test_answers_expected_tables(M) :- 104 | M:expected_variants(Xs0), 105 | maplist(mqualify(M), Xs0, Xs), 106 | test_answers_expected_tables_(Xs, True), 107 | True \== false. 108 | 109 | test_answers_expected_tables_([], _). 110 | test_answers_expected_tables_([Variant|Rest], True) :- 111 | ( test_answers_for_expected_variant(Variant) 112 | -> true 113 | ; print_message(error, format('Wrong answers for expected variant ~p',[Variant])), 114 | True = false 115 | ), 116 | test_answers_expected_tables_(Rest, True). 117 | 118 | % ATTENTION: works only for ground answers in the tables (which we currently enforce when adding answers as well). To be on the safe side, an exception will be thrown if one of the expected answers is nonground. 119 | % Requires a predicate expected_answers_for_variant/2 in the example. 120 | % Uses "private" predicate from table_datastructure.gpp or table_link_manager.gpp depending on the version. 121 | test_answers_for_expected_variant(M:Variant) :- 122 | % We really want a variant check here, not unification... 123 | M:expected_answers_for_variant(SomeVariant,ExpectedAnswers0), 124 | maplist(mqualify(M), ExpectedAnswers0, ExpectedAnswers), 125 | variant(Variant,SomeVariant), 126 | p_existing_table(M:Variant,TableIdentifier), 127 | test_answers_for_variant_(ExpectedAnswers,TableIdentifier, True), 128 | True \== false, 129 | % Now check that there are not more answers than expected 130 | length(ExpectedAnswers,NumExpected), 131 | get_num_answers(TableIdentifier,NumActual), 132 | assert_equal(NumExpected,NumActual,'test_answers_for_expected_variant'). 133 | 134 | % Slow, but only used for testing. We don't need to keep the number of answers at runtime, 135 | % so we don't keep track of it (for performance). 136 | get_num_answers(TableIdentifier,NumActual) :- 137 | findall(A,get_answer(TableIdentifier,A),L), 138 | length(L,NumActual). 139 | 140 | test_answers_for_variant_([],_TableIdentifier, _). 141 | test_answers_for_variant_([ExpectedAnswer|Rest],TableIdentifier, True) :- 142 | ( ground(ExpectedAnswer) 143 | -> true 144 | ; print_message(error, format('Got nonground expected answer ~p, \c 145 | which it cannot handle correctly',[ExpectedAnswer])), 146 | True = false 147 | ), 148 | % get_answer => uses unification, so this won't work properly for nonground answers. 149 | ( get_answer(TableIdentifier,ExpectedAnswer) 150 | -> true 151 | ; print_message(error, format('Missing expected answer ~p',[ExpectedAnswer])), 152 | True = false 153 | ), 154 | test_answers_for_variant_(Rest,TableIdentifier,True). 155 | 156 | assert_equal(NumExpected,NumActual,ContextualInfo) :- 157 | ( NumExpected == NumActual 158 | -> true 159 | ; print_message(error, format('assert_equal failed in context of ~w: \c 160 | expected ~w but was ~w~n', 161 | [ContextualInfo,NumExpected,NumActual])), 162 | fail 163 | ). 164 | -------------------------------------------------------------------------------- /trie.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Benoit Desouter 4 | Jan Wielemaker (SWI-Prolog port) 5 | Copyright (c) 2016, Benoit Desouter 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in 17 | the documentation and/or other materials provided with the 18 | distribution. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 23 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 25 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 26 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 27 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 30 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 31 | POSSIBILITY OF SUCH DAMAGE. 32 | */ 33 | 34 | :- module(trie, 35 | [ trie_new/1, % -Trie 36 | trie_insert/3, % !Trie, +Key, +Value 37 | trie_insert_succeed/3, 38 | trie_lookup/3, % +Trie, +Key, -Value 39 | trie_get_all_values/2 % +Trie, -Value 40 | ]). 41 | :- use_module(library(assoc)). 42 | :- use_module(library(lists)). 43 | 44 | % Implementation of a prefix tree, a.k.a. trie % 45 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 46 | 47 | % Desired complexity for lookup and insert: linear in the length of the key. 48 | 49 | % ATTENTION: do not use the term functor_data/2; this is used internally here. 50 | 51 | % Inspiration from http://en.wikipedia.org/wiki/Trie 52 | 53 | % Structure of tries: 54 | % trie_inner_node(MaybeValue,Children). 55 | % where Children is an association list of nonvars to tries. 56 | % and where MaybeValue is maybe_none/0 or maybe_just(Value). 57 | 58 | % PRIVATE 59 | % For a term of the form p(a,q(b)), "returns" functor_data(p,2) and [a,q(b)]. 60 | % p_trie_arity_univ(+Term,-FunctorData,-ArgumentsList). 61 | p_trie_arity_univ(Term,functor_data(Name,Arity),Arguments) :- 62 | Term =.. [Name|Arguments], 63 | functor(Term,_NameAgain,Arity). 64 | 65 | % Returns a new empty trie. 66 | trie_new(Trie) :- 67 | empty_assoc(A), 68 | Trie = trie_inner_node(maybe_none,A). 69 | 70 | % Succeeds if given trie does not contain any key-value pair. 71 | % trie_is_empty(+Trie) 72 | trie_is_empty(trie_inner_node(maybe_none,A)) :- 73 | empty_assoc(A). 74 | 75 | % For internal use. 76 | % For now, Children is an association list that can be manipulated using the assoc_ predicates. 77 | trie_get_children(trie_inner_node(_MaybeValue,Children),Children). 78 | 79 | % For internal use. 80 | trie_get_maybe_value(trie_inner_node(MaybeValue,_Children),MaybeValue). 81 | 82 | % Destructive update of the association list Children. 83 | % For internal use. 84 | trie_set_children(Trie,Children) :- 85 | nb_linkarg(2,Trie,Children). 86 | 87 | trie_set_maybe_value(Trie,MaybeValue) :- 88 | nb_linkarg(1,Trie,MaybeValue). 89 | 90 | trie_insert_succeed(Trie,Key,Value) :- 91 | ( trie_insert(Trie,Key,Value) -> 92 | true 93 | ; 94 | true 95 | ). 96 | 97 | % Succeeds if the term was not present, fails if the term was present. 98 | % The term will be present now, whatever the outcome. 99 | % We don't use an extra argument to indicate earlier presence, as this increases the trail size. 100 | trie_insert(Trie,Key,Value) :- 101 | p_trie_arity_univ(Key,FunctorData,KeyList), 102 | trie_insert_1(KeyList,FunctorData,Trie,Value). 103 | 104 | trie_insert_1([],FunctorData,Trie,Value) :- 105 | trie_get_children(Trie,Assoc), 106 | % You need Assoc twice: once to traverse through it, once keeping it as a whole for insertion using put_assoc/4. 107 | trie_insert_a(Assoc,Assoc,FunctorData,Trie,Value). 108 | % Inline the failure and success continuation to avoid a growing trail stack. 109 | trie_insert_1([First|Rest],FunctorData,Trie,Value) :- 110 | trie_get_children(Trie,Assoc), 111 | % You need Assoc twice: once to traverse through it, once keeping it as a whole for insertion using put_assoc/4. 112 | trie_insert_1_1(Assoc,Assoc,FunctorData,Trie,First,Rest,Value). 113 | 114 | % Else part, base case: empty assoc list. 115 | trie_insert_a(t,Assoc,FunctorData,Trie,Value) :- 116 | trie_new(Subtrie), 117 | trie_set_maybe_value(Subtrie,maybe_just(Value)), 118 | put_assoc(FunctorData,Assoc,Subtrie,NewAssoc), 119 | trie_set_children(Trie,NewAssoc). 120 | 121 | % Then part, nonempty assoc tree. 122 | trie_insert_a(t(K,V,_,L,R),Assoc,FunctorData,Trie,Value) :- 123 | compare(Rel,FunctorData,K), 124 | trie_insert_b(Rel,V,L,R,Assoc,FunctorData,Trie,Value). 125 | 126 | % Recursively look in the left part of the assoc tree. 127 | trie_insert_b(<,_V,L,_R,Assoc,FunctorData,Trie,Value) :- 128 | trie_insert_a(L,Assoc,FunctorData,Trie,Value). 129 | 130 | % Recursively look in the right part of the assoc tree. 131 | trie_insert_b(>,_V,_L,R,Assoc,FunctorData,Trie,Value) :- 132 | trie_insert_a(R,Assoc,FunctorData,Trie,Value). 133 | 134 | trie_insert_b(=,V,_L,_R,_Assoc,_FunctorData,_Trie,Value) :- 135 | trie_get_maybe_value(V,MaybeValue), % V is the Subtrie 136 | ( MaybeValue == maybe_none -> 137 | trie_set_maybe_value(V,maybe_just(Value)) 138 | % Use true to indicate that the answer was new. 139 | ; 140 | MaybeValue = maybe_just(JustValue), 141 | ( JustValue == Value -> 142 | % Fail to indicate earlier presence 143 | fail 144 | ; 145 | throw('trie: attempt to update the value for a key') 146 | ) 147 | ). 148 | 149 | 150 | % Else part, base case: empty assoc list 151 | trie_insert_1_1(t,Assoc,FunctorData,Trie,First,Rest,Value) :- 152 | % Assoc = t, % t is the empty assoc tree 153 | trie_new(Subtrie), 154 | put_assoc(FunctorData,Assoc,Subtrie,NewAssoc), 155 | trie_set_children(Trie,NewAssoc), 156 | trie_insert_2(First,Rest,Subtrie,Value). 157 | 158 | % Then part, lookup in assoc list. 159 | trie_insert_1_1(t(K,V,_,L,R),Assoc,FunctorData,Trie,First,Rest,Value) :- 160 | compare(Rel,FunctorData,K), 161 | trie_insert_1_1_1(Rel,V,L,R,Assoc,FunctorData,Trie,First,Rest,Value). 162 | 163 | trie_insert_1_1_1(=,V,_L,_R,_Assoc,_FunctorData,_Trie,First,Rest,Value) :- 164 | trie_insert_2(First,Rest,V,Value). % V is the Subtrie 165 | 166 | trie_insert_1_1_1(<,_V,L,_R,Assoc,FunctorData,Trie,First,Rest,Value) :- 167 | % Look in the left part of the assoc tree. 168 | trie_insert_1_1(L,Assoc,FunctorData,Trie,First,Rest,Value). 169 | 170 | trie_insert_1_1_1(>,_V,_L,R,Assoc,FunctorData,Trie,First,Rest,Value) :- 171 | % Look in the right part of the assoc tree. 172 | trie_insert_1_1(R,Assoc,FunctorData,Trie,First,Rest,Value). 173 | 174 | trie_insert_2(RegularTerm,Rest,Trie,Value) :- 175 | p_trie_arity_univ(RegularTerm,FunctorData,KList), 176 | append(KList,Rest,KList2), 177 | trie_insert_1(KList2,FunctorData,Trie,Value). 178 | 179 | trie_lookup(Trie,Key,Value) :- 180 | p_trie_arity_univ(Key,FunctorData,KeyList), 181 | trie_lookup_1(FunctorData,KeyList,Trie,Value). 182 | 183 | trie_lookup_1(FunctorData,Rest,Trie,Value) :- 184 | % Select right subtree, fail if it isn't there, and do recursive call. 185 | trie_get_children(Trie,Assoc), 186 | get_assoc(FunctorData,Assoc,Subtrie), % Fails if not present 187 | trie_lookup_2(Rest,Subtrie,Value). 188 | 189 | trie_lookup_2([],Trie,Value) :- 190 | % If the value at this trie is maybe_just(X), then X is our Value. 191 | % Otherwise, there is no value for this key, so we fail... 192 | trie_get_maybe_value(Trie,maybe_just(Value)). 193 | % Regular term at the head, like p or p(a). Not functor_data/2. 194 | trie_lookup_2([RegularTerm|Rest],Trie,Value) :- 195 | % split RegularTerm 196 | p_trie_arity_univ(RegularTerm,FunctorData,KList), 197 | % Make a recursive call on KList ++ Rest. 198 | % Since we cannot implement p_trie_arity_univ so that "its result", KList, has a free variable at the end, without resorting to techniques that require linear time, we need a call to append/3. However, since KList will in general be rather short, I don't expect this to be a large problem in practice. 199 | append(KList,Rest,KList2), 200 | trie_lookup_1(FunctorData,KList2,Trie,Value). 201 | 202 | 203 | % Returns all values in the trie by backtracking - we don't provide any information about the associated key. 204 | trie_get_all_values(Trie,Value) :- 205 | trie_get_maybe_value(Trie,maybe_just(Value)). 206 | trie_get_all_values(Trie,Value) :- 207 | trie_get_children(Trie,Children), 208 | gen_assoc(_Key, Children, ChildTrie), 209 | trie_get_all_values(ChildTrie,Value). 210 | -------------------------------------------------------------------------------- /wrapper.pl: -------------------------------------------------------------------------------- 1 | /* Part of SWI-Prolog 2 | 3 | Author: Jan Wielemaker 4 | Copyright (c) 2016, VU University Amsterdam 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in 16 | the documentation and/or other materials provided with the 17 | distribution. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 22 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 23 | COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 24 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 25 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 26 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 28 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | */ 32 | 33 | :- module(table_wrapper, 34 | [ (table)/1, % +Predicates 35 | 36 | op(1150, fx, table) 37 | ]). 38 | :- use_module(library(error)). 39 | 40 | :- multifile 41 | system:term_expansion/2, 42 | tabled/2. 43 | :- dynamic 44 | system:term_expansion/2. 45 | 46 | %% table(+PredicateIndicators) 47 | % 48 | % Prepare the given PredicateIndicators for tabling. Can only 49 | % be used as a directive. 50 | 51 | table(PIList) :- 52 | throw(error(context_error(nodirective, table(PIList)), _)). 53 | 54 | 55 | wrappers(Var) --> 56 | { var(Var), !, 57 | instantiation_error(Var) 58 | }. 59 | wrappers((A,B)) --> !, 60 | wrappers(A), 61 | wrappers(B). 62 | wrappers(Name//Arity) --> 63 | { atom(Name), integer(Arity), Arity >= 0, !, 64 | Arity1 is Arity+2 65 | }, 66 | wrappers(Name/Arity1). 67 | wrappers(Name/Arity) --> 68 | { atom(Name), integer(Arity), Arity >= 0, !, 69 | functor(Head, Name, Arity), 70 | atom_concat(Name, ' tabled', WrapName), 71 | Head =.. [Name|Args], 72 | WrappedHead =.. [WrapName|Args], 73 | prolog_load_context(module, Module) 74 | }, 75 | [ table_wrapper:tabled(Head, Module), 76 | ( Head :- 77 | start_tabling(Module:Head, WrappedHead) 78 | ) 79 | ]. 80 | 81 | rename(M:Term0, M:Term, _) :- 82 | atom(M), !, 83 | rename(Term0, Term, M). 84 | rename((Head :- Body), (NewHead :- Body), Module) :- !, 85 | rename(Head, NewHead, Module). 86 | rename((Head --> Body), (NewHead --> Body), Module) :- !, 87 | functor(Head, Name, Arity), 88 | PlainArity is Arity+1, 89 | functor(PlainHead, Name, PlainArity), 90 | tabled(PlainHead, Module), 91 | rename_term(Head, NewHead). 92 | rename(Head, NewHead, Module) :- 93 | tabled(Head, Module), !, 94 | rename_term(Head, NewHead). 95 | 96 | rename_term(Compound0, Compound) :- 97 | compound(Compound0), !, 98 | compound_name_arguments(Compound0, Name, Args), 99 | atom_concat(Name, ' tabled', WrapName), 100 | compound_name_arguments(Compound, WrapName, Args). 101 | rename_term(Name, WrapName) :- 102 | atom_concat(Name, ' tabled', WrapName). 103 | 104 | 105 | system:term_expansion((:- table(Preds)), 106 | [ (:- multifile table_wrapper:tabled/2) 107 | | Clauses 108 | ]) :- 109 | phrase(wrappers(Preds), Clauses). 110 | system:term_expansion(Clause, NewClause) :- 111 | prolog_load_context(module, Module), 112 | rename(Clause, NewClause, Module). 113 | --------------------------------------------------------------------------------