1########################################################### 2# DrawingWand test 3# - The purpose is to test the correctness of TclMagick, 4# not to produce meaningful output 5# 6########################################################### 7 8 9############################################ 10# Load debugging version 11# or require TclMagick package from library 12# 13 14if { $tcl_platform(platform) == "unix" } { 15 set auto_path [linsert $auto_path 0 [file join .. unix]] 16 package require TclMagick 17} else { 18 set dll [file join .. win debug tclMagick.dll] 19 if {[file exists $dll]} { 20 load $dll 21 } 22 package require TclMagick 23} 24puts [info script] 25 26 27########################################## 28# Global options 29# 30set IMG "xc:white" 31set TMP [file join .. tmp] 32set FONT "Ariel" ;# undefine FONT if none available 33 34########################################## 35# Check which tests should be performed 36# 37set TestFunctions { 38 DrawTest img 1 39 PathTest img 1 40} 41 42############################################ 43# Command debugging 44# 45catch { 46 wm withdraw . 47 console show 48 console eval {wm protocol . WM_DELETE_WINDOW exit} 49} 50proc debug {args} { 51 foreach cmdMask $args { 52 foreach cmd [info commands $cmdMask] { 53 trace add execution $cmd leave debugLeave 54 } 55 } 56} 57proc debugLeave {cmdstr code result op} { 58 puts [format " %s ==>{%s}" [string range $cmdstr 0 50] [string range $result 0 50]] 59 update 60} 61 62########################################## 63# Single image tests 64# 65proc DrawTest {img} { 66 set wand [$img clone imgX] 67 set draw [magick create draw draw0] 68 debug $draw $wand 69 70 [magick create pixel pix0] SetColor "lightblue" 71 [magick create pixel pix1] SetColor "blue" 72 [magick create pixel pix2] SetColor "red" 73 [magick create pixel pix3] SetColor "yellow" 74 [magick create pixel pix4] SetColor "brown" 75 [magick create pixel pix5] SetColor "lightgreen" 76 [magick create pixel pix6] SetColor "green" 77 [magick create pixel pix7] SetColor "lightgray" 78 [magick create pixel pix8] SetColor "black" 79 80 $draw PushGraphicContext 81 $draw SetStrokeWidth 1.0 82 $draw SetStrokeColor pix1 83 $draw SetFillColor pix1 84 $draw SetFontSize 24 85 $draw Annotation 5 30 "Created by TclMagick:" 86 $draw PopGraphicContext 87 $draw PushGraphicContext 88 $draw SetStrokeWidth 1.0 89 $draw SetStrokeColor pix8 90 $draw SetFillColor pix2 91 $draw Arc 50 50 100 100 45 -45 92 $draw PopGraphicContext 93 $draw PushGraphicContext 94 $draw SetStrokeWidth 1.0 95 $draw SetStrokeColor pix1 96 $draw SetFillColor pix3 97 $draw Bezier 110 110 140 10 170 120 150 150 110 110 98 $draw PopGraphicContext 99 $draw PushGraphicContext 100 $draw SetStrokeWidth 1.0 101 $draw SetStrokeColor pix4 102 $draw SetFillColor pix7 103 $draw Circle 100 200 50 200 104 $draw PopGraphicContext 105 $draw PushGraphicContext 106 $draw SetStrokeColor pix8 107 $draw SetFillColor pix6 108 $draw SetFillOpacity 0.7 109 $draw Ellipse 250 100 50 25 0 360 110 $draw PopGraphicContext 111 $draw PushGraphicContext 112 $draw SetStrokeWidth 1.0 113 $draw SetStrokeColor pix2 114 $draw SetFillColor pix2 115 $draw Point 200 200 116 $draw PopGraphicContext 117 $draw PushGraphicContext 118 $draw SetFillColor pix0 119 $draw Color 0 0 replace 120 $draw PopGraphicContext 121 122 $wand DrawImage $draw 123 $wand WriteImage "$::TMP/y-Draw-%0d.bmp" 124 125 magick delete pix0 pix1 pix2 pix3 pix4 pix5 pix6 pix7 pix8 126 magick delete $draw $wand 127} 128 129########################################## 130# 131# 132proc DLR_logo {draw color x y scale} { 133 134 $draw PushGraphicContext 135 136 $draw SetStrokeColor $color 137 $draw SetFillColor $color 138 $draw SetStrokeWidth 0.0 139 140 $draw Scale $scale 141 $draw path start move [expr {$x+72.5}] [expr {$y+0.0}] 142 $draw path { 143 # "Diagonal part of the DLR bird" 144 -relative on 145 line -45 +45 vertical +31 line +45 -45 vertical -31 146 line -5 +12 147 line -35 +35 vertical +17 line +35 -35 vertical -17 148 close 149 finish 150 } 151 $draw path start move [expr {$x+1.0}] [expr {$y+49.0}] 152 $draw path { 153 # "Horizontal part of the DLR bird" 154 -relative on 155 horizontal +76 line +22 -22 horizontal -76 line -22 +22 156 line +12 -5 157 horizontal +62 line +12 -12 horizontal -62 line -12 +12 158 close 159 finish 160 } 161 if {[info exists ::FONT]} { 162 # Use specified FONT 163 # 164 $draw SetFontFamily $::FONT 165 $draw SetFontSize 20 166 $draw Annotation [expr {$x+55.0}] [expr {$y+82.0}] "DLR" 167 } else { 168 # Draw the letters manually 169 # 170 $draw path start move [expr {$x+55.0}] [expr {$y+82.0}] 171 $draw path { 172 # "Letter D" 173 -relative on 174 vertical -18 horizontal +6 175 quadratic +7 +0 +7 +9 176 quadratic +0 +9 -7 +9 177 horizontal -6 178 line +2.5 -2.5 179 vertical -13 horizontal +3 180 quadratic +5 +0 +5 +6.5 181 quadratic +0 +6.5 -5 +6.5 182 horizontal -3 183 line -2.5 +2.5 184 close 185 186 # "Letter L" 187 move +17 +0 188 vertical -18 horizontal +2.5 189 vertical +15 horizontal +7 190 vertical +3 horizontal -10 191 close 192 193 # "Letter R" 194 move +12.5 +0 195 vertical -18 horizontal +5 196 quadratic +5 +0 +5 +5 197 quadratic +0 +5 -4 +5 198 line +5 +8 horizontal -2.5 line -5 -8 199 horizontal -1 vertical +8 horizontal -2.5 200 line +2.5 -10.5 201 vertical -5 horizontal +2 202 quadratic +3 +0 +3 +2.5 203 quadratic +0 +2.5 -3 +2.5 204 horizontal -2 205 line -2.5 +10.5 206 close 207 finish 208 } 209 } 210 $draw PopGraphicContext 211} 212proc PathTest {img} { 213 set wand [$img clone imgX] 214 set draw [magick create draw draw0] 215 debug $draw $wand 216 217 [magick create pixel pix0] SetColor "gray" 218 [magick create pixel pix1] SetColor "black" 219 220 DLR_logo $draw pix0 0 2 4 221 DLR_logo $draw pix1 1 1.5 4 222 223 $wand DrawImage $draw 224 $wand WriteImage "$::TMP/y-Path-%0d.bmp" 225 226 magick delete $draw $wand 227} 228 229########################################## 230# Main test loop 231# 232 233debug magick 234 235if { ! [file isdirectory $TMP]} { 236 file mkdir $TMP 237} 238 239set img [magick create wand img0] 240debug $img 241 242$img ReadImage $IMG 243$img ResizeImage 400 340 244 245magick names 246 247set ERRORS 0 248foreach {func var flag} $TestFunctions { 249 if {$flag} { 250 puts [format "%s:" $func $var] 251 set err [catch {$func [set $var]} result] 252 if {$err} { 253 incr ERRORS 254 puts stderr [format "error: %s" $result] 255 } 256 } else { 257 puts [format "--- skip: %s ---" $func] 258 } 259} 260 261puts "##### DRAW TEST READY #####" 262if {!$ERRORS} { 263 after 3000 exit 264} 265 266