From 3b5a237f1ea2e53bbe3a41385708c8d739d5d615 Mon Sep 17 00:00:00 2001 From: Arfon Smith Date: Tue, 22 Apr 2014 19:22:49 -0500 Subject: [PATCH] Adding Common Lisp examples with .cl extension --- samples/Common Lisp/macros-advanced.cl | 82 ++++ samples/Common Lisp/motor-inferencia.cl | 475 ++++++++++++++++++++++++ 2 files changed, 557 insertions(+) create mode 100644 samples/Common Lisp/macros-advanced.cl create mode 100644 samples/Common Lisp/motor-inferencia.cl diff --git a/samples/Common Lisp/macros-advanced.cl b/samples/Common Lisp/macros-advanced.cl new file mode 100644 index 00000000..b746d769 --- /dev/null +++ b/samples/Common Lisp/macros-advanced.cl @@ -0,0 +1,82 @@ +;; @file macros-advanced.cl +;; +;; @breif Advanced macro practices - defining your own macros +;; +;; Macro definition skeleton: +;; (defmacro name (parameter*) +;; "Optional documentation string" +;; body-form*) +;; +;; Note that backquote expression is most often used in the `body-form` +;; + +; `primep` test a number for prime +(defun primep (n) + "test a number for prime" + (if (< n 2) (return-from primep)) + (do ((i 2 (1+ i)) (p t (not (zerop (mod n i))))) + ((> i (sqrt n)) p) + (when (not p) (return)))) +; `next-prime` return the next prime bigger than the specified number +(defun next-prime (n) + "return the next prime bigger than the speicified number" + (do ((i (1+ n) (1+ i))) + ((primep i) i))) +; +; The recommended procedures to writting a new macro are as follows: +; 1. Write a sample call to the macro and the code it should expand into +(do-primes (p 0 19) + (format t "~d " p)) +; Expected expanded codes +(do ((p (next-prime (- 0 1)) (next-prime p))) + ((> p 19)) + (format t "~d " p)) +; 2. Write code that generate the hardwritten expansion from the arguments in +; the sample call +(defmacro do-primes (var-and-range &rest body) + (let ((var (first var-and-range)) + (start (second var-and-range)) + (end (third var-and-range))) + `(do ((,var (next-prime (- ,start 1)) (next-prime ,var))) + ((> ,var ,end)) + ,@body))) +; 2-1. More concise implementations with the 'parameter list destructuring' and +; '&body' synonym, it also emits more friendly messages on incorrent input. +(defmacro do-primes ((var start end) &body body) + `(do ((,var (next-prime (- ,start 1)) (next-prime ,var))) + ((> ,var ,end)) + ,@body)) +; 2-2. Test the result of macro expansion with the `macroexpand-1` function +(macroexpand-1 '(do-primes (p 0 19) (format t "~d " p))) +; 3. Make sure the macro abstraction does not "leak" +(defmacro do-primes ((var start end) &body body) + (let ((end-value-name (gensym))) + `(do ((,var (next-prime (- ,start 1)) (next-prime ,var)) + (,end-value-name ,end)) + ((> ,var ,end-value-name)) + ,@body))) +; 3-1. Rules to observe to avoid common and possible leaks +; a. include any subforms in the expansion in positions that will be evaluated +; in the same order as the subforms appear in the macro call +; b. make sure subforms are evaluated only once by creating a variable in the +; expansion to hold the value of evaluating the argument form, and then +; using that variable anywhere else the value is needed in the expansion +; c. use `gensym` at macro expansion time to create variable names used in the +; expansion +; +; Appendix I. Macro-writting macros, 'with-gensyms', to guranttee that rule c +; gets observed. +; Example usage of `with-gensyms` +(defmacro do-primes-a ((var start end) &body body) + "do-primes implementation with macro-writting macro 'with-gensyms'" + (with-gensyms (end-value-name) + `(do ((,var (next-prime (- ,start 1)) (next-prime ,var)) + (,end-value-name ,end)) + ((> ,var ,end-value-name)) + ,@body))) +; Define the macro, note how comma is used to interpolate the value of the loop +; expression +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(loop for n in names collect `(,n (gensym))) + ,@body) +) \ No newline at end of file diff --git a/samples/Common Lisp/motor-inferencia.cl b/samples/Common Lisp/motor-inferencia.cl new file mode 100644 index 00000000..6a2a97ea --- /dev/null +++ b/samples/Common Lisp/motor-inferencia.cl @@ -0,0 +1,475 @@ +#| +ESCUELA POLITECNICA SUPERIOR - UNIVERSIDAD AUTONOMA DE MADRID +INTELIGENCIA ARTIFICIAL + +Motor de inferencia +Basado en parte en "Paradigms of AI Programming: Case Studies +in Common Lisp", de Peter Norvig, 1992 +|# + + +;;;;;;;;;;;;;;;;;;;;; +;;;; Global variables +;;;;;;;;;;;;;;;;;;;;; + + +(defvar *hypothesis-list*) +(defvar *rule-list*) +(defvar *fact-list*) + +;;;;;;;;;;;;;;;;;;;;; +;;;; Constants +;;;;;;;;;;;;;;;;;;;;; + +(defconstant +fail+ nil "Indicates unification failure") + +(defconstant +no-bindings+ '((nil)) + "Indicates unification success, with no variables.") + +(defconstant *mundo-abierto* nil) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Functions for the user +;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; Resets *fact-list* to NIL +(defun erase-facts () (setq *fact-list* nil)) + +(defun set-hypothesis-list (h) (setq *hypothesis-list* h)) + + +;; Returns a list of solutions, each one satisfying all the hypothesis contained +;; in *hypothesis-list* +(defun motor-inferencia () + (consulta *hypothesis-list*)) + + + +;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Auxiliary functions +;;;;;;;;;;;;;;;;;;;;;;;; + +#|____________________________________________________________________________ +FUNCTION: CONSULTA + +COMMENTS: +CONSULTA receives a list of hypothesis (variable ), and returns +a list of binding lists (each binding list being a solution). + +EXAMPLES: +hypotheses is: +((brothers ?x ?y) (neighbours juan ?x)). + +That is, we are searching the brothers of the possible neighbors of Juan. + +The function can return in this case: + +(((?x . sergio) (?y . javier)) ((?x . julian) (?y . mario)) ((?x . julian) (?y . pedro))). +That is, the neighbors of Juan (Sergio and Julian) have 3 brothers in total(Javier, Mario, Pedro) +____________________________________________________________________________|# + +(defun consulta (hypotheses) + (if (null hypotheses) (list +no-bindings+) + (mapcan #'(lambda (b) + (mapcar #'(lambda (x) (une-bindings-con-bindings b x)) + (consulta (subst-bindings b (rest hypotheses))))) + (find-hypothesis-value (first hypotheses))))) + + + +#|____________________________________________________________________________ +FUNCTION: FIND-HYPOTHESIS-VALUE + +COMMENTS: +This function manages the query a single query (only one hypothesis) given a binding list. +It tries (in the following order) to: +- Answer the query from *fact-list* +- Answer the query from the rules in *rule-list* +- Ask the user + +The function returns a list of solutions (list of binding lists). + +EXAMPLES: +If hypothesis is (brothers ?x ?y) +and the function returns: +(((?x . sergio) (?y . javier)) ((?x . julian) (?y . maria)) ((?x . alberto) (?y . pedro))). + +Means that Sergio and Javier and brothers, Julian and Mario are brothers, and Alberto and Pedro are brothers. +____________________________________________________________________________|# + +(defun find-hypothesis-value (hypothesis) + (let (rules) + (cond + ((equality? hypothesis) + (value-from-equality hypothesis)) + ((value-from-facts hypothesis)) + ((setq good-rules (find-rules hypothesis)) + (value-from-rules hypothesis good-rules)) + (t (ask-user hypothesis))))) + + + +; une-bindings-con-bindings takes two binding lists and returns a binding list +; Assumes that b1 and b2 are not +fail+ +(defun une-bindings-con-bindings (b1 b2) + (cond + ((equal b1 +no-bindings+) b2) + ((equal b2 +no-bindings+) b1) + (T (append b1 b2)))) + + + +#|____________________________________________________________________________ +FUNCTION: VALUE-FROM-FACTS + +COMMENTS: +Returns all the solutions of obtained directly from *fact-list* + +EXAMPLES: +> (setf *fact-list* '((man luis) (man pedro)(woman mart)(man daniel)(woman laura))) + +> (value-from-facts '(man ?x)) +returns: + +(((?X . LUIS)) ((?X . PEDRO)) ((?X . DANIEL))) +____________________________________________________________________________|# + +(defun value-from-facts (hypothesis) + (mapcan #'(lambda(x) (let ((aux (unify hypothesis x))) + (when aux (list aux)))) *fact-list*)) + + + + +#|____________________________________________________________________________ +FUNCTION: FIND-RULES + +COMMENTS: +Returns the rules in *rule-list* whose THENs unify with the term given in +The variables in the rules that satisfy this requirement are renamed. + +EXAMPLES: +> (setq *rule-list* + '((R1 (pertenece ?E (?E . ?_))) + (R2 (pertenece ?E (?_ . ?Xs)) :- ((pertenece ?E ?Xs))))) + +Then: +> (FIND-RULES (PERTENECE 1 (2 5))) +returns: +((R2 (PERTENECE ?E.1 (?_ . ?XS.2)) :- ((PERTENECE ?E.1 ?XS.2)))) +That is, only the THEN of rule R2 unify with + +However, +> (FIND-RULES (PERTENECE 1 (1 6 7))) + +returns: +((R1 (PERTENECE ?E.6 (?E.6 . ?_))) + (R2 (PERTENECE ?E.7 (?_ . ?XS.8)) :- ((PERTENECE ?E.7 ?XS.8)))) +So the THEN of both rules unify with +____________________________________________________________________________|# + +(defun find-rules (hypothesis) + (mapcan #'(lambda(b) (let ((renamed-rule (rename-variables b))) + (when (in-then? hypothesis renamed-rule) + (list renamed-rule)))) *rule-list*)) + +(defun in-then? (hypothesis rule) + (unless (null (rule-then rule)) + (not (equal +fail+ (unify hypothesis (rule-then rule)))))) + + + +#|____________________________________________________________________________ +FUNCTION: VALUE-FROM-RULES + +COMMENTS: +Returns all the solutions to found using all the rules given in +the list . Note that a single rule can have multiple solutions. +____________________________________________________________________________|# +(defun value-from-rules (hypothesis rules) + (mapcan #'(lambda (r) (eval-rule hypothesis r)) rules)) + +(defun limpia-vinculos (termino bindings) + (unify termino (subst-bindings bindings termino))) + + +#|____________________________________________________________________________ +FUNCTION: EVAL-RULE + +COMMENTS: +Returns all the solutions found using the rule given as input argument. + +EXAMPLES: +> (setq *rule-list* + '((R1 (pertenece ?E (?E . ?_))) + (R2 (pertenece ?E (?_ . ?Xs)) :- ((pertenece ?E ?Xs))))) +Then: +> (EVAL-RULE + (PERTENECE 1 (1 6 7)) + (R1 (PERTENECE ?E.42 (?E.42 . ?_)))) +returns: +(((NIL))) +That is, the query (PERTENECE 1 (1 6 7)) can be proven from the given rule, and +no binding in the variables in the query is necessary (in fact, the query has no variables). +On the other hand: +> (EVAL-RULE + (PERTENECE 1 (7)) + (R2 (PERTENECE ?E.49 (?_ . ?XS.50)) :- ((PERTENECE ?E.49 ?XS.50)))) +returns: +NIL +That is, the query can not be proven from the rule R2. +____________________________________________________________________________|# + +(defun eval-rule (hypothesis rule) + (let ((bindings-then + (unify (rule-then rule) hypothesis))) + (unless (equal +fail+ bindings-then) + (if (rule-ifs rule) + (mapcar #'(lambda(b) (limpia-vinculos hypothesis (append bindings-then b))) + (consulta (subst-bindings bindings-then (rule-ifs rule)))) + (list (limpia-vinculos hypothesis bindings-then)))))) + + +(defun ask-user (hypothesis) + (let ((question hypothesis)) + (cond + ((variables-in question) +fail+) + ((not-in-fact-list? question) +fail+) + (*mundo-abierto* + (format t "~%Es cierto el hecho ~S? (T/nil)" question) + (cond + ((read) (add-fact question) +no-bindings+) + (T (add-fact (list 'NOT question)) +fail+))) + (T +fail+)))) + + +; value-from-equality: +(defun value-from-equality (hypothesis) + (let ((new-bindings (unify (second hypothesis) (third hypothesis)))) + (if (not (equal +fail+ new-bindings)) + (list new-bindings)))) + + + +#|____________________________________________________________________________ +FUNCTION: UNIFY + +COMMENTS: +Finds the most general unifier of two input expressions, taking into account the +bindings specified in the input +In case the two expressions can unify, the function returns the total bindings necessary +for that unification. Otherwise, returns +fail+ + +EXAMPLES: +> (unify '1 '1) +((NIL)) ;; which is the constant +no-bindings+ +> (unify 1 '2) +nil ;; which is the constant +fail+ +> (unify '?x 1) +((?x . 1)) +> (unify '(1 1) ?x) +((? x 1 1)) +> (unify '?_ '?x) +((NIL)) +> (unify '(p ?x 1 2) '(p ?y ?_ ?_)) +((?x . ?y)) +> (unify '(?a . ?_) '(1 2 3)) +((?a . 1)) +> (unify '(?_ ?_) '(1 2)) +((nil)) +> (unify '(?a . ?b) '(1 2 3)) +((?b 2 3) (?a . 1)) +> (unify '(?a . ?b) '(?v . ?d)) +((?b . ?d) (?a . ?v)) +> (unify '(?eval (+ 1 1)) '1) +nil +> (unify '(?eval (+ 1 1)) '2) +(nil)) +____________________________________________________________________________|# + +(defun unify (x y &optional (bindings +no-bindings+)) + "See if x and y match with given bindings. If they do, + return a binding list that would make them equal [p 303]." + (cond ((eq bindings +fail+) +fail+) + ((eql x y) bindings) + ((eval? x) (unify-eval x y bindings)) + ((eval? y) (unify-eval y x bindings)) + ((variable? x) (unify-var x y bindings)) + ((variable? y) (unify-var y x bindings)) + ((and (consp x) (consp y)) + (unify (rest x) (rest y) + (unify (first x) (first y) bindings))) + (t +fail+))) + + +;; rename-variables: renombra ?X por ?X.1, ?Y por ?Y.2 etc. salvo ?_ que no se renombra +(defun rename-variables (x) + "Replace all variables in x with new ones. Excepto ?_" + (sublis (mapcar #'(lambda (var) + (if (anonymous-var? var) + (make-binding var var) + (make-binding var (new-variable var)))) + (variables-in x)) + x)) + + + +;;;; Auxiliary Functions + +(defun unify-var (var x bindings) + "Unify var with x, using (and maybe extending) bindings [p 303]." + (cond ((or (anonymous-var? var)(anonymous-var? x)) bindings) + ((get-binding var bindings) + (unify (lookup var bindings) x bindings)) + ((and (variable? x) (get-binding x bindings)) + (unify var (lookup x bindings) bindings)) + ((occurs-in? var x bindings) + +fail+) + (t (extend-bindings var x bindings)))) + +(defun variable? (x) + "Is x a variable (a symbol starting with ?)?" + (and (symbolp x) (eql (char (symbol-name x) 0) #\?))) + +(defun get-binding (var bindings) + "Find a (variable . value) pair in a binding list." + (assoc var bindings)) + +(defun binding-var (binding) + "Get the variable part of a single binding." + (car binding)) + +(defun binding-val (binding) + "Get the value part of a single binding." + (cdr binding)) + +(defun make-binding (var val) (cons var val)) + +(defun lookup (var bindings) + "Get the value part (for var) from a binding list." + (binding-val (get-binding var bindings))) + +(defun extend-bindings (var val bindings) + "Add a (var . value) pair to a binding list." + (append + (unless (eq bindings +no-bindings+) bindings) + (list (make-binding var val)))) + +(defun occurs-in? (var x bindings) + "Does var occur anywhere inside x?" + (cond ((eq var x) t) + ((and (variable? x) (get-binding x bindings)) + (occurs-in? var (lookup x bindings) bindings)) + ((consp x) (or (occurs-in? var (first x) bindings) + (occurs-in? var (rest x) bindings))) + (t nil))) + +(defun subst-bindings (bindings x) + "Substitute the value of variables in bindings into x, + taking recursively bound variables into account." + (cond ((eq bindings +fail+) +fail+) + ((eq bindings +no-bindings+) x) + ((and (listp x) (eq '?eval (car x))) + (subst-bindings-quote bindings x)) + ((and (variable? x) (get-binding x bindings)) + (subst-bindings bindings (lookup x bindings))) + ((atom x) x) + (t (cons (subst-bindings bindings (car x)) ;; s/reuse-cons/cons + (subst-bindings bindings (cdr x)))))) + +(defun unifier (x y) + "Return something that unifies with both x and y (or fail)." + (subst-bindings (unify x y) x)) + +(defun variables-in (exp) + "Return a list of all the variables in EXP." + (unique-find-anywhere-if #'variable? exp)) + +(defun unique-find-anywhere-if (predicate tree &optional found-so-far) + "Return a list of leaves of tree satisfying predicate, + with duplicates removed." + (if (atom tree) + (if (funcall predicate tree) + (pushnew tree found-so-far) + found-so-far) + (unique-find-anywhere-if + predicate + (first tree) + (unique-find-anywhere-if predicate (rest tree) + found-so-far)))) + +(defun find-anywhere-if (predicate tree) + "Does predicate apply to any atom in the tree?" + (if (atom tree) + (funcall predicate tree) + (or (find-anywhere-if predicate (first tree)) + (find-anywhere-if predicate (rest tree))))) + +(defun new-variable (var) + "Create a new variable. Assumes user never types variables of form ?X.9" + (gentemp (format nil "~S." var))) +; (gentemp "?") ) +;;; + +(defun anonymous-var? (x) + (eq x '?_)) + +(defun subst-bindings-quote (bindings x) + "Substitute the value of variables in bindings into x, + taking recursively bound variables into account." + (cond ((eq bindings +fail+) +fail+) + ((eq bindings +no-bindings+) x) + ((and (variable? x) (get-binding x bindings)) + (if (variable? (lookup x bindings)) + (subst-bindings-quote bindings (lookup x bindings)) + (subst-bindings-quote bindings (list 'quote (lookup x bindings))) + ) + ) + ((atom x) x) + (t (cons (subst-bindings-quote bindings (car x)) ;; s/reuse-cons/cons + (subst-bindings-quote bindings (cdr x)))))) + +(defun eval? (x) + (and (consp x) (eq (first x) '?eval))) + +(defun unify-eval (x y bindings) + (let ((exp (subst-bindings-quote bindings (second x)))) + (if (variables-in exp) + +fail+ + (unify (eval exp) y bindings)))) + + + +(defun rule-ifs (rule) (fourth rule)) +(defun rule-then (rule) (second rule)) + + +(defun equality? (term) + (and (consp term) (eql (first term) '?=))) + + +(defun in-fact-list? (expresion) + (some #'(lambda(x) (equal x expresion)) *fact-list*)) + +(defun not-in-fact-list? (expresion) + (if (eq (car expresion) 'NOT) + (in-fact-list? (second expresion)) + (in-fact-list? (list 'NOT expresion)))) + + +;; add-fact: + +(defun add-fact (fact) + (setq *fact-list* (cons fact *fact-list*))) + + +(defun variable? (x) + "Is x a variable (a symbol starting with ?) except ?eval and ?=" + (and (not (equal x '?eval)) (not (equal x '?=)) + (symbolp x) (eql (char (symbol-name x) 0) #\?))) + + +;; EOF \ No newline at end of file