Artifact e85456ae724ed12d9026d0ff722b95bf55da42b6:

• File packages/visual/lib/slides.tcl — part of check-in [e31c194738] at 2020-02-09 22:45:55 on branch trunk — ycl shelf

  refactor into {ycl ns object} and redesign to use namespaces as containers for three distinct and non-overlapping things: units of code, object interfaces, and object member data.

  everything else cascading rewrites based on changes to ycl shelf (user: pooryorick size: 13336)

#! /bin/env tclsh

package require Tk

package require {ycl tk canvas}
namespace import [yclprefix]::tk::canvas::textgrow
namespace import [yclprefix]::tk::canvas::textshrink
package require {ycl coro call}
namespace import [yclprefix]::coro::call::hi

package require {ycl string}
namespace import [yclprefix]::string::dedent
package require {ycl list}
namespace import [yclprefix]::list::ss

.my .routine textgrow
.my .routine textshrink


proc advance {_ count} {
	namespace upvar $_ autoscaledown autoscaledown autoscaleup autoscaleup \
		c c slide slide slideconfs slideconfs slides slides
	incr slide $count 
	if {![dict exists $slideconfs $slide]} {
		incr slide [expr -$count]
		return
	}
	set config [dict get $slideconfs $slide]
	if {$slide >= [llength $slides]} {
		set slide [expr {[llength $slides] - 1}]
	}
	if {$slide < 0} {
		set slide -1 
	}
	set items [$c find withtag [list slide $slide]]
	if {[llength $items]} {
		$_ layout $items 
		if {[$config get autoscaleup]} {
			$_ autoscaleup $items
		}
		if {[$config get autoscaledown]} {
			$_ autoscaledown $items
		}
	}
}
.my .method advance


proc autoscaledown {_ items} {
	namespace upvar $_ c c wheight wheight wwidth wwidth
	if {![llength $items]} return
	while 1 {
		lassign [$c bbox {*}$items] bx1 by1 bx2 by2
		if {$bx1 < 0 || $by1 < 0 || $bx2 >= $wwidth || $by2 >= $wheight} {
			$_ scaledown
		} else {
			break
		}
	}
}
.my .method autoscaledown


proc autoscaleup {_ items} {
	# No need to to worry about scaling down if we go to far, because [scaleup]
	# calls [layout], which calls [scaledown]
	namespace upvar $_ c c wheight wheight wwidth wwidth

	lassign [$c bbox {*}$items] bx1 by1 bx2 by2
	if {$bx1 > 0 && $by1 > 0 && $bx2 < $wwidth && $by2 < $wheight} {
		$_ scaleup
	}
	$_ autoscaledown $items
}
.my .method autoscaleup

.my $ config [[yclprefix] shelf shelf .spawn config_[info cmdcount]]
[.my $ config] .eval {
	package require {ycl parse tcl}
	package require {ycl parse tcl commands}

	proc get {_ args} {
		set confinterp [$_ $ confinterp]
		if {[llength $args] == 1} {
			set name [lindex $args 0]
			set script [$_ $ $name]
			switch $name {
				fontsize {
					expr {entier(max(1 ,entier([$_ num $name [$confinterp eval $script]])))}
				}
				width {
					expr {max(0,[$_ num $name [$confinterp eval $script]])}
				}
				
				default {
					$confinterp eval $script 
				}
			}
		} elseif {![llength $args]} {
			error [list whattdddd?]
		}
	}
	.my .method get 

	proc init {_ args} {
		dict update args slideshow slideshow {}
		if {[info exists slideshow]} {
			$_ $ slideshow $slideshow
		}
		$_ $ confinterp [interp create -safe]
		[$_ $ confinterp] alias page $_ page
		[$_ $ confinterp] alias get $_ get
		[$_ $ confinterp] alias num $_ num
		return $_
	}
	.my .method init

	proc num {_ name args} {
		if {[llength $args]} {
			lassign $args val
			# First quantifier is non-greedy, 
			if {![regexp {^\s*?([-+]?)\s*?([^\s]+?)\s*(%?)$} $val \
				-> sign num percent]} {
				return -code error [list {no match} $val]
			}
			if {![string is entier $num]} {
				return -code error [list {bad numeric value} $val]
			}
			if {$sign eq {}} {
				if {$percent ne {}} {
					set val [expr {[[$_ .basis] get $name] * .$num}]
				}
			} else {
				if {$percent ne {}} {
					set val [expr .$num * [[$_ .basis] get $name]]
				}
				set val [expr [[$_ .basis] get $name] $sign $val]
			}
		}
		return $val
	}
	.my .method num

	namespace eval page {
		namespace ensemble create -parameters _
		namespace export *
		proc width {_} {
			[$_ $ slideshow] $ wwidth
		}
	}
	.my .method page


	proc parse {_ config} {
		set res {}
		set config [[yclprefix] parse tcl commands commands $config]
		foreach line $config {
			set line [[yclprefix] parse tcl words $line]
			if {[llength $line] > 2} {
				return -code error [list {bad syntax} $line]
			}
			lassign $line key val
			# Assumption:  [regexp] does not modify val
			if {![regexp {^\s*?\[(.*?)\]\s*$} $val -> val]} {
				set val "lindex [list $val]"
			}
			dict set res $key $val
		}
		return $res
	}
	.my .method parse


	proc read {_ args} {
		namespace upvar $_ confinterp confinterp
		set names {anchor autoscaledown autoscaleup font fontsize virtual weight width}
		if {[llength $args]} {
			lassign $args parsed
		} else {
			set parsed {}
		}
		dict for {key val} $parsed { 
			switch $key {
				anchor - autoscaledown - autoscaleup - font - fontsize -
				scaledownfactor - scaleupfactor - virtual - weight - width {
					$_ $ $key $val 
				}
				width {
				}
				default {
					return -code error [list {unknown configuration item} $key]
				}
			}
		}
		return
	}
	.my .method read 

}
[.my $ config] init

[.my $ config] read [[.my $ config] parse {
	autoscaledown 1
	autoscaleup 1
	font Courier
	fontsize 12
	anchor center
	weight normal 
	width [page width]
	scaleupfactor 1.05
	scaledownfactor 0.95
	virtual 0 
}]


proc coords {_ item curh curv} {
	namespace upvar $_ c c citem citem 
	set type [$c type $item]
	switch $type {
		line - rectangle {
			$_ coords4 $item $curh $curv
			if {[dict exists $citem $item slave]} {
				set slave [dict get $citem $item slave]
				switch [$c type $slave] {
					text {
						$c coords $slave $curh $curv
					}
					default {
						return -code error [list {don't know how to manage the coordinates for type} [$c type $slave]]
					}
				}
			}
		}
		default {
			return -code error [
				list {unknown canvas item type} $type {for item} $item]
		}
	}
}
.my .method coords


proc coords4 {_ item curh curv} {
	namespace upvar $_ c c 
	lassign [$c coords $item] x1 y1 x2 y2
	set xd [expr {$x2 - $x1}]
	set yd [expr {$y2 - $y1}]
	$c coords $item [expr {$curh - ($xd / 2.0)}] [
		expr {$curv - ($yd / 2.0)}] [expr {$curh + ($xd / 2.0)}] [
			expr {$curv + ($yd / 2.0)}]
}
.my .method coords4


proc init {_ argv0 argv} {
	$_ $ argv0 $argv0
	$_ $ argv $argv
	# state
	$_ $ wheight -1
	$_ $ wwidth -1
	$_ $ hcenter -1 
	$_ $ vcenter -1

	$_ $ currentfontsize 0
	$_ $ scaling_busy 0
	$_ $ shiftrate 1
	$_ $ shiftratereset {}
	$_ $ slide -1
	$_ $ slides {}
	$_ $ userevent_busy 0

	$_ $ citem {}

	$_ $ config [[[$_ $ config] .spawn [info cmdcount]] init slideshow $_]

	coroutine [$_ .namespace]::douserevent apply [list {_ args} {
		while 1 {
			set args [yieldto return -level 0 [info coroutine]]
			if {[catch $args cres copts]} {
				puts stderr [dict get $copts -errorinfo]
			}
			$_ $ userevent_busy 0
		}
	} [namespace current]] $_ 
	$_ .method douserevent

	return $_
}
.my .method init


proc userevent {_ args} {
	set userevent_busy [$_ $ userevent_busy]
	if {$userevent_busy} {
		return
	}
	$_ $ userevent_busy 1
	$_ douserevent {*}$args
}
.my .method userevent


proc layout {_ items args} {
	namespace upvar $_ c c hcenter hcenter vcenter vcenter wheight wheight wwidth wwidth
	dict for {arg val} $args {
		switch $arg {
			scale {
				set $arg $val
			}
			default {
				return -code error [list {unknown argument} $arg]
			}
		}
	}

	set htotal 0
	set vtotal 0
	set curv $vcenter
	set curh $hcenter
	set visible [$c find overlapping 0 0 $wwidth $wheight]
	foreach item $visible {
		$c moveto $item -9999 -9999
	}
	foreach item $items {
		lassign [$c bbox $item] bx1 by1 bx2 by2
		set bwidth [expr {$bx2 - $bx1}]
		set bheight [expr {$by2 - $by1}]
		set bheight2 [expr {$bheight / 2.0}]
		set curv [expr {$curv + $bheight2}]
		$_ coords $item $curh $curv
		set curv [expr {$curv + $bheight2}]

		set htotal [expr {$htotal + $bwidth}]
		incr vtotal [expr {$vtotal + $bheight}]

		# Recenter viewable items
		set visible [$c find overlapping 0 0 $wwidth $wheight]
		foreach item $visible {
			$c move $item 0 [expr -$bheight2]
		}
		
	}
}
.my .method layout

apply [list {} {
	foreach {name subs} {scaleup {
		@factor@ scaleupfactor 
		@scaletext@ textgrow
	} scaledown {
		@factor@ scaledownfactor 
		@scaletext@ textshrink
	}} {
		proc $name _ [string map [list @name@ [list $name] {*}$subs] {
			namespace upvar $_ c c citem citem scale scale \
				@factor@ @factor@ scaling_busy scaling_busy slide slide 
			if {$scaling_busy} {
				return 
			}
			set scaling_busy 1
			foreach item [$c find withtag [list slide $slide]] {
				switch [$c type $item] {
					line - rectangle {
						set config [dict get $citem $item config]
						set factor [$config get @factor@]
						lassign [$c coords $item] x1 y1 x2 y2
						$c scale $item [expr {($x1 + $x2) / 2.0}] [
							expr {($y1 + $y2) / 2.0}] $factor $factor
						if {[dict exists $citem $item slave]} {
							set slave [dict get $citem $item slave]
							switch [$c type $slave] {
								text {
									$_ @scaletext@ $c $item $slave
								}
								default {
									return -code error [list {don't know how to
									scale} type [$c type $slave] for $slave]
								}
							}
						}
					}
					default {
						return [code error {don't know how to scale} type [
							$c type $item] for $item]
					}
				}
			}
			set scaling_busy 0
			$_ layout [$c find withtag [list slide $slide]]
		}]
		.my .method $name
	}
} [namespace current]]


proc reorient _ {
	namespace upvar $_ c c hcenter hcenter vcenter vcenter slide slide \
		wheight wheight wwidth wwidth
	set oldwheight $wheight
	set oldwwidth $wwidth
	set wheight [winfo height $c]
	set wwidth [winfo width $c]
	set hcenter [expr {$wwidth / 2.0}]
	set vcenter [expr {$wheight / 2.0}]
	$_ layout [$c find withtag [list slide $slide]]
}
.my .method reorient


proc run {_ args} {
	coroutine [info cmdcount] apply [list {_ args}  {
		dict for {arg val} $args {
			switch $arg {
				slides {
					$_ $ slides $val
				}
				default {
					return -code error [list {unknown arguent} $arg]
				}
				
			}
		}
		
		namespace upvar $_ c c slide slide
		wm attributes . -fullscreen
		tkwait visibility .
		set c [canvas .[info cmdcount]]
		pack $c -expand 1 -fill both
		$c configure -bg white
		bind $c <Configure> [list $_ reorient]
		bind . <KeyPress-plus> [list $_ userevent scaleup]
		bind . <KeyPress-minus> [list $_ userevent scaledown]
		foreach keyname {Left Right Up Down}  {
			bind . <KeyPress-$keyname> [list $_ shift [string tolower $keyname]]
		}
		bind . <j> [list $_ advance 1]
		bind . <k> [list $_ advance -1]
		$_ slides
		#event generate $c k
	} [namespace current]] $_ {*}$args
}
.my .method run


proc shift {_ direction} {
	namespace upvar $_ c c citem citem hcenter hcenter shiftratereset shiftratereset \
		vcenter vcenter slide slide shiftrate shiftrate
	set items [$c find withtag [list slide $slide]]
	lassign [dict get {left {-1 0} right {1 0} up {0 -1} down {0 1}} $direction] xamount yamount
	set xamount  [expr {$xamount * min(15,$shiftrate)}]
	set yamount  [expr {$yamount * min(15,$shiftrate)}]
	set hcenter [expr {$hcenter + $xamount}]
	set vcenter [expr {$vcenter + $yamount}]
	foreach item $items {
		$c move $item $xamount $yamount 
		if {[dict exists $citem $item slave]} {
			$c move [dict get $citem $item slave] $xamount $yamount
		}
	}
	set shiftrate [expr {$shiftrate * 1.4}]
	after cancel $shiftratereset
	set shiftratereset [after 200 [list $_ shiftratereset]]
}
.my .method shift


proc shiftratereset _ {
	namespace upvar $_ shiftrate shiftrate
	set shiftrate 1
}
.my .method shiftratereset


proc slide {_ slide num} {
	namespace upvar $_ c c citem citem config config
	set i -1
	foreach content [ss $slide] {
		if {[llength $content] > 3} {
			return -code error [list {wrong number components} $content]
		}
		set currentconfig [$_ $ config] 
		lassign $content type val configsource
		incr i
		switch $type {
			line {
				set config [[[$_ $ config] .spawn config_[info cmdcount]] init]
				set val [$config parse $val]
				$config read $val
				if {[llength $content] == 1} {
					$config $ virtual 1
				}
				set item [$c create line -9999 -9999 [expr {-9999 + [
					$config get width]}] -9999 -tags [list [list slide $num] [list seq $i]]]
				dict set citem $item config [$_ $ config]
			}
			text {
				set config [[[$_ $ config] .spawn config_[info cmdcount]] init]
				set configsource [$config parse $configsource]
				$config read $configsource
				dedent val
				set font [font create -size [$config get fontsize] -weight [$config get weight]]
				set item [$c create text -9999 -9999 -text $val -font $font]
				set bbox [$c bbox $item]
				set item2 [$c create rectangle {*}$bbox -width 0 -tags [
					list [list slide $num] [list seq $i]]]
				dict set citem $item2 config $config 
				dict set citem $item master $item2
				dict set citem $item2 slave $item
			}
			default {
				# slide-level configuration
				set config [[[$_ $ config] .spawn config_[info cmdcount]] init]
				set configsource [$config parse $configsource]
				$config read $configsource
				continue
			}
		}
		after 0 [list after idle [list [info coroutine]]]
		yield
		$_ $ config $currentconfig
	}
}
.my .method slide


proc slides _ {
	set slides [$_ $ slides]
	namespace upvar $_ c c  slideconfs slideconfs
	set i 0 
	foreach slide [ss $slides] {
		lassign $slide content configsource
		set currentconfig [$_ $ config]
		set config [[$currentconfig .spawn config_[info cmdcount]] init]
		set configsource [$config parse $configsource]
		$config read $configsource
		if {$content eq {}} {
			# global-level configuration
			continue
		}
		dict set slideconfs $i $config 
		$_ slide $content $i 
		$_ $ config $currentconfig
		incr i
	}
}
.my .method slides