Test-Picture Generator
JMeh 13 Jul 2017 - Test-Picture Generator
The test picture generator helps calibrating old CRT monitors and is a nice example using the canvas widget. It displays a full sized window on the main screen and shows up a little menu by pressing the left button.
PO 2017/07/30 - Test-Image Generator is a slightly modified version of the Test-Picture Generator. Instead of displaying the test-picture on the screen, it is saved into an image file.
Here are some screenshots:
And here is the source:
#!/bin/sh
#\
exec wish "$0"
wm withdraw .
set Pattern {}
set ForeColor white
set BackColor black
set DrawPos(x) 0
set DrawPos(y) 0
set PenSize 1
set Font {Arial -13}
set SenderKennung "Farb-Testbild Generator - J.Mehring 1.2"
proc hsv2rgb { hue sat value } {
set v $value
if {$sat == 0} {
set v [format %04X [expr $v * 65535]]
return "#$v$v$v"
} else {
set hue [expr $hue * 6.0]
if {$hue >= 6.0} {
set hue 0.0
}
scan $hue. %d i
set f [expr $hue - $i]
set p [expr $value * (1 - $sat)]
set q [expr $value * (1 - ($sat * $f))]
set t [expr $value * (1 - ($sat * (1 - $f)))]
switch -exact $i {
0 { set r $v; set g $t; set b $p }
1 { set r $q; set g $v; set b $p }
2 { set r $p; set g $v; set b $t }
3 { set r $p; set g $q; set b $v }
4 { set r $t; set g $p; set b $v }
5 { set r $v; set g $p; set b $q }
default {
error "hsv2rgb: i value $i is out of range"
}
}
set r [format %04X [expr int($r * 65535)]]
set g [format %04X [expr int($g * 65535)]]
set b [format %04X [expr int($b * 65535)]]
return "#$r$g$b"
}
}
proc transform { x a1 a2 b1 b2 } {
expr ((double($x) - double($a1)) / (double($a2) - double($a1))) * \
(double($b2) - double($b1)) + double($b1)
}
proc Transform { x a1 a2 b1 b2 } {
expr round(((double($x) - double($a1)) / (double($a2) - double($a1))) * \
(double($b2) - double($b1)) + double($b1))
}
proc XPos { p } {
upvar prc rc
expr round($p * ($rc(right) - $rc(left)) + $rc(left))
}
proc XPos1 { p } {
upvar prc rc
expr round($p * ($rc(right) - $rc(left)) + $rc(left)) +1
}
proc YPos { p } {
upvar prc rc
expr round($p * ($rc(bottom) - $rc(top)) + $rc(top))
}
proc YPos1 { p } {
upvar prc rc
expr round($p * ($rc(bottom) - $rc(top)) + $rc(top)) +1
}
proc SetRect { v_rc x0 y0 x1 y1 } {
upvar $v_rc rc
set rc(top) $y0
set rc(left) $x0
set rc(bottom) $y1
set rc(right) $x1
}
proc GetFontInfo { v_finfo } {
upvar $v_finfo finfo
global Font
set finfo(ascent) [font metrics $Font -ascent]
set finfo(descent) [font metrics $Font -descent]
set finfo(linespace) [font metrics $Font -linespace]
}
proc StringWidth { str } {
global Font
return [font measure $Font $str]
}
proc TextFont { which } {
global Font
set Font $which
}
proc DrawString { str {anchor w} } {
global DrawPos Font ForeColor cv
$cv create text $DrawPos(x) $DrawPos(y) -font $Font -fill $ForeColor \
-anchor $anchor -text $str
}
proc SetPenSize { width } {
global PenSize
set PenSize $width
}
proc FillRect { v_rc } {
upvar $v_rc rc
global Pattern ForeColor cv
if {$Pattern != {}} {
$cv create rect $rc(left) $rc(top) $rc(right) $rc(bottom) \
-fill $ForeColor -stipple $Pattern -width 0
} else {
$cv create rect $rc(left) $rc(top) $rc(right) $rc(bottom) \
-fill $ForeColor -width 0
}
}
proc ClearPoly3 { x0 y0 x1 y1 x2 y2 } {
global BackColor cv
$cv create poly $x0 $y0 $x1 $y1 $x2 $y2 -fill $BackColor -width 0
}
proc FrameRect { v_rc } {
upvar $v_rc rc
MoveTo $rc(left) $rc(top)
LineTo $rc(right) $rc(top)
LineTo $rc(right) $rc(bottom)
LineTo $rc(left) $rc(bottom)
LineTo $rc(left) $rc(top)
}
proc EraseRect { v_rc } {
upvar $v_rc rc
global Pattern BackColor cv
$cv create rect $rc(left) $rc(top) $rc(right) $rc(bottom) -fill $BackColor
}
proc FrameCircle { v_rc } {
upvar $v_rc rc
global Pattern ForeColor PenSize cv
$cv create oval $rc(left) $rc(top) $rc(right) $rc(bottom) \
-outline $ForeColor -width $PenSize
}
proc MoveTo { x0 y0 } {
global DrawPos
set DrawPos(x) $x0
set DrawPos(y) $y0
}
proc LineTo { x1 y1 } {
global DrawPos ForeColor PenSize cv
$cv create line $DrawPos(x) $DrawPos(y) $x1 $y1 \
-fill $ForeColor -width $PenSize
set DrawPos(x) $x1
set DrawPos(y) $y1
}
proc RGBForeColor { color } {
global ForeColor
set ForeColor $color
}
proc RGBBackColor { color } {
global BackColor
set BackColor $color
}
proc PenPattern { id } {
global Pattern
set Pattern $id
}
proc Color { which } {
switch $which {
gray { return #C000C000C000 }
yellow { return #FF00EA000000 }
cyan { return #0000A400DE00 }
green { return #0000FFFF0000 }
magenta { return #CE0000006800 }
red { return #FFFF00000000 }
blue { return #00000000FFFF }
black { return #000000000000 }
white_25 { return #400040004000 }
white_50 { return #800080008000 }
white_75 { return #C000C000C000 }
white { return #FFFFFFFFFFFF }
}
}
proc Draw4Rects { x0 x1 x2 x3 y0 y1 y2 y3 } {
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
SetRect rc $x2 $y0 $x3 $y1
FillRect rc
SetRect rc $x0 $y2 $x1 $y3
FillRect rc
SetRect rc $x2 $y2 $x3 $y3
FillRect rc
}
###############################################################################
proc DrawBalken { v_prc } {
upvar $v_prc prc
array set rc [array get prc]
set x1 [XPos 0]
set pos 0.125
foreach color {gray yellow cyan green magenta red blue black} {
set x0 $x1
set x1 [XPos $pos]
set rc(left) $x0
set rc(right) $x1
RGBForeColor [Color $color]
FillRect rc
set pos [expr $pos + 0.125]
}
}
###############################################################################
proc DrawFuBK { v_prc } {
upvar $v_prc prc
global SenderKennung
# Hintergrundfarbe schwarz
RGBBackColor [Color black]
RGBForeColor [Color black]
FillRect prc
# 14 horizontale Linien
RGBForeColor [Color white]
array set rc [array get prc]
set pos 0.033333333
for {set idx 0} {$idx < 15} {incr idx} {
set y0 [YPos $pos]
MoveTo $rc(left) $y0
LineTo $rc(right) $y0
set pos [expr $pos + 0.066666666]
}
# 18 verticale Linien
RGBForeColor [Color white]
array set rc [array get prc]
set pos 0.026315789
for {set idx 0} {$idx < 19} {incr idx} {
set x0 [XPos $pos]
MoveTo $x0 $rc(top)
LineTo $x0 $rc(bottom)
set pos [expr $pos + 0.052631578]
}
# die inneren 12x3 Kästchen ausblenden
RGBForeColor [Color black]
SetRect rc [XPos1 0.1842105263] [YPos1 0.1666666667] \
[XPos1 0.8157894737] [YPos1 0.8333333333]
FillRect rc
# 8 Farbbalken in die oberen 12x3 Kästchen
set rc(top) [YPos1 0.1666666667]
set rc(bottom) [YPos 0.3666666667]
set x1 [XPos 0.1842105263]
set pos 0.263157894
foreach color {gray yellow cyan green magenta red blue black} {
set x0 $x1
set x1 [XPos $pos]
set rc(left) $x0
set rc(right) $x1
RGBForeColor [Color $color]
FillRect rc
set pos [expr $pos + 0.078947368]
}
# 5 Graustufen in die darunter liegenden 12x2 Kästchen
set rc(top) [YPos1 0.3666666667]
set rc(bottom) [YPos 0.5]
set x1 [XPos 0.1842105263]
set pos 0.310526315
foreach color {black white_25 white_50 white_75 white} {
set x0 $x1
set x1 [XPos $pos]
set rc(left) $x0
set rc(right) $x1
RGBForeColor [Color $color]
FillRect rc
set pos [expr $pos + 0.126315789]
}
# die "Senderkennung" umrahmt von 2 Weißkästchen in die Zeile darunter
RGBForeColor [Color black]
SetRect rc [XPos 0.1842105263] [YPos 0.5] \
[XPos 0.2894736840] [YPos 0.5526315789]
FillRect rc
RGBForeColor [Color white]
SetRect rc [XPos 0.1842105263] [YPos 0.5] \
[XPos 0.2894736842] [YPos 0.5666666667]
FillRect rc
SetRect rc [XPos 0.7105263158] [YPos 0.5] \
[XPos 0.8157894737] [YPos 0.5666666667]
FillRect rc
# Pattern in die nächste Zeile
set y0 [YPos 0.5666666667]
set y1 [YPos 0.6333333333]
RGBForeColor [Color white]
SetRect rc [XPos 0.1842105263] $y0 [XPos 0.2631578947] $y1
FillRect rc
SetRect rc [XPos 0.2631578947] $y0 [XPos 0.3815789474] $y1
PenPattern gray12
FillRect rc
SetRect rc [XPos 0.3815789474] $y0 [XPos 0.5000000000] $y1
PenPattern gray25
FillRect rc
SetRect rc [XPos 0.5000000000] $y0 [XPos 0.6184210530] $y1
PenPattern gray50
FillRect rc
SetRect rc [XPos 0.6184210530] $y0 [XPos 0.7631578947] $y1
PenPattern gray75
FillRect rc
PenPattern {}
RGBForeColor [Color white_50]
SetRect rc [XPos 0.7631578947] $y0 [XPos 0.8157894737] $y1
FillRect rc
# ein weißes Kreuz in die Mitte
RGBForeColor [Color white]
set x0 [XPos 0.5]
set y0 [YPos1 0.3666666667]
set y1 [YPos 0.6333333333]
SetPenSize 3
MoveTo $x0 $y0
LineTo $x0 $y1
set y0 [YPos 0.5]
set x0 [XPos 0.1842105263]
set x1 [XPos 0.8157894737]
MoveTo $x0 $y0
LineTo $x1 $y0
SetPenSize 1
# den Text der "Senderkennung" anzeigen
set len [XPos 0.3684210526]
TextFont "Arial -24 bold"
if {[StringWidth $SenderKennung] > $len} { TextFont "Arial -18 bold" }
if {[StringWidth $SenderKennung] > $len} { TextFont "Arial -14 bold" }
if {[StringWidth $SenderKennung] > $len} { TextFont "Arial -12 bold" }
if {[StringWidth $SenderKennung] > $len} { TextFont "Arial -10 bold" }
if {[StringWidth $SenderKennung] > $len} { TextFont "Arial -8 bold" }
set x0 [XPos 0.5]
set y0 [YPos 0.5333333333]
GetFontInfo fInfo
set len [StringWidth $SenderKennung]
SetRect rc \
[expr $x0 - $len / 2] \
[expr $y0 - $fInfo(ascent) / 2 -1] \
[expr $x0 + $len / 2] \
[expr $y0 + $fInfo(ascent) / 2 + $fInfo(descent) +1]
EraseRect rc
MoveTo [expr $x0 - $len / 2] [expr $y0 + $fInfo(ascent) / 2]
RGBForeColor [Color white]
DrawString $SenderKennung
# Weißbalken mit kurzem Schwarzimpuls in die nächste Zeile
RGBForeColor [Color white]
set y0 [YPos 0.6333333333]
set y1 [YPos 0.7]
SetRect rc [XPos 0.1842105263] $y0 [XPos 0.49] $y1
FillRect rc
SetRect rc [XPos 0.51] $y0 [XPos 0.8157894737] $y1
FillRect rc
# Graukeile
set x0 [XPos 0.1842105263]
set x1 [XPos 0.6052631579]
set y0 [YPos 0.7000000000]
set y1 [YPos 0.8333333333]
for {set x $x0} {$x <= $x1} {incr x} {
set color [format %04X [Transform $x $x0 $x1 0 65535]]
RGBForeColor #$color$color$color
MoveTo $x $y0
LineTo $x $y1
}
# RGB-Farbkeil
set x0 [XPos 0.6052631579]
set x1 [XPos 0.8157894737]
set y0 [YPos 0.7000000000]
set y1 [YPos 0.8333333333]
for {set x $x0} {$x <= $x1} {incr x} {
set hue [transform $x $x0 $x1 0 1]
set rgb [hsv2rgb $hue 1.0 0.9]
RGBForeColor $rgb
MoveTo $x $y0
LineTo $x $y1
}
# den inneren Rahmen neu zeichnen
RGBForeColor [Color white]
SetRect rc [XPos 0.1842105263] [YPos 0.1666666667] \
[XPos1 0.8157894737] [YPos1 0.8333333333]
FrameRect rc
# ein Kreis in die Mitte
RGBForeColor [Color white]
set x0 [XPos 0.5]
set y0 [YPos 0.5]
set r [YPos 0.45]
SetRect rc [expr $x0 - $r] [expr $y0 - $r] [expr $x0 + $r] [expr $y0 + $r]
SetPenSize 2
FrameCircle rc
SetPenSize 1
# vier Kreise für die Ecken
SetRect rc [XPos 0.028947368] [YPos 0.036666667] \
[XPos 0.181578947] [YPos 0.230000000]
FrameCircle rc
SetRect rc [XPos 0.818421052] [YPos 0.036666667] \
[XPos 0.971052631] [YPos 0.230000000]
FrameCircle rc
SetRect rc [XPos 0.028947368] [YPos 0.770000000] \
[XPos 0.181578947] [YPos 0.963333333]
FrameCircle rc
SetRect rc [XPos 0.818421052] [YPos 0.770000000] \
[XPos 0.971052631] [YPos 0.963333333]
FrameCircle rc
}
proc DrawCt { v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color black]
# schwarzer Hintergrund
RGBForeColor [Color black]
FillRect prc
# weißer Rahmen
array set rc [array get prc]
RGBForeColor [Color white]
FrameRect rc
# weiße horizontale Linien
set pos 0.0625
for {set idx 0} {$idx < 16} {incr idx} {
set x0 [XPos $pos]
MoveTo $x0 [expr $prc(top) +2]
LineTo $x0 [expr $prc(bottom) -3]
set pos [expr $pos + 0.0625]
}
# weiße vertikale Linien
set pos 0.0833333333
for {set idx 0} {$idx < 16} {incr idx} {
set y0 [YPos $pos]
MoveTo [expr $prc(left) +2] $y0
LineTo [expr $prc(right) -3] $y0
set pos [expr $pos + 0.0833333333]
}
# weiße Balken (n x 24) an die Ränder
set y0 [expr $prc(top) +2]
set y1 [expr $y0 +24]
set y3 [expr $prc(bottom) -2]
set y2 [expr $y3 -24]
set x0 [XPos 0.1250]
set x1 [XPos 0.3125]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
SetRect rc $x0 $y2 $x1 $y3
FillRect rc
set x0 [XPos 0.4375]
set x1 [XPos 0.5625]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
SetRect rc $x0 $y2 $x1 $y3
FillRect rc
set x0 [XPos 0.6875]
set x1 [XPos 0.8750]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
SetRect rc $x0 $y2 $x1 $y3
FillRect rc
set x0 [expr $prc(left) +2]
set x1 [expr $x0 +24]
set x3 [expr $prc(right) -2]
set x2 [expr $x3 - 24]
set y0 [YPos 0.1666666666]
set y1 [YPos 0.4166666666]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
SetRect rc $x2 $y0 $x3 $y1
FillRect rc
set y0 [YPos 0.5833333333]
set y1 [YPos 0.8333333333]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
SetRect rc $x2 $y0 $x3 $y1
FillRect rc
# einen dicken weißen Balken links
SetRect rc [expr $prc(left) +2 +24 +1] [YPos 0.4166666666] \
[XPos 0.21875] [YPos 0.5833333333]
FillRect rc
# vier kleine weiße Balken innen
set x0 [XPos 0.3125]
set x1 [XPos 0.34375]
set x2 [XPos 0.65625]
set x3 [XPos 0.6875]
set y0 [YPos 0.3333333333]
set y1 [YPos 0.375]
set y2 [YPos 0.625]
set y3 [YPos 0.6666666666]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
# verschiedene Pattern (24 x 24) in die Ecken
PenPattern gray12
set y0 [expr $prc(top) + 2]
set y1 [expr $y0 + 24]
set y3 [expr $prc(bottom) - 2]
set y2 [expr $y3 - 24]
set x0 [expr $prc(left) + 2]
set x1 [expr $x0 + 24]
set x3 [expr $prc(right) - 2]
set x2 [expr $x3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
PenPattern gray25
set x0 [expr $x1]
set x1 [expr $x0 + 24]
set x3 [expr $x2]
set x2 [expr $x3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
PenPattern gray50
set x0 [expr $x1]
set x1 [expr $x0 + 24]
set x3 [expr $x2]
set x2 [expr $x3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
PenPattern gray75
set x0 [expr $prc(left) + 2]
set x1 [expr $x0 + 24]
set x3 [expr $prc(right) - 2]
set x2 [expr $x3 - 24]
set y0 [expr $prc(top) + 2 + 24]
set y1 [expr $y0 + 24]
set y3 [expr $prc(bottom) - 2 - 24]
set y2 [expr $y3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
PenPattern {}
set y0 [expr $y1]
set y1 [expr $y0 + 24]
set y3 [expr $y2]
set y2 [expr $y3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
# farbige (R,G,B) Kästchen in die Ecken der Pattern
RGBForeColor [Color blue]
set x0 [expr $prc(left) + 2 + 25]
set x1 [expr $x0 + 24]
set x3 [expr $prc(right) - 2 - 25]
set x2 [expr $x3 - 24]
set y0 [expr $prc(top) + 2 + 25]
set y1 [expr $y0 + 24]
set y3 [expr $prc(bottom) - 2 - 25]
set y2 [expr $y3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
RGBForeColor [Color green]
set x0 [expr $x1]
set x1 [expr $x0 + 24]
set x3 [expr $x2]
set x2 [expr $x3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
RGBForeColor [Color red]
set x0 [expr $x0 - 24]
set x1 [expr $x1 - 24]
set x2 [expr $x2 + 24]
set x3 [expr $x3 + 24]
set y0 [expr $y1]
set y1 [expr $y0 + 24]
set y3 [expr $y2]
set y2 [expr $y3 - 24]
Draw4Rects $x0 $x1 $x2 $x3 $y0 $y1 $y2 $y3
# mit Pattern die inneren Felder umrahmen
RGBForeColor [Color white]
set x1 [XPos 0.25]
set y0 [YPos 0.25]
set y1 [YPos 0.3333333333]
set pos 0.3125
set pats {gray12 gray25 gray50 gray75 gray12 gray25 gray50 gray75}
for {set idx 0} {$idx < 8} {incr idx} {
# HexPenPat [expr $idx + 6]
PenPattern [lindex $pats $idx]
set x0 $x1
set x1 [XPos $pos]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
set pos [expr $pos + 0.0625]
}
set x0 [XPos 0.25]
set x1 [XPos 0.3125]
set x2 [XPos 0.6875]
set x3 [XPos 0.75]
set y1 [YPos 0.3333333333]
set pos 0.4166666666
set pats {gray12 gray12 gray25 gray25 gray50 gray50 gray75 gray75}
for {set idx 0} {$idx < 8} {incr idx 2} {
# HexPenPat [expr $idx + 14]
PenPattern [lindex $pats $idx]
set y0 $y1
set y1 [YPos $pos]
SetRect rc $x0 $y0 $x1 $y1
FillRect rc
# HexPenPat [expr $idx + 14 +1]
PenPattern [lindex $pats $idx]
SetRect rc $x2 $y0 $x3 $y1
FillRect rc
set pos [expr $pos + 0.0833333333]
}
PenPattern {}
# RGB-Farbkeil
set x0 [XPos 0.25]
set x1 [XPos 0.75]
set y0 [YPos 0.6666666666]
set y1 [YPos 0.75]
for {set x $x0} {$x <= $x1} {incr x} {
set hue [transform $x $x0 $x1 0 0.6666666667]
set rgb [hsv2rgb $hue 1.0 0.9]
RGBForeColor $rgb
MoveTo $x $y0
LineTo $x $y1
}
RGBForeColor [Color white]
# Strahlen, die von der Mitte ausgehen
set x0 [XPos 0.5]
set y0 [YPos 0.5]
set x1 [XPos 0.6875]
ClearPoly3 $x0 $y0 $x1 [YPos 0.416666666] $x1 [YPos 0.583333333]
set pos 0.416666666
while {$pos <= 0.583333333} {
MoveTo $x0 $y0
LineTo $x1 [YPos $pos]
set pos [expr $pos + 0.005555555]
}
set x1 [XPos 0.3125]
ClearPoly3 $x0 $y0 $x1 [YPos 0.416666666] $x1 [YPos 0.583333333]
set pos 0.416666666
while {$pos <= 0.583333333} {
MoveTo $x0 $y0
LineTo $x1 [YPos $pos]
set pos [expr $pos + 0.005555555]
}
set y1 [YPos 0.333333333]
ClearPoly3 $x0 $y0 [XPos 0.4375] $y1 [XPos 0.5625] $y1
set pos 0.4375
while {$pos <= 0.5625} {
MoveTo $x0 $y0
LineTo [XPos $pos] $y1
set pos [expr $pos + 0.004166666]
}
set y1 [YPos 0.666666666]
ClearPoly3 $x0 $y0 [XPos 0.4375] $y1 [XPos 0.5625] $y1
set pos 0.4375
while {$pos <= 0.5625} {
MoveTo $x0 $y0
LineTo [XPos $pos] $y1
set pos [expr $pos + 0.004166666]
}
# zwei Kreise in die Mitte
SetRect rc [XPos1 0.1875] [YPos1 0.0833333333] \
[XPos 0.8125] [YPos 0.9166666666]
FrameCircle rc
SetRect rc [XPos1 0.4375] [YPos1 0.4166666666] \
[XPos 0.5625] [YPos 0.5833333333]
FrameCircle rc
# einen Kreis in die jede Ecke
SetRect rc [XPos1 0.0625] [YPos1 0.0833333333] \
[XPos 0.1875] [YPos 0.2500000000]
FrameCircle rc
SetRect rc [XPos1 0.0625] [YPos1 0.7500000000] \
[XPos 0.1875] [YPos 0.9166666666]
FrameCircle rc
SetRect rc [XPos1 0.8125] [YPos1 0.0833333333] \
[XPos 0.9375] [YPos 0.2500000000]
FrameCircle rc
SetRect rc [XPos1 0.8125] [YPos1 0.7500000000] \
[XPos 0.9375] [YPos 0.9166666666]
FrameCircle rc
# farbige Kästchen in die Mitte
set y0 [YPos 0.3333333333]
set y1 [YPos 0.375]
set y2 [YPos 0.625]
set y3 [YPos 0.6666666666]
set x0 [XPos 0.375]
set x1 [XPos 0.4375]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color blue]
FillRect rc
SetRect rc $x0 $y2 $x1 $y3
RGBForeColor [Color cyan]
FillRect rc
set x0 $x1
set x1 [XPos 0.5]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color green]
FillRect rc
set x0 $x1
set x1 [XPos 0.5625]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color red]
FillRect rc
set x0 $x1
set x1 [XPos 0.625]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color yellow]
FillRect rc
SetRect rc $x0 $y2 $x1 $y3
RGBForeColor [Color magenta]
FillRect rc
}
proc DrawPattern { v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color white]
RGBForeColor [Color black]
EraseRect prc
# 2 Pattern (links und rechts)
array set rc [array get prc]
set rc(right) [XPos 0.5]
PenPattern gray25
FillRect rc
array set rc [array get prc]
set rc(left) [XPos 0.5]
PenPattern gray75
FillRect rc
PenPattern {}
}
proc DrawTestText { v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color white]
RGBForeColor [Color black]
EraseRect prc
# Text
RGBForeColor [Color black]
set testText [concat "Das ist ein Test-Text zur Bestimmung von " \
"Konvergenzfehlern mittels kleiner Schrift. "]
TextFont {Courier 8}
set l [StringWidth "D"]
set len [StringWidth $testText]
GetFontInfo fInfo
set x0 [expr $prc(left) - $l / 2]
set y0 [expr $prc(top) + $fInfo(ascent) / 2]
set h [expr $fInfo(ascent) + $fInfo(descent)]
while {$y0 < [expr $prc(bottom) + $h]} {
for {set x1 $x0} {$x1 < $prc(right)} {incr x1 $len} {
MoveTo $x1 $y0
DrawString $testText
}
incr x0 -$l
incr y0 $h
}
}
proc Draw100Pixel { v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color black]
# schwarzer Hintergrund
RGBForeColor [Color black]
FillRect prc
# weißer Rahmen
array set rc [array get prc]
RGBForeColor [Color white]
FrameRect rc
parray rc
RGBForeColor [Color white_25]
# dunkelgraue horizontale Linien alle 10 Pixel
for {set x 10} {$x < $rc(right)} {incr x 10} {
MoveTo $x [expr $prc(top) +2]
LineTo $x [expr $prc(bottom) -3]
}
# dunkelgraue vertikale Linien alle 10 Pixel
for {set y 10} {$y < $rc(bottom)} {incr y 10} {
MoveTo [expr $prc(left) +2] $y
LineTo [expr $prc(right) -3] $y
}
RGBForeColor [Color white_50]
# graue horizontale Linien alle 50+100 Pixel
for {set x 50} {$x < $rc(right)} {incr x 100} {
MoveTo $x [expr $prc(top) +2]
LineTo $x [expr $prc(bottom) -3]
}
# graue vertikale Linien alle 50+100 Pixel
for {set y 50} {$y < $rc(bottom)} {incr y 100} {
MoveTo [expr $prc(left) +2] $y
LineTo [expr $prc(right) -3] $y
}
RGBForeColor [Color white]
# weiße horizontale Linien alle 100 Pixel
for {set x 100} {$x < $rc(right)} {incr x 100} {
MoveTo $x [expr $prc(top) +2]
LineTo $x [expr $prc(bottom) -3]
}
# weiße vertikale Linien alle 100 Pixel
for {set y 100} {$y < $rc(bottom)} {incr y 100} {
MoveTo [expr $prc(left) +2] $y
LineTo [expr $prc(right) -3] $y
}
TextFont "Courier 18 bold"
set xm [XPos 0.5]
set ym [YPos 0.5]
MoveTo $xm $ym
set txt "$rc(right) x $rc(bottom) Pixel"
set l [StringWidth $txt]
SetRect crc [expr {$xm - $l / 2 - 25}] [expr {$ym - 25}] \
[expr {$xm + $l / 2 + 25}] [expr {$ym + 25}]
EraseRect crc
DrawString $txt center
}
proc DrawUniColor { v_prc color } {
upvar $v_prc prc
RGBForeColor [Color $color]
FillRect prc
}
proc Draw { which } {
global cv cvrc
set cursor [$cv cget -cursor]
$cv configure -cursor watch
update
foreach item [winfo children $cv] { destroy $item }
switch $which {
Weiß { DrawUniColor cvrc white }
Schwarz { DrawUniColor cvrc black }
Rot { DrawUniColor cvrc red }
Grün { DrawUniColor cvrc green }
Blau { DrawUniColor cvrc blue }
Cyan { DrawUniColor cvrc cyan }
Magenta { DrawUniColor cvrc magenta }
Gelb { DrawUniColor cvrc yellow }
Balken { DrawBalken cvrc }
FuBK { DrawFuBK cvrc }
ct { DrawCt cvrc }
Pattern { DrawPattern cvrc }
100Pixel { Draw100Pixel cvrc }
Text { DrawTestText cvrc }
}
$cv configure -cursor $cursor
}
proc Testbild {} {
global cv cvrc tcl_platform
set win .testbild
toplevel $win -bg black -bd 0
wm withdraw $win
bind $win <Key-Escape> "exit 0"
wm overrideredirect $win 1
set dy [winfo screenheight .]
set dx [winfo screenwidth .]
wm geometry $win ${dx}x${dy}+0+0
set cv $win.cv
pack [canvas $cv -bd 0 -bg black] -expand 1 -fill both -padx 0 -pady 0
wm deiconify $win
focus -force $win
menu .popup -tearoff 0
.popup add command -label "Weiß" -command "Draw Weiß"
.popup add command -label "Schwarz" -command "Draw Schwarz"
.popup add command -label "Rot" -command "Draw Rot"
.popup add command -label "Grün" -command "Draw Grün"
.popup add command -label "Blau" -command "Draw Blau"
.popup add command -label "Cyan" -command "Draw Cyan"
.popup add command -label "Magenta" -command "Draw Magenta"
.popup add command -label "Gelb" -command "Draw Gelb"
.popup add separator
.popup add command -label "Farb-Balken" -command "Draw Balken"
.popup add command -label "FuBK (ARD)" -command "Draw FuBK"
.popup add command -label "c't" -command "Draw ct"
.popup add command -label "Pattern" -command "Draw Pattern"
.popup add command -label "Test-Text" -command "Draw Text"
.popup add command -label "100 Pixel" -command "Draw 100Pixel"
.popup add separator
.popup add command -label "Beenden" -command "exit 0"
foreach btn {1 2 3} { bind $cv <Button-$btn> "tk_popup .popup %X %Y" }
if {$tcl_platform(platform) == "windows"} {
bind all <Control-Alt-c> { console show }
}
SetRect cvrc 0 0 $dx $dy
Draw FuBK
}
Testbild