(require :mcclim)

(defpackage "TEST-GUI"
  (:use "CLIM-LISP" "CLIM"))

(in-package "TEST-GUI")

(defun random-render (width height callback)
  (declare (fixnum width height) (function callback))
  (dotimes (y height)
    (dotimes (x width)
      (sleep (random 0.000001))
      (funcall callback (vector (random 1.0) (random 1.0) (random 1.0)) x y))))

(defun render-scene (medium)
  (let* ((pixmap nil)
         (width 400)
         (height 300)
         (end (- width 1)))
    (unwind-protect
         (progn
           (setf pixmap (allocate-pixmap medium width height))
           (random-render width height
                          (lambda (color x y)
                            (declare (type simple-vector color)
                                     (type fixnum x y))
                            (draw-point* pixmap x y :ink (make-rgb-color (aref color 0) (aref color 1) (aref color 2)))
                            (when (= x end)
                              (copy-from-pixmap pixmap 0 y width 1 medium 0 y)))))
      (when pixmap
        (deallocate-pixmap pixmap)))))

(define-application-frame test-frame ()
  ()
  (:panes
   (canvas :application :display-time nil :height 400 :width 600)
   (repl :interactor))
  (:layouts
   (default (vertically (:width 600 :height 600)
              canvas
              (:fill repl)))))

(defmethod frame-standard-output ((frame test-frame))
  (find-pane-named frame 'repl))

(define-test-frame-command (com-quit :name t)
    ()
  (frame-exit *application-frame*))

(define-test-frame-command (com-clear-canvas :name t)
    ()
  (window-clear (find-pane-named *application-frame* 'canvas))
  (window-clear (find-pane-named *application-frame* 'repl)))

(define-test-frame-command (com-stress :name t)
    ()
  (dotimes (i 30)
    (render-scene (find-pane-named *application-frame* 'canvas))))

#+nil
(run-frame-top-level (make-application-frame 'test-frame))