path: root/library/iconlist.tcl

# iconlist.tcl
#
#	Implements the icon-list megawidget used in the "Tk" standard file
#	selection dialog boxes.
#
# RCS: @(#) $Id: iconlist.tcl,v 1.1 2009/02/12 21:32:49 dkf Exp $
#
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
# Copyright (c) 2009 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require Tk 8.6

oo::class create ::tk::IconList {
    variable w canvas list index itemList textList selection sbar \
	maxIW maxIH maxTW maxTH numItems noScroll hull fill \
	selected rect font itemsPerColumn options arrangeCB
    constructor args {
	set w [namespace tail [self]]
	my configure {*}$args
	rename [self] _$w
	my Create
	rename ::$w theFrame
	rename [self] ::$w
	set arrangeCB {}
    }
    self {
	method unknown {w args} {
	    if {[string match .* $w]} {
		uplevel 1 [list [self] create $w {*}$args]
		return $w
	    }
	    next $w {*}$args
	}
	unexport new unknown
    }
    destructor {
	after cancel $arrangeCB
	my Reset
	if {[winfo exists $w]} {
	    bind $hull <Destroy> {}
	    destroy $w
	}
    }

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

    method index i {
	if {![info exist list]} {
	    set list {}
	}
	switch -regexp -- $i {
	    "^-?[0-9]+$" {
		if {$i < 0} {
		    set i 0
		}
		if {$i >= [llength $list]} {
		    set i [expr {[llength $list] - 1}]
		}
		return $i
	    }
	    "^anchor$" {
		return $index(anchor)
	    }
	    "^end$" {
		return [llength $list]
	    }
	    "@-?[0-9]+,-?[0-9]+" {
		scan $i "@%d,%d" x y
		set item [$canvas find closest \
			[$canvas canvasx $x] [$canvas canvasy $y]]
		return [lindex [$canvas itemcget $item -tags] 1]
	    }
	}
    }

    method selection {op args} {
	switch -exact -- $op {
	    anchor {
		if {[llength $args] == 1} {
		    set index(anchor) [$w index [lindex $args 0]]
		} else {
		    return $index(anchor)
		}
	    }
	    clear {
		switch [llength $args] {
		    2 {
			lassign $args first last
		    }
		    1 {
			set first [set last [lindex $args 0]]
		    }
		    default {
			return -code error "wrong # args: should be\
			     \"[lrange [info level 0] 0 1] first ?last?\""
		    }
		}

		set first [$w index $first]
		set last [$w index $last]
		if {$first > $last} {
		    set tmp $first
		    set first $last
		    set last $tmp
		}
		set ind 0
		foreach item $selection {
		    if {$item >= $first} {
			set first $ind
			break
		    }
		    incr ind
		}
		set ind [expr {[llength $selection] - 1}]
		for {} {$ind >= 0} {incr ind -1} {
		    set item [lindex $selection $ind]
		    if {$item <= $last} {
			set last $ind
			break
		    }
		}

		if {$first > $last} {
		    return
		}
		set selection [lreplace $selection $first $last]
		event generate $w <<ListboxSelect>>
		my DrawSelection
	    }
	    get {
		return $selection
	    }
	    includes {
		return [expr {[lindex $args 0] in $selection}]
	    }
	    set {
		switch [llength $args] {
		    2 {
			lassign $args first last
		    }
		    1 {
			set first [set last [lindex $args 0]]
		    }
		    default {
			return -code error "wrong # args: should be\
			     \"[lrange [info level 0] 0 1] first ?last?\""
		    }
		}

		set first [$w index $first]
		set last [$w index $last]
		if {$first > $last} {
		    set tmp $first
		    set first $last
		    set last $tmp
		}

		for {set i $first} {$i <= $last} {incr i} {
		    lappend selection $i
		}
		set selection [lsort -integer -unique $selection]
		event generate $w <<ListboxSelect>>
		my DrawSelection
	    }
	}
    }

    method get item {
	set rTag [lindex $list $item 2]
	lassign $itemList($rTag) iTag tTag text serial
	return $text
    }

    #	Configure the widget variables of IconList, according to the command
    #	line arguments.
    #
    method configure args {
	# 1: the configuration specs
	#
	set specs {
	    {-command "" "" ""}
	    {-font "" "" "TkIconFont"}
	    {-multiple "" "" "0"}
	}

	# 2: parse the arguments
	#
	tclParseConfigSpec [my varname options] $specs "" $args
    }

    method cget option {
	return $options($option)
    }

    #	Deletes all the items inside the canvas subwidget and reset the
    #	iconList's state.
    #
    method deleteall {} {
	$canvas delete all
	unset -nocomplain selected rect list itemList
	set maxIW 1
	set maxIH 1
	set maxTW 1
	set maxTH 1
	set numItems 0
	set noScroll 1
	set selection {}
	set index(anchor) ""
	$sbar set 0.0 1.0
	$canvas xview moveto 0
    }

    #	Adds an icon into the IconList with the designated image and text
    #
    method add {image items} {
	foreach text $items {
	    set iID item$numItems
	    set iTag [$canvas create image 0 0 -image $image -anchor nw \
			  -tags [list icon $numItems $iID]]
	    set tTag [$canvas create text  0 0 -text  $text  -anchor nw \
			  -font $options(-font) -fill $fill \
			  -tags [list text $numItems $iID]]
	    set rTag [$canvas create rect  0 0 0 0 -fill "" -outline "" \
			  -tags [list rect $numItems $iID]]

	    lassign [$canvas bbox $iTag] x1 y1 x2 y2
	    set iW [expr {$x2 - $x1}]
	    set iH [expr {$y2 - $y1}]
	    if {$maxIW < $iW} {
		set maxIW $iW
	    }
	    if {$maxIH < $iH} {
		set maxIH $iH
	    }

	    lassign [$canvas bbox $tTag] x1 y1 x2 y2
	    set tW [expr {$x2 - $x1}]
	    set tH [expr {$y2 - $y1}]
	    if {$maxTW < $tW} {
		set maxTW $tW
	    }
	    if {$maxTH < $tH} {
		set maxTH $tH
	    }

	    lappend list [list $iTag $tTag $rTag $iW $iH $tW $tH $numItems]
	    set itemList($rTag) [list $iTag $tTag $text $numItems]
	    set textList($numItems) [string tolower $text]
	    incr numItems
	}
	my ArrangeWhenIdle
    }

    #	Gets called when the user invokes the IconList (usually by
    #	double-clicking or pressing the Return key).
    #
    method invoke {} {
	if {$options(-command) ne "" && [llength $selection]} {
	    uplevel #0 $options(-command)
	}
    }

    #	If the item is not (completely) visible, scroll the canvas so that it
    #	becomes visible.
    #
    method see rTag {
	if {$noScroll} {
	    return
	}
	set sRegion [$canvas cget -scrollregion]
	if {$sRegion eq ""} {
	    return
	}

	if {$rTag < 0 || $rTag >= [llength $list]} {
	    return
	}

	set bbox [$canvas bbox item$rTag]
	set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]

	set x1 [lindex $bbox 0]
	set x2 [lindex $bbox 2]
	incr x1 [expr {$pad * -2}]
	incr x2 [expr {$pad * -1}]

	set cW [expr {[winfo width $canvas] - $pad*2}]

	set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
	set dispX [expr {int([lindex [$canvas xview] 0]*$scrollW)}]
	set oldDispX $dispX

	# check if out of the right edge
	#
	if {($x2 - $dispX) >= $cW} {
	    set dispX [expr {$x2 - $cW}]
	}
	# check if out of the left edge
	#
	if {($x1 - $dispX) < 0} {
	    set dispX $x1
	}

	if {$oldDispX ne $dispX} {
	    set fraction [expr {double($dispX) / double($scrollW)}]
	    $canvas xview moveto $fraction
	}
    }

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

    method ArrangeWhenIdle {} {
	if {$arrangeCB eq ""} {
	    set arrangeCB [after idle [namespace code {my Arrange}]]
	}
	return
    }

    #	Places the icons in a column-major arrangement.
    #
    method Arrange {} {
	set arrangeCB ""

	if {![info exists list]} {
	    if {[info exists canvas] && [winfo exists $canvas]} {
		set noScroll 1
		$sbar configure -command ""
	    }
	    return
	}

	set W [winfo width  $canvas]
	set H [winfo height $canvas]
	set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
	if {$pad < 2} {
	    set pad 2
	}

	incr W [expr {$pad*-2}]
	incr H [expr {$pad*-2}]

	set dx [expr {$maxIW + $maxTW + 8}]
	if {$maxTH > $maxIH} {
	    set dy $maxTH
	} else {
	    set dy $maxIH
	}
	incr dy 2
	set shift [expr {$maxIW + 4}]

	set x [expr {$pad * 2}]
	set y [expr {$pad * 1}] ; # Why * 1 ?
	set usedColumn 0
	foreach sublist $list {
	    set usedColumn 1
	    lassign $sublist iTag tTag rTag iW iH tW tH

	    set i_dy [expr {($dy - $iH)/2}]
	    set t_dy [expr {($dy - $tH)/2}]

	    $canvas coords $iTag $x                    [expr {$y + $i_dy}]
	    $canvas coords $tTag [expr {$x + $shift}]  [expr {$y + $t_dy}]
	    $canvas coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]

	    incr y $dy
	    if {($y + $dy) > $H} {
		set y [expr {$pad * 1}] ; # *1 ?
		incr x $dx
		set usedColumn 0
	    }
	}

	if {$usedColumn} {
	    set sW [expr {$x + $dx}]
	} else {
	    set sW $x
	}

	if {$sW < $W} {
	    $canvas configure -scrollregion [list $pad $pad $sW $H]
	    $sbar configure -command ""
	    $canvas xview moveto 0
	    set noScroll 1
	} else {
	    $canvas configure -scrollregion [list $pad $pad $sW $H]
	    $sbar configure -command [list $canvas xview]
	    set noScroll 0
	}

	set itemsPerColumn [expr {($H-$pad) / $dy}]
	if {$itemsPerColumn < 1} {
	    set itemsPerColumn 1
	}

	my DrawSelection
    }

    method DrawSelection {} {
	$canvas delete selection
	$canvas itemconfigure selectionText -fill black
	$canvas dtag selectionText
	set cbg [ttk::style lookup TEntry -selectbackground focus]
	set cfg [ttk::style lookup TEntry -selectforeground focus]
	foreach item $selection {
	    set rTag [lindex $list $item 2]
	    foreach {iTag tTag text serial} $itemList($rTag) {
		break
	    }

	    set bbox [$canvas bbox $tTag]
	    $canvas create rect $bbox -fill $cbg -outline $cbg \
		-tags selection
	    $canvas itemconfigure $tTag -fill $cfg -tags selectionText
	}
	$canvas lower selection
	return
    }

    #	Creates an IconList widget by assembling a canvas widget and a
    #	scrollbar widget. Sets all the bindings necessary for the IconList's
    #	operations.
    #
    method Create {} {
	ttk::frame $w
	set hull [ttk::entry $w.cHull -takefocus 0]
	set sbar [ttk::scrollbar $w.cHull.sbar -orient horizontal -takefocus 0]
	catch {$sbar configure -highlightthickness 0}
	set canvas [canvas $w.cHull.canvas -highlightthick 0 -takefocus 1 \
			-width 400 -height 120 -background white]
	pack $sbar -side bottom -fill x -padx 2 -in $hull -pady {0 2}
	pack $canvas -expand yes -fill both -padx 2 -pady {2 0}
	pack $hull -expand yes -fill both -ipadx 2 -ipady 2

	$sbar configure -command [list $canvas xview]
	$canvas configure -xscrollcommand [list $sbar set]

	# Initializes the max icon/text width and height and other variables
	#
	set maxIW 1
	set maxIH 1
	set maxTW 1
	set maxTH 1
	set numItems 0
	set noScroll 1
	set selection {}
	set index(anchor) ""
	set fg [option get $canvas foreground Foreground]
	if {$fg eq ""} {
	    set fill black
	} else {
	    set fill $fg
	}

	# Creates the event bindings.
	#
	bind $canvas <Configure>	[namespace code {my ArrangeWhenIdle}]

	bind $canvas <1>		[namespace code {my Btn1 %x %y}]
	bind $canvas <B1-Motion>	[namespace code {my Motion1 %x %y}]
	bind $canvas <B1-Leave>		[namespace code {my Leave1 %x %y}]
	bind $canvas <Control-1>	[namespace code {my CtrlBtn1 %x %y}]
	bind $canvas <Shift-1>		[namespace code {my ShiftBtn1 %x %y}]
	bind $canvas <B1-Enter>		[list tk::CancelRepeat]
	bind $canvas <ButtonRelease-1>	[list tk::CancelRepeat]
	bind $canvas <Double-ButtonRelease-1> \
	    [namespace code {my Double1 %x %y}]

	bind $canvas <Control-B1-Motion> {;}
	bind $canvas <Shift-B1-Motion>	[namespace code {my ShiftMotion1 %x %y}]

	bind $canvas <Up>		[namespace code {my UpDown -1}]
	bind $canvas <Down>		[namespace code {my UpDown  1}]
	bind $canvas <Left>		[namespace code {my LeftRight -1}]
	bind $canvas <Right>		[namespace code {my LeftRight  1}]
	bind $canvas <Return>		[namespace code {my ReturnKey}]
	bind $canvas <KeyPress>		[namespace code {my KeyPress %A}]
	bind $canvas <Control-KeyPress> ";"
	bind $canvas <Alt-KeyPress>	";"

	bind $canvas <FocusIn>		[namespace code {my FocusIn}]
	bind $canvas <FocusOut>		[namespace code {my FocusOut}]

	bind $hull <Destroy>		[namespace code {my destroy}]

	return $w
    }

    #	This procedure is invoked when the mouse leaves an entry window with
    #	button 1 down.  It scrolls the window up, down, left, or right,
    #	depending on where the mouse left the window, and reschedules itself
    #	as an "after" command so that the window continues to scroll until the
    #	mouse moves back into the window or the mouse button is released.
    #
    method AutoScan {} {
	variable ::tk::Priv
	if {![winfo exists $w]} return
	set x $Priv(x)
	set y $Priv(y)
	if {$noScroll} {
	    return
	}
	if {$x >= [winfo width $canvas]} {
	    $canvas xview scroll 1 units
	} elseif {$x < 0} {
	    $canvas xview scroll -1 units
	} elseif {$y >= [winfo height $canvas]} {
	    # do nothing
	} elseif {$y < 0} {
	    # do nothing
	} else {
	    return
	}
	my Motion1 $x $y
	set Priv(afterId) [after 50 [namespace code {my AutoScan}]]
    }

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

    # Event handlers
    method Btn1 {x y} {
	focus $canvas
	set i [$w index @$x,$y]
	if {$i eq ""} {
	    return
	}
	$w selection clear 0 end
	$w selection set $i
	$w selection anchor $i
    }
    method CtrlBtn1 {x y} {
	if {$options(-multiple)} {
	    focus $canvas
	    set i [$w index @$x,$y]
	    if {$i eq ""} {
		return
	    }
	    if {[$w selection includes $i]} {
		$w selection clear $i
	    } else {
		$w selection set $i
		$w selection anchor $i
	    }
	}
    }
    method ShiftBtn1 {x y} {
	if {$options(-multiple)} {
	    focus $canvas
	    set i [$w index @$x,$y]
	    if {$i eq ""} {
		return
	    }
	    if {[$w index anchor] eq ""} {
		$w selection anchor $i
	    }
	    $w selection clear 0 end
	    $w selection set anchor $i
	}
    }

    #	Gets called on button-1 motions
    #
    method Motion1 {x y} {
	variable ::tk::Priv
	set Priv(x) $x
	set Priv(y) $y
	set i [$w index @$x,$y]
	if {$i eq ""} {
	    return
	}
	$w selection clear 0 end
	$w selection set $i
    }
    method ShiftMotion1 {x y} {
	variable ::tk::Priv
	set Priv(x) $x
	set Priv(y) $y
	set i [$w index @$x,$y]
	if {$i eq ""} {
	    return
	}
	$w selection clear 0 end
	$w selection set anchor $i
    }
    method Double1 {x y} {
	if {[llength $selection]} {
	    $w invoke
	}
    }
    method ReturnKey {} {
	$w invoke
    }
    method Leave1 {x y} {
	variable ::tk::Priv
	set Priv(x) $x
	set Priv(y) $y
	my AutoScan
    }
    method FocusIn {} {
	$hull state focus
	if {![info exists list]} {
	    return
	}
	if {[llength $selection]} {
	    my DrawSelection
	}
    }
    method FocusOut {} {
	$hull state !focus
	$w selection clear 0 end
    }

    #	Moves the active element up or down by one element
    #
    # Arguments:
    #	amount -	+1 to move down one item, -1 to move back one item.
    #
    method UpDown amount {
	if {![info exists list]} {
	    return
	}
	set curr [$w selection get]
	if {[llength $curr] == 0} {
	    set i 0
	} else {
	    set i [$w index anchor]
	    if {$i eq ""} {
		return
	    }
	    incr i $amount
	}
	$w selection clear 0 end
	$w selection set $i
	$w selection anchor $i
	$w see $i
    }

    #	Moves the active element left or right by one column
    #
    # Arguments:
    #	amount -	+1 to move right one column, -1 to move left one column
    #
    method LeftRight amount {
	if {![info exists list]} {
	    return
	}
	set curr [$w selection get]
	if {[llength $curr] == 0} {
	    set i 0
	} else {
	    set i [$w index anchor]
	    if {$i eq ""} {
		return
	    }
	    incr i [expr {$amount * $itemsPerColumn}]
	}
	$w selection clear 0 end
	$w selection set $i
	$w selection anchor $i
	$w see $i
    }

    #	Gets called when user enters an arbitrary key in the listbox.
    #
    method KeyPress key {
	variable ::tk::Priv
	append Priv(ILAccel,[self]) $key
	my Goto $Priv(ILAccel,[self])
	catch {
	    after cancel $Priv(ILAccel,[self],afterId)
	}
	set Priv(ILAccel,[self],afterId) \
	    [after 500 [namespace code {my Reset}]]
    }
    method Goto text {
	if {![info exists list]} {
	    return
	}
	if {$text eq "" || $numItems == 0} {
	    return
	}

	if {[llength [$w selection get]]} {
	    set start [$w index anchor]
	} else {
	    set start 0
	}
	set theIndex -1
	set less 0
	set len [string length $text]
	set len0 [expr {$len - 1}]
	set i $start

	# Search forward until we find a filename whose prefix is a
	# case-insensitive match with $text
	while {1} {
	    if {[string equal -nocase -length $len0 $textList($i) $text]} {
		set theIndex $i
		break
	    }
	    incr i
	    if {$i == $numItems} {
		set i 0
	    }
	    if {$i == $start} {
		break
	    }
	}

	if {$theIndex > -1} {
	    $w selection clear 0 end
	    $w selection set $theIndex
	    $w selection anchor $theIndex
	    $w see $theIndex
	}
    }
    method Reset {} {
	variable ::tk::Priv

	unset -nocomplain Priv(ILAccel,[self])
    }
}