(in-package "CL-USER")

(defparameter *race-title* "International Lisp Conference 2003 - Programming Contest")

(defparameter *debug-scale-factor* 1)   ; set this to 1 to occupy most of screen

(defparameter *worthies*
  '(("Nils"   :red   490    95     66)
    ("Russ"   :blue  366    23    172))) 

(defvar *race-started* nil)

(defun race ()
  (setf *race-started* nil)
  (let* ((screen (capi:convert-to-screen))
         (screen-width (capi:screen-width screen))
         (screen-height (capi:screen-height screen))
         (best-width (floor (* 9/10 screen-width *debug-scale-factor*)))
         (best-height (floor (* 9/10 screen-height *debug-scale-factor*)))
         (output-pane (make-instance 'capi:output-pane
                                     :name :race                              ; debugging aid
                                     :display-callback 'redisplay-race
                                     :input-model `(((:button-1 :release) start-race))
                                     ;; Prevent resizing as it doesn't make sense
                                     :visible-min-width best-width
                                     :visible-max-width best-width
                                     :visible-min-height best-height
                                     :visible-max-height best-height)))
    (capi:contain output-pane :title *race-title*)
    (let* ((mapped-width (gp:port-width output-pane))
           (mapped-height (gp:port-height output-pane))
           (pixmap (gp:create-pixmap-port output-pane 
                                          (floor (* 9/10 mapped-width))
                                          (floor (* 9/10 mapped-height))
                                          :clear t :background :white)))
      (setf (capi:capi-object-property output-pane 'pixmap) pixmap))
    (start-timer output-pane)
    output-pane))

(defun start-race (&rest ignore)
  (declare (ignore ignore))
  (setf *race-started* t))

(defmacro with-racemap ((port-var pane) &body body)
  `(when-let (,port-var (capi:capi-object-property ,pane 'pixmap))
     ,@body))

(defun redisplay-race (pane x y width height)
  (with-racemap (port pane)
    (gp:pixblt pane boole-1 port
               x y
               width height
               x y)))

(defparameter *maximum-plausible-run* 1000) ; seconds

(defparameter *time-scale* 50) ; ratio of demo time to actual time 

(defun start-timer (pane)
  (mp:process-run-function
   "Timer" ()
   (lambda ()
     (do-timer pane))))

(defun do-timer (pane)
  (with-racemap (port pane)
    (let* ((port-width (gp:port-width port))
           (port-height (gp:port-height port))
           (font (gp:find-best-font port (gp:make-font-description :size (floor port-height 10)))))
      (multiple-value-bind (max-left max-above max-right max-below)
          (gp:get-string-extent port "000.000" font)
        (let* ((string-width (+ max-left max-right))
               (string-x (- port-width string-width))
               (string-y (- port-height max-below))
               (start-time (get-internal-real-time))
               (max-time (1- (* *maximum-plausible-run* internal-time-units-per-second)))
               previous-string
               (done 0)
               (worthy-count (length *worthies*)))
          (loop (let* ((time (/ (min max-time
                                     (- (get-internal-real-time) start-time))
                                *time-scale*))
                       (string (format nil "~7,3,,,'0f" (/ time internal-time-units-per-second)))
                       (mismatch (mismatch string previous-string))
                       (position (and previous-string mismatch))
                       (string-x (if position
                                     (multiple-value-bind (string-left ignore string-right)
                                         (gp:get-string-extent port (subseq string 0 position) font)
                                       (declare (ignore ignore))
                                       (+ string-x string-left string-right))
                                   string-x)))
                  (when (and (zerop done)
                             (or mismatch (not previous-string)))
                    (when previous-string
                      (send-undraw-string port pane 
                                          (subseq previous-string (or position 0))
                                          string-x string-y font))
                    (send-draw-string port pane
                                      (subseq string (or position 0))
                                      string-x string-y font))
                  (unless previous-string
                    (count-down pane font port-width (+ string-y max-above))
                    (setf start-time (get-internal-real-time)))
                  (setf done (display-progress pane time))
                  (when (= done worthy-count)
                    (return-from do-timer))
                  (sleep 0.01)
                  (setf previous-string string))))))))

(defun count-down (pane name-font invalid-width invalid-height)
  (let ((done nil))
    (mp:process-run-function
     "Count down" ()
     (lambda ()
       (display-grid pane name-font 2)
       (mp:process-wait "Awaiting start" (lambda () *race-started*))
       (with-racemap (port pane)
         (gp:clear-rectangle pane 0 0 invalid-width invalid-height)
         (gp:clear-rectangle port 0 0 invalid-width invalid-height)
         (let* ((centre-x (floor (gp:port-width port) 2))
                (centre-y (floor (gp:port-height port) 2))
                (font (gp:find-best-font port (gp:make-font-description :size (floor (* (min centre-x centre-y) 9/10))))))
           (dotimes (i 5)
             (let* ((char (code-char (- #.(char-code #\5)
                                        i)))
                    (string (string char)))
               (multiple-value-bind (left above right below)
                   (gp:get-string-extent port string font)
                 (let* ((real-width (+ left right))
                        (real-height (+ above below))
                        (char-x (- centre-x (floor real-width 2)))
                        (char-y (- centre-y (floor real-height 2))))
                   (send-draw-string port pane string char-x char-y font)
                   (sleep 1)
                   (send-undraw-string port pane string char-x char-y font)))))))
       (setf done t)))
    (mp:process-wait "Counting down" (lambda () done))
    (display-grid pane name-font)))

(defun send-draw-string (port pane string x y font)
  (let ((interface (capi:element-interface pane)))
    (capi:execute-with-interface
     interface
     (lambda ()
       (multiple-value-bind (left above right below)
           (gp:get-string-extent port string font)
         (gp:with-graphics-state (port :foreground :black
                                       :font font)
           (gp:draw-string port string x y))
         (gp:invalidate-rectangle pane
                                  (+ x left)
                                  (+ y above)
                                  right
                                  (- below above)))))))

(defun send-undraw-string (port pane string x y font)
  (let ((interface (capi:element-interface pane)))
    (capi:execute-with-interface
     interface
     (lambda ()
       (multiple-value-bind (left above right below)
           (gp:get-string-extent port string font)
         (setf x (+ x left -2)
               y (+ y above -2))
         (let ((width (+ right 4))
               (height (+ (- below above) 4)))
           (gp:clear-rectangle port
                               x y width height)
           (gp:invalidate-rectangle pane
                                    x y width height)))))))

(defmacro with-frame ((x-var y-var width-var height-var) port &body body)
  (let ((port-var (gensym "port"))
        (port-width-var (gensym "port-width"))
        (port-height-var (gensym "port-height")))
    `(let* ((,port-var ,port)
            (,port-width-var (gp:port-width ,port-var))
            (,port-height-var (gp:port-height ,port-var))
            (,x-var (round ,port-width-var 10))
            (,y-var (round ,port-height-var 10))
            (,width-var (* ,x-var 9))
            (,height-var (* ,y-var 7)))
       ,@body)))

(defun display-grid (pane font &optional time)
  (with-racemap (port pane)
    (with-frame (top left width height) port
      (let* ((right (+ left width))
             (bottom (+ top height))
             (mark-1 (floor (+ left (* width 3/10))))
             (mark-2 (floor (+ left (* width 6/10))))
             (mark-3 right)
             (number (length *worthies*))
             (port-height (gp:port-height port))
             (small-font-height (floor port-height 20))
             (small-font (gp:find-best-font port (gp:make-font-description :size small-font-height))))
        (gp:with-graphics-state (port :dashed t :foreground :black)
          (loop for x in (list mark-1 mark-2 mark-3)
                as name in '("Compile" "Load" "Run")
                do
                (multiple-value-bind (left above right below)
                    (gp:get-string-extent port name small-font)
                  (declare (ignore left))
                  (let ((vertical-boost (round (- below above) 5)))
                    (incf small-font-height vertical-boost)
                    (gp:draw-string port name 
                                    (- x (round right))
                                    (- top vertical-boost)
                                    :font small-font)))
                (gp:draw-line port x top x bottom)))
        (loop for (name colour) in *worthies*
              as y from (floor (+ top (/ height 2 number))) by (/ height number)
              do
              (gp:with-graphics-state (port :foreground colour
                                            :font font)
                (gp:draw-string port name left y)))
        (gp:invalidate-rectangle pane 0 0 (gp:port-width pane) (gp:port-height pane)))))
  (when time
    (display-progress pane time)))

(defun display-progress (pane time)
  (with-racemap (port pane)
    (with-frame (top left width height) port
      (let* ((width-1 (floor (* width 3/10)))
             (width-2 (- (floor (* width 6/10)) width-1))
             (width-3 (- width width-1 width-2))
             (number (length *worthies*))
             (done 0))
        (loop for (nil colour time-1 time-2 time-3) in *worthies*
              as y from (floor (+ top (/ height 3/2 number))) by (floor height number)
              do
              (incf time-2 time-1)
              (incf time-3 time-2)
              (let ((right (round
                            (+ left
                               (cond 
                                ((< time time-1)                    (* width-1 (/ time            time-1)))
                                ((< time time-2) (+ width-1         (* width-2 (/ (- time time-1) (- time-2 time-1)))))
                                ((< time time-3) (+ width-1 width-2 (* width-3 (/ (- time time-2) (- time-3 time-2)))))
                                (t width))))))
                (without-preemption
                 (gp:draw-line port left y right y :thickness 20 :foreground colour)
                 ;; get flicker from invalidate-rectangle
                 (gp:draw-line pane left y right y :thickness 20 :foreground colour))
                (when (>= time time-3)
                  (incf done))))
        done))))

;; $Id: //info.ravenbrook.com/user/ndl/lisp/contest/entries/timings/race.lisp#4 $