Posted to tcl by tomk at Mon Mar 18 22:08:05 GMT 2013view raw

  1. package require Tcl 8.6
  2. package require Tk 8.6
  3.  
  4. lappend auto_path \
  5. . \
  6. [file normalize [file join ~ local tbox lib]] \
  7. [file normalize [file join ~ local tbox lib win32]] \
  8. [file normalize [file join ~ local tbox lib critcl_3 critcl3.vfs lib]] \
  9. [file normalize [file join ~ local tbox Plotchart]] \
  10. [pwd]/imageviewer \
  11. [pwd]/CRIMP
  12.  
  13. puts [info patchlevel]
  14.  
  15. set debug 1
  16. foreach p {
  17. crimp::core
  18. crimp
  19. crimp::tk
  20. crimp::ppm
  21. crimp::pgm
  22. crimp::pfm
  23. crimp::bmp
  24. } {
  25. set ver [package require $p]
  26. if { ${debug} == 1 } {
  27. puts "$p: ${ver}"
  28. }
  29. }
  30.  
  31. wm geometry . 600x600
  32.  
  33. set c [canvas .p -background beige]
  34. grid ${c} -column 1 -row 1 -sticky news
  35. set b [button .b -text "NEXT" -command {}]
  36. grid ${b} -column 1 -row 2
  37.  
  38. grid columnconfigure . 1 -weight 1
  39. grid rowconfigure . 1 -weight 1
  40.  
  41. # create blank image
  42. proc blankImage { w h {color red} } {
  43. set clist [winfo rgb . ${color}]
  44. set img [crimp blank rgba ${w} ${h} {*}${clist} 255]
  45. set img [crimp meta set ${img} -xpos 0]
  46. set img [crimp meta set ${img} -ypos 0]
  47. # uncommenting the following causes image corruption
  48. #set img [crimp meta set ${img} -name 0]
  49. return ${img}
  50. }
  51.  
  52. proc renderImage { c x y img } {
  53. set photo [image create photo]
  54. crimp write 2tk ${photo} ${img}
  55. ${c} delete img
  56. update
  57. ${c} create image ${x} ${y} \
  58. -anchor nw \
  59. -image ${photo} \
  60. -tags img
  61. }
  62.  
  63. set bg [blankImage 100 100 black]
  64.  
  65. #set img [compositeImage 300 300 ${image2}]
  66. renderImage ${c} 0 0 ${bg}
  67.