clpfd, puzzle example works

parent 2d49fe56
......@@ -1398,9 +1398,10 @@ label([], _, _, _, Consistency) :- !,
( Consistency = upto_in(I0,I) -> I0 = I
; true
).
label(Vars, Selection, Order, Choice, Consistency) :-
( Vars = [V|Vs], nonvar(V) -> label(Vs, Selection, Order, Choice, Consistency)
; select_var(Selection, Vars, Var, RVars),
(Vars = [V|Vs], nonvar(V) -> label(Vs, Selection, Order, Choice, Consistency)
; select_var(Selection, Vars, Var, RVars),
( var(Var) ->
( Consistency = upto_in(I0,I), fd_get(Var, _, Ps), all_dead(Ps) ->
fd_size(Var, Size),
......@@ -1669,28 +1670,19 @@ tighten(max, E, V) :- E #> V.
%
% Vars are pairwise distinct.
-trace.
all_different(Ls) :-
write(1),
fd_must_be_list(Ls),
write(2),
maplist(fd_variable, Ls),
write(3),
put_attr(Orig, clpfd_original, all_different(Ls)),
write(4),
all_different(Ls, [], Orig),
write(5),
do_queue.
all_different([], _, _).
all_different([X|Right], Left, Orig) :-
( var(X) ->
write(a),
make_propagator(pdifferent(Left,Right,X,Orig), Prop),
write(b),
init_propagator(X, Prop),
write(c),
trigger_prop(Prop), write(d)
trigger_prop(Prop)
; exclude_fire(Left, Right, X)
),
all_different(Right, [X|Left], Orig).
......@@ -6615,27 +6607,21 @@ clpfd_original:attr_unify_hook(_,_) :- false.
attributes_goals([]) --> [].
attributes_goals([propagator(P, State)|As]) -->
{write(P),nl},
( { ground(State) } -> []
; { phrase(attribute_goal_(P), Gs) } ->
{ del_attr(State, clpfd_aux), State = processed,
write(l),
( current_prolog_flag(clpfd_monotonic, true) ->
maplist(unwrap_with(bare_integer), Gs, Gs1)
; maplist(unwrap_with(=), Gs, Gs1)
),
write(k),
maplist(with_clpfd, Gs1, Gs2) },
{write(u)},
list(Gs2),
{write(v)}
list(Gs2)
; [P] % possibly user-defined constraint
),
attributes_goals(As).
with_clpfd(G, G).
-trace.
unwrap_with(_, V, V) :- var(V), !.
unwrap_with(Goal, ?(V0), V) :- !, call(Goal, V0, V).
unwrap_with(Goal, Term0, Term) :-
......
......@@ -423,9 +423,9 @@ vtosym_([X|XL],[U|UL],H,I) :-
vtosym_([],[],_,_) :- !.
vtosym_(X,Y,_,_) :- atomic(X) -> (!,X=Y) ; fail.
vtosym_(X,Y,H,I) :-
X =.. [F|A], !, vtosym_(F,G,H,I),vtosym_(A,B,H,I), Y =.. [G|B].
X =.. [F|A], !,
vtosym_(F,G,H,I),vtosym_(A,B,H,I), Y =.. [G|B].
vtosym_(F,G,H,I) :- ftof(F,G,H,I).
......
......@@ -36,6 +36,7 @@
#:use-module ((logic guile-log functional-database) #:select (extended))
#:export (reset-flags reset-prolog set)
#:replace (sort load)
#:re-export (;;swi stuff
meta_predicate public
memberchk $skip_list is_list
......@@ -220,9 +221,9 @@
*term-expansions*
*goal-expansions*
*swi-standard-operators*
min max abs
)
#:export (make-unbound-term
default_module
re-export-iso-operators
......@@ -282,3 +283,4 @@ sort(X,L) :- msort(X,LL),unique(LL,L).
(cc s p))))
load)))))
......@@ -75,9 +75,9 @@
(define-syntax-rule (fl-let (cut s p cc) code ...)
(syntax-parameterize ((S (identifier-syntax s))
(P (identifier-syntax p))
(CC (identifier-syntax cc))
(CUT (identifier-syntax cut)))
(P (identifier-syntax p))
(CC (identifier-syntax cc))
(CUT (identifier-syntax cut)))
code ...))
(define-syntax-rule (cc-let (cc) code ...)
......@@ -167,7 +167,7 @@
(let ((pp (lambda ()
(gp-unwind s)
(or-aux (cut s p cc) . as))))
(parse<> (cut s pp cc) a)))))
(parse<> (cut s pp cc) (<with-fail> pp a))))))
(define-and-log <values>
(syntax-rules ()
......@@ -724,17 +724,18 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(fluid-set! delayers old)
(cut))))
(<and> (cut2 s p2 cc)
code
(if (eq? (fluid-ref delayers) old)
(if (eq? P p2)
(<with-fail> p <cc>)
<cc>)
(<and>
(dls old)
(if (eq? P p2)
(<with-fail> p <cc>)
<cc>))))))
(fl-let (cut2 s p2 cc)
(<and> (cut2 s p2 cc)
code
(if (eq? (fluid-ref delayers) old)
(if (eq? P p2)
(<with-fail> p <cc>)
<cc>)
(<and>
(dls old)
(if (eq? P p2)
(<with-fail> p <cc>)
<cc>)))))))
(define-syntax-rule (dls-match (cut s p cc) old code ...)
(<and> (cut s p cc)
......
......@@ -139,14 +139,13 @@
fnew)
(define-syntax-rule (mktr f xx)
(let ((ff f)
(xxx xx))
(let ((ff f))
(if Trace
(tr-meta
ff
(<lambda> x
(<apply> trace-fkn 'in ff Level x)
(<apply> xxx x)
(<apply> xx x)
(<apply> trace-fkn 'out ff Level x)))
xx)))
......
......@@ -308,14 +308,32 @@
(let ((f (gp-lookup f s)))
(cond
((procedure? f)
(cons*
(get-fkn f)
(GL S)
(map* (lambda (x)
(compile-s match-map-i x))
a)))
(cond
((eq? (object-property f 'prolog-functor-type) #:scm)
(cons*
(get-fkn f)
(GL S)
(map* (lambda (x)
(compile-s match-map-i x))
a)))
((eq? (object-property f 'prolog-functor-type) #:goal)
(cons*
(list '@ '(logic guile-log iso-prolog) (procedure-name f))
(map* (lambda (x)
(compile-s match-map-i x))
a)))
(else
(cons*
(get-fkn f)
(map* (lambda (x)
(compile-s match-map-i x))
a)))))
(else
(error "copmile-s fkn not a procedure")))))
(a
(let ((a (gp-lookup a s)))
(cond
......
......@@ -352,13 +352,32 @@
(procedure-name l)))
(namespace-switch module l))))
(define -if
(<case-lambda>
((p a) (p) <cut> (a))
((p a b) (<if> (p) (a) (b)))))
(<define-guile-log-rule> (--if x ...) (-if (<lambda> () x) ...))
(<define> (-and x y) (<and> (x) (y)))
(<define-guile-log-rule> (--and x ...) (-and (<lambda> () x) ...))
(<define> (-or x y) (<or> (x) (y)))
(<define-guile-log-rule> (--or x ...) (-or (<lambda> () x) ...))
(<define> (-not x) (<not> (x)))
(<define-guile-log-rule> (--not x ...) (-not (<lambda> () x) ...))
(mk-prolog-biop 'xfy ":" tr-ns: op2: <:> a a)
(mk-prolog-biop 'xfy "," tr-and #{,}# <and> g g)
(mk-prolog-biop 'xfy "->" tr-if-then -> <if> g g)
(mk-prolog-unop 'fy "\\+" tr-negation #{\\+}# <not> g )
(mk-prolog-biop 'xfy "," tr-and #{,}# --and g g)
(mk-prolog-biop 'xfy "->" tr-if-then -> --if g g)
(mk-prolog-unop 'fy "\\+" tr-negation #{\\+}# --not g )
(set! (@ (logic guile-log prolog goal-functors) op2:) op2:)
(<define> (-<r=> x y) (<r=> x y))
(<define> (-<=> x y) (<=> x y))
(<define> (-<==> x y) (<==> x y))
(mk-prolog-biop-tr 'xfx "=" unify-tr op2= <r=> (v v)
((unify-tr stx n m x y)
(match x
......@@ -380,10 +399,10 @@
#`(<r=> #,(*var* stx x) #,(*var* stx y))))
(_
#`(<r=> #,(*var* stx x) #,(*var* stx y))))))))
(mk-prolog-biop 'xfx "==" ident-tr == <==> v v)
(mk-prolog-biop-not 'xfx "\\==" not-ident-tr #{\\==}# <==> v v)
(mk-prolog-biop-not 'xfx "\\=" not-unify-tr #{\\=}# <=> v v)
(mk-prolog-biop 'xfx "==" ident-tr == <==> v v)
(mk-prolog-biop-not 'xfx "\\==" not-ident-tr #{\\==}# <==> v v)
(mk-prolog-biop-not 'xfx "\\=" not-unify-tr #{\\=}# <r=> v v)
(mk-prolog-biop 'xfx "=@=" variant-tr =@= is-variant? a a)
(mk-prolog-biop-not 'xfx "\\=@=" not-variant-tr #{\\=@=}# is-variant? a a)
......
......@@ -103,6 +103,15 @@
((#:variable '_ n m)
(warn (format #f "compilation-error ~a '_' cannot be a goal"
(get-refstr n m))))
((#:term (and atom (#:atom f _ _ n m)) (and ag ((_ _ "|" _) x y _ _))
#f . _)
#`(caller `#,(arg stx atom) `#,(arg stx (list #:list ag n m))))
((#:term (and atom (#:atom f _ _ n m)) (and ag ((_ _ "|" _) y _ _))
#f . _)
#`(caller `#,(arg stx atom) `#,(arg stx (list #:list y n m))))
((#:term (#:atom 'call . _) ((_ _ "," _) (and f (#:atom . _)) l n m) . u)
(goal stx `(#:term ,f ,l ,@u)))
......
......@@ -756,6 +756,8 @@
(cond
((not f)
(format #f "#f"))
((eq? f |)
(trail (cons a l) qq))
((string? f)
(format #f "'~a'(~a~{, ~a~})" f (lp a) (map lp (gp->scm l s))))
......
......@@ -4,7 +4,6 @@ SCM_DEFINE(gp_attvar, "gp-attvar?", 2, 0, 0, (SCM x, SCM s),
{
SCM l;
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x))
{
......
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