namespace eval tig {
namespace ensemble create
namespace export Draw
variable Pattern {}
variable ForeColor white
variable BackColor black
variable PenSize 1
variable Font {Courier 12}
variable DrawPos
set DrawPos(x) 0
set DrawPos(y) 0
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
variable 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 } {
variable Font
return [font measure $Font $str]
}
proc TextFont { which } {
variable Font
set Font $which
}
proc DrawString { canvasId str {anchor w} } {
variable DrawPos
variable Font
variable ForeColor
$canvasId create text $DrawPos(x) $DrawPos(y) -font $Font -fill $ForeColor \
-anchor $anchor -text $str
}
proc SetPenSize { width } {
variable PenSize
set PenSize $width
}
proc FillRect { canvasId v_rc } {
upvar $v_rc rc
variable Pattern
variable ForeColor
if {$Pattern != {}} {
$canvasId create rect $rc(left) $rc(top) $rc(right) $rc(bottom) \
-fill $ForeColor -stipple $Pattern -width 0
} else {
$canvasId create rect $rc(left) $rc(top) $rc(right) $rc(bottom) \
-fill $ForeColor -width 0
}
}
proc ClearPoly3 { canvasId x0 y0 x1 y1 x2 y2 } {
variable BackColor
$canvasId create poly $x0 $y0 $x1 $y1 $x2 $y2 -fill $BackColor -width 0
}
proc FrameRect { canvasId v_rc } {
upvar $v_rc rc
MoveTo $rc(left) $rc(top)
LineTo $canvasId $rc(right) $rc(top)
LineTo $canvasId $rc(right) $rc(bottom)
LineTo $canvasId $rc(left) $rc(bottom)
LineTo $canvasId $rc(left) $rc(top)
}
proc EraseRect { canvasId v_rc } {
upvar $v_rc rc
variable Pattern
variable BackColor
$canvasId create rect $rc(left) $rc(top) $rc(right) $rc(bottom) -fill $BackColor
}
proc FrameCircle { canvasId v_rc } {
upvar $v_rc rc
variable Pattern
variable ForeColor
variable PenSize
$canvasId create oval $rc(left) $rc(top) $rc(right) $rc(bottom) \
-outline $ForeColor -width $PenSize
}
proc MoveTo { x0 y0 } {
variable DrawPos
set DrawPos(x) $x0
set DrawPos(y) $y0
}
proc LineTo { canvasId x1 y1 } {
variable DrawPos
variable ForeColor
variable PenSize
$canvasId create line $DrawPos(x) $DrawPos(y) $x1 $y1 \
-fill $ForeColor -width $PenSize
set DrawPos(x) $x1
set DrawPos(y) $y1
}
proc RGBForeColor { color } {
variable ForeColor
set ForeColor $color
}
proc RGBBackColor { color } {
variable BackColor
set BackColor $color
}
proc PenPattern { id } {
variable 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 { canvasId x0 x1 x2 x3 y0 y1 y2 y3 } {
SetRect rc $x0 $y0 $x1 $y1
FillRect $canvasId rc
SetRect rc $x2 $y0 $x3 $y1
FillRect $canvasId rc
SetRect rc $x0 $y2 $x1 $y3
FillRect $canvasId rc
SetRect rc $x2 $y2 $x3 $y3
FillRect $canvasId rc
}
proc DrawBalken { canvasId 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 $canvasId rc
set pos [expr $pos + 0.125]
}
}
proc DrawFuBK { canvasId v_prc { testText "" } } {
upvar $v_prc prc
if { $testText eq "" } {
set testText "Farb-Testbild Generator - J.Mehring 1.2"
}
# Hintergrundfarbe schwarz
RGBBackColor [Color black]
RGBForeColor [Color black]
FillRect $canvasId 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 $canvasId $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 $canvasId $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 $canvasId 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 $canvasId 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 $canvasId 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 $canvasId rc
RGBForeColor [Color white]
SetRect rc [XPos 0.1842105263] [YPos 0.5] \
[XPos 0.2894736842] [YPos 0.5666666667]
FillRect $canvasId rc
SetRect rc [XPos 0.7105263158] [YPos 0.5] \
[XPos 0.8157894737] [YPos 0.5666666667]
FillRect $canvasId 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 $canvasId rc
SetRect rc [XPos 0.2631578947] $y0 [XPos 0.3815789474] $y1
PenPattern gray12
FillRect $canvasId rc
SetRect rc [XPos 0.3815789474] $y0 [XPos 0.5000000000] $y1
PenPattern gray25
FillRect $canvasId rc
SetRect rc [XPos 0.5000000000] $y0 [XPos 0.6184210530] $y1
PenPattern gray50
FillRect $canvasId rc
SetRect rc [XPos 0.6184210530] $y0 [XPos 0.7631578947] $y1
PenPattern gray75
FillRect $canvasId rc
PenPattern {}
RGBForeColor [Color white_50]
SetRect rc [XPos 0.7631578947] $y0 [XPos 0.8157894737] $y1
FillRect $canvasId 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 $canvasId $x0 $y1
set y0 [YPos 0.5]
set x0 [XPos 0.1842105263]
set x1 [XPos 0.8157894737]
MoveTo $x0 $y0
LineTo $canvasId $x1 $y0
SetPenSize 1
# den Text der "Senderkennung" anzeigen
set len [XPos 0.3684210526]
TextFont "Courier 24 bold"
if {[StringWidth $testText] > $len} { TextFont "Courier 18 bold" }
if {[StringWidth $testText] > $len} { TextFont "Courier 14 bold" }
if {[StringWidth $testText] > $len} { TextFont "Courier 12 bold" }
if {[StringWidth $testText] > $len} { TextFont "Courier 10 bold" }
if {[StringWidth $testText] > $len} { TextFont "Courier 8 bold" }
set x0 [XPos 0.5]
set y0 [YPos 0.5333333333]
GetFontInfo fInfo
set len [StringWidth $testText]
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 $canvasId rc
MoveTo [expr $x0 - $len / 2] [expr $y0 + $fInfo(ascent) / 2]
RGBForeColor [Color white]
DrawString $canvasId $testText
# 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 $canvasId rc
SetRect rc [XPos 0.51] $y0 [XPos 0.8157894737] $y1
FillRect $canvasId 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 $canvasId $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 $canvasId $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 $canvasId 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 $canvasId rc
SetPenSize 1
# vier Kreise für die Ecken
SetRect rc [XPos 0.028947368] [YPos 0.036666667] \
[XPos 0.181578947] [YPos 0.230000000]
FrameCircle $canvasId rc
SetRect rc [XPos 0.818421052] [YPos 0.036666667] \
[XPos 0.971052631] [YPos 0.230000000]
FrameCircle $canvasId rc
SetRect rc [XPos 0.028947368] [YPos 0.770000000] \
[XPos 0.181578947] [YPos 0.963333333]
FrameCircle $canvasId rc
SetRect rc [XPos 0.818421052] [YPos 0.770000000] \
[XPos 0.971052631] [YPos 0.963333333]
FrameCircle $canvasId rc
}
proc DrawCt { canvasId v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color black]
# schwarzer Hintergrund
RGBForeColor [Color black]
FillRect $canvasId prc
# weißer Rahmen
array set rc [array get prc]
RGBForeColor [Color white]
FrameRect $canvasId 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 $canvasId $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 $canvasId [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 $canvasId rc
SetRect rc $x0 $y2 $x1 $y3
FillRect $canvasId rc
set x0 [XPos 0.4375]
set x1 [XPos 0.5625]
SetRect rc $x0 $y0 $x1 $y1
FillRect $canvasId rc
SetRect rc $x0 $y2 $x1 $y3
FillRect $canvasId rc
set x0 [XPos 0.6875]
set x1 [XPos 0.8750]
SetRect rc $x0 $y0 $x1 $y1
FillRect $canvasId rc
SetRect rc $x0 $y2 $x1 $y3
FillRect $canvasId 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 $canvasId rc
SetRect rc $x2 $y0 $x3 $y1
FillRect $canvasId rc
set y0 [YPos 0.5833333333]
set y1 [YPos 0.8333333333]
SetRect rc $x0 $y0 $x1 $y1
FillRect $canvasId rc
SetRect rc $x2 $y0 $x3 $y1
FillRect $canvasId 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 $canvasId 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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId $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 $canvasId 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 $canvasId rc
# HexPenPat [expr $idx + 14 +1]
PenPattern [lindex $pats $idx]
SetRect rc $x2 $y0 $x3 $y1
FillRect $canvasId 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 $canvasId $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 $canvasId $x0 $y0 $x1 [YPos 0.416666666] $x1 [YPos 0.583333333]
set pos 0.416666666
while {$pos <= 0.583333333} {
MoveTo $x0 $y0
LineTo $canvasId $x1 [YPos $pos]
set pos [expr $pos + 0.005555555]
}
set x1 [XPos 0.3125]
ClearPoly3 $canvasId $x0 $y0 $x1 [YPos 0.416666666] $x1 [YPos 0.583333333]
set pos 0.416666666
while {$pos <= 0.583333333} {
MoveTo $x0 $y0
LineTo $canvasId $x1 [YPos $pos]
set pos [expr $pos + 0.005555555]
}
set y1 [YPos 0.333333333]
ClearPoly3 $canvasId $x0 $y0 [XPos 0.4375] $y1 [XPos 0.5625] $y1
set pos 0.4375
while {$pos <= 0.5625} {
MoveTo $x0 $y0
LineTo $canvasId [XPos $pos] $y1
set pos [expr $pos + 0.004166666]
}
set y1 [YPos 0.666666666]
ClearPoly3 $canvasId $x0 $y0 [XPos 0.4375] $y1 [XPos 0.5625] $y1
set pos 0.4375
while {$pos <= 0.5625} {
MoveTo $x0 $y0
LineTo $canvasId [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 $canvasId rc
SetRect rc [XPos1 0.4375] [YPos1 0.4166666666] \
[XPos 0.5625] [YPos 0.5833333333]
FrameCircle $canvasId rc
# einen Kreis in die jede Ecke
SetRect rc [XPos1 0.0625] [YPos1 0.0833333333] \
[XPos 0.1875] [YPos 0.2500000000]
FrameCircle $canvasId rc
SetRect rc [XPos1 0.0625] [YPos1 0.7500000000] \
[XPos 0.1875] [YPos 0.9166666666]
FrameCircle $canvasId rc
SetRect rc [XPos1 0.8125] [YPos1 0.0833333333] \
[XPos 0.9375] [YPos 0.2500000000]
FrameCircle $canvasId rc
SetRect rc [XPos1 0.8125] [YPos1 0.7500000000] \
[XPos 0.9375] [YPos 0.9166666666]
FrameCircle $canvasId 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 $canvasId rc
SetRect rc $x0 $y2 $x1 $y3
RGBForeColor [Color cyan]
FillRect $canvasId rc
set x0 $x1
set x1 [XPos 0.5]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color green]
FillRect $canvasId rc
set x0 $x1
set x1 [XPos 0.5625]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color red]
FillRect $canvasId rc
set x0 $x1
set x1 [XPos 0.625]
SetRect rc $x0 $y0 $x1 $y1
RGBForeColor [Color yellow]
FillRect $canvasId rc
SetRect rc $x0 $y2 $x1 $y3
RGBForeColor [Color magenta]
FillRect $canvasId rc
}
proc DrawPattern { canvasId v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color white]
RGBForeColor [Color black]
EraseRect $canvasId prc
# 2 Pattern (links und rechts)
array set rc [array get prc]
set rc(right) [XPos 0.5]
PenPattern gray25
FillRect $canvasId rc
array set rc [array get prc]
set rc(left) [XPos 0.5]
PenPattern gray75
FillRect $canvasId rc
PenPattern {}
}
proc DrawTestText { canvasId v_prc { testText "" } } {
upvar $v_prc prc
if { $testText eq "" } {
set testText "Das ist ein Test-Text zur Bestimmung von Konvergenzfehlern mittels kleiner Schrift. "
}
# Hintergrundfarbe schwarz
RGBBackColor [Color white]
RGBForeColor [Color black]
EraseRect $canvasId prc
# Text
RGBForeColor [Color black]
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 $canvasId $testText
}
incr x0 -$l
incr y0 $h
}
}
proc Draw100Pixel { canvasId v_prc } {
upvar $v_prc prc
# Hintergrundfarbe schwarz
RGBBackColor [Color black]
# schwarzer Hintergrund
RGBForeColor [Color black]
FillRect $canvasId prc
# weißer Rahmen
array set rc [array get prc]
RGBForeColor [Color white]
FrameRect $canvasId 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 $canvasId $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 $canvasId [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 $canvasId $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 $canvasId [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 $canvasId $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 $canvasId [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 $canvasId crc
DrawString $canvasId $txt center
}
proc DrawUniColor { canvasId v_prc color } {
upvar $v_prc prc
RGBForeColor [Color $color]
FillRect $canvasId prc
}
proc Draw { which { xsize -1 } { ysize -1 } { testText "" } } {
variable cvrc
if { $xsize < 0 } {
set xsize [winfo screenwidth .]
}
if { $ysize < 0 } {
set ysize [winfo screenheight .]
}
set win .tig
toplevel $win -bg black -bd 0
ttk::frame $win.fr
pack $win.fr -expand 1 -fill both
set canvasId [CreateScrolledCanvas $win.fr -bd 0 -bg black -highlightthickness 0]
$canvasId configure -width 512 -height 512
$canvasId configure -scrollregion "0 0 $xsize $ysize"
tig::SetRect tig::cvrc 0 0 $xsize $ysize
switch $which {
white { DrawUniColor $canvasId cvrc white }
black { DrawUniColor $canvasId cvrc black }
red { DrawUniColor $canvasId cvrc red }
green { DrawUniColor $canvasId cvrc green }
blue { DrawUniColor $canvasId cvrc blue }
cyan { DrawUniColor $canvasId cvrc cyan }
magenta { DrawUniColor $canvasId cvrc magenta }
yellow { DrawUniColor $canvasId cvrc yellow }
colorbar { DrawBalken $canvasId cvrc }
fubk { DrawFuBK $canvasId cvrc $testText }
ct { DrawCt $canvasId cvrc }
pattern { DrawPattern $canvasId cvrc }
100 { Draw100Pixel $canvasId cvrc }
text { DrawTestText $canvasId cvrc $testText }
}
update
raise $win
after 1000
set phImg [Canvas2Img $canvasId]
destroy $win
return $phImg
}
proc CreateScrolledWidget { wType w args } {
if { [winfo exists $w.par] } {
destroy $w.par
}
ttk::frame $w.par
pack $w.par -side top -fill both -expand 1
$wType $w.par.widget \
-xscrollcommand "$w.par.xscroll set" \
-yscrollcommand "$w.par.yscroll set" {*}$args
ttk::scrollbar $w.par.xscroll -command "$w.par.widget xview" -orient horizontal
ttk::scrollbar $w.par.yscroll -command "$w.par.widget yview" -orient vertical
set rowNo 0
grid $w.par.widget $w.par.yscroll -sticky news
grid $w.par.xscroll -sticky ew
grid rowconfigure $w.par $rowNo -weight 1
grid columnconfigure $w.par 0 -weight 1
return $w.par.widget
}
proc CreateScrolledCanvas { w args } {
return [CreateScrolledWidget canvas $w {*}$args]
}
proc Canvas2Img { canvasId } {
set region [$canvasId cget -scrollregion]
set xsize [lindex $region 2]
set ysize [lindex $region 3]
set img [image create photo -width $xsize -height $ysize]
$canvasId xview moveto 0
$canvasId yview moveto 0
update
set xr 0.0
set yr 0.0
set px 0
set py 0
while { $xr < 1.0 } {
while { $yr < 1.0 } {
set tmpImg [image create photo -format window -data $canvasId]
$img copy $tmpImg -to $px $py
image delete $tmpImg
set yr [lindex [$canvasId yview] 1]
$canvasId yview moveto $yr
set py [expr round ($ysize * [lindex [$canvasId yview] 0])]
update
}
$canvasId yview moveto 0
set yr 0.0
set py 0
set xr [lindex [$canvasId xview] 1]
$canvasId xview moveto $xr
set px [expr round ($xsize * [lindex [$canvasId xview] 0])]
update
}
return $img
}
}
if { [file tail [info script]] eq [file tail $::argv0] } {
package require Tk
package require Img
proc PrintUsage { progName } {
global gOpt
puts "$progName: Generate test image"
puts "Options:"
puts "--help: Print this usage message"
puts "--x : Horizontal size of test image. Default: Screen resolution."
puts "--y : Vertical size of test image. Default: Screen resolution."
puts "--out : Name of test image file. Default: $gOpt(file)."
puts "--type: Type of test image. Default: $gOpt(type)."
puts " Possible values: black white red green blue cyan magenta yellow"
puts " colorbar fubk ct pattern 100 text"
puts "--text: Name of test string for types text and fubk. Default: Builtin."
exit 1
}
set gOpt(xsize) -1
set gOpt(ysize) -1
set gOpt(type) "colorbar"
set gOpt(file) "out.png"
set gOpt(text) ""
set curArg 0
while { $curArg < $argc } {
set curParam [lindex $argv $curArg]
if { [string compare -length 1 $curParam "-"] == 0 || \
[string compare -length 2 $curParam "--"] == 0 } {
set curOpt [string tolower [string trimleft $curParam "-"]]
if { $curOpt eq "help" } {
PrintUsage $argv0
} elseif { $curOpt eq "x" } {
incr curArg
set gOpt(xsize) [lindex $argv $curArg]
} elseif { $curOpt eq "y" } {
incr curArg
set gOpt(ysize) [lindex $argv $curArg]
} elseif { $curOpt eq "type" } {
incr curArg
set gOpt(type) [lindex $argv $curArg]
} elseif { $curOpt eq "text" } {
incr curArg
set gOpt(text) [lindex $argv $curArg]
} elseif { $curOpt eq "out" } {
incr curArg
set gOpt(file) [lindex $argv $curArg]
} else {
PrintUsage $argv0
}
incr curArg
}
}
if { $gOpt(xsize) < 0 && $gOpt(ysize) < 0 } {
puts "Drawing test image $gOpt(type) with screen resolution"
} else {
puts "Drawing test image $gOpt(type) with size $gOpt(xsize) x $gOpt(ysize)"
}
set phImg [tig Draw $gOpt(type) $gOpt(xsize) $gOpt(ysize) $gOpt(text)]
puts "Saving image as $gOpt(file)"
$phImg write $gOpt(file)
exit 0
} else {
package provide tig 1.2
}PO 2017/07/30This is a modified version of the Test-Picture Generator. Instead of displaying the test-picture on the screen, it is saved into an image file.
Getting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit