package require Tk
package require treectrl

after 2000 tksnip_demo

proc tksnip_demo {} {
   wm minsize . 400 400
   wm geom . 900x600
   image create photo testimage
   button .b -text "Take a snip" -command [list tksnip testimage]
   button .q -text "Quit" -command [list exit]
   button .l -anchor sw -bd 0 \
           -text "Please wait until screen flashes. Select a screen region with your mouse. When you release, your image will be displayed."
   canvas .c -bd 2 -relief ridge -width 2000 -height 2000 \
        -scrollregion {0 0 2000 2000} \
        -xscrollcommand [list .x set] -yscrollcommand [list .y set]
   scrollbar .x -orient horizontal -command [list .c xview]
   scrollbar .y -orient vertical   -command [list .c yview]
   .c create image 0 0 -image testimage -anchor nw

     grid .c -row 1 -column 1 -sticky news -columnspan 2
     grid .x -row 2 -column 1 -sticky ew -columnspan 2
     grid .y -row 1 -column 3 -sticky ns
     grid .b -row 3 -column 1 -sticky ns
     grid .q -row 3 -column 2 -sticky ns
     grid .l -row 4 -column 1 -sticky news -columnspan 2

     grid rowconfigure    . 1 -weight 1
     grid rowconfigure    . 2 -weight 0
     grid rowconfigure    . 3 -weight 0
     grid columnconfigure . 1 -weight 1
     grid columnconfigure . 2 -weight 1
     grid columnconfigure . 3 -weight 0

}



################################
proc tksnip {{dest_img {}}} {
     global tksnip

     incr tksnip(id)
     set seq $tksnip(id)
     set win ".snip${seq}"
     if {[winfo exists $win]} {
               ### id not unique
          return ""
     }

     ### take the screenshot of the full screen
     set w [winfo screenwidth  .]
     set h [winfo screenheight .]
     lassign [tksnip_loupe 0 0 $w $h] bg_img x y w h

     ### use overrideredirect to pretend it is full screen
     ### and change its alpha level
     toplevel $win
     wm attributes $win -alpha 0.4
     wm geometry $win ${w}x${h}+0+0
     wm overrideredirect $win 1

     ### canvas
     set can $win.c
     canvas  $can -width $w -height $h -bd 0 -relief flat
     $win.c create image 0 0 -image $bg_img -anchor nw
     pack $can -fill both -expand 1

     ### initialize
     set tksnip($seq,topwin)     $win
     set tksnip($seq,canvas)     $can
     set tksnip($seq,full_img) $bg_img
     set tksnip($seq,dest_img) $dest_img
     set tksnip($seq,final_img) ""
     set tksnip($seq,coords)     [list]
     set tksnip($seq,region)   {}
     set tksnip($seq,afterID)    {}
     set tksnip($seq,finito)    ""

     ### canvas bindings
     bind $win <Button-1>        [list tksnip_button1     $seq {%x} {%y}]
     bind $win <B1-Motion>       [list tksnip_motion     $seq {%x} {%y}]
     bind $win <ButtonRelease-1> [list tksnip_release1   $seq {%x} {%y}]
     bind $win <Double-Button-1> [list tksnip_done    $seq]
     bind $win <Escape>          [list tksnip_done    $seq]

     bind $can <Button-1>        [list tksnip_button1     $seq {%x} {%y}]
     bind $can <B1-Motion>       [list tksnip_motion     $seq {%x} {%y}]
     bind $can <ButtonRelease-1> [list tksnip_release1   $seq {%x} {%y}]
     bind $can <Double-Button-1> [list tksnip_done    $seq]
     bind $can <Escape>          [list tksnip_done    $seq]

     switch -exact $::tcl_platform(platform) {
              windows { bind $win <Button-3>         [list tksnip_done $seq]
                   bind $can <Button-3>         [list tksnip_done $seq]
                  }

         default { bind $win <Button-2>         [list tksnip_done $seq]
                   bind $win <Command-Button-1> [list tksnip_done $seq]

                    bind $can <Button-2>         [list tksnip_done $seq]
                   bind $can <Command-Button-1> [list tksnip_done $seq]
                  }
     }

     ### auto-close if not completed within 30 seconds
     set tksnip($seq,afterID) [after [expr {30 * 1000}] [list tksnip_expire $seq]]

     ### indicate that screenshot is ready
     tksnip_flash $seq

     ### bring to focus
     raise $win
     focus $win

     ### wait for user to be done or until the time-out
     vwait tksnip($seq,finito)

     set retImg $tksnip($seq,final_img)

     ### delete the object
     tksnip_delete $seq

     return $retImg
}


################################
proc tksnip_delete {seq} {
     global tksnip

     catch {after cancel $tksnip($seq,afterID)}
     catch {destroy $tksnip($seq,topwin)}
     array unset tksnip "*,*"
}


################################
proc tksnip_done {seq} {
     global tksnip

     ### all done
     set tksnip($seq,finito) "finito..."
}


################################
proc tksnip_flash {seq} {
     global tksnip

     ### toplevel window
     set topwin $tksnip($seq,topwin)

     ### update toplevel border style as a visual clue
     set orig [$topwin cget -relief]
     set bd   [$topwin cget -bd]
     set styles [list sunken ridge]
     set mod    [llength $styles]
     set newBD 8


     ### highlight the window
     for {set i 0} {$i < 8} {incr i} {
          after 200
               $topwin config -bd $newBD \
                           -relief [lindex $styles [expr {$i % $mod}]]
          update idletasks
     }

     ### restore orig relief
     $topwin config -bd $bd -relief $orig
}


################################
proc tksnip_button1 {seq x y} {
     global tksnip


     ### start rubberbanding the screenshot area
     set tksnip($seq,coords) [list $x $y $x $y]


     ### draw it
     set tksnip($seq,region) [$tksnip($seq,canvas)              \
                                      create rectangle $x $y $x $y              \
                                      -dash {_}                \
                                      -outline #337f4c        \
                                      -fill    #ffffbd        \
                                      -width   3
                                      ]

     ### make selected area visible
     $tksnip($seq,canvas) raise $tksnip($seq,region) all


     return
}


################################
proc tksnip_motion {seq x y} {
     global tksnip

     ### update with new coordinates
     lassign $tksnip($seq,coords) fromX fromY oldX oldY
     set tksnip($seq,coords) [list $fromX $fromY $x $y]

     ### update the display
     $tksnip($seq,canvas) coords $tksnip($seq,region) $fromX $fromY $x $y
}


################################
proc tksnip_release1 {seq x y} {
     global tksnip

     ### get the start coordinates of the rubberband
     lassign $tksnip($seq,coords) x1 y1 x2 y2

     ### width/height of the selected area
     set regionw [expr {int(abs($x1 - $x2))}]
     set regionh [expr {int(abs($y1 - $y2))}]

     if {$x1 > $x2} {
          set x1 $x2
          set x1 $y2
     }

     set src_img  $tksnip($seq,full_img)
     set dest_img $tksnip($seq,dest_img)
     set x2  [expr {min($x1 + $regionw, [image width  $src_img])}]
     set y2  [expr {min($y1 + $regionh, [image height $src_img])}]


     ### create a new image of the requested size
     if {$dest_img eq ""} {
               set temp_img [image create photo -width $regionw -height $regionh]
     } else {
               set temp_img [image create photo $dest_img \
                                            -width $regionw -height $regionh]
     }

     ### crop it
     $temp_img copy $src_img -from $x1 $y1 $x2 $y2
     set tksnip($seq,final_img) $temp_img

     ### done
     tksnip_done $seq
}


################################
proc tksnip_expire {seq} {
     global tksnip

     ### done
     if {[info exists tksnip($seq,topwin)]} {
          tksnip_done $seq
     }
}


################################
proc tksnip_loupe {x y w h} {
     if {[llength [info commands "loupe"]] == 0} {
               ### loupe command not available
          return [list]
     } else {
          set img [image create photo -width $w -height $h]
          loupe $img $x $y $w $h 1

          return [list $img $x $y $w $h]
     }
}