#| -*- Mode: Lisp;
       Base: 10;
       Fonts: (FONTS:HL12B FONTS:TR12BI);
       Package: USER;
       Readtable: Common-Lisp; -*- |#

(in-package 'user)

#| COMPILED-P is a predicate that tests a function spec and returns t if
   the function is compiled.
   TIME-IT takes a form and evaluates it and returns the amount of elapsed
   time in microseconds. |#

(eval-when (compile eval load)
  (defmacro compiled-p (function-spec)
    `(typep ,function-spec 'compiled-function))
  (defun time-it (form)
    "evaluate form and return its value and the time it tool to evaluate."
    (let ((xtime (time:microsecond-time))
	  (otime (time:microsecond-time))
	  (values (multiple-value-list (eval form)))
	  (ntime (time:microsecond-time)))
      (values (- (+ ntime xtime) otime otime) values)))
  (defmacro next-multiple-of-x (x n &aux (m (gensym)))
    `(let ((,m ,n))
       (if (zerop (remainder ,m ,x)) (if (zerop ,m) ,x ,m)
	 (* (1+ (quotient ,m ,x)) ,x)))))

#|------------------------------------------------------
   B E N C H M A R K S
--------------------------------------------------------
  2.4 There are no non-default compiler features. Microcode optimizations 
      were not attempted although bottlenecks can easily be determined 
      with LMI supplied meter software.
  2.5 Same as 2.3 for each benchmark.
  2.6 Lisp Machines are tagged architecture machines.
      No type declarations need to be added.
  2.7 Compiled Run Time of Modified Code: No attempt has been
      made to optimize the supplied code.
  2.8
      Allocating an image in virtual memory will have little effect on run
      time performance of the benchmarks.
      Sections 2.1 - 2.7 were run after instantiating the image
      window into virtual memory.

      All of the above benchmarks were accomplished with the garbage
      collector turned on.
      The garbage collector actually speeds up the application by reducing
      the amount of paging.

  4. No non-standard features were used in computing these benchmarks.
     These benchmarks were accomplished using our 3.0 software release
     running with 6MB of memory.

  5. Running in interpreter mode, the factorial program produced a stack
     overflow condition.
     Resuming the program (with a larger stack size) from the debugger
     allowed the program to complete. The initial stack size of a process
     can be specified when the process is created.
      
-------------------------------------------------------|#

#|------------------------------------------------------
   B E N C H M A R K  #  1  --   S I E V E
--------------------------------------------------------

  2.1 Time to complete development: 5 minutes
  2.2 Interpreted run time from Supervisor: Not attempted.  
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

#|  The Zetalisp loop macro expands into a progn form to accomplish
     iteration. <While> is not a Zetalisp or Common-Lisp construct.     |#

(defun sieve (size &aux total (flags (make-array size :type 'art-1b)))
  (dotimes (count 10 total)
    (setq total 0)
    (dotimes (index size)
      (setf (aref flags index) 1))
    (dotimes (index size)
      (if (null (zerop (aref flags index)))
	  (progn	    
	    (incf total)
	    (loop
	      with inc = (+ index index 3)
	      for next from (+ index inc) to (1- size) by inc
	      (setf (aref flags next) 0)))))))

#|------------------------------------------------------
   B E N C H M A R K  #  2  --   M I X E D  S I E V E
--------------------------------------------------------
   The mixed sieve benchmark was not attempted on the LMI machine.
   Lisp Machines are designed for running Lisp efficiently. Our flexible bus
   centered architecture allows other processors that are more suitable
   for other languages to communicate with the Lisp processor at bus speed.
   LMI offers an optional UNIX processor on the NUBUS for running other 
   languages. Please contact LMI if you need an example of interprocessor
   communication.
-------------------------------------------------------|#

#|------------------------------------------------------
   B E N C H M A R K  #  3  --   D R A G O N
--------------------------------------------------------
  2.1 Time to complete development: 1 hour
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defflavor turtle (window angle x y) () :settable-instance-variables)

(defmethod (turtle new-position) (new-x new-y) (setq x new-x y new-y))

(defmethod (turtle left) (amount) (setq angle (- angle amount)))

(defmethod (turtle right) (amount) (setq angle (+ angle amount)))

(defmethod (turtle forward)
	    (amount
	     &aux (new-x (+ x (fix (* (cosd angle) amount))))
	     (new-y (+ y (fix (* (sind angle) amount)))))
  (send window :draw-line x y new-x new-y)
  (setq x new-x y new-y))	 

(defresource turtle-resource (window x y angle)
  :constructor (make-instance 'turtle)
	      :initializer
	      (progn (send object :set-x x) (send object :set-y y)
		      (send object :set-angle angle)
		      (send object :set-window window)))

(defflavor dragon-window (turtle) (tv:window) :settable-instance-variables)

(defmethod (dragon-window new-turtle) (window x y angle)
  (setq turtle (allocate-resource 'turtle-resource window x y angle)))

(defmethod (dragon-window close) () (funcall-self :deactivate))

(defmethod (dragon-window wait-for-user-input) () (funcall-self :tyi))

(defwindow-resource dragon-window-resource ()
  :make-window (dragon-window))

(defconst *image-window* (allocate-resource 'dragon-window-resource))

(defun dragon (size level &aux fred)
  (let* ((x 50) (y 50) (width 600) (height 600) (angle 0))
    (send *image-window* :set-edges x y (+ x width) (+ y height))
    (send *image-window* :expose)
    (setq fred (send *image-window* 'new-turtle *image-window*
		      (quotient width 2) (quotient height 2) angle))
				     ;(send fred 'new-position 300 300)
    (send *image-window* :clear-screen)
				  ; (send fred 'hide-turtle)
				  ; (send fred 'pen-down)
    (send *image-window* 'ldragon size level)
				  ;(send *image-window* 'wait-for-user-input)
    (send *image-window* 'close) 
    ))

(defmethod (dragon-window ldragon) (size level)
  (if (eq level 0)
      (send turtle 'forward size)
    (progn
      (funcall-self 'ldragon size (1- level))
      (send turtle 'left 90)
      (funcall-self 'rdragon size (1- level)))))

(defmethod (dragon-window rdragon) (size level)
  (if (eq level 0)
      (send turtle 'forward size)
    (progn
      (funcall-self 'ldragon size (1- level))
      (send turtle 'right 90)
      (funcall-self 'rdragon size (1- level)))))
#|------------------------------------------------------
   B E N C H M A R K  #  4  --   F A C T
--------------------------------------------------------
  2.1 Time to complete development: 1 minute
  2.2 Interpreted run time from Supervisor:
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#
(defun fact (n) (cond ((zerop n) 1) (t (* n (fact (1- n))))))
#|------------------------------------------------------
   B E N C H M A R K  #  5  --   M A K E _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 10 minutes
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor:
-------------------------------------------------------|#

(defconst image nil)

(defconst *bit-image* nil)

(defun make_image (size &aux end)
  (setq image (make-array `(,size ,size) :type 'art-8b)
	end (1- size))
  (dotimes (x size)
    (dotimes (y size)
      (setf (aref image x y) (random 256))))
  (dotimes (x size)
    (setf (aref image x 0) 0)
    (setf (aref image x end) 0)
    (setf (aref image 0 x) 0)
    (setf (aref image end x) 0)))

#|------------------------------------------------------
   B E N C H M A R K  #  6  --   S E N D _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 1 minute
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor:
-------------------------------------------------------|#

#| OPUS is the name of another host on the ethernet. |#

(defun send_image (&optional (path "opus:pierce;image"))
  (compiler:fasd-symbol-value path 'image))

#|------------------------------------------------------
   B E N C H M A R K  #  7  --   F E T C H _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 1 minute
  2.2 Interpreted run time from Supervisor:
  2.3 Compiled run time from Supervisor:
2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defun fetch_image (&optional (path "opus:pierce;image"))
  (load path))

#|------------------------------------------------------
   B E N C H M A R K  #  8  --   F I L T E R _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 2 minutes
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defun filter_image (&aux temp n y s w x e)
  (setq temp (make-array (array-dimensions image) :type 'art-16b))
  (dotimes (y_count (- (array-dimension image 0) 2))
    (setq n y_count
	  y (1+ y_count)
	  s (+ y_count 2))
    (dotimes (x_count (- (array-dimension image 1) 2))
      (setq w x_count
	    x (1+ x_count)
	    e (+ x_count 2))
      (setf (aref temp x y)
	    (quotient (- (* 8 (aref image x y)) (aref image w n)
			 (aref image w y) (aref image w s)
			 (aref image x n) (aref image x s)
			 (aref image e n) (aref image e y) (aref image e s))
		      8))))
  (setq image temp))

#| Threshold the image sepearately from displaying it so that
   SHOW_IMAGE only measures display time. |#
#|------------------------------------------------------
   B E N C H M A R K  #  9  --   T H R E S H O L D _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 5 minutes
  2.2 Interpreted run time from Supervisor: Not attempted.
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defun threshold_image ()
  "For every bit in image with a value > 127. assign a 1 to the
   corresponding bit in *bit-image*, otherwise assign a 0."
  (when image
    (if (null *bit-image*)
        (setq *bit-image* (make-array
			    (loop for d in (array-dimensions image)
				  collect (next-multiple-of-x 32 d))
			    :type 'art-1b)))
    (dotimes (x (array-dimension image 0))
      (dotimes (y (array-dimension image 1)) 
        (setf (aref *bit-image* x y)
	      (if (> (aref image x y) 127.) 1 0))))))

#|------------------------------------------------------
   B E N C H M A R K  #  10  --   S H O W _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 5 minutes
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defun show_image ()
  (let* ((x 50) (y 50) (width 600) (height 600))
    (send *image-window* :set-edges x y (+ x width) (+ y height))
    (send *image-window* :expose)
    (let* ((bit-array (send *image-window* :screen-array)))
      (tv:bitblt tv:alu-seta width height *bit-image* 0 0 bit-array 0 0))))


#|------------------------------------------------------
   B E N C H M A R K  #  11 --   H I D E _ I M A G E
--------------------------------------------------------
  2.1 Time to complete development: 1 minute
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defun hide_image () (send *image-window* :deexpose))
#|------------------------------------------------------
   B E N C H M A R K  #  12  --   S U P E R V I S O R
--------------------------------------------------------
  2.1 Time to complete development: 20 minutes
  2.2 Interpreted run time from Supervisor:  Not attempted.  
  2.3 Compiled run time from Supervisor: See attached screen dump.
-------------------------------------------------------|#

(defflavor supervisor-window (state menu-items)
	   (tv:inspect-history-window-with-margin-scrolling)
  (:default-init-plist
    :label (list nil nil nil nil fonts:hl12b "empty")
    :menu-items nil
    :blinker-p nil)
  (:documentation :combination "History Scroll Window.")
  :settable-instance-variables)

(defmethod (supervisor-window close) () (funcall-self :deactivate))

(defmethod (supervisor-window :clear-items) ()
  (funcall-self :pop-history (funcall-self :number-of-items)))  

(defmethod (supervisor-window :push-on-history) (data)
  (funcall-self :append-item data))

(defmethod (supervisor-window :pop-history) (&optional (n 1))
  (dotimes (x n)
    (funcall-self :delete-item (1- (funcall-self :number-of-items)))))

(defmethod (supervisor-window :next-state) ()
  (funcall-self :change-state (if (= state 7) 1 (1+ state))))

(defmethod (supervisor-window :change-state) (new-state)
  (setq state new-state)
  (case state
    (1
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :value (Make_image 1000)  :font FONTS:HL12B)
	     ("(Fetch_image)"  :value (Fetch_image) :font FONTS:HL12B)
	     ("(Filter_image)" :no-select "" :font FONTS:TR8I)
	     ("(Threshold_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Show_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Send_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Hide_image)"  :no-select "" :font FONTS:TR8I)		
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    (2	   
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :no-select "" :font FONTS:TR8I)
	     ("(Fetch_image)" :no-select "" :font FONTS:TR8I)
	     ("(Filter_image)" :value (Filter_image) :font FONTS:HL12B) 
	     ("(Threshold_image)" :value (Threshold_image) :font FONTS:HL12B) 
	     ("(Show_image)"  :no-select "" :font FONTS:TR8I)
	     ("(Send_image)"  :value (Send_image) :font FONTS:HL12B)
	     ("(Hide_image)"  :no-select "" :font FONTS:TR8I)		
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    (3	   	   
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :no-select "" :font FONTS:TR8I)
	     ("(Fetch_image)" :no-select "" :font FONTS:TR8I)
	     ("(Filter_image)" :no-select "" :font FONTS:TR8I)
	     ("(Threshold_image)" :value (Threshold_image) :font FONTS:HL12B)
	     ("(Show_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Send_image)" :value (Send_image) :font FONTS:HL12B)
	     ("(Hide_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    (4
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :no-select "" :font FONTS:TR8I)
	     ("(Fetch_image)"  :value (Fetch_image) :font FONTS:HL12B)
	     ("(Filter_image)" :no-select "" :font FONTS:TR8I)
	     ("(Threshold_image)" :no-select "" :font FONTS:TR8I)
	     ("(Show_image)" :no-select "" :font FONTS:TR8I)
	     ("(Send_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Hide_image)"  :no-select "" :font FONTS:TR8I)		
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    (5
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :no-select "" :font FONTS:TR8I)
	     ("(Fetch_image)" :no-select "" :font FONTS:TR8I)
	     ("(Filter_image)" :no-select "" :font FONTS:TR8I)
	     ("(Threshold_image)" :value (Threshold_image) :font FONTS:HL12B)
	     ("(Show_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Send_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Hide_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    (6
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :no-select "" :font FONTS:TR8I)
	     ("(Fetch_image)" :no-select "" :font FONTS:TR8I)		
	     ("(Filter_image)" :no-select "" :font FONTS:TR8I)
	     ("(Threshold_image)" :no-select "" :font FONTS:TR8I)
	     ("(Show_image)"  :value (Show_image) :font FONTS:HL12B) 
	     ("(Send_image)" :no-select "" :font FONTS:TR8I)
	     ("(Hide_image)" :no-select "" :font FONTS:TR8I)
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    (7
     (setq menu-items
	   '(("(Sieve 8191)" :value (Sieve 8191) :font FONTS:HL12B)
	     ("(Mixed_Sieve 8191)" :no-select "" :font FONTS:TR8I)
	     ("(Dragon 2 14)" :value (Dragon 2 14) :font FONTS:HL12B)
	     ("(Fact 1000)" :value (Fact 1000) :font FONTS:HL12B)
	     ("(Make_image 1000)" :value (Make_image) :font FONTS:HL12B)
	     ("(Fetch_image)"  :value (Fetch_image) :font FONTS:HL12B)
	     ("(Filter_image)" :no-select "" :font FONTS:TR8I)
	     ("(Threshold_image)" :no-select "" :font FONTS:TR8I)
	     ("(Show_image)"   :no-select "" :font FONTS:TR8I)
	     ("(Send_image)" :no-select "" :font FONTS:TR8I)
	     ("(Hide_image)" :value (Hide_image) :font FONTS:HL12B)
	     ("(Quit)" :value :quit :font FONTS:HL12B)
	     ("Clear History" :value :clear-history :font FONTS:HL12B)
	     ("Next State" :value :next-state :font FONTS:HL12B))))
    ))
	
(defwindow-resource supervisor-window-resource ()
  :make-window (supervisor-window))
	
(defconst *time* nil)
	
(defun supervisor ()
  (using-resource (w supervisor-window-resource)
    (let ((x 20) (y 200) (width 700) (height 500))
      (send w :set-edges x y (+ x width) (+ y height))      
      (send w :set-deexposed-typeout-action :permit)
      (send w :set-label '(:string "Notes" :top :centered :font FONTS:TR12BI))
      (send w :expose)
      (send w :change-state 1)
      (using-resource (menu tv:momentary-menu tv:mouse-sheet)
        (funcall menu :set-label "Select A Benchmark to Run")
	(loop
	  (funcall menu :set-item-list (send w :menu-items))
	  (tv:expose-window-near menu `(:window ,w))
	  as choice = (send menu :choose)
	  as choice-made = (send menu :last-item)	      
	  (funcall menu :set-item-list (send w :menu-items))
	  (case (if (consp choice) (car choice) choice)
	    (Make_image (send w :change-state 2))
	    (Filter_image (send w :change-state 3))	    		
	    (Send_image (send w :change-state 4))
	    (Fetch_image (send w :change-state 5))
	    (Threshold_image (send w :change-state 6))
	    (Show_image (send w :change-state 7))
	    (Hide_image (send w :change-state 1))
	    (:quit (if *image-window* (send *image-window* 'close))
		  (send w 'close))
	    (:clear-history (send w :clear-items))
	    (:next-state (send w :next-state)))
	  (if (consp choice)
	      (send w :push-on-history
		     (format nil "Evaluating ~A ~A"
			      choice
			      (if (compiled-p (symbol-function (car choice)))
				  "Compiled" "Interpreted"))))
	  (setq *time* (time-it choice))
	  (when (consp choice)
	    (send w :pop-history)
	    (let (microseconds seconds minutes)
	      (setq seconds (quotient *time* 1000000)
		    microseconds (remainder *time* 1000000)
		    minutes (quotient seconds 60)
		    seconds (remainder seconds 60))
	      (send w
		     :push-on-history
		     (format
		       nil
	    "~A ~D Minutes ~D Seconds ~D Microseconds Elapsed Time ~A"
		       choice
		       minutes
		       seconds
		       microseconds
		       (if (compiled-p (symbol-function (car choice)))
			   "Compiled" "Interpreted")))))
	  until (and choice-made (eq choice :quit)))))))