home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 49 / traverse.cl < prev    next >
Encoding:
Text File  |  1990-07-13  |  3.5 KB  |  136 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         traverse.cl
  3. ; Description:  TRAVERSE benchmark
  4. ; Author:       Richard Gabriel
  5. ; Created:      12-Apr-85
  6. ; Modified:     12-Apr-85 10:24:04 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; TRAVERSE --  Benchmark which creates and traverses a tree structure.
  13.  
  14. (defstruct node
  15.   (parents nil)
  16.   (sons nil)
  17.   (sn (snb))
  18.   (entry1 nil)
  19.   (entry2 nil)
  20.   (entry3 nil)
  21.   (entry4 nil)
  22.   (entry5 nil)
  23.   (entry6 nil)
  24.   (mark nil))
  25.  
  26. (defvar *sn* 0)
  27. (defvar *rand* 21)
  28. (defvar *count* 0)
  29. (defvar *marker* nil)
  30. (defvar *root*)
  31.  
  32. (proclaim '(type fixnum *sn* *rand* *count*))
  33.  
  34. (defun snb ()
  35.   (setq *sn* (1+ *sn*)))
  36.  
  37. (defun seed ()
  38.   (setq *rand* 21))
  39.  
  40. (defun traverse-random () (setq *rand* (mod (* *rand* 17) 251)))
  41.  
  42. (defun traverse-remove (n q)
  43.   (cond ((eq (cdr (car q)) (car q))
  44.      (prog2 nil (caar q) (rplaca q nil)))
  45.     ((= n 0)
  46.      (prog2 nil (caar q)
  47.         (do ((p (car q) (cdr p)))
  48.             ((eq (cdr p) (car q))
  49.              (rplaca q
  50.                  (rplacd p (cdr (car q))))))))
  51.     (t (do ((n n (1- n))
  52.         (q (car q) (cdr q))
  53.         (p (cdr (car q)) (cdr p)))
  54.            ((= n 0) (prog2 nil (car q) (rplacd q p)))
  55.          (declare (fixnum n))))))
  56.  
  57. (defun traverse-select (n q)
  58.   (do ((n n (1- n))
  59.        (q (car q) (cdr q)))
  60.       ((= n 0) (car q))
  61.     (declare (fixnum n))))
  62.  
  63. (defun add (a q)
  64.   (cond ((null q)
  65.      `(,(let ((x `(,a)))
  66.           (rplacd x x) x)))
  67.     ((null (car q))
  68.      (let ((x `(,a)))
  69.        (rplacd x x)
  70.        (rplaca q x)))
  71.     (t (rplaca q
  72.            (rplacd (car q) `(,a .,(cdr (car q))))))))
  73.  
  74. (defun create-structure (n)
  75.   (declare (fixnum n))
  76.   (let ((a `(,(make-node))))
  77.     (do ((m (1- n) (1- m))
  78.      (p a))
  79.     ((= m 0) (setq a `(,(rplacd p a)))
  80.      (do ((unused a)
  81.           (used (add (traverse-remove 0 a) nil))
  82.           (x) (y))
  83.          ((null (car unused))
  84.           (find-root (traverse-select 0 used) n))
  85.        (setq x (traverse-remove (mod (traverse-random) n) unused))
  86.        (setq y (traverse-select (mod (traverse-random) n) used))
  87.        (add x used)
  88.        (setf (node-sons y) `(,x .,(node-sons y)))
  89.        (setf (node-parents x) `(,y .,(node-parents x))) ))
  90.       (declare (fixnum m))
  91.       (push (make-node) a))))
  92.  
  93. (defun find-root (node n)
  94.   (do ((n n (1- n)))
  95.       ((= n 0) node)
  96.     (declare (fixnum n))
  97.     (cond ((null (node-parents node))
  98.        (return node))
  99.       (t (setq node (car (node-parents node)))))))
  100.  
  101. (defun travers (node mark)
  102.   (cond ((eq (node-mark node) mark) nil)
  103.     (t (setf (node-mark node) mark)
  104.        (setq *count* (1+ *count*))
  105.        (setf (node-entry1 node) (not (node-entry1 node)))
  106.        (setf (node-entry2 node) (not (node-entry2 node)))
  107.        (setf (node-entry3 node) (not (node-entry3 node)))
  108.        (setf (node-entry4 node) (not (node-entry4 node)))
  109.        (setf (node-entry5 node) (not (node-entry5 node)))
  110.        (setf (node-entry6 node) (not (node-entry6 node)))
  111.        (do ((sons (node-sons node) (cdr sons)))
  112.            ((null sons) nil)
  113.          (travers (car sons) mark)))))
  114.  
  115. (defun traverse (root)
  116.   (let ((*count* 0))
  117.     (travers root (setq *marker* (not *marker*)))
  118.     *count*))
  119.  
  120. (defun init-traverse ()  ; Changed from defmacro to defun \bs
  121.   (setq *root* (create-structure 100))
  122.   nil)
  123.  
  124. (defun run-traverse ()  ; Changed from defmacro to defun \bs
  125.   (do ((i 50 (1- i)))
  126.       ((= i 0))
  127.     (declare (fixnum i))
  128.     (traverse *root*)
  129.     (traverse *root*)))
  130.  
  131. ;;; to initialize, call:  (init-traverse)
  132. ;;; to run traverse, call:  (run-traverse)
  133.  
  134. (run-benchmark "Traverse-init" '(init-traverse))
  135. (run-benchmark "Traverse" '(run-traverse))
  136.