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 / canvPsGrph.tcl < prev    next >
Encoding:
Text File  |  1997-08-15  |  3.2 KB  |  88 lines  |  [TEXT/ALFA]
  1. # This file creates a screen to exercise Postscript generation
  2. # for some of the graphical objects in canvases.  It is part of the Tk
  3. # visual test suite, which is invoked via the "visual" script.
  4. #
  5. # SCCS: @(#) canvPsGrph.tcl 1.3 96/02/16 10:56:07
  6.  
  7. catch {destroy .t}
  8. toplevel .t
  9. wm title .t "Postscript Tests for Canvases"
  10. wm iconname .t "Postscript"
  11. wm geom .t +0+0
  12. wm minsize .t 1 1
  13.  
  14. set c .t.mid.c
  15.  
  16. message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets.  Select what you want to display with the buttons below, then click on "Print" to print it to your default printer.  You can click on items in the canvas to delete them.} -width 4i
  17. pack .t.m -side top -fill both
  18.  
  19. frame .t.top
  20. pack .t.top -side top -fill both
  21. set what rect
  22. radiobutton .t.top.rect -text Rectangles -variable what -value rect \
  23.     -command "mkObjs $c" -relief flat
  24. radiobutton .t.top.oval -text Ovals -variable what -value oval \
  25.     -command "mkObjs $c" -relief flat
  26. radiobutton .t.top.poly -text Polygons -variable what -value poly \
  27.     -command "mkObjs $c" -relief flat
  28. radiobutton .t.top.line -text Lines -variable what -value line \
  29.     -command "mkObjs $c" -relief flat
  30. pack .t.top.rect .t.top.oval .t.top.poly .t.top.line \
  31.     -side left -pady 2m -ipadx 2m -ipady 1m -expand 1
  32.  
  33. frame .t.bot
  34. pack .t.bot -side bottom -fill both
  35. button .t.bot.quit -text Quit -command {destroy .t}
  36. button .t.bot.print -text Print -command "lpr $c"
  37. pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1
  38.  
  39. frame .t.mid -relief sunken -bd 2
  40. pack .t.mid -side top -expand yes -fill both -padx 2m -pady 2m
  41. canvas $c -width 400 -height 350 -bd 0 -relief sunken
  42. pack $c -expand yes -fill both -padx 1 -pady 1
  43.  
  44. proc mkObjs c {
  45.     global what
  46.     $c delete all
  47.     if {$what == "rect"} {
  48.     $c create rect 0 0 400 350 -outline black
  49.     $c create rect 2 2 100 50 -fill black -stipple gray25
  50.     $c create rect -20 180 80 320 -fill black -stipple gray50 -width .5c
  51.     $c create rect 200 -20 240 20 -fill black
  52.     $c create rect 380 200 420 240 -fill black
  53.     $c create rect 200 330 240 370 -fill black
  54.     }
  55.     
  56.     if {$what == "oval"} {
  57.     $c create oval 50 10 150 80 -fill black -stipple gray25 -outline {}
  58.     $c create oval 100 100 200 150 -outline {} -fill black -stipple gray50
  59.     $c create oval 250 100 400 300 -width .5c
  60.     }
  61.     
  62.     if {$what == "poly"} {
  63.     $c create poly 100 200 200 50 300 200 -smooth yes -stipple gray25 \
  64.         -outline black -width 4
  65.     $c create poly 100 300 100 250 350 250 350 300 350 300 100 300 100 300 \
  66.         -fill red -smooth yes
  67.     $c create poly 20 10 40 10 40 60 80 60 80 25 30 25 30 \
  68.         35 50 35 50 45 20 45
  69.     $c create poly 300 20 300 120 380 80 320 100 -fill blue -outline black
  70.     $c create poly 20 200 100 220 90 100 40 250 \
  71.         -fill {} -outline brown -width 3
  72.     }
  73.     
  74.     if {$what == "line"} {
  75.     $c create line 20 20 120 20 -arrow both -width 5
  76.     $c create line 20 80 150 80 20 200 150 200 -smooth yes
  77.     $c create line 150 20 150 150 250 150 -width .5c -smooth yes \
  78.         -arrow both -arrowshape {.75c 1.0c .5c} -stipple gray25
  79.     $c create line 50 340 100 250 150 340 -join round -cap round -width 10
  80.     $c create line 200 340 250 250 300 340 -join bevel -cap project \
  81.         -width 10
  82.     $c create line 300 20 380 20 300 150 380 150 -join miter -cap butt \
  83.         -width 10 -stipple gray25
  84.     }
  85. }
  86.  
  87. mkObjs $c
  88.