gui/implementation/CanvasBox.tcl


@implementation CanvasBox {
  - init {} {
      $super init
      $super hideBorder 
      set zoom 0
      $self zoomFactor: 2

      set bg [[entry $path._e] cget -background]
      destroy $path._e

      $frame configure -relief sunken -bd 1

      set canvas [canvas $frame.canvas -width 1 -height 1 -bd 1 -relief flat]
      $canvas configure -bg $bg

      set xscroll [scrollbar $frame.xscroll -orient horizontal \
        -command "$canvas xview"]
      set yscroll [scrollbar $frame.yscroll -orient vertical \
        -command "$canvas yview"]

      grid rowconfigure $frame 0 -weight 1
      grid columnconfigure $frame 0 -weight 1
      grid $canvas $yscroll -sticky snew -padx 0 -pady 0
      grid $xscroll -sticky snew -padx 0 -pady 0

      $canvas configure -xscrollcommand "$xscroll set" \
        -yscrollcommand "$yscroll set"

      $self enableEvent: Configure on: $canvas
      $self on: Configure do: "$canvas configure -scrollregion \[$canvas bbox all\]"

      $self enableEvent: {Button-4 Button-5} on: $canvas
      $self on: Button-4 do: {$canvas yview scroll -1 units}
      $self on: Button-5 do: {$canvas yview scroll +1 units}
      
      $self enableEvent: {
        Alt-ButtonPress-1 Alt-ButtonPress-3 
        Alt-ButtonRelease-1 Alt-ButtonRelease-3
      } on: $canvas

      $self on: Alt-ButtonPress-1 do: {$self startZooming}
      $self on: Alt-ButtonPress-3 do: {$self startUnZooming}
      $self on: Alt-ButtonRelease-1 do: {$self stopZooming}
      $self on: Alt-ButtonRelease-3 do: {$self stopZooming}
    }

  - canvas {} {
      return $canvas
    }

  - zoomFactor: newFactor {
      set newFactor [expr 1.0 * $newFactor]
      if {($newFactor != 0.0) && ($newFactor != 1.0)} {
        $self zoomReset
        set zoomFactor $newFactor 
      }
    }

  - zoomFactor {} {
      return $zoomFactor
    }

  - zoom {} {
      $canvas scale all 0 0 $zoomFactor $zoomFactor
      $canvas configure -scrollregion [$canvas bbox all]
      incr zoom
    }

  - unzoom {} {
      set factor [expr 1.0/$zoomFactor]
      $canvas scale all 0 0 $factor $factor
      $canvas configure -scrollregion [$canvas bbox all]
      incr zoom -1
    }

  - zoomSync {} {
      #- to do after a canvas reset
      if {[set oldzoom $zoom] != 0} {
        set zoom 0
        if {$oldzoom > 0} {
          while {$zoom < $oldzoom} {
            $self zoom
          }
        } elseif {$oldzoom < 0} {
          while {$zoom > $oldzoom} {
            $self unzoom
          }
        }
      }
    }

  - zoomReset {} {
      if {$zoom != 0} {
        if {$zoom > 0} {
          while {$zoom > 0} { 
            $self unzoom
          }
        } elseif {$zoom < 0} {
          while {$zoom < 0} { 
            $self zoom
          }
        }
      }
    }

  - startZooming {} {
      $self stopZooming
      $self zooming
    }

  - zooming {} {
      $self zoom
      set cmd "$self zooming"
      set zoomingId [after 200 $cmd]
    }

  - startUnZooming {} {
      $self stopZooming
      $self unZooming
    }

  - unZooming {} {
      $self unzoom
      set cmd "$self unZooming"
      set zoomingId [after 200 $cmd]
    }

  - stopZooming {} {
      if {[string length $zoomingId]} {
        after cancel $zoomingId
        set zoomingId {}
      }
    }

  - canvasBackground: aColor {
      $canvas configure -bg $aColor
      $frame configure -bg $aColor
    }

  - canvasBackground {} {
      return [$canvas cget -background]
    }

  - busy {} {
      $canvas configure -cursor watch
    }
  - unbusy {} {
      $canvas configure -cursor {}
    }
}