Artifact 1daa65b3f9db078c07a936254f755e88c6374de0:

• File lib/jedit/img_display.tcl — part of check-in [cac5136bc6] at 2019-07-26 22:42:43 on branch restructure-packages — Switched all remaining packages over to a `jt::` prefix to prevent clashes with anything in the environment. Updated all users.

  Removed the package index files. Kettle handles everything on install. Removed the remaining auto_path shenanigans. (user: aku size: 9234)

## -*- tcl -*-
# ### ### ### ######### ######### #########

## Manage the displays which use an image.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.5
package require debug
package require debug::caller
package require snit
package require struct::set
package require jt::job::stack

# ### ### ### ######### ######### #########
## Tracing

debug level  img/display
debug prefix img/display {[debug caller] | }

# ### ### ### ######### ######### #########
## Implementation

snit::type img::display {
    # ### ### ### ######### ######### #########
    ## API

    constructor {theimage} {
	debug.img/display {}

	set myimage $theimage
	# All other state information is initialized statically.
	return
    }

    method disconnect {} {
	foreach display [array names mydisplay2size] {
	    Disconnect $display
	}
	return
    }

    method add {display {size full}} {
	debug.img/display {}

	$myimage lock
	$myimage geometry wxh \
	    [future new \
		 on return [mymethod Add $display $size] \
		 on error  [mymethod Error $size]]
	return
    }

    method remove {display} {
	debug.img/display {}

	# Last act on the display on our behalf.
	Text $display Undefined

	# Ignore a display which is not linked anyway
	if {![IsDisplayKnown $display]} return

	# Remove display structures, do not forget that it might still
	# be waiting for the photo to show.
	set size [DropDisplay $display]

	# We are done if there is no photo for it yet.
	if {![IsPhotoKnown $size]} return

	DropPhotoAt $size $display
	return
    }

    method text {{str {}}} {
	debug.img/display {}

	foreach display [array names mydisplay2size] {
	    Text $display $str
	}
	return
    }

    method refresh {} {
	debug.img/display {}

	$self text {}

	set displays [array get mydisplay2size]

	debug.img/display {==> [list $displays]}

	foreach {display size} $displays {
	    $self remove $display
	}

	debug.img/display =========================================

	foreach {display size} $displays {
	    debug.img/display ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	    $self add $display $size
	}

	debug.img/display =========================================
    }

    # ### ### ### ######### ######### #########
    ## Internals.

    method Add {display size _geometry_} {
	debug.img/display {}

	# Prevent the image from getting scaled beyond its native
	# size.

	if {[string is integer -strict $size] &&
	    ($size > [$myimage geometry size])} {
	    set size [$myimage geometry size]
	}

	set mydisplay2size($display) $size

	# Broadcast a notification that this image is used at the
	# given size. The environment may intercept this, and scale a
	# few images after this one, in sort order, to stay ahead of
	# the user regarding to scaling and caching of scaled images.

	uevent::generate $myimage <<Size>> $size

	# Is the image shown already at this size ?
	# Show it directly.

	if {[IsPhotoKnown $size]} {
	    set photo [PhotoAt $size]

	    struct::set include myphoto2display($photo) $display

	    Show $display $photo

	    $myimage unlock
	    return
	}

	# Image is not known yet. Show a placeholder text for the user
	# and retrieve it at the proper scale. Then the latter is
	# done, show.

	Text $display {Waiting for scaling result}

	# mypending(size) - 3 states
	# - exists            - We have a scale request running for this size
	# - exists, not empty - s.a, and displays are waiting for the result.
	# - not existing      - Nothing waits, no request in progress

	# Going directly to 'scale' instead of through 'get' to
	# allow us to avoid superfluous image loads (due to
	# intervening unlink calls).

	set scaleRunning [info exists mypending($size)]
	struct::set include mypending($size) $display
        if {$scaleRunning} {
	    $myimage unlock
	    return
	}

	$myimage scale at $size \
	    [future new \
		 on return [mymethod Scaled $size] \
		 on error  [mymethod Error  $size]]
	return
    }

    # --- --- --- --------- --------- ---------

    method Scaled {size path} {
	debug.img/display {}
	Run [mymethod Load $size $path]
	return
    }

    method Load {size path} {
	debug.img/display {== [list $mypending($size)]}

	# If the display object has been unlinked it cannot be
	# pending, 'unlink' has removed it from the set. Therefore we
	# can simply use the set here, without checking.

	# And if the pending set is empty already then we do not need
	# the photo any more, so we do not load it at all. This is why
	# we went through 'scale' instead of 'get'. Otherwise we
	# actually load the photo, record it in our structures and
	# notify the connected displays of its arrival.

	set pending $mypending($size)
	unset        mypending($size)

	if {![llength $pending]} return

	set photo [image create photo -file $path]
	set mysize2photo($size) $photo

	foreach display $pending {
	    struct::set include myphoto2display($photo) $display
	    Show $display $photo
	}

	$myimage unlock
	return
    }

    method Error {size message} {
	debug.img/display {}

	# If the display object has been unlinked it cannot be
	# pending, 'remove' took it already out of the set. Therefore
	# we can simply use the set here, without checking.

	set pending $mypending($size)
	unset        mypending($size)

	foreach display $pending {
	    Text $display $message
	}

	$myimage unlock
	return
    }

    # --- --- --- --------- --------- ---------

    proc IsDisplayKnown {display} {
	upvar 1 mydisplay2size mydisplay2size
	return [info exists mydisplay2size($display)]
    }

    proc SizeOf {display} {
	upvar 1 mydisplay2size mydisplay2size
	return $mydisplay2size($display)
    }

    proc DropDisplay {display} {
	upvar 1 mydisplay2size mydisplay2size \
	    mypending mypending

	debug.img/display {Drop $display}

	set size $mydisplay2size($display)
	unset     mydisplay2size($display)

	if {[info exists mypending($size)] &&
	    [struct::set contains $mypending($size) $display]} {
	    struct::set exclude mypending($size) $display

	    debug.img/display {Clear pending of $display}
	}

	return $size
    }

    # --- --- --- --------- --------- ---------

    proc IsPhotoKnown {size} {
	upvar 1 mysize2photo mysize2photo
	return [info exists mysize2photo($size)]
    }

    proc PhotoAt {size} {
	upvar 1 mysize2photo mysize2photo
	return $mysize2photo($size)
    }

    proc DropPhotoAt {size display} {
	upvar 1 mysize2photo mysize2photo \
	    myphoto2display myphoto2display

	debug.img/display {Drop photo at $size}

	set photo $mysize2photo($size)
	struct::set exclude myphoto2display($photo) $display

	if {![struct::set empty $myphoto2display($photo)]} return

	# This was the last display using this photo, throw it out of
	# the memory.

	debug.img/display {Drop photo $photo}

	unset mysize2photo($size)
	image delete $photo
	return
    }

    # --- --- --- --------- --------- ---------

    proc Text {display str} {
	debug.img/display {}
	uplevel \#0 [list {*}$display textoverlay $str]
	return
    }

    proc Show {display photo} {
	debug.img/display {}
	uplevel \#0 [list {*}$display photo $photo]
	return
    }

    proc Disconnect {display} {
	debug.img/display {}
	uplevel \#0 [list {*}$display disconnect]
	return
    }

    # ### ### ### ######### ######### #########
    ## State

    variable  myimage ; # The image object the display manager belongs to.

    # Data structures ...
    # * Per display we know
    #   - the size of the photo it is showing.
    #   - the photo image itself it is showing (indirect per the size, see below).
    # * Per photo we know
    #   - The set of displays showing it.
    # * Per size we know
    #   - the photo image at that size.
    #
    # display -- n:1 --> size -- 1:1 --> photo -- 1:n --> display
    #
    # The data structures may be partially filled:
    #
    # - We may not have a photo at a certain size.
    #   In that case a scale operation will be started, or is running,
    #   to generate it from the main image.
    #

    variable mysize2photo    -array {} ; # size -> photo
    variable mydisplay2size  -array {} ; # display -> size
    variable myphoto2display -array {} ; # photo -> set of using displays.

    variable mypending       -array {} ; # size -> set of displays waiting for scale result.

    #
    variable myphotoat    -array {} ; # photo <- size
    variable mysizeof     -array {} ; # size <- display
    variable mydisplaysof -array {} ; # set(display) <- photo

    # ### ### ### ######### ######### #########
    # ### ### ### ######### ######### #########
    ## Type API

    proc Run {cmd} {
	debug.img/display {}

	$ourload schedule $cmd
	return
    }

    # ### ### ### ######### ######### #########
    ## Initialization/Setup

    typeconstructor {
	debug.img/display {}

	set ourload [jt::job::stack ${type}::LOADER]
	return
    }

    # ### ### ### ######### ######### #########
    ## State

    typecomponent ourload

    # ### ### ### ######### ######### #########
    ## Configuration

    pragma -hastypeinfo    no
    pragma -hastypedestroy no
    pragma -hasinfo        no
    pragma -simpledispatch yes

    ##
    # ### ### ### ######### ######### #########
}

# ### ### ### ######### ######### #########
## Ready
package provide img::display 0.1