home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume1 / 8707 / 49 / browse.cl < prev    next >
Lisp/Scheme  |  1990-07-13  |  4KB  |  140 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         browse.cl
  3. ; Description:  The BROWSE benchmark from the Gabriel tests
  4. ; Author:       Richard Gabriel
  5. ; Created:      8-Apr-85
  6. ; Modified:     14-Jun-85 18:44:49 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; BROWSE -- Benchmark to create and browse through 
  13. ;;; an AI-like data base of units.
  14.  
  15. ;;; n is # of symbols
  16. ;;; m is maximum amount of stuff on the plist
  17. ;;; npats is the number of basic patterns on the unit
  18. ;;; ipats is the instantiated copies of the patterns
  19.  
  20. (defvar *rand* 21)
  21.  
  22. (defmacro char1 (x) `(schar (symbol-name ,x) 0))
  23.  
  24. (defun init (n m npats ipats)
  25.   (declare (fixnum n m npats))
  26.   (let ((ipats (copy-tree ipats)))
  27.     (do ((p ipats (cdr p)))
  28.     ((null (cdr p)) (rplacd p ipats)))    
  29.     (do ((n n (1- n))
  30.      (i m (cond ((= i 0) m)
  31.             (t (1- i))))
  32.      (name (gensym) (gensym))
  33.      (a nil))
  34.     ((= n 0) a)
  35.       (declare (fixnum n i))
  36.       (push name a)
  37.       (do ((i i (1- i)))
  38.       ((= i 0))
  39.     (declare (fixnum i))
  40.     (setf (get name (gensym)) nil))
  41.       (setf (get name 'pattern)
  42.         (do ((i npats (1- i))
  43.          (ipats ipats (cdr ipats))
  44.          (a ()))
  45.         ((= i 0) a)
  46.           (declare (fixnum i ipats))
  47.           (push (car ipats) a)))
  48.       (do ((j (- m i) (1- j)))
  49.       ((= j 0))
  50.     (declare (fixnum j))
  51.     (setf (get name (gensym)) nil)))))  
  52.  
  53. (defun browse-random ()
  54.   (setq *rand* (mod (* *rand* 17) 251)))
  55.  
  56. (defun randomize (l)
  57.   (do ((a ()))
  58.       ((null l) a)
  59.     (let ((n (mod (browse-random) (length l))))
  60.       (declare (fixnum n))
  61.       (cond ((= n 0)
  62.          (push (car l) a)
  63.          (setq l (cdr l)))
  64.         (t 
  65.          (do ((n n (1- n))
  66.           (x l (cdr x)))
  67.          ((= n 1)
  68.           (push (cadr x) a)
  69.           (rplacd x (cddr x)))
  70.          (declare (fixnum n))))))))
  71.  
  72. (defun match (pat dat alist)
  73.   (cond ((null pat)
  74.      (null dat))
  75.     ((null dat) ())
  76.     ((or (eq (car pat) '?)
  77.          (eq (car pat)
  78.          (car dat)))
  79.      (match (cdr pat) (cdr dat) alist))
  80.     ((eq (car pat) '*)
  81.      (or (match (cdr pat) dat alist)
  82.          (match (cdr pat) (cdr dat) alist)
  83.          (match pat (cdr dat) alist)))
  84.     (t (cond ((atom (car pat))
  85.           (cond ((eq (char1 (car pat)) #\?)
  86.              (let ((val (assoc (car pat) alist)))
  87.                (cond (val (match (cons (cdr val)
  88.                            (cdr pat))
  89.                          dat alist))
  90.                  (t (match (cdr pat)
  91.                        (cdr dat)
  92.                        (cons (cons (car pat)
  93.                                (car dat))
  94.                          alist))))))
  95.             ((eq (char1 (car pat)) #\*)
  96.              (let ((val (assoc (car pat) alist)))
  97.                (cond (val (match (append (cdr val)
  98.                              (cdr pat))
  99.                          dat alist))
  100.                  (t 
  101.                   (do ((l () (nconc l (cons (car d) nil)))
  102.                        (e (cons () dat) (cdr e))
  103.                        (d dat (cdr d)))
  104.                       ((null e) ())
  105.                     (cond ((match (cdr pat) d
  106.                           (cons (cons (car pat) l)
  107.                             alist))
  108.                        (return t))))))))))
  109.          (t (and 
  110.               (not (atom (car dat)))
  111.               (match (car pat)
  112.                  (car dat) alist)
  113.               (match (cdr pat)
  114.                  (cdr dat) alist)))))))
  115.  
  116. (defun browse ()
  117.   (investigate 
  118.     (randomize 
  119.       (init 100 10 4 '((a a a b b b b a a a a a b b a a a)
  120.                (a a b b b b a a
  121.             (a a)(b b))
  122.                (a a a b (b a) b a b a))))
  123.     '((*a ?b *b ?b a *a a *b *a)
  124.       (*a *b *b *a (*a) (*b))
  125.       (? ? * (b a) * ? ?))))
  126.  
  127. (defun investigate (units pats)
  128.   (do ((units units (cdr units)))
  129.       ((null units))
  130.     (do ((pats pats (cdr pats)))
  131.     ((null pats))
  132.       (do ((p (get (car units) 'pattern)
  133.           (cdr p)))
  134.       ((null p))
  135.     (match (car pats) (car p) ())))))
  136.  
  137. ;;; call: (browse)
  138.  
  139. (run-benchmark "Browse" '(browse))
  140.