00001 # TKE - Advanced Programmer's Editor
00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com)
00003 #
00004 # This program is free software; you can redistribute it and/or modify
00005 # it under the terms of the GNU General Public License as published by
00006 # the Free Software Foundation; either version 2 of the License, or
00007 # (at your option) any later version.
00008 #
00009 # This program is distributed in the hope that it will be useful,
00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of
00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
00012 # GNU General Public License for more details.
00013 #
00014 # You should have received a copy of the GNU General Public License along
00015 # with this program; if not, write to the Free Software Foundation, Inc.,
00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
00017
00018 ######################################################################
00019 # Name: scroller.tcl
00020 # Author: Trevor Williams (phase1geo@gmail.com)
00021 # Date: 3/23/2015
00022 # Brief: Scrollbar used in editor.
00023 ######################################################################
00024
00025 namespace eval scroller {
00026
00027 array set data {}
00028
00029 ######################################################################
00030 # Creates the difference map which is basically a colored scrollbar.
00031 proc scroller {win args} {
00032
00033 variable data
00034
00035 array set opts {
00036 -background "white"
00037 -foreground "black"
00038 -altforeground "red"
00039 -orient "vertical"
00040 -command ""
00041 -markcommand1 ""
00042 -markcommand2 ""
00043 -thickness 15
00044 -markhide1 0
00045 -markhide2 0
00046 -autohide 0
00047 -usealt 0
00048 }
00049 array set opts $args
00050
00051 set data($win,-background) $opts(-background)
00052 set data($win,-foreground) $opts(-foreground)
00053 set data($win,-altforeground) $opts(-altforeground)
00054 set data($win,-orient) $opts(-orient)
00055 set data($win,-command) $opts(-command)
00056 set data($win,-markcommand1) $opts(-markcommand1)
00057 set data($win,-markcommand2) $opts(-markcommand2)
00058 set data($win,-thickness) $opts(-thickness)
00059 set data($win,-markhide1) $opts(-markhide1)
00060 set data($win,-markhide2) $opts(-markhide2)
00061 set data($win,-autohide) $opts(-autohide)
00062 set data($win,-usealt) $opts(-usealt)
00063
00064 # Constant values
00065 set data($win,minwidth) 3
00066 set data($win,minheight) 21
00067
00068 # Variables
00069 set data($win,extra_width) [expr {(($opts(-markcommand1) ne "") ? 3 : 0) + (($opts(-markcommand2) ne "") ? 3 : 0)}]
00070 set data($win,slider_width) $data($win,minwidth)
00071 set data($win,pressed) 0
00072 set data($win,first) 0.0
00073 set data($win,last) 1.0
00074 set data($win,marks) 0
00075 set data($win,after_id) ""
00076
00077 # Create the canvas
00078 if {$data($win,-orient) eq "vertical"} {
00079 set data($win,canvas) [canvas $win -height 1 -width [expr $data($win,-thickness) + $data($win,extra_width)] -relief flat -bd 1 -highlightthickness 0 -bg $data($win,-background)]
00080 } else {
00081 set data($win,canvas) [canvas $win -width 1 -height $data($win,-thickness) -relief flat -bd 1 -highlightthickness 0 -bg $data($win,-background)]
00082 }
00083
00084 # Create canvas bindings
00085 bind $data($win,canvas) <Configure> [list scroller::configure %W]
00086 bind $data($win,canvas) <ButtonPress-1> [list scroller::position_slider %W %x %y 0]
00087 bind $data($win,canvas) <ButtonRelease-1> [list scroller::release_slider %W]
00088 bind $data($win,canvas) <ButtonPress-$::right_click> [list scroller::page_slider %W %x %y]
00089 bind $data($win,canvas) <B1-Motion> [list scroller::position_slider %W %x %y 1]
00090 bind $data($win,canvas) <Enter> [list scroller::enter %W]
00091 bind $data($win,canvas) <Leave> [list scroller::leave %W %x %y]
00092 bind $data($win,canvas) <MouseWheel> [list scroller::wheel_slider %W %D]
00093 bind $data($win,canvas) <4> [list scroller::wheel_slider %W 1]
00094 bind $data($win,canvas) <5> [list scroller::wheel_slider %W -1]
00095
00096 bind $win <Destroy> [list array unset scroller::data %W,*]
00097
00098 rename ::$win $win
00099 interp alias {} ::$win {} scroller::widget_command $win
00100
00101 return $win
00102
00103 }
00104
00105 ######################################################################
00106 # Executes map commands.
00107 proc widget_command {win args} {
00108
00109 variable data
00110
00111 set args [lassign $args cmd]
00112
00113 switch $cmd {
00114
00115 get {
00116 return [list $data($win,first) $data($win,last)]
00117 }
00118
00119 set {
00120 if {![info exists data($win,slider)]} {
00121 return
00122 }
00123 lassign $args first last
00124 set data($win,first) $first
00125 set data($win,last) $last
00126 if {$data($win,-orient) eq "vertical"} {
00127 set height [winfo height $data($win,canvas)]
00128 set x1 [expr ($data($win,-thickness) + $data($win,extra_width)) - $data($win,slider_width)]
00129 set y1 [expr int( $height * $first )]
00130 set x2 [expr $data($win,-thickness) + $data($win,extra_width)]
00131 set y2 [expr int( $height * $last )]
00132 if {($y2 - $y1) < $data($win,minheight)} {
00133 set height [expr $height - ($data($win,minheight) - ($y2 - $y1))]
00134 set y1 [expr int( $height * $first )]
00135 set y2 [expr $y1 + $data($win,minheight)]
00136 }
00137 $data($win,canvas) configure -width [expr (($first == 0) && ($last == 1) && ($data($win,marks) == 0) && $data($win,-autohide)) ? 0 : ($data($win,-thickness) + $data($win,extra_width))]
00138 } else {
00139 set width [winfo width $data($win,canvas)]
00140 set x1 [expr int( $width * $first )]
00141 set y1 [expr $data($win,-thickness) - $data($win,slider_width)]
00142 set x2 [expr int( $width * $last )]
00143 set y2 $data($win,-thickness)
00144 if {($x2 - $x1) < $data($win,minheight)} {
00145 set width [expr $width - ($data($win,minheight) - ($x2 - $x1))]
00146 set x1 [expr int( $width * $first )]
00147 set x2 [expr $x1 + $data($win,minheight)]
00148 }
00149 $data($win,canvas) configure -height [expr (($first == 0) && ($last == 1) && ($data($win,marks) == 0) && $data($win,-autohide)) ? 0 : $data($win,-thickness)]
00150 }
00151 $data($win,canvas) coords $data($win,slider) [expr $x1 + 2] [expr $y1 + 2] $x2 $y2
00152 }
00153
00154 configure {
00155 array set opts $args
00156 if {[info exists opts(-background)]} {
00157 set data($win,-background) $opts(-background)
00158 $data($win,canvas) configure -bg $data($win,-background)
00159 }
00160 if {[info exists opts(-usealt)]} {
00161 set data($win,-usealt) $opts(-usealt)
00162 }
00163 if {[info exists opts(-foreground)]} {
00164 set data($win,-foreground) $opts(-foreground)
00165 }
00166 if {[info exists opts(-altforeground)]} {
00167 set data($win,-altforeground) $opts(-altforeground)
00168 }
00169 if {[info exists opts(-usealt)] || [info exists opts(-foreground)] || [info exists opts(-altforeground)]} {
00170 set color [expr {$data($win,-usealt) ? $data($win,-altforeground) : $data($win,-foreground)}]
00171 if {[info exists data($win,slider)]} {
00172 $data($win,canvas) itemconfigure $data($win,slider) -outline $color -fill $color
00173 }
00174 }
00175 if {[info exists opts(-thickness)]} {
00176 set data($win,-thickness) $opts(-thickness)
00177 if {$data($win,-orient) eq "vertical"} {
00178 $data($win,canvas) configure -width [expr $data($win,-thickness) + $data($win,extra_width)]
00179 } else {
00180 $data($win,canvas) configure -height $data($win,-thickness)
00181 }
00182 }
00183 if {($data($win,-orient) eq "vertical") && ([info exists opts(-markhide1)] || [info exists opts(-markhide2)])} {
00184 for {set i 1} {$i <= 2} {incr i} {
00185 if {[info exists opts(-markhide$i)]} {
00186 set data($win,-markhide$i) $opts(-markhide$i)
00187 }
00188 }
00189 update_markers $win
00190 }
00191 }
00192
00193 default {
00194 return -code error "scroller called with invalid command ($cmd)"
00195 }
00196
00197 }
00198
00199 }
00200
00201 ######################################################################
00202 # Handles a left-click or click-drag in the canvas area, positioning
00203 # the cursor at the given position.
00204 proc position_slider {W x y motion} {
00205
00206 variable data
00207
00208 if {$data($W,-command) ne ""} {
00209
00210 # Indicate that we are pressed
00211 set data($W,pressed) 1
00212
00213 if {$motion || ([$data($W,canvas) find withtag current] ne $data($W,slider))} {
00214
00215 # Get the coordinates for the slider
00216 lassign [$data($W,canvas) coords $data($W,slider)] x1 y1 x2 y2
00217
00218 # Calculate the moveto fraction
00219 if {$data($W,-orient) eq "vertical"} {
00220 set moveto [expr ($y.0 - (($y2 - $y1) / 2)) / [winfo height $W]]
00221 } else {
00222 set moveto [expr ($x.0 - (($x2 - $x1) / 2)) / [winfo width $W]]
00223 }
00224
00225 # Call the command
00226 uplevel #0 "$data($W,-command) moveto $moveto"
00227
00228 }
00229
00230 }
00231
00232 }
00233
00234 ######################################################################
00235 # Indicate that the slider button has been released.
00236 proc release_slider {W} {
00237
00238 variable data
00239
00240 set data($W,pressed) 0
00241
00242 }
00243
00244 ######################################################################
00245 # Handles a mouse enter event.
00246 proc enter {W} {
00247
00248 variable data
00249
00250 set data(after_id) [after 300 scroller::expand_slider $W]
00251
00252 }
00253
00254 ######################################################################
00255 # Handles a mouse leave event.
00256 proc leave {W x y} {
00257
00258 variable data
00259
00260 # If this isn't a real leave event (i.e., due to mouse clicking), don't collpase the slider
00261 if {($x >= 0) && ($x < [winfo width $W]) && ($y >= 0) && ($y < [winfo height $W])} {
00262 return
00263 }
00264
00265 # Cancel the enter ID
00266 after cancel $data(after_id)
00267
00268 # Collapse the slider (if necessary)
00269 collapse_slider $W
00270
00271 }
00272
00273 ######################################################################
00274 # Expands the slider to make it easier to grab.
00275 proc expand_slider {W} {
00276
00277 variable data
00278
00279 if {!$data($W,pressed) && ($data($W,slider_width) != $data($W,-thickness))} {
00280
00281 set data($W,slider_width) $data($W,-thickness)
00282
00283 lassign [eval $data($W,-command)] first last
00284
00285 widget_command $W set $first $last
00286
00287 }
00288
00289 }
00290
00291 ######################################################################
00292 # Collapses the slider to make it less obtrusive.
00293 proc collapse_slider {W} {
00294
00295 variable data
00296
00297 if {!$data($W,pressed)} {
00298
00299 set data($W,slider_width) $data($W,minwidth)
00300
00301 lassign [eval $data($W,-command)] first last
00302
00303 widget_command $W set $first $last
00304
00305 }
00306
00307 }
00308
00309 ######################################################################
00310 # Moves the text view up or left by a page.
00311 proc page_slider {W x y} {
00312
00313 variable data
00314
00315 if {[$data($W,canvas) find withtag current] ne $data($W,slider)} {
00316 lassign [$data($W,canvas) coords $data($W,slider)] x1 y1
00317 if {(($data($W,-orient) eq "vertical") && ($y < $y1)) || (($data($W,-orient) eq "horizontal") && ($x < $x1))} {
00318 uplevel #0 [list {*}$data($W,-command) scroll -1 pages]
00319 } else {
00320 uplevel #0 [list {*}$data($W,-command) scroll 1 pages]
00321 }
00322 }
00323
00324 }
00325
00326 ######################################################################
00327 # Moves the text view via a mousewheel event.
00328 proc wheel_slider {W d} {
00329
00330 variable data
00331
00332 switch [tk windowingsystem] {
00333 x11 -
00334 aqua { uplevel #0 [list {*}$data($W,-command) scroll [expr -($d)] units] }
00335 win32 { uplevel #0 [list {*}$data($W,-command) scroll [expr int( pow( $d / -120, 3 ) )] units] }
00336 }
00337
00338 }
00339
00340 ######################################################################
00341 # Called whenever the map widget is configured.
00342 proc configure {win} {
00343
00344 variable data
00345
00346 # Remove all canvas items
00347 $data($win,canvas) delete all
00348
00349 # Draw the markers
00350 update_markers $win
00351
00352 # Calculate the foreground color
00353 set foreground [expr {$data($win,-usealt) ? $data($win,-altforeground) : $data($win,-foreground)}]
00354
00355 # Add the slider
00356 set data($win,slider) [$data($win,canvas) create rectangle 0 0 1 1 -outline $foreground -fill $foreground -width 2 -state disabled]
00357
00358 # Set the size and position of the slider
00359 widget_command $win set {*}[eval $data($win,-command)]
00360
00361 }
00362
00363 ######################################################################
00364 # Draw the markers in the scrollbar.
00365 proc update_markers {win} {
00366
00367 variable data
00368
00369 # Get the lines
00370 set height [winfo height $win]
00371
00372 # Delete all markers
00373 $data($win,canvas) delete mark
00374
00375 # Clear the marker count
00376 set data($win,marks) 0
00377
00378 foreach i {1 2} {
00379
00380 # If the -markcommandx was not set or the -hide indicator is set for markcommand1, don't continue
00381 if {($data($win,-markcommand$i) eq "") || $data($win,-markhide$i)} {
00382 continue
00383 }
00384
00385 # Draw each of the markers
00386 foreach {startpos endpos color} [uplevel #0 $data($win,-markcommand$i)] {
00387 set x1 [expr ($i == 1) ? 0 : 3]
00388 set y1 [expr int( $height * $startpos)]
00389 set x2 [expr $data($win,-thickness) + $data($win,extra_width)]
00390 set y2 [expr int( $height * $endpos)]
00391 set marker [$data($win,canvas) create rectangle $x1 $y1 $x2 $y2 -fill $color -width 0 -tags mark -state disabled]
00392 incr data($win,marks)
00393 }
00394
00395 }
00396
00397 # Put the scrollbar above everything
00398 catch { $data($win,canvas) raise $data($win,slider) }
00399
00400 }
00401
00402 }
00403
