;; $Id: ltk-ui.lisp,v 1.15 2006/01/06 13:30:39 jimka Exp $

#|

 This software is Copyright (c) 2005 Jim Newton <jimka@rdrop.com>

 Jim Newton grants you the rights to distribute
 and use this software as governed by the terms
 of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html),
 known as the LLGPL.
 
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.
 
|#


;; This packages makes use of the LTK package, however
;; it does not assume that the LTK symbols have been interned into
;; this package.  All LTK symbols are referenced with the LTK: prefix.

;; It is not required that the "ltk-ui.lisp" file be loaded to run
;; the LUNIT framework.  However, loading the file does destructively
;; add the LTK LUNIT GUI to the the test framework.

(defpackage "HEUTE-LTK-UI"
  (:use "HEUTE"
	"COMMON-LISP"))

(in-package heute-ltk-ui)

(defgeneric row-pitch (obj))
(defgeneric create-rectangle ( obj suite-level))
(defgeneric color-rectangle-per-status (obj status))
(defgeneric rect-width (obj))
(defgeneric row-height (obj))
(defgeneric verbose (obj))
(defgeneric canvas (obj))
(defgeneric row-spacing (obj))
(defgeneric tk-rectangle (obj))
(defgeneric x0 (obj))
(defgeneric y0 (obj))
(defgeneric x1 (obj))
(defgeneric y1 (obj))

(defclass uni-ltk ()
  (( canvas
     :documentation "The tk canvas object which we will create rectangles on."
     :accessor canvas
     :allocation :class
     :initform nil)
   ( verbose
     :documentation "Sets ltk:*debug-tk*."
     :accessor verbose
     :allocation :class
     :initform nil)
   ( row-height
     :documentation "Y-height of each row of rectangles."
     :accessor row-height
     :allocation :class
     :initform 25)
   ( rect-width
     :documentation "X-width of a particular rectangle"
     :accessor rect-width
     :initform 300)
   ( row-spacing
     :documentation "Y-gap between rows."
     :accessor row-spacing
     :allocation :class
     :initform 3)
   ( tk-rectangle
     :documentation "The tk rectangle corresponding to a test suite."
     :initform nil
     :accessor tk-rectangle)
   ( x0
     :documentation "Left X-edge of the rectangle."
     :initform 0.0
     :accessor x0)
   ( y0
     :documentation "Top Y-edge of the rectnagle."
     :initform 0.0
     :accessor y0)
   ( x1
     :documentation "Right X-edge of the rectangle."
     :accessor x1)
   ( y1
     :documentation "Bottom Y-edge of the rectangle."
     :accessor y1))
  (:documentation
   "Mixin class to control the LTK graphical interface for HEUTE"))


(defmethod row-pitch (( obj uni-ltk))
  "The pitch is the height + gap."
  (+ (row-height obj) (row-spacing obj)))

(defmethod create-rectangle (( obj uni-ltk) (suite-level (eql 0)))
  "The top-most rectangle is calculated with absolute coordinates."
  (setf (x1 obj) (+ (x0 obj) (rect-width obj))
	(y1 obj) (+ (y0 obj) (row-height obj))))

(defmethod create-rectangle (( obj uni-ltk) (suite-level number))
  "The non-top-most rectangles are calculated as a function of the
  rectangle belonging to the parent suite"
  (let (( parent (parent-suite obj)))
    (setf (rect-width obj) (/ (rect-width parent) (number-of-siblings obj))
	  (x0 obj) (+ (x0 parent) (* (sibling-index obj) (rect-width obj)))
	  (x1 obj) (+ (x0 obj) (rect-width obj))
	  
	  (y0 obj) (+ (y0 parent) (row-pitch obj))
	  (y1 obj) (+ (y1 parent) (row-pitch obj)))))

(defmethod color-rectangle-per-status (( obj (eql nil)) status)
  "color-rectangle-per-status is a recursive function in the case
  that tests fail.  This method terminates the recursion because
  eventually the PARENT-SUITE function will return nil so obj
  will match this."
  (declare (ignore obj status))

  nil)

(defmethod color-rectangle-per-status (( obj uni-ltk) (status (eql :pass)))
  "If the status is PASS then color the rectangle green."
  (declare (ignore status))
  (ltk:configure (tk-rectangle obj)
		 :fill :green))

(defmethod color-rectangle-per-status (( obj uni-ltk) (status (eql :fail)))
  "If the status is FAIL, then color this and all its parents back up
   to the root node red."
  (ltk:configure (tk-rectangle obj)
		 :fill :red)
  (color-rectangle-per-status (parent-suite obj) status))

(defmethod color-rectangle-per-status (( obj uni-ltk) status)
  "If the status is anything other than PASS or FAIL, then color
  the rectangle white."
  (declare (ignore status))
  (ltk:configure (tk-rectangle obj)
		 :fill :white))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interface to the HEUTE framework
;; The following are before and after methods
;; on the generic functions provided by the framework.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod run-suite :before (( obj uni-ltk))
  "If the tk-rectangle corresponding to this suite has not yet been created,
  then calculate its coordinates and draw it."
  (unless (tk-rectangle obj)
    (create-rectangle obj (suite-level obj))

    (setf (tk-rectangle obj)
	  (ltk:make-rectangle (canvas obj)
			      (x0 obj) (y0 obj) (x1 obj) (y1 obj)))

    (ltk:itembind (canvas obj) (tk-rectangle obj) 
		  "<Enter>"
		  (lambda (event)
		    (declare (ignore event))
		    (dolist (result (results obj))
		      (format t "~A ~A ~A: ~A~%"
			      (status result)
			      (test-fun result)
			      (tag result)
			      (text result))
		      (force-output))))
    (ltk:itembind (canvas obj) (tk-rectangle obj)
		  "<Button-1>"
		  (lambda (event)
		    (declare (ignore event))

		    (run-all-unit-tests obj)))

    )
  
  (ltk:configure (tk-rectangle obj)
		 :fill :yellow
		 :outline :black))

(defmethod run-suite :after (( obj uni-ltk))
  "Color the rectangle according to whether the suite passed or failed."
  (color-rectangle-per-status obj (status obj)))

(defmethod run-all-unit-tests :before (( obj uni-ltk))
  "Start the TK wish shell, and pack an empty canvas ok it."
  (setf ltk:*debug-tk* (verbose obj))
  (unless ltk:*wish*
    (ltk:start-wish)
    (ltk:wm-title ltk:*tk* "HEUTE")
    (let* (( sc (make-instance 'ltk:scrolled-canvas))
	   ( canvas (ltk:canvas sc)))
      (ltk:pack sc :expand 1 :fill :both)
      (setf (canvas obj) canvas))))

(defmethod run-all-unit-tests :after (( obj uni-ltk))
  (ltk:mainloop))

(setf ltk:*wish* nil)
(register-gui uni-ltk)