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