';;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest 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.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(declare (unit gutils))
(module gutils
(iuplistbox-fill-list
message-window
gutils:colors-similar?
gutils:colors
gutils:get-color-for-state-status
)
(import (prefix iup iup:)
canvas-draw)
(import scheme
chicken.base
chicken.condition
chicken.string
chicken.pretty-print
chicken.sort
chicken.time
chicken.file
chicken.file.posix
chicken.process
chicken.process-context
chicken.process-context.posix)
(import srfi-1 regex regex-case srfi-69)
(define (iuplistbox-fill-list lb items #!key (selected-item #f))
(let ((i 1))
(for-each (lambda (item)
(iup:attribute-set! lb (number->string i) item)
(if selected-item
(if (equal? selected-item item)
(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
(set! i (+ i 1)))
items)
;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
i))
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
(iup:label msg #:margin "40x40")))))
;; NOTE: These functions will move to iuputils
(define (gutils:colors-similar? color1 color2)
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
(delta (map (lambda (a b)(abs (- a b))) c1 c2)))
(null? (filter (lambda (x)(> x 3)) delta))))
(define gutils:colors
'((PASS . "70 249 73")
(FAIL . "253 33 49")
(SKIP . "230 230 0")))
(define (gutils:get-color-spec effective-state)
(or (alist-ref effective-state gutils:colors)
(alist-ref 'FAIL gutils:colors)))
;; BBnote - state status dashboard button color / text defined here
(define (gutils:get-color-for-state-status state status);; #!key (get-label #f))
;; ((if get-label cadr car)
(case (string->symbol state)
((COMPLETED) ;; ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 249 73" status))
((PREQ_FAIL PREQ_DISCARDED) (list "255 127 127" status))
((WARN WAIVED) (list "255 172 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
((ABORT) (list "198 36 166" status))
(else (list "253 33 49" status))))
((ARCHIVED)
(case (string->symbol status)
((PASS) (list "70 170 73" status))
((WARN WAIVED) (list "200 130 13" status))
((SKIP) (list (gutils:get-color-spec 'SKIP) status))
(else (list "180 33 49" status))))
;; (if (equal? status "PASS")
;; '("70 249 73" "PASS")
;; (if (or (equal? status "WARN")
;; (equal? status "WAIVED"))
;; (list "255 172 13" status)
;; (list "223 33 49" status)))) ;; greenish orangeish redish
((LAUNCHED) (list "101 123 142" state))
((CHECK) (list "255 100 50" state))
((REMOTEHOSTSTART) (list "50 130 195" state))
((RUNNING STARTED) (list "9 131 232" state))
((KILLREQ) (list "39 82 206" state))
((KILLED) (list "234 101 17" state))
((NOT_STARTED) (case (string->symbol status)
((CHECK STARTED)(list (gutils:get-color-spec 'SKIP) state))
(else (list "240 240 240" state))))
;; for xor mode below
;;
((CLEAN)
(case (string->symbol status)
((CLEAN-FAIL CLEAN-CHECK CLEAN-ABORT) (list "200 130 13" status)) ;; orange requested for these
(else (list "60 235 63" status))))
((DIRTY-BETTER) (list "160 255 153" status))
((DIRTY-WORSE) (list "165 42 42" status))
((BOTH-BAD) (list "180 33 49" status))
(else (list
;; "192 192 192"
"222 222 221"
state))))
)