clpb addition and various bugfixes

parent bc8d3f31
......@@ -96,6 +96,7 @@ PSSOURCES = \
prolog-user.scm \
language/prolog/install.scm \
language/prolog/spec.scm \
language/prolog/modules/user.scm \
language/prolog/modules/boot/expand.pl \
language/prolog/modules/boot/dcg.pl \
language/prolog/modules/library/error.pl \
......@@ -112,7 +113,8 @@ PSSOURCES = \
language/prolog/modules/library/ordsets.pl \
language/prolog/modules/library/oset.pl \
language/prolog/modules/library/rbtrees.pl \
language/prolog/modules/library/clpfd.pl
language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
AM_MAKEINFOFLAGS=--force
AM_MAKEINFOHTMLFLAGS=--force
info_TEXINFOS = doc/guile-log.texi
......
......@@ -36,6 +36,7 @@
(language prolog modules library dcg_basics)
(language prolog modules test)
(language prolog modules test2)
(language prolog modules library clpb)
(language prolog modules library clpfd)))
......
This diff is collapsed.
(define-module (language prolog modules library clpb)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (language prolog modules boot dcg)
#:use-module (language prolog modules user)
#:pure
#:duplicates (last replace)
#:replace (sat taut labeling sat_count))
(clear-directives)
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
*prolog-ops* *swi-standard-operators*))
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
(@ (logic guile-log prolog parser) *term-expansions*)
'()))
((@ (guile) eval-when) (compile load eval)
((@ (guile) fluid-set!)
(@ (logic guile-log prolog parser) *goal-expansions*)
'()))
(compile-prolog-string "
:- op(300,fy,~).
:- op(500,yfx,#).
")
((@ (guile) define) *public-module-operators* (list '(300 fy ~) '(500 yfx #{#}#) ))
(compile-prolog-file "/home/stis/src/guile-log/language/prolog/modules/library/clpb.pl")
((@ (guile) define) *optable-save-first* #t)
((@ (guile) when) *optable-save-first*
((@ (guile) set!) *optable-save-first* #f)
(module-optable-set! (save-operator-table)))
((@ (guile) define) *prolog-scm-path* "./")
((@ (guile) define) *prolog-reverse-path* "../clpb.pl")
......@@ -439,6 +439,9 @@ defaulty_to_bound(D, P) :- ( integer(D) -> P = n(D) ; P = D ).
with infinities, tailored for the modes needed by this solver.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
-trace.
A cis B :- phrase(cis_goals(B, A), Goals), list_goal(Goals, Goal),Goal.
goal_expansion(A cis B, Expansion) :-
phrase(cis_goals(B, A), Goals),
list_goal(Goals, Expansion).
......@@ -449,24 +452,33 @@ goal_expansion(A cis_geq B, cis_geq_numeric(A, N)) :- nonvar(B), B = n(N).
goal_expansion(A cis_gt B, cis_lt_numeric(B, N)) :- nonvar(A), A = n(N).
goal_expansion(A cis_gt B, cis_gt_numeric(A, N)) :- nonvar(B), B = n(N).
-trace.
cis_lt(A,B) :- cis_gt(B,A).
% cis_gt only works for terms of depth 0 on both sides
-trace.
cis_gt(sup, B0) :- B0 \== sup.
cis_gt(n(N), B) :- cis_lt_numeric(B, N).
-trace.
cis_lt_numeric(inf, _).
cis_lt_numeric(n(B), A) :- B < A.
-trace.
cis_gt_numeric(sup, _).
cis_gt_numeric(n(B), A) :- B > A.
-trace.
cis_geq(inf, inf).
cis_geq(sup, _).
cis_geq(n(N), B) :- cis_leq_numeric(B, N).
-trace.
cis_leq_numeric(inf, _).
cis_leq_numeric(n(B), A) :- B =< A.
-trace.
cis_geq_numeric(sup, _).
cis_geq_numeric(n(B), A) :- B >= A.
......@@ -1948,6 +1960,7 @@ parse_clpfd0(E, R,
-eval_when(compile).
parse_clpfd(A,B,C) :- parse_clpfd0(A,B,C).
-trace.
non_monotonic(X) :-
( \+ fd_var(X), current_prolog_flag(clpfd_monotonic, true) ->
instantiation_error(X)
......@@ -2249,6 +2262,7 @@ match_goal(p(Prop), _) -->
%
% X is greater than or equal to Y.
-trace.
X #>= Y :- clpfd_geq(X, Y).
clpfd_geq(X, Y) :- clpfd_geq_(X, Y), reinforce(X), reinforce(Y).
......@@ -2467,6 +2481,7 @@ integer_kroot_leq(L, U, N, K, R) :-
%
% X is not Y.
-trace.
X #\= Y :- clpfd_neq(X, Y), do_queue.
% X #\= Y + Z
......@@ -2488,6 +2503,7 @@ neq_num(X, N) :-
%
% X is greater than Y.
-trace.
X #> Y :- X #>= Y + 1.
%% #<(?X, ?Y)
......@@ -2507,6 +2523,7 @@ X #> Y :- X #>= Y + 1.
% pair(1, 4)-pair(2, 3)].
% ==
-trace.
X #< Y :- Y #> X.
%% #\ +Q
......@@ -2519,6 +2536,7 @@ X #< Y :- Y #> X.
% X in inf.. -4\/1..9\/81..sup.
% ==
-trace.
#\ Q :- reify(Q, 0), do_queue.
%% ?P #<==> ?Q
......@@ -6187,7 +6205,7 @@ chain(Relation, X, Prev, X) :- call(Relation, ?(Prev), ?(X)).
%% fd_var(+Var)
%
% True iff Var is a CLP(FD) variable.
-trace.
fd_var(X) :- get_attr(X, clpfdId, _).
%% fd_inf(+Var, -Inf)
......@@ -6519,12 +6537,12 @@ make_clpfd_var('$clpfd_current_propagator') :-
nb_setval('$clpfd_current_propagator', []).
make_clpfd_var('$clpfd_queue_status') :-
nb_setval('$clpfd_queue_status', enabled).
/*
:- multifile user:exception/3.
user:exception(undefined_global_variable, Name, retry) :-
make_clpfd_var(Name), !.
*/
write(Name),make_clpfd_var(Name), !.
warn_if_bounded_arithmetic :-
( current_prolog_flag(bounded, true) ->
......
......@@ -6,8 +6,9 @@
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog coroutine)
#:use-module (language prolog modules boot dcg)
#:use-module (language prolog modules user)
#:pure
#:duplicates (last)
#:duplicates (last replace)
#:replace (#{#>}# #{#<}# #{#>=}# #{#=<}# #{#=}# #{#\\\\=}# #{#\\\\}# #{#<==>}# #{#==>}# #{#<==}# #{#\\\\/}# #{#/\\\\}# in ins all_different all_distinct sum scalar_product tuples_in labeling label indomain lex_chain serialized global_cardinality global_cardinality circuit cumulative cumulative element automaton automaton transpose zcompare chain fd_var fd_inf fd_sup fd_size fd_dom))
(clear-directives)
((@ (guile) eval-when) (compile load eval)
......
(define-module (language prolog modules user)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log iso-prolog)
#:export (exception))
(compile-prolog-string
"
:- dynamic(exception/3).
exception(X,Y,Tag) :- fail.
")
(<define> ($exe x atfail)
(<or>
(<and>
(<<match>> (#:mode -) (x)
(#(("error" #(("existence_error" tag val)) _))
(<var> (action)
(exception tag val action)
(<<match>> (#:mode -) (action)
("error" (atfail))
("retry" <cc>)
("fail" <fail>)
(_ (atfail)))))
(_ (atfail)))
<cut>)
(atfail)))
(set! user-exception-hook $exe)
......@@ -354,7 +354,7 @@ used it is then a safe journey.
(e (ref h))
(bt (mk api e h ref (dobt))))
(when (not (backtrack-ref h s))
(backtrack-add h s))
(backtrack-add bt s))
(cc s p)))))
......
......@@ -137,7 +137,7 @@ add/run * vlist *
(define (get-nlist-from-atom a dlink)
(let* ((r (get-atoms dlink)))
(if r
(let ((x (vhash-assq a r)))
(let ((x (vhash-assoc a r)))
(if x
(values r (cdr x))
(values r (make-empty))))
......@@ -146,7 +146,7 @@ add/run * vlist *
(define (get-nlist-from-atom! a dlink)
(let* ((r (get-atoms dlink)))
(if r
(let ((x (vhash-assq a r)))
(let ((x (vhash-assoc a r)))
(if x
(values r (cdr x))
(values r #f)))
......@@ -177,7 +177,7 @@ add/run * vlist *
(call-with-values (lambda () (get-nlist-from-atom a dlink))
(lambda (r k)
(add-atoms-all dlink
(vhash-consq a (difference k tag) r)
(vhash-cons a (difference k tag) r)
(difference (get-all dlink) tag)))))))
#f))
......@@ -209,7 +209,7 @@ add/run * vlist *
(call-with-values (lambda () (get-nlist-from-atom a dlink))
(lambda (r k)
(add-atoms-all dlink
(vhash-consq a (union k f) r)
(vhash-cons a (union k f) r)
(union f (get-all dlink)))))))))
(define (bitmap-indexer-add! s e f dlink)
......@@ -242,14 +242,14 @@ add/run * vlist *
(add-atoms-all dlink
(with-fluids ((init-block-size 128))
(if v
(vhash-setq! a (union f v) r)
(vhash-setq! a f r)))
(vhash-set! a (union f v) r)
(vhash-set! a f r)))
(union f (get-all dlink)))))))))
(define (get-fs-from-atoms a dlink)
(let ((r (get-atoms dlink)))
(if r
(let ((w (vhash-assq a r)))
(let ((w (vhash-assoc a r)))
(if w
(cdr w)
(make-empty)))
......
......@@ -22,6 +22,7 @@
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog dynamic-features)
#:use-module (logic guile-log guile-prolog memoize)
#:use-module (logic guile-log prolog global)
#:use-module (logic guile-log guile-prolog postpone)
#:export (prolog-shell conversation leave read-prolog user_ref user_set
......@@ -361,11 +362,12 @@ conversation_ :-
) ; conversation_.
conversation1(X,All) :-
backtrack_dynamic_object(scm[*globals-map*]),
fluid_guard_dynamic_object(scm[*var-attributator*],scm[-n-],
scm[-nsol-], scm[-all-], scm[-mute?-]),
scm[-nsol-], scm[-all-], scm[-mute?-],scm[*globals-map*]),
state_guard_dynamic_object(scm[*var-attributator*],
scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-],
scm[*user-data*]),
scm[*user-data*],scm[*globals-map*]),
wrap_frame,
conversation2(X,All).
......
......@@ -36,7 +36,8 @@
<define-guile-log-rule>
<get-fixed> <cp> <lookup> <wrap> <wrap-s>
<with-bind>
<attvar?> <put-attr> <get-attr> <del-attr> <get-attrs>
<attvar?> attvar?
<put-attr> <get-attr> <del-attr> <get-attrs>
<raw-attvar> <attvar-raw?> <set>
))
......@@ -94,7 +95,8 @@
(define-syntax-rule (<unwind> p) (gp-unwind p))
(define-syntax-rule (<cp> x ...) (gp-cp x ... S))
(define-syntax-rule (<cons?> x) (gp-pair- (gp-lookup x S) S))
(define-syntax-rule (<var?> x) (gp-var? (gp-lookup x S) S))
(define-syntax-rule (<var?> x) (let ((x (gp-lookup x S)))
(gp-var? x S)))
(define-syntax-rule (<get-fixed> x y) (gp-get-fixed-free x y S))
(define-syntax let-values*
(syntax-rules ()
......@@ -1223,7 +1225,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(syntax-rules ()
((_ w a ...)
(<with-guile-log> w code ...)))))
(define-syntax-rule (attvar? x) (gp-attvar? (gp-lookup x S) S))
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<attvar-raw?> x) (if (gp-attvar-raw? x S) <cc> <fail>))
(<define> (<put-attr> x m v) (<let> ((s (gp-put-attr x m v S)))
......@@ -1278,7 +1280,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
f))
(<define> (<set> x y)
(if (<var?> x)
(if (gp? x)
(<with-s> (gp-set! x y S) <cc>)))
......
......@@ -569,7 +569,7 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(pp 'res #`(begin
(ppp 'res #`(begin
#,@mod
(eval-when (compile load eval)
(add-non-defined
......@@ -926,7 +926,7 @@
(() #t)))
(set! burp
(pp 'burp
(ppp 'burp
#`(lambda (s123 #,@(map
(lambda (x)
(datum->syntax stx x))
......
(define-module (logic guile-log prolog error)
#:use-module ((logic guile-log)
#:select (</.> <abort> <define> <match> <cut> <let>
<lookup> <var?> <cc> <fail>))
<lookup> <var?> <cc> <fail> <lambda> <fail>))
#:use-module (ice-9 match)
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log umatch)
......@@ -11,7 +11,8 @@
#:export (type_error instantiation_error domain_error existence_error
permission_error list/plist? existence_error
*call-expression* representation_error syntax_error
scheme-wrapper evaluation_error throw-it system_error))
scheme-wrapper evaluation_error throw-it system_error
user-exception-hook))
(define-syntax fkn-it
(syntax-rules (quote)
......@@ -35,7 +36,13 @@
(define tag (make-prompt-tag))
(define G #f)
(define H #f)
(<define> (user-exception-hook x err) (err))
(<define> (abort1 code)
(user-exception-hook code
(<lambda> ()
(<abort> 'prolog non-reentrant code))))
(define-syntax-rule (define-error (nm a ...) code)
(define (nm s p cc a ...)
(pk (list 'nm a ...))
......@@ -47,8 +54,7 @@
(lambda ()
(call-with-eh
(lambda ()
(<abort> s p cc
'prolog non-reentrant (fkn-it code)))))
(abort1 s p cc (fkn-it code)))))
H)))))))
(define evaluation_error
......
......@@ -3,10 +3,12 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log dynamic-features)
#:export (b_setval b_getval nb_setval nb_getval nb_current
setarg nb_setarg))
setarg nb_setarg *globals-map*))
(define *globals-map* (make-fluid vlist-null))
(<wrap> add-vhash-dynamics *globals-map*)
(<define> (b_setval atom val)
(<let> ((atom (<lookup> atom)))
......@@ -14,14 +16,16 @@
((<var?> atom)
(instantiation_error))
((procedure? atom)
(<let> ((r (hashq-ref (fluid-ref *globals-map*) atom #f)))
(<let> ((r (vhashq-ref (fluid-ref *globals-map*) atom #f)))
(if (not r)
(<code> (set! r (gp-make-var))
(fluid-set! *globals-map*
(vhash-consq atom r
(fluid-ref *globals-map*))))
<cc>)
(<set> r val)))
(<pp> `(b_setval ,(pk r)))
(<set> r val)
(<pp> r)))
((string? atom)
(<let> ((mod (current-module))
(sym (string->symbol atom)))
......@@ -37,7 +41,7 @@
((<var?> atom)
(instantiation_error))
((procedure? atom)
(<let> ((r (hashq-ref (fluid-ref *globals-map*) atom #f)))
(<let> ((r (vhashq-ref (fluid-ref *globals-map*) atom #f)))
(if (not r)
(<code>
(set! r (gp-make-var))
......@@ -62,10 +66,13 @@
((<var?> atom)
(instantiation_error))
((procedure? atom)
(<let> ((r (hashq-ref (fluid-ref *globals-map*) atom #f)))
(if (not r)
(existence_error "variable" atom)
(<=> val r))))
(<recur> lp ()
(<let> ((r (vhashq-ref (fluid-ref *globals-map*) atom #f)))
(if (not r)
(<and>
(existence_error "undefined_global_variable" atom)
(lp))
(<=> val r)))))
((string? atom)
(<let> ((mod (current-module))
(sym (string->symbol atom)))
......
......@@ -743,7 +743,7 @@ floor(x) (floor x)
(<and> (if code <cc> <fail>)))
(mk-prolog-term-1 tr-nm fk-nm -nm a)))
(mk-test tr-var var -var x (<var?> x))
(mk-test tr-var var -var x (pk (attvar? (pk x))))
(mk-test tr-atom atom -atom x (let ((y (<lookup> x)))
(or (symbol? y) (string? y)
(procedure? y)
......
......@@ -944,14 +944,13 @@
(define found-scm #f) ;; defined in var.scm
(<define> (expand stx x)
(<var> (y)
;(<pp> `(expand ,x))
(expand_term x y)
;(<pp> y)
(<recur> lp ((y y) (r '()))
(<<match>> (#:mode - #:name expand) (y)
((x . l)
(<and>
;(<pp> `(assert-source ,x))
(<pp> `(assert-source ,x))
(lp l (cons (<scm>
(assertz-source S (lambda () #f) (lambda (s p x) x)
stx
......
......@@ -196,10 +196,10 @@ MK_ACC(dlink_cdr, get_cdr)
inline SCM get_fs_from_atoms(SCM a, SCM *dlink)
{
SCM r = get_atoms(dlink);
SCM r = get_atoms(dlink);
if(scm_is_true(r))
{
SCM w = vhash_assq(a,r);
{
SCM w = vhash_assoc(a,r);
if(!scm_is_eq(w, SCM_UNSPECIFIED))
return w;
else
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment