path: root/tkread

#!/usr/bin/tclsh
# Requires Tk and Img packages (tk and libtk-img in Debian)
#
# Copyright 2013-2014 Nick White <njw.me.uk>, released under the ISC License
#
# Permission to use, copy, modify, and/or distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.

set usage {tkread [-w] [-m]
 -w rewrap lines
 -m format markdown text}

# The markdown parsing is inspired by the code of smu:
# <https://github.com/Gottox/smu> 
#
# TODO:
# - `` wrapping code (eg make monospace)
# - bug: regular [square brackets] have the opening bracket removed
# - rewrap after markdown processing (or just rewrap more smartly), so that things like underlines aren't screwed up by it
# - justify text (not simple; see http://wiki.tcl.tk/1774)
# - add a basic search function
# - add function to type 30g to scroll 30% through an article
# - if window width is small, reduce padx space
# - make scrolling using mouse work even when text area isn't hovered over (also note this sort of scrolling doesn't update the title); integrate the MouseWheel event with scroll. this *should* also fix the issue of dragging and then leaving the window, as the strange scrolling is likely caused by related default behaviour
# - add more markdown processing

set fontfamily {Linux Libertine O}
set fontsize 11
set textcolour #443322
set bgcolour #eeeee2
set outercolour #222222
set selectbgcolour #ffffff
set inverttextcolour #eeeeee
set invertbgcolour #333030
set invertoutercolour #222222
set width 64

set inverted 0
set drag 0
set tagnum 0
set underlinenum 0
set prefixnum 0
set domarkdown 0

set surroundfmt { \
      {"***" "0" "bold italic"} \
      {"**" "0" "bold"} \
      {"*" "0" "italic"} \
     }

set underlinefmt { \
	{"=" "6" ""} \
	{"-" "3" "italic"} \
}

set prefixfmt { \
	{"# " "6" ""} \
	{"## " "3" "italic"} \
	{"### " "1" "italic"} \
	{"#### " "0" "italic"} \
	{"##### " "0" "italic"} \
	{"###### " "0" "italic"} \
}

set listitems { \
	{\* *} \
	{- *} \
	{\+ *} \
}

# Using low asterisk so it isn't interpreted as markdown later
set replacements { \
	{{^\* \* \* \* \*$} "―"} \
	{{\\$} ""} \
	{{\\\$} "$"} \
	{{\\\*} "⁎"} \
	{{\\#} "#"} \
	{{\\_} "_"} \
}

array set imgcache {}
array set imgshrunk {}

if { $::argc > 0 && [lindex $::argv 0] == "-h" } {
	puts "Usage: $usage"
	exit
}

package require Tk
package require Img

proc rewrap {text} {
	set wrapped [regsub -all {\n([^\n])} $text { \1}]
	set spaced [regsub -all {  *} $wrapped { }]
	set better [regsub -all {\n *} $spaced "\n"]
	set better [regsub -all {\n} $better "\n\n"]
	return [regsub -all {\n\n\n} $better "\n"]
}

# Moves char part of a text widget index (linenum.charnum)
proc indexmovechar {str moveby} {
	set dotindex [string first . $str]
	set charnum [string range $str [expr $dotindex + 1] end]
	set linenum [string range $str 0 [expr $dotindex - 1]]
	return $linenum.[expr $charnum $moveby]
}

# Moves line part of a text widget index (linenum.charnum)
proc indexmoveline {str moveby} {
	set dotindex [string first . $str]
	set charnum [string range $str [expr $dotindex + 1] end]
	set linenum [string range $str 0 [expr $dotindex - 1]]
	return [expr $linenum $moveby].$charnum
}

# TODO: move each section into their own procedures
proc markup {widget} {
	global fontfamily
	global fontsize
	global surroundfmt
	global underlinefmt
	global prefixfmt
	global listitems
	global replacements
	global tagnum
	global underlinenum
	global prefixnum
	global imgcache
	global imgshrunk

	# process replacements
	foreach item $replacements {
		set searchfor [lindex $item 0]
		set replacement [lindex $item 1]

		set cur [$widget search -count len -regex "$searchfor" 0.0 end]
		while {$cur != ""} {
			$widget replace $cur [indexmovechar $cur "+ $len"] "$replacement"
			set cur [$widget search -regex "$searchfor" $cur end]
		}
	}

	# process images
	set cur [$widget search {![} 0.0 end]
	while {$cur != ""} {
		set altstart [indexmovechar $cur "+ 2"]
		set cur [$widget search "](" $cur end]
		if {$cur == ""} { break }
		set altend $cur
		set srcstart [indexmovechar $cur "+ 2"]
		set cur [$widget search ")" $cur end]
		if {$cur == ""} { break }
		set srcend $cur

		set alt [$widget get $altstart $altend]
		set src [$widget get $srcstart $srcend]

		# sometimes "title" tags are encoded after a space following the source, enclosed in ""
		set imgtitlestart [string first " " $src]
		if {$imgtitlestart != -1} {
			set imgtitle [string trim [string range $src $imgtitlestart end] {" }]
			set src [string range $src 0 [expr $imgtitlestart - 1] ]
		} else {
			set imgtitle ""
		}

		$widget delete [indexmovechar $altstart "- 2"] [indexmovechar $srcend "+ 1"]
		set insertion [indexmovechar $altstart "- 2"]
		set localfile [file tail $src]
		if { [file exists $localfile] && ! [catch { set curimg [image create photo -file $localfile] }] } {
			set imgcache($curimg) [image create photo]
			$imgcache($curimg) copy $curimg
			set imgshrunk($curimg) 0
			$widget image create $insertion -image $curimg -align baseline
			set cur $insertion
		} else {
			$widget insert $insertion $alt
			set cur [indexmovechar $insertion "+ [string length $alt]"]
		}

		set insertion [indexmoveline $insertion "+ 1"]
		if {[string length $imgtitle] != 0} {
			$widget insert $insertion "${imgtitle}\n"
		}

		set cur [$widget search {![} $cur end]
	}

	# remove links
	# TODO: search for ]( and then work back to find the [, as otherwise false positives occur when something like 'strike[s] him' is encountered
	# TODO: save the link contents and allow the links to be shown / hidden with a keystroke
	set cur [$widget search {[} 0.0 end]
	while {$cur != ""} {
		set altstart [indexmovechar $cur "+ 1"]
		set cur [$widget search "](" $cur end]
		if {$cur == ""} { break }
		set altend $cur
		set srcstart [indexmovechar $cur "+ 2"]
		set cur [$widget search ")" $cur end]
		if {$cur == ""} { break }
		set srcend $cur

		set alt [$widget get $altstart $altend]
		set src [$widget get $srcstart $srcend]

		$widget delete $altend [indexmovechar $srcend "+ 1"]
		$widget delete [indexmovechar $altstart "- 1"] $altstart

		set cur [indexmovechar $altend "- 1"]
		set cur [$widget search {[} $cur end]
	}


	# process underlined headings
	foreach fmt $underlinefmt {
		set searchchar [lindex $fmt 0]
		set fmtsizemod [lindex $fmt 1]
		set fmtstring [lindex $fmt 2]

		set cur [$widget search -regexp "^$searchchar$searchchar*\$" 0.0 end]
		while {$cur != ""} {
			set dotindex [string first . $cur]
			set linenum [string range $cur 0 [expr $dotindex - 1]]
			$widget tag add underline_$underlinenum [expr $linenum - 1].0 $linenum.end
			$widget delete $linenum.0 [expr $linenum + 1].0

			set cur [$widget search -regexp "^$searchchar$searchchar*\$" [expr $linenum + 1].0 end]
		}
		$widget tag configure underline_$underlinenum -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
		incr underlinenum
	}

	# process line prefixes
	foreach fmt $prefixfmt {
		set searchchar [lindex $fmt 0]
		set fmtsizemod [lindex $fmt 1]
		set fmtstring [lindex $fmt 2]

		set cur [$widget search -regexp "^$searchchar" 0.0 end]
		while {$cur != ""} {
			set dotindex [string first . $cur]
			set linenum [string range $cur 0 [expr $dotindex - 1]]
			$widget tag add prefix_$prefixnum $linenum.0 $linenum.end
			$widget delete $linenum.0 $linenum.[string length $searchchar]

			set cur [$widget search -regexp "^$searchchar" [expr $linenum + 1].0 end]
		}
		$widget tag configure prefix_$prefixnum -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
		incr prefixnum
	}

	# process surrounds (bold, italic, and some headers)
	# This uses marks before tags, as they handle deletions fine, so
	# marks can be made and then the formatting characters can be
	# deleted without affecting the position for formatting
	# (should try just tags as they may still work).
	foreach fmt $surroundfmt {
		set searchchar [lindex $fmt 0]
		set fmtsizemod [lindex $fmt 1]
		set fmtstring [lindex $fmt 2]
		set searchlen [string length $searchchar]
		set insection 0
		set cur ""
		set markonnum 0
		set markoffnum 0

		set cur [$widget search $searchchar 0.0 end]
		while {$cur != ""} {
			if {$insection == 0} {
				set insection 1
				$widget mark set markon_$markonnum $cur
				incr markonnum
			} else {
				set insection 0
				$widget mark set markoff_$markoffnum $cur
				incr markoffnum
			}
			$widget delete $cur "$cur + $searchlen chars"

			set cur [$widget search "$searchchar" $cur end]
		}

		# ignore any final mismatched mark
		if {$markonnum != $markoffnum } {
			set markonnum $markoffnum
		}

		for {set x 0} {$x < $markonnum} {incr x} {
			$widget tag add tag_$tagnum markon_$x markoff_$x
		}

		$widget tag configure tag_$tagnum -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
		incr tagnum
	}

	# process lists
	foreach item $listitems {
		set cur [$widget search -count len -regexp "^$item" 0.0 end]
		while {$cur != ""} {
			set dotindex [string first . $cur]
			set linenum [string range $cur 0 [expr $dotindex - 1]]
			$widget replace $linenum.0 $linenum.$len "• "
			set cur [$widget search -regexp "^$item" $cur end]
		}
	}
}

proc changeFontSize {change} {
	global fontfamily
	global fontsize
	global surroundfmt
	global tagnum
	global underlinefmt
	global underlinenum
	global prefixfmt
	global prefixnum

	set newsize [expr $fontsize $change]
	if {$newsize > 0} {
		set fontsize $newsize
		.t configure -font "{$fontfamily} $fontsize" -padx [expr $fontsize * 3]
		for {set x 0} {$x < $tagnum} {incr x} {
			set fmtstring [lindex [lindex $surroundfmt $x] 2]
			set fmtsizemod [lindex [lindex $surroundfmt $x] 1]
			.t tag configure tag_$x -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
		}
		for {set x 0} {$x < $underlinenum} {incr x} {
			set fmtstring [lindex [lindex $underlinefmt $x] 2]
			set fmtsizemod [lindex [lindex $underlinefmt $x] 1]
			.t tag configure underline_$x -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
		}
		for {set x 0} {$x < $prefixnum} {incr x} {
			set fmtstring [lindex [lindex $prefixfmt $x] 2]
			set fmtsizemod [lindex [lindex $prefixfmt $x] 1]
			.t tag configure prefix_$x -font "{$fontfamily} [expr $fontsize + $fmtsizemod] $fmtstring"
		}
	}
	scaleImages
}

proc reduceImageIfNeeded {img maxwidth} {
	global imgshrunk

	set curwidth [image width $img]
	if {$curwidth > $maxwidth} {
		set zoom [expr int(ceil($curwidth.0 / $maxwidth))]
		if {$zoom > 1} {
			set t [image create photo]
			$t copy $img
			$img blank
			$img copy $t -shrink -subsample $zoom
			image delete $t
			set imgshrunk($img) 1
		}
	}
}

proc scaleImages {} {
	global fontfamily
	global fontsize
	global imgcache
	global imgshrunk
	global width

	foreach img [.t image names] {
		set charwidth [font measure "{$fontfamily} $fontsize" "0"]
		set maxwidth [expr $charwidth * $width]
		set curwidth [image width $img]
		if {$curwidth < $maxwidth} {
			if { $imgshrunk($img) == 1 } {
				$img copy $imgcache($img)
				set imgshrunk($img) 0
			}
		}
		reduceImageIfNeeded $img $maxwidth
	}
}

proc invertColours {} {
	global inverted
	global bgcolour textcolour outercolour
	global invertbgcolour inverttextcolour invertoutercolour
	if {$inverted} {
		set inverted 0
		.t configure -bg $bgcolour -fg $textcolour
		. configure -bg $outercolour
	} else {
		set inverted 1
		.t configure -bg $invertbgcolour -fg $inverttextcolour
		. configure -bg $invertoutercolour
	}
}

proc scroll {dir amount} {
	.t yview scroll $dir $amount
	set percent [expr [lindex [.t yview] 1] * 100]
	set rough [regsub {\..*} $percent {}]
	wm title . "tkread $rough%"
}

proc doMotion {ypos} {
	global lasty
	if { $lasty != -1 } {
		scroll [expr $lasty - $ypos] pixels
	}
	set lasty $ypos
}

if { [lsearch [font families] "$fontfamily"] == -1 } {
	# A font called "Times" is guaranteed by Tk to be available
	set fontfamily Times
}
. configure -bg $outercolour
text .t -font "{$fontfamily} $fontsize" -wrap word -width $width -padx [expr $fontsize * 3] -bg $bgcolour -fg $textcolour -relief flat -inactiveselectbackground $selectbgcolour
pack .t -expand yes -fill y
set text [read stdin]
foreach arg $::argv {
	switch $arg {
		-w { set text [rewrap $text] }
		-m { set domarkdown 1 }
	}
}
.t insert end $text
if { $domarkdown } {
	markup .t
}
.t configure -state disabled ;# disable text insertion & cursor
scaleImages

bind . <Up> {scroll -1 unit}
bind . <k> {scroll -1 unit}
bind . <Down> {scroll 1 unit}
bind . <j> {scroll 1 unit}
bind . <Prior> {scroll -1 page}
bind . <Shift-space> {scroll -1 page}
bind . <Left> {scroll -1 page}
bind . <b> {scroll -1 page}
bind . <K> {scroll -1 page}
bind . <Next> {scroll 1 page}
bind . <space> {scroll 1 page}
bind . <Right> {scroll 1 page}
bind . <J> {scroll 1 page}
bind . <Home> {.t yview moveto 0}
bind . <End> {.t yview moveto 1}
bind . <equal> {changeFontSize +5}
bind . <minus> {changeFontSize -5}
bind . <plus> {changeFontSize +1}
bind . <underscore> {changeFontSize -1}
bind . <v> {invertColours}
bind . <q> {exit}
bind . <ButtonPress-1> {set drag 1; set lasty -1}
bind . <ButtonRelease-1> {set drag 0}
bind . <Motion> {if {$drag} { doMotion %y } }
bind .t <Motion> {set drag 0} ;# so text selection can span lines properly