home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / AIE8906.ZIP / TOOLBOX.ASC < prev   
Encoding:
Text File  |  1988-05-04  |  3.3 KB  |  124 lines
  1. Basic Database Functions.
  2.  
  3.  
  4. (defun clear-db ()
  5.   (setq *db* (make-hash-table)))
  6.  
  7. (clear-db)
  8.  
  9.  (defmacro entries (x)
  10.   `(gethash ,x *db*))
  11.  
  12. (defmacro fact (pred &rest args)
  13.   `(fact+ ',pred ',args))
  14.  
  15. (defun fact+ (pred args)
  16.   (push args (entries pred))
  17.   args)
  18.  
  19. (defun world ()
  20.   (maphash #'(lambda (key value)
  21.                (pprint (list key value)))
  22.            *db*))
  23.  
  24.  
  25. --------------------------------------
  26. Functions for Answering Queries.
  27.  
  28.  
  29. (defun lookup (pred args)
  30.   (let ((result nil))
  31.     (dolist (e (entries pred))
  32.       (let ((vals (pmatch e args '((null binds)))))
  33.         (if vals (push vals result))))
  34.     (reverse result)))
  35.  
  36. (defun var? (x)
  37.   (string= (subseq (princ-to-string x) 0 1) '?))
  38. (defun pmatch (obj pat binds)
  39.   (cond ((null pat) binds)
  40.         ((not (var? (car pat)))
  41.          (and (equal (car pat) (car obj))
  42.               (pmatch (cdr obj) (cdr pat) binds)))
  43.         ((assoc (car pat) binds)
  44.          (and (eq (car obj)
  45.                   (cadr (assoc (car pat) binds)))
  46.               (pmatch (cdr obj) (cdr pat) binds)))
  47.         (t (pmatch (cdr obj)
  48.                    (cdr pat)
  49.                    (cons (list (car pat) (car obj))
  50.                           binds)))))
  51.  
  52.  
  53.  
  54. (defmacro with-answer (query &body body) 
  55.   (let ((vars (vars-in query)))    
  56. `(mapcar #'(lambda (binds)
  57.                  (apply #'(lambda ,vars ,@body)
  58.                         binds)) ,(compile-query query vars)))) 
  59.  
  60. (defun vars-in (expr)
  61.   (labels ((rec-vars (expr)
  62.              (cond ((null expr) nil)
  63.                    ((consp expr)
  64.                     (mapcan #'rec-vars expr))
  65.                    (t (if (var? expr) (list expr))))))
  66.     (remove-duplicates (rec-vars expr))))
  67.  
  68. ---------------------------------------------------
  69.  
  70.  
  71. Query Compiler.
  72.  
  73.  
  74. (defun compile-query (expr vars)
  75.   `(mapcan #'(lambda (binds)
  76.                ,(query-code expr vars))
  77.            '(,vars)))
  78.  
  79. (defun query-code (expr vars)
  80.   (case (car expr)
  81.     (and  (compile-and (reverse (cdr expr)) vars))
  82.     (or   (compile-or (cdr expr) vars))
  83.     (not  (compile-not  (cadr expr) vars))
  84.     (lisp (compile-lisp (cadr expr) vars))
  85.     (t    (compile-simple (car expr) (cdr expr) vars))))
  86.  
  87. (defun compile-and (clauses vars)
  88.   (if (singleton clauses)
  89.       (query-code (car clauses) vars)
  90.       `(mapcan #'(lambda (binds)
  91.                    ,(query-code (car clauses) vars))
  92.                ,(compile-and (cdr clauses) vars))))
  93.  
  94. (defun compile-or (clauses vars)
  95.   `(delete-duplicates
  96.      (append ,@(mapcar #'(lambda (c)
  97.                            (query-code c vars))
  98.                        clauses))
  99.      :test #'equal))
  100.  
  101. (defun compile-not (clause vars)
  102.   `(if ,(query-code clause vars)
  103.        nil
  104.        (list binds)))
  105.  
  106.  
  107. (defun compile-lisp (expr vars)
  108.   `(apply #'(lambda ,vars
  109.               (if ,expr
  110.                   (list binds)))
  111.           binds))
  112.  
  113. (defun compile-simple (pred args vars)
  114.   `(apply #'(lambda ,vars
  115.          (mapcar #'(lambda (result)
  116.                (list ,@(mapcar #'(lambda (v)
  117.                              `(or (cadr (assoc ',v result))
  118.                                   ,v))
  119.                          vars)))
  120.            (lookup ',pred (list ,@args))))
  121.      binds))
  122.  
  123.                            ,v))
  124.