;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:ZL -*-

(defvar fff  'keithfont)
(defvar fffl "it:keith;keithfont")

(defun font-test-init()
  (load fffl))

(defun font-test(&aux l)
  (setq l (make-instance 'tv:lisp-listener))
  (send l :set-font-map (list fff))
  (send l :select)
  (send l :string-out "this is a test")
  (send l :fresh-line)
  (send l :string-out (make-string 10 :initial-element (int-char 130.)))
  )

(defun draw-special-string(string font &optional (sheet tv:selected-window))
  (let* ((inside-right (tv:sheet-inside-right sheet))
	 (margin-flag (not (zerop (tv:sheet-right-margin-character-flag sheet))))
	 (xpos (tv:sheet-cursor-x sheet))
	 (ypos (tv:sheet-cursor-y sheet))
	 (stop (array-active-length string)))
    (tv:prepare-sheet (sheet)
      (setf (tv:sheet-cursor-y sheet) ypos)	;%DRAW-STRING depends on this in some cases.
      (tv:%draw-string-2 sheet (send sheet :char-aluf)
		    xpos ypos string font 0 stop
		    (if margin-flag (- inside-right (tv:sheet-char-width sheet)) inside-right)))))

(defun test-draw(fcn string font &optional (sheet tv:selected-window))
  (let* ((inside-right (tv:sheet-inside-right sheet))
	 (margin-flag (not (zerop (tv:sheet-right-margin-character-flag sheet))))
	 (xpos (tv:sheet-cursor-x sheet))
	 (ypos (tv:sheet-cursor-y sheet))
	 (stop (array-active-length string)))
    (tv:prepare-sheet (sheet)
      (setf (tv:sheet-cursor-y sheet) ypos)	;%DRAW-STRING depends on this in some cases.
      (funcall fcn sheet (send sheet :char-aluf)
		    xpos ypos string font 0 stop
		    (if margin-flag (- inside-right (tv:sheet-char-width sheet)) inside-right)))))

(defun gc-flip-for-timing()
  (gc:flip :volatility 2 :reclaim-mode :batch))

(defun test-special-string(&key (size 10.) (char 130.)
			   (font fonts:keithfont) (sheet tv:selected-window)
			   &aux string)
  (setq string (or string (make-string size :initial-element char)))
  (let ((form1 `(progn (terpri) (test-draw #'tv:%draw-string   ,string ,font ,sheet)))
	(form2 `(progn (terpri) (test-draw #'tv:%draw-string-2 ,string ,font ,sheet)))
	time1 time2 time3 time4)
    (setq time1 (useful-timer form1))
    (setq time2 (tv:with-weird-character-handling (useful-timer form2)))
    (setq time3 (useful-timer form1))
    (setq time4 (useful-timer form2))
    (format t "~&*** Weird handling:  original mean = ~s , revised mean = ~s x[~5,2f] ."
	    time1 time2 (quotient time2 time1))
    (format t "~&*** Normal handling: original mean = ~s , revised mean = ~s x[~5,2f] ."
	    time3 time4 (quotient time3 time4))
    (values time1 time2 time3 time4))
  )

(defun list-mean(l)
  (let*((sum (apply #'plus l))
	(n (list-length l))
	(mean (quotient (float sum) (float n))))
    mean))

(defun useful-timer (form &key (iterations 1000.) &aux etime)
  "Evaluate FORM, returning the values it returns,
ITERATION times; prints and returns mean of microsecond time elapsed."
  (si:turn-on-microsecond-clock-if-present)
  (gc-flip-for-timing)
  (prog (tstack mean)
	(dotimes (i iterations)
	  (let ((xtime (time:microsecond-time))
		(otime (time:microsecond-time))
		(ignore (eval form))
		(ntime (time:microsecond-time)))
	    (setq etime (- (+ ntime xtime) otime otime))
	    (push etime tstack)))
	(setq mean (list-mean tstack))
	(gc-flip-for-timing)
	(format t "~2%Mean time over ~s iterations: ~s microseconds."
		iterations mean)
	(return mean)))