;;;-*- Mode:LISP; Package:BENCH-TRAVERSEU; Base:8; Fonts:(CPTFONTB) -*-
;;; From the "Dick Gabriel" Benchmark Series.
;;; Enhancements (C) Copyright 1983, Lisp Machine, Inc.

;;;BEGIN
;;;TRAVERSE
;;; Benchmark to create once and traverse a Structure
;(declare  (fasload struct fas dsk (mac lsp)))

#+LMI
(EVAL-WHEN (EVAL COMPILE LOAD)
  (DEFCONST *TO-UCOMPILE* '(snb remove select add create-structure find-root
				   travers traverse random))
  (MAPC #'(LAMBDA (X)
	    (PUTPROP X T 'COMPILER:MICROCOMPILE)
	    (PUTPROP X
		     T			   ; ':DYNAMIC
		     ':DEPEND-ON-BEING-MICROCOMPILED))
	*TO-UCOMPILE*))

(defstruct node
	   (parents ())
	   (sons ())
	   (sn (snb))
	   (entry1 ())
	   (entry2 ())
	   (entry3 ())
	   (entry4 ())
	   (entry5 ())
	   (entry6 ())
	   (mark ()))

(declare (special sn))
(defun snb () (setq sn (the fixnum (1+ sn))))
(setq sn 0)

(defmacro mod (x n) `(remainder ,x ,n))

(declare (special rand)#-LISPM (FIXNUM rand))
(setq rand 21.)

(defun seed () (setq rand 21.))

(defun random () (setq rand (mod (* rand 17.) 251.)))

(defun remove (n q)
  (declare (fixnum n))
  (cond ((eq (cdr (car q)) (car q))
	 (prog2 () (caar q) (rplaca q ())))
	((= n 0)
	 (prog2 () (caar q)
		(do ((p (car q) (cdr p)))
		    ((eq (cdr p) (car q))
		     (rplaca q
			     (rplacd p (cdr (car q))))))))
	(t (do ((n n (the fixnum (1- n)))
		(q (car q) (cdr q))
		(p (cdr (car q)) (cdr p)))
	       ((= n 0) (prog2 () (car q) (rplacd q p)))))))

(defun select (n q)
  (declare (fixnum n))
  (do ((n n (the fixnum (1- n)))
       (q (car q) (cdr q)))
      ((= n 0) (car q))
    (declare (fixnum n))))

(defun add (a q)
  (cond ((null q)
	 `(,(let ((x `(,a)))
	      (rplacd x x) x)))
	((null (car q))
	 (let ((x `(,a)))
	   (rplacd x x)
	   (rplaca q x)))
	(t (rplaca q
		   (rplacd (car q) `(,a .,(cdr (car q))))))))

(defun create-structure (n)
  (declare (fixnum n))
  (let ((a `(,(make-node))))
    (do ((m (the fixnum (1- n)) (the fixnum (1- m)))
	 (p a))
	((= m 0) (setq a `(,(rplacd p a)))
	 (do ((unused a)
	      (used (add (remove 0 a) ()))
	      (x) (y))
	     ((null (car unused))
	      (find-root (select 0 used) n))
	   (setq x (remove (mod (random) n) unused))
	   (setq y (select (mod (random) n) used))
	   (add x used)
	   (setf (sons y) `(,x .,(sons y)))
	   (setf (parents x) `(,y .,(parents x))) ))
      (declare (fixnum m))
      (push (make-node) a))))

(defun find-root (node n)
  (declare (fixnum n))
  (do ((n n (the fixnum (1- n))))
      ((= n 0) node)
    (declare (fixnum n))
    (cond ((null (parents node))
	   (return node))
	  (t (setq node (car (parents node)))))))

(declare (special count marker))

(setq count 0 marker ())

(defun travers (node mark)
       (cond ((eq (mark node) mark) ())
	     (t (setf (mark node) mark)
		(setq count (the fixnum (1+ count)))
		(setf (entry1 node) (not (entry1 node)))
		(setf (entry2 node) (not (entry1 node)))
		(setf (entry3 node) (not (entry1 node)))
		(setf (entry4 node) (not (entry1 node)))
		(setf (entry5 node) (not (entry1 node)))
		(setf (entry6 node) (not (entry1 node)))
		(do ((sons (sons node) (cdr sons)))
		    ((null sons) ())
		    (travers (car sons) mark)))))
	


(defun traverse (root)
       (let ((count 0))
	    (travers root (setq marker (not marker)))
	    count))

#-LMI (include "timer.lsp")

#+LMI
(DEFUN LOAD-UCODE ()
  (lexpr-funcall #'COMPILER:MA-LOAD *TO-UCOMPILE*)
  (SETQ *UCODE-LOADED? T))

(declare (special root))

(timer init-timit
       (progn #+lmi (IF (not *ucode-loaded?) (print "ucode not loaded"))
	      (prog2 (setq root (create-structure 100.)) ())
	      ))

(timer timit
 (progn #+lmi (IF (not *ucode-loaded?) (print "ucode not loaded"))
	(do ((i 50. (the fixnum (1- i))))
	    ((= i 0))
	  (declare (fixnum i))
	  (traverse root)
	  (traverse root)
	  (traverse root)
	  (traverse root)
	  (traverse root))))
;;;END