Posted to tcl by tomk at Mon Mar 18 22:08:05 GMT 2013view raw
- package require Tcl 8.6
- package require Tk 8.6
- lappend auto_path \
- . \
- [file normalize [file join ~ local tbox lib]] \
- [file normalize [file join ~ local tbox lib win32]] \
- [file normalize [file join ~ local tbox lib critcl_3 critcl3.vfs lib]] \
- [file normalize [file join ~ local tbox Plotchart]] \
- [pwd]/imageviewer \
- [pwd]/CRIMP
- puts [info patchlevel]
- set debug 1
- foreach p {
- crimp::core
- crimp
- crimp::tk
- crimp::ppm
- crimp::pgm
- crimp::pfm
- crimp::bmp
- } {
- set ver [package require $p]
- if { ${debug} == 1 } {
- puts "$p: ${ver}"
- }
- }
- wm geometry . 600x600
- set c [canvas .p -background beige]
- grid ${c} -column 1 -row 1 -sticky news
- set b [button .b -text "NEXT" -command {}]
- grid ${b} -column 1 -row 2
- grid columnconfigure . 1 -weight 1
- grid rowconfigure . 1 -weight 1
- # create blank image
- proc blankImage { w h {color red} } {
- set clist [winfo rgb . ${color}]
- set img [crimp blank rgba ${w} ${h} {*}${clist} 255]
- set img [crimp meta set ${img} -xpos 0]
- set img [crimp meta set ${img} -ypos 0]
- # uncommenting the following causes image corruption
- #set img [crimp meta set ${img} -name 0]
- return ${img}
- }
- proc renderImage { c x y img } {
- set photo [image create photo]
- crimp write 2tk ${photo} ${img}
- ${c} delete img
- update
- ${c} create image ${x} ${y} \
- -anchor nw \
- -image ${photo} \
- -tags img
- }
- set bg [blankImage 100 100 black]
- #set img [compositeImage 300 300 ${image2}]
- renderImage ${c} 0 0 ${bg}