archie/tk4.2/tests/color.test
2024-05-27 16:40:40 +02:00

168 lines
4.5 KiB
Plaintext

# This file is a Tcl script to test out the procedures in the file
# tkColor.c. It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) color.test 1.5 96/02/16 10:56:05
if {[info procs test] != "test"} {
source defs
}
eval destroy [winfo children .]
wm geometry . {}
raise .
# cname --
# Returns a proper name for a color, given its intensities.
#
# Arguments:
# r, g, b - Intensities on a 0-255 scale.
proc cname {r g b} {
format #%02x%02x%02x $r $g $b
}
proc cname4 {r g b} {
format #%04x%04x%04x $r $g $b
}
# mkColors --
# Creates a canvas and fills it with a 2-D array of squares, each of a
# different color.
#
# Arguments:
# c - Name of canvas window to create.
# width - Number of squares in each row.
# height - Number of squares in each column.
# r, g, b - Initial value for red, green, and blue intensities.
# rx, gx, bx - Change in intensities between adjacent elements in row.
# ry, gy, by - Change in intensities between adjacent elements in column.
proc mkColors {c width height r g b rx gx bx ry gy by} {
catch {destroy $c}
canvas $c -width 400 -height 200 -bd 0
for {set y 0} {$y < $height} {incr y} {
for {set x 0} {$x < $width} {incr x} {
set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \
[expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]]
$c create rectangle [expr 10*$x] [expr 20*$y] \
[expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
-fill $color
}
}
}
# closest -
# Given intensities between 0 and 255, return the closest intensities
# that the server can provide.
#
# Arguments:
# w - Window in which to lookup color
# r, g, b - Desired intensities, between 0 and 255.
proc closest {w r g b} {
set vals [winfo rgb $w [cname $r $g $b]]
list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
[expr [lindex $vals 2]/256]
}
# c255 -
# Given a list of red, green, and blue intensities, scale them
# down to a 0-255 range.
#
# Arguments:
# vals - List of intensities.
proc c255 {vals} {
list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
[expr [lindex $vals 2]/256]
}
# colorsFree --
#
# Returns 1 if there appear to be free colormap entries in a window,
# 0 otherwise.
#
# Arguments:
# w - Name of window in which to check.
# red, green, blue - Intensities to use in a trial color allocation
# to see if there are colormap entries free.
proc colorsFree {w {red 31} {green 245} {blue 192}} {
set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
&& ([lindex $vals 2]/256 == $blue)
}
# Create a top-level with its own colormap (so we can test under
# controlled conditions), then check to make sure that the visual
# is color-mapped with 256 colors. If not, just skip this whole
# test file.
if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] {
return
}
wm geom .t +0+0
if {[winfo depth .t] != 8} {
destroy .t
return
}
mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
pack .t.c
update
if ![colorsFree .t.c 101 233 17] {
destroy .t
return
}
mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
pack .t.c2
if [colorsFree .t.c] {
destroy .t
return
}
destroy .t.c .t.c2
test color-1.1 {Tk_GetColor procedure} {
c255 [winfo rgb .t red]
} {255 0 0}
test color-1.2 {Tk_GetColor procedure} {
list [catch {winfo rgb .t noname} msg] $msg
} {1 {unknown color name "noname"}}
test color-1.3 {Tk_GetColor procedure} {
c255 [winfo rgb .t #123456]
} {18 52 86}
test color-1.4 {Tk_GetColor procedure} {
list [catch {winfo rgb .t #xyz} msg] $msg
} {1 {invalid color name "#xyz"}}
test color-2.1 {Tk_FreeColor procedure, reference counting} {
eval destroy [winfo child .t]
mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
pack .t.c
mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
pack .t.c2
update
set last [.t.c2 create rectangle 50 50 70 60 -outline {} \
-fill [cname 0 240 240]]
.t.c delete 1
set result [colorsFree .t]
.t.c2 delete $last
lappend result [colorsFree .t]
} {0 1}
test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} {
eval destroy [winfo child .t]
mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40
pack .t.c
mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0
pack .t.c2
update
closest .t 241 241 1
} {240 240 0}
destroy .t