<div dir="ltr"><div><div>Hi</div><div><br></div><div>I amanged to define the<span class="" style="white-space:pre"> </span>macro defrule that do what I want but it<span class="" style="white-space:pre"> </span>was a difficult process.</div>
<div>The issue is to<span class="" style="white-space:pre"> </span>manage the special variables ?x,?y,... that are<span class="" style="white-space:pre"> </span>used by<span class="" style="white-space:pre"> </span>the select patterns; </div>
<div>if a svar is bound then<span class="" style="white-space:pre"> </span>the symbol value replaces the svar in the pattern otherwise the<span class="" style="white-space:pre"> </span>query</div><div>will return all<span class="" style="white-space:pre"> </span>possible matches<span class="" style="white-space:pre"> </span>with the svar within the db.</div>
<div><br></div><div>(defun var? (x)</div><div> (and (symbolp x) (not (keywordp x)) (eq (char (symbol-name x) 0) #\?)))</div><div><br></div><div>(defmacro with-locals (locals &rest body)</div><div> (if (null locals)</div>
<div> `(progn ,@body)</div><div> (let ((old-values (gensym)) (dummy (intern (symbol-name (gensym)) :keyword)))</div><div> `(let ((,old-values (mapcar #'(lambda (x) (if (boundp x) (symbol-value x) ,dummy))</div>
<div> ',locals)))</div><div> ,@(mapcar #'(lambda (x) `(makunbound ',x)) locals)</div><div> (let ((r (progn ,@body)))</div><div> (mapcar #'(lambda (x y) (if (not (eq ,dummy y)) (setf (symbol-value x) y))) ',locals ,old-values)</div>
<div> r)))))</div><div><br></div><div>(defmacro defrule (name args &rest body)</div><div> (let ((foo (gensym))</div><div> (vars (loop for v in args until (eq v :locals) collect v))</div><div> (locals (cadr (member :locals args))))</div>
<div> `(progn</div><div> (ccl::%defun</div><div> (nfunction ,foo</div><div> (LAMBDA ,vars</div><div> (let ,(mapcar #'(lambda (x) `(,x (if (and (var? ,x) (boundp ,x)) (symbol-value ,x) ,x)))</div>
<div> vars)</div><div> (declare (special ,@vars))</div><div> ,@(mapcar #'(lambda (x) `(if (var? ,x) (makunbound ',x))) ; unbound the local variable and not the passed one </div>
<div> vars)</div><div> (with-locals ,locals ; unbound locals and revert back to exact state of locals before running body </div>
<div> (macrolet ((,name ,vars ; within foo the macro name is redirected to call foo recursively </div><div><span class="" style="white-space:pre"> </span>(list ',foo ,@(mapcar #'(lambda (x) ``',,x) vars))))</div>
<div> ,@body)))))</div><div> 'nil)</div><div> (defmacro ,name ,vars</div><div> (list ',foo</div><div> ,@(mapcar #'(lambda (x) ``',,x) vars) ; quote arguments to function foo to avoid eval </div>
<div> )))))</div></div><div><br></div><div><div>(defrule ancestor (?x ?y :locals (?z))</div><div> (union</div><div> (select-loop (parent ?x ?y) collect `(ancestor ,?x ,?y))</div><div> (select-loop (parent ?x ?z)</div>
<div> append (loop for a in (ancestor ?z ?y) collect `(ancestor ,?x ,(third a)))</div><div> )))</div><div><br></div><div>Example:</div><div><br></div><div>(assert-fact (parent b a))</div><div>(assert-fact (parent c b))</div>
<div>(assert-fact (parent d c))</div><div>(assert-fact (parent e d))</div><div><br></div><div>? (ancestor ?x b)</div><div>((ANCESTOR C B) (ANCESTOR E B) (ANCESTOR D B))</div><div>? (ancestor ?x d)</div><div>((ANCESTOR E D))</div>
<div>? (ancestor c ?x)</div><div>((ANCESTOR C B) (ANCESTOR C A))</div><div>? (ancestor d ?x)</div><div>((ANCESTOR D C) (ANCESTOR D B) (ANCESTOR D A))</div><div>? (ancestor ?x ?y)</div><div>((ANCESTOR B A) (ANCESTOR C B) (ANCESTOR D C) (ANCESTOR E D) (ANCESTOR E C) (ANCESTOR E B) (ANCESTOR E A) (ANCESTOR D B) (ANCESTOR D A) (ANCESTOR C A))</div>
<div><br></div><div><br></div><div>;;; compare this to prolog ;;; (ancestor X Y) :- (parent X Y). </div>
<div>;;; (ancestor X Y) :- (parent X Z),(ancestor Z Y). </div><div><br></div><div> I am planning do the same with another magic macro</div>
<div> the objective is to be able to define a rule such this:</div><div> (defrule ancestor (?x ?y) (or (parent ?x ?y) (and (parent ?x ?z) (ancestor ?z ?y))))</div><div> </div><div>where the disjunctions will be transformed to unions and the conjunctions to nested select-loops;</div>
<div>I am not there yet, it is difficult because of the special variables that I have to manage I am wondering</div><div>if lexicons/dlets of Ron Garret can help here?</div><div><br></div><div>If there is a simpler solution to this I will be happy to hear from you</div>
<div><br></div><div>Kind regards</div></div><div>Taoufik</div><div><br></div></div><div class="gmail_extra"><br><br><div class="gmail_quote">On Sat, Dec 28, 2013 at 10:35 PM, Taoufik Dachraoui <span dir="ltr"><<a href="mailto:dachraoui.taoufik@gmail.com" target="_blank">dachraoui.taoufik@gmail.com</a>></span> wrote:<br>
<blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex"><div dir="ltr">Hi<div><br></div><div>Thank you for the rapid reply</div><div><br></div><div>the select accepts a pattern with special variables (?x, ?y, ...)</div>
<div><br></div><div>The select when it founds a bound special variable ?x it will replace it by its value in the pattern</div>
<div><br></div><div>Example: with ?x unbound (select-loop (p ?x a) collect it) will return all expressions in the db where the first and the third </div><div>elements are p and a respectively, but if ?x is bound to Z say, then the select will return (p Z a) if it exists in the db</div>
<div><br></div><div>I did this in order to embed queries like the following:</div><div><br></div><div>(select-loop (p ?x a) append (select-loop (?x ?y) collect it) (the second ?x will be bound to the value of ?x returned by the </div>
<div>first select (nested loops)</div><div><br></div><div>I did not see the infinite loop I will check again and see if I can solve this</div><div><br></div><div>Thanks</div><span class="HOEnZb"><font color="#888888"><div>
Taoufik</div><div><br></div></font></span></div><div class="HOEnZb"><div class="h5"><div class="gmail_extra">
<br><br><div class="gmail_quote">On Sat, Dec 28, 2013 at 10:06 PM, Ron Garret <span dir="ltr"><<a href="mailto:ron@flownet.com" target="_blank">ron@flownet.com</a>></span> wrote:<br><blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">
You have an infinite loop in your macroexpansion:<br>
<br>
? (macroexpand-all '(ancestor ?x a))<br>
> Error: Stack overflow on value stack.<br>
<br>
Also, I have no idea what this code is intended to do, but whatever it is this almost certainly isn’t helping:<br>
<br>
? (pprint (macroexpand '(ancestor ?x a)))<br>
<br>
(LET ((?X '?X) (?Y 'A))<br>
(DECLARE (SPECIAL ?X ?Y))<br>
(IF (VAR? ?X) (MAKUNBOUND ?X))<br>
(IF (VAR? ?Y) (MAKUNBOUND ?Y))<br>
(UNION (SELECT-LOOP (P ?X ?Y) COLLECT IT)<br>
(SELECT-LOOP (P ?X ?Z) APPEND (ANCESTOR ?Z ?Y))))<br>
<br>
You are binding ?X to itself, and then immediately making it unbound again. That is almost certainly not what you want to do.<br>
<br>
rg<br>
<div><div><br>
<br>
On Dec 28, 2013, at 12:05 PM, Taoufik Dachraoui <<a href="mailto:dachraoui.taoufik@gmail.com" target="_blank">dachraoui.taoufik@gmail.com</a>> wrote:<br>
<br>
> Hi<br>
><br>
> Could you please check this "Unhandled exception" and explain what is wrong<br>
> with my code<br>
><br>
> (defun var? (x)<br>
> (and (symbolp x) (not (keywordp x)) (eq (char (symbol-name x) 0) #\?)))<br>
><br>
> (defun vars-in (expr)<br>
> (if (atom expr)<br>
> (if (var? expr) (list expr))<br>
> (union<br>
> (vars-in (car expr))<br>
> (vars-in (cdr expr)))))<br>
><br>
> (defmacro aif (test-form then-form &optional else-form)<br>
> `(let ((it ,test-form))<br>
> (if it ,then-form ,else-form)))<br>
><br>
> (defun select! (pat) ; returns a list of bindings<br>
> (print pat)<br>
> '((it . (p b a)) (?x . 'b)))<br>
><br>
> (defmacro select-loop (pat &rest keywords-and-forms)<br>
> (let ((bind (gensym))<br>
> (vars (cons 'it (vars-in pat))))<br>
> `(block select-loop<br>
> (aif (select! ',pat)<br>
> (progn<br>
> (let ((binds it) ,@(mapcar #'list vars))<br>
> (declare (special ,@vars))<br>
> (loop for ,bind in binds<br>
> do (progn<br>
> (setf it (cdr (assoc 'it ,bind)))<br>
> ,@(mapcar #'(lambda (v) `(setf ,v (cdr (assoc ',v ,bind))))<br>
> vars))<br>
> ,@keywords-and-forms)))))))<br>
><br>
> (defmacro defrule (name args &rest body)<br>
> `(defmacro ,name ,args<br>
> (list 'let (list ,@(mapcar #'(lambda (x) `(list ',x `',,x)) args))<br>
> '(declare (special ,@args))<br>
> ,@(mapcar #'(lambda (x) `'(if (var? ,x) (makunbound ,x))) args)<br>
> ,@(mapcar #'(lambda (x) `',x) body))))<br>
><br>
> (defrule ancestor (?x ?y)<br>
> (union<br>
> (select-loop (p ?x ?y) collect it)<br>
> (select-loop (p ?x ?z)<br>
> append (ancestor ?z ?y))))<br>
><br>
> ? (ancestor ?x a)<br>
><br>
> Unhandled exception 10 at 0x28545, context->regs at #xb01641fc<br>
> Exception occurred while executing foreign code<br>
> at compact_dynamic_heap + 965<br>
> received signal 10; faulting address: 0xd360000<br>
> ? for help<br>
> [3422] Clozure CL kernel debugger: ?<br>
> (G) Set specified GPR to new value<br>
> (R) Show raw GPR/SPR register values<br>
> (L) Show Lisp values of tagged registers<br>
> (F) Show FPU registers<br>
> (S) Find and describe symbol matching specified name<br>
> (B) Show backtrace<br>
> (T) Show info about current thread<br>
> (M) Show memory areas<br>
> (X) Exit from this debugger, asserting that any exception was handled<br>
> (P) Propagate the exception to another handler (debugger or OS)<br>
> (K) Kill Clozure CL process<br>
> (V) Show Subversion revision information<br>
> (?) Show this help<br>
> [3422] Clozure CL kernel debugger: B<br>
> current thread: tcr = 0x2000f0, native thread ID = 0xbe03, interrupts enabled<br>
><br>
><br>
> Bogus frame 606b40<br>
> [3422] Clozure CL kernel debugger: L<br>
> [3422] Clozure CL kernel debugger:<br>
><br>
><br>
> Kind regards<br>
> Taoufik<br>
><br>
</div></div>> _______________________________________________<br>
> Openmcl-devel mailing list<br>
> <a href="mailto:Openmcl-devel@clozure.com" target="_blank">Openmcl-devel@clozure.com</a><br>
> <a href="http://clozure.com/mailman/listinfo/openmcl-devel" target="_blank">http://clozure.com/mailman/listinfo/openmcl-devel</a><br>
<br>
</blockquote></div><br></div>
</div></div></blockquote></div><br></div>