Scale images down if they can't fit in the text area

1 files changed, 35 insertions, 0 deletions

diff --git a/tkread b/tkread
index 12d4908..e6c7c87 100755
--- a/tkread
+++ b/tkread
@@ -327,6 +327,40 @@ proc changeFontSize {change} {
 			.t tag configure prefix_$x -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
 		}
 	}
+	scaleImages
+}
+
+proc reduceImageIfNeeded {img maxwidth} {
+	set curwidth [image width $img]
+	if {$curwidth > $maxwidth} {
+		set t [image create photo]
+		$t copy $img
+		$img blank
+		set zoom [expr round($curwidth.0 / $maxwidth)]
+		$img copy $t -shrink -subsample $zoom
+		image delete $t
+	}
+}
+
+proc scaleImages {} {
+	global fontfamily
+	global fontsize
+
+	foreach img [.t image names] {
+		# note width is 64 * (width of '0' char)
+		set charwidth [font measure "{$fontfamily} $fontsize" "0"]
+		set maxwidth [expr $charwidth * 64]
+		set curwidth [image width $img]
+		if {$curwidth < $maxwidth} {
+			# re-load the image as it may have been shrunk
+			# TODO: could make this more efficient by keeping track of which images actually have been shrunk
+			# TODO: also should keep copies of the original image in memory
+			puts "$curwidth < $maxwidth"
+			set f [$img cget -file]
+			$img read $f
+		}
+		reduceImageIfNeeded $img $maxwidth
+	}
 }
 
 proc invertColours {} {
@@ -378,6 +412,7 @@ if { $domarkdown } {
 	markup .t
 }
 .t configure -state disabled ;# disable text insertion & cursor
+scaleImages
 
 bind . <Up> {scroll -1 unit}
 bind . <k> {scroll -1 unit}