home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / canvRect.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  11.9 KB  |  330 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out the procedures in tkRectOval.c,
  2. # which implement canvas "rectangle" and "oval" items.  It is organized
  3. # in the standard fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10. # SCCS: @(#) canvRect.test 1.18 97/08/06 15:33:39
  11.  
  12. if {[info procs test] != "test"} {
  13.     source defs
  14. }
  15.  
  16. foreach i [winfo children .] {
  17.     destroy $i
  18. }
  19. wm geometry . {}
  20. raise .
  21.  
  22. canvas .c -width 400 -height 300 -bd 2 -relief sunken
  23. pack .c
  24. bind .c <1> {
  25.     puts "button down at (%x,%y)"
  26. }
  27. update
  28.  
  29. set i 1
  30. .c create rectangle 20 20 80 80 -tag test
  31. foreach test {
  32.     {-fill #ff0000 #ff0000 non-existent {unknown color name "non-existent"}}
  33.     {-outline #123456 #123456 bad_color {unknown color name "bad_color"}}
  34.     {-stipple gray50 gray50 bogus {bitmap "bogus" not defined}}
  35.     {-tags {test a b c} {test a b c} {} {}}
  36.     {-width 6 6 abc {bad screen distance "abc"}}
  37. } {
  38.     set name [lindex $test 0]
  39.     test canvRect-1.$i {configuration options} {
  40.     .c itemconfigure test $name [lindex $test 1]
  41.     list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name]
  42.     } [list [lindex $test 2] [lindex $test 2]]
  43.     incr i
  44.     if {[lindex $test 3] != ""} {
  45.     test canvRect-1.$i {configuration options} {
  46.         list [catch {.c itemconfigure test $name [lindex $test 3]} msg] $msg
  47.     } [list 1 [lindex $test 4]]
  48.     }
  49.     incr i
  50. }
  51. test canvRect-1.$i {configuration options} {
  52.     .c itemconfigure test -tags {test xyz}
  53.     .c itemcget xyz -tags
  54. } {test xyz}
  55.  
  56. test canvRect-2.1 {CreateRectOval procedure} {
  57.     list [catch {.c create rect} msg] $msg
  58. } {1 {wrong # args: should be ".c create rectangle x1 y1 x2 y2 ?options?"}}
  59. test canvRect-2.2 {CreateRectOval procedure} {
  60.     list [catch {.c create oval x y z} msg] $msg
  61. } {1 {wrong # args: should be ".c create oval x1 y1 x2 y2 ?options?"}}
  62. test canvRect-2.3 {CreateRectOval procedure} {
  63.     list [catch {.c create rectangle x 2 3 4} msg] $msg
  64. } {1 {bad screen distance "x"}}
  65. test canvRect-2.4 {CreateRectOval procedure} {
  66.     list [catch {.c create rectangle 1 y 3 4} msg] $msg
  67. } {1 {bad screen distance "y"}}
  68. test canvRect-2.5 {CreateRectOval procedure} {
  69.     list [catch {.c create rectangle 1 2 z 4} msg] $msg
  70. } {1 {bad screen distance "z"}}
  71. test canvRect-2.6 {CreateRectOval procedure} {
  72.     list [catch {.c create rectangle 1 2 3 q} msg] $msg
  73. } {1 {bad screen distance "q"}}
  74. test canvRect-2.7 {CreateRectOval procedure} {
  75.     .c create rectangle 1 2 3 4 -tags x
  76.     set result {}
  77.     foreach element [.c coords x] {
  78.     lappend result [format %.1f $element]
  79.     }
  80.     set result
  81. } {1.0 2.0 3.0 4.0}
  82. test canvRect-2.8 {CreateRectOval procedure} {
  83.     list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg
  84. } {1 {unknown option "-gorp"}}
  85.  
  86. .c delete withtag all
  87. .c create rectangle 10 20 30 40 -tags x
  88. test canvRect-3.1 {RectOvalCoords procedure} {
  89.     set result {}
  90.     foreach element [.c coords x] {
  91.     lappend result [format %.1f $element]
  92.     }
  93.     set result
  94. } {10.0 20.0 30.0 40.0}
  95. test canvRect-3.2 {RectOvalCoords procedure} {
  96.     list [catch {.c coords x a 2 3 4} msg] $msg
  97. } {1 {bad screen distance "a"}}
  98. test canvRect-3.3 {RectOvalCoords procedure} {
  99.     list [catch {.c coords x 1 b 3 4} msg] $msg
  100. } {1 {bad screen distance "b"}}
  101. test canvRect-3.4 {RectOvalCoords procedure} {
  102.     list [catch {.c coords x 1 2 c 4} msg] $msg
  103. } {1 {bad screen distance "c"}}
  104. test canvRect-3.5 {RectOvalCoords procedure} {
  105.     list [catch {.c coords x 1 2 3 d} msg] $msg
  106. } {1 {bad screen distance "d"}}
  107. test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} {
  108.     # Non-portable due to rounding differences.
  109.     .c coords x 10 25 15 40
  110.     .c bbox x
  111. } {9 24 16 41}
  112. test canvRect-3.7 {RectOvalCoords procedure} {
  113.     list [catch {.c coords x 1 2 3 4 5} msg] $msg
  114. } {1 {wrong # coordinates: expected 0 or 4, got 5}}
  115.  
  116. .c delete withtag all
  117. .c create rectangle 10 20 30 40 -tags x -width 1
  118. test canvRect-4.1 {ConfigureRectOval procedure} {
  119.     list [catch {.c itemconfigure x -width abc} msg] $msg \
  120.         [.c itemcget x -width]
  121. } {1 {bad screen distance "abc"} 1}
  122. test canvRect-4.2 {ConfigureRectOval procedure} {
  123.     .c itemconfigure x -width -5
  124.     .c itemcget x -width
  125. } {1}
  126. test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} {
  127.     # Non-portable due to rounding differences.
  128.     .c itemconfigure x -width 10
  129.     .c bbox x
  130. } {5 15 35 45}
  131. # I can't come up with any good tests for DeleteRectOval.
  132.  
  133. .c delete withtag all
  134. .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
  135. test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} {
  136.     # Non-portable due to rounding differences:
  137.     .c coords x 20 15 10 5
  138.     .c bbox x
  139. } {10 5 20 15}
  140. test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} {
  141.     # Non-portable due to rounding differences:
  142.     .c coords x 10 20 30 10
  143.     .c itemconfigure x -width 1 -outline red
  144.     .c bbox x
  145. } {9 9 31 21}
  146. test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} {
  147.     # Non-portable due to rounding differences:
  148.     .c coords x 10 20 30 10
  149.     .c itemconfigure x -width 2 -outline red
  150.     .c bbox x
  151. } {9 9 31 21}
  152. test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} {
  153.     # Non-portable due to rounding differences:
  154.     .c coords x 10 20 30 10
  155.     .c itemconfigure x -width 3 -outline red
  156.     .c bbox x
  157. } {8 8 32 22}
  158.  
  159. # I can't come up with any good tests for DisplayRectOval.
  160.  
  161. .c delete withtag all
  162. set x  [.c create rectangle 10 20 30 35 -tags x -fill green]
  163. set y [.c create rectangle 15 25 25 30  -tags y -fill red]
  164. test canvRect-6.1 {RectToPoint procedure} {
  165.     .c itemconfigure y -outline {}
  166.     list [.c find closest 14.9 28] [.c find closest 15.1 28] \
  167.         [.c find closest 24.9 28] [.c find closest 25.1 28]
  168. } "$x $y $y $x"
  169. test canvRect-6.2 {RectToPoint procedure} {
  170.     .c itemconfigure y -outline {}
  171.     list [.c find closest 20 24.9] [.c find closest 20 25.1] \
  172.         [.c find closest 20 29.9]  [.c find closest 20 30.1]
  173. } "$x $y $y $x"
  174. test canvRect-6.3 {RectToPoint procedure} {
  175.     .c itemconfigure y -width 1 -outline black
  176.     list [.c find closest 14.4 28] [.c find closest 14.6 28] \
  177.         [.c find closest 25.4 28] [.c find closest 25.6 28]
  178. } "$x $y $y $x"
  179. test canvRect-6.4 {RectToPoint procedure} {
  180.     .c itemconfigure  y -width 1 -outline black
  181.     list [.c find closest 20 24.4] [.c find closest 20 24.6] \
  182.         [.c find closest 20 30.4] [.c find closest 20 30.6]
  183. } "$x $y $y $x"
  184. .c itemconfigure x -fill {} -outline black -width 3
  185. .c itemconfigure y -outline {}
  186. test canvRect-6.5 {RectToPoint procedure} {
  187.     list [.c find closest 13.2 28] [.c find closest 13.3 28] \
  188.         [.c find closest 26.7 28] [.c find closest 26.8 28]
  189. } "$x $y $y $x"
  190. test canvRect-6.6 {RectToPoint procedure} {
  191.     list [.c find closest 20 23.2] [.c find closest 20 23.3] \
  192.         [.c find closest 20 31.7] [.c find closest 20 31.8]
  193. } "$x $y $y $x"
  194. .c delete withtag all
  195. set x [.c create rectangle 10 20 30 40 -outline {} -fill black]
  196. set y [.c create rectangle 40 40 50 50 -outline {} -fill black]
  197. test canvRect-6.7 {RectToPoint procedure} {
  198.     list [.c find closest 35 35] [.c find closest 36 36] \
  199.         [.c find closest 37 37] [.c find closest 38 38]
  200. } "$x $y $y $y"
  201.  
  202. .c delete withtag all
  203. set x  [.c create rectangle 10 20 30 35 -fill green -outline {}]
  204. set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3]
  205. set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3]
  206. test canvRect-7.1 {RectToArea procedure} {
  207.     list [.c find overlapping 20 50 38 60] \
  208.         [.c find overlapping 20 50 39 60] \
  209.         [.c find overlapping 20 50 70 60] \
  210.         [.c find overlapping 61 50 70 60] \
  211.         [.c find overlapping 62 50 70 60]
  212. } "{} $y $y $y {}"
  213. test canvRect-7.2 {RectToArea procedure} {
  214.     list [.c find overlapping 45 20 55 43] \
  215.         [.c find overlapping 45 20 55 44] \
  216.         [.c find overlapping 45 20 55 80] \
  217.         [.c find overlapping 45 71 55 80] \
  218.         [.c find overlapping 45 72 55 80]
  219. } "{} $y $y $y {}"
  220. test canvRect-7.3 {RectToArea procedure} {
  221.     list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30]
  222. } "{} $x"
  223. test canvRect-7.4 {RectToArea procedure} {
  224.     list [.c find overlapping 102 152 118 168] \
  225.         [.c find overlapping 101 152 118 168] \
  226.         [.c find overlapping 102 151 118 168] \
  227.         [.c find overlapping 102 152 119 168] \
  228.         [.c find overlapping 102 152 118 169]
  229. } "{} $z $z $z $z"
  230. test canvRect-7.5 {RectToArea procedure} {
  231.     list [.c find enclosed 20 40 38 80] \
  232.         [.c find enclosed 20 40 39 80] \
  233.         [.c find enclosed 20 40 70 80] \
  234.         [.c find enclosed 61 40 70 80] \
  235.         [.c find enclosed 62 40 70 80]
  236. } "{} {} $y {} {}"
  237. test canvRect-7.6 {RectToArea procedure} {
  238.     list [.c find enclosed 20 20 65 43] \
  239.         [.c find enclosed 20 20 65 44] \
  240.         [.c find enclosed 20 20 65 80] \
  241.         [.c find enclosed 20 71 65 80] \
  242.         [.c find enclosed 20 72 65 80]
  243. } "{} {} $y {} {}"
  244.  
  245. .c delete withtag all
  246. set x  [.c create oval 50 100 200 150 -fill green -outline {}]
  247. set y [.c create oval 50 100 200 150 -fill red -outline black -width 3]
  248. set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3]
  249. test canvRect-8.1 {OvalToArea procedure} {
  250.     list [.c find overlapping 20 120 48 130] \
  251.         [.c find overlapping 20 120 49 130] \
  252.         [.c find overlapping 20 120 50.2 130] \
  253.         [.c find overlapping 20 120 300 130] \
  254.         [.c find overlapping 60 120 190 130] \
  255.         [.c find overlapping 199.9 120 300 130] \
  256.         [.c find overlapping 201 120 300 130] \
  257.         [.c find overlapping 202 120 300 130]
  258. } "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
  259. test canvRect-8.2 {OvalToArea procedure} {
  260.     list [.c find overlapping 100 50 150 98] \
  261.         [.c find overlapping 100 50 150 99] \
  262.         [.c find overlapping 100 50 150 100.1] \
  263.         [.c find overlapping 100 50 150 200] \
  264.         [.c find overlapping 100 110 150 140] \
  265.         [.c find overlapping 100 149.9 150 200] \
  266.         [.c find overlapping 100 151 150 200] \
  267.         [.c find overlapping 100 152 150 200]
  268. } "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}"
  269. test canvRect-8.3 {OvalToArea procedure} {
  270.     list [.c find overlapping 176 104 177 105] \
  271.         [.c find overlapping 187 116 188 117] \
  272.         [.c find overlapping 192 142 193 143] \
  273.         [.c find overlapping 180 138 181 139] \
  274.         [.c find overlapping 61 142 62 143] \
  275.         [.c find overlapping 65 137 66 136] \
  276.         [.c find overlapping 62 108 63 109] \
  277.         [.c find overlapping 68 115 69 116]
  278. } "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}"
  279.  
  280. test canvRect-9.1 {ScaleRectOval procedure} {
  281.     .c delete withtag all
  282.     .c create rect 100 300 200 350 -tags x
  283.     .c scale x 50 100 2 4
  284.     .c coords x
  285. } {150.0 900.0 350.0 1100.0}
  286.  
  287. test canvRect-10.1 {TranslateRectOval procedure} {
  288.     .c delete withtag all
  289.     .c create rect 100 300 200 350 -tags x
  290.     .c move x 100 -10
  291.     .c coords x
  292. } {200.0 290.0 300.0 340.0}
  293.  
  294. # This test is non-portable because different color information
  295. # will get generated on different displays (e.g. mono displays
  296. # vs. color).
  297. test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable win32sCrash macCrash} {
  298.     # Crashes on Mac because the XGetImage() call isn't implemented, causing a
  299.     # dereference of NULL.
  300.     
  301.     .c configure -bd 0 -highlightthickness 0
  302.     .c delete withtag all
  303.     .c create rect 50 60 90 80 -fill black -stipple gray50 -outline {}
  304.     .c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5
  305.     update
  306.     set x [.c postscript]
  307.     string range $x [string first "-200 -150 translate" $x] end
  308. } {-200 -150 translate
  309. 0 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath
  310. gsave
  311. 50 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath
  312. 0.000 0.000 0.000 setrgbcolor AdjustColor
  313. clip 16 16 <5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555
  314. aaaa> StippleFill
  315. grestore
  316. gsave
  317. matrix currentmatrix
  318. 150 125 translate 50 25 scale 1 0 moveto 0 0 1 0 360 arc
  319. setmatrix
  320. 5 setlinewidth 0 setlinejoin 2 setlinecap
  321. 1.000 0.000 0.000 setrgbcolor AdjustColor
  322. stroke
  323. grestore
  324. restore showpage
  325.  
  326. %%Trailer
  327. end
  328. %%EOF
  329. }
  330.