Commit 0afe813f by Stefan Israelsson Tampe

### 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) ( pp a)))))) (define-and-log (syntax-rules () ... ... @@ -724,17 +724,18 @@ For tabling, negations are tricky. the reason is that when a recursive applicati (fluid-set! delayers old) (cut)))) ( (cut2 s p2 cc) code (if (eq? (fluid-ref delayers) old) (if (eq? P p2) ( p ) ) ( (dls old) (if (eq? P p2) ( p ) )))))) (fl-let (cut2 s p2 cc) ( (cut2 s p2 cc) code (if (eq? (fluid-ref delayers) old) (if (eq? P p2) ( p ) ) ( (dls old) (if (eq? P p2) ( p ) ))))))) (define-syntax-rule (dls-match (cut s p cc) old code ...) ( (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 ( x ( trace-fkn 'in ff Level x) ( xxx x) ( xx x) ( 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 ( ((p a) (p) (a)) ((p a b) ( (p) (a) (b))))) ( (--if x ...) (-if ( () x) ...)) ( (-and x y) ( (x) (y))) ( (--and x ...) (-and ( () x) ...)) ( (-or x y) ( (x) (y))) ( (--or x ...) (-or ( () x) ...)) ( (-not x) ( (x))) ( (--not x ...) (-not ( () x) ...)) (mk-prolog-biop 'xfy ":" tr-ns: op2: <:> a a) (mk-prolog-biop 'xfy "," tr-and #{,}# g g) (mk-prolog-biop 'xfy "->" tr-if-then -> g g) (mk-prolog-unop 'fy "\\+" tr-negation #{\\+}# 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:) ( (- x y) ( x y)) ( (-<=> x y) (<=> x y)) ( (-<==> x y) (<==> x y)) (mk-prolog-biop-tr 'xfx "=" unify-tr op2= (v v) ((unify-tr stx n m x y) (match x ... ... @@ -380,10 +399,10 @@ #`( #,(*var* stx x) #,(*var* stx y)))) (_ #`( #,(*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 #{\\=}# 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!