Subversion Repositories or1k

# 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.

#

# RCS: @(#) $Id: color.test,v 1.1.1.1 2002-01-16 10:25:58 markom Exp $

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