Made the mouse wheel bindings for the text widget (which scroll by pixels) and the sort arrows of the Widget Demo script mclist.tcl scaling-aware.

3 files changed, 28 insertions, 26 deletions

diff --git a/library/demos/mclist.tcl b/library/demos/mclist.tcl
index 73b2b7a..d91fb5c 100644
--- a/library/demos/mclist.tcl
+++ b/library/demos/mclist.tcl
@@ -28,7 +28,7 @@ pack [addSeeDismiss $w.seeDismiss $w {} {
 
 ttk::frame $w.container
 ttk::treeview $w.tree -columns {country capital currency} -show headings \
-    -yscroll "$w.vsb set" -xscroll "$w.hsb set" 
+    -yscroll "$w.vsb set" -xscroll "$w.hsb set"
 ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview"
 ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview"
 pack $w.container -fill both -expand 1
@@ -37,13 +37,23 @@ grid $w.hsb         -in $w.container -sticky nsew
 grid column $w.container 0 -weight 1
 grid row    $w.container 0 -weight 1
 
-image create photo upArrow -data {
-    R0lGODlhDgAOAJEAANnZ2YCAgPz8/P///yH5BAEAAAAALAAAAAAOAA4AAAImhI+
-    py+1LIsJHiBAh+BgmiEAJQITgW6DgUQIAECH4JN8IPqYuNxUAOw==}
-image create photo downArrow -data {
-    R0lGODlhDgAOAJEAANnZ2YCAgPz8/P///yH5BAEAAAAALAAAAAAOAA4AAAInhI+
-    py+1I4ocQ/IgDEYIPgYJICUCE4F+YIBolEoKPEJKZmVJK6ZACADs=}
-image create photo noArrow -height 14 -width 14
+image create photo upArrow -format $tk::svgFmt -data {
+    <?xml version="1.0" encoding="UTF-8"?>
+    <svg width="16" height="4" version="1.1" xmlns="http://www.w3.org/2000/svg">
+     <path d="m4 4 4-4 4 4z" fill="#000"/>
+    </svg>
+}
+image create photo downArrow -format $tk::svgFmt -data {
+    <?xml version="1.0" encoding="UTF-8"?>
+    <svg width="16" height="4" version="1.1" xmlns="http://www.w3.org/2000/svg">
+     <path d="m4 0 4 4 4-4z" fill="#000"/>
+    </svg>
+}
+image create photo noArrow -format $tk::svgFmt -data {
+    <?xml version="1.0" encoding="UTF-8"?>
+    <svg width="16" height="4" version="1.1" xmlns="http://www.w3.org/2000/svg">
+    </svg>
+}
 
 ## The data we're going to insert
 set data {
@@ -66,12 +76,11 @@ set data {
 
 ## Code to insert the data nicely
 set font [ttk::style lookup Heading -font]
+set morePx [expr {[image width noArrow] + round(4 * $tk::scalingPct / 100.0)}]
 foreach col {country capital currency} name {Country Capital Currency} {
     $w.tree heading $col -text $name -image noArrow -anchor w \
 	-command [list SortBy $w.tree $col 0]
-    $w.tree column $col -width [expr {
-	[font measure $font $name] + [image width noArrow] + 5
-    }]
+    $w.tree column $col -width [expr {[font measure $font $name] + $morePx}]
 }
 set font [ttk::style lookup Treeview -font]
 foreach {country capital currency} $data {
diff --git a/library/scaling.tcl b/library/scaling.tcl
index a7b6ea6..51180e8 100644
--- a/library/scaling.tcl
+++ b/library/scaling.tcl
@@ -125,21 +125,14 @@ proc ::tk::ScalingPct {} {
 
 # ::tk::ScaleNum --
 #
-# Scales a nonnegative integer according to the display's current scaling
-# percentage.
+# Scales an integer according to the display's current scaling percentage.
 #
 # Arguments:
-#   num - A nonnegative integer.
+#   num - An integer.
 
 proc ::tk::ScaleNum num {
-    set pct [::tk::ScalingPct]
-    set factor [expr {$num * $pct}]
-    set result [expr {$factor / 100}]
-    if {$factor % 100 >= 50} {
-	incr result
-    }
-
-    return $result
+    variable scalingPct
+    return [expr {round($num * $scalingPct / 100.0)}]
 }
 
 # ::tk::ScanMonitorsFile --
diff --git a/library/text.tcl b/library/text.tcl
index eb73db0..e5a4c11 100644
--- a/library/text.tcl
+++ b/library/text.tcl
@@ -457,16 +457,16 @@ bind Text <B2-Motion> {
 set ::tk::Priv(prevPos) {}
 
 bind Text <MouseWheel> {
-    tk::MouseWheel %W y %D -4.0 pixels
+    tk::MouseWheel %W y [tk::ScaleNum %D] -4.0 pixels
 }
 bind Text <Option-MouseWheel> {
-    tk::MouseWheel %W y %D -1.2 pixels
+    tk::MouseWheel %W y [tk::ScaleNum %D] -1.2 pixels
 }
 bind Text <Shift-MouseWheel> {
-    tk::MouseWheel %W x %D -4.0 pixels
+    tk::MouseWheel %W x [tk::ScaleNum %D] -4.0 pixels
 }
 bind Text <Shift-Option-MouseWheel> {
-    tk::MouseWheel %W x %D -1.2 pixels
+    tk::MouseWheel %W x [tk::ScaleNum %D] -1.2 pixels
 }
 
 # ::tk::TextClosestGap --