# pagesel.tcl -- GV-like page selector for TkDVI.
# Copyright © 2000 Anselm Lingnau <lingnau@tm.informatik.uni-frankfurt.de>.
# See file COPYING for conditions on use and distribution.
# $Id: pagesel.tcl,v 1.4 2000/06/29 11:35:23 lingnau Exp $

package provide tkdvi::pagesel 2.0

namespace eval ::tkdvi::pagesel:: {
    variable Configure
    variable State
    variable Options

    namespace export pagesel

    array set Options {
	command {Command {}}
	background {Background white}
	width {Width 40}
	relief {Relief sunken}
	borderwidth {Borderwidth 2}
	popup {Popup 1}
	scrollbar {Scrollbar 1}
    }

    foreach {option cv} [array get Options] {
	foreach {optClass value} $cv break
	option add *TkDVIPageSel.$optClass $value widgetDefault
    }
}

proc ::tkdvi::pagesel::Defaults {name} {
    variable Configure
    variable State
    variable Options

    set Configure($name-command) {}
    foreach {option cv} [array get Options] {
	foreach {optClass value} $cv break
	set Configure($name-$option) [option get $name $option $optClass]
    }
}

proc ::tkdvi::pagesel::Traces {name} {
    variable Configure

    trace variable Configure($name-popup) w \
	    [namespace code [list WidgetSetup $name]]
    trace variable Configure($name-scrollbar) w \
	    [namespace code [list WidgetSetup $name]]

    trace variable Configure($name-background) w \
	    [namespace code [list ReconfigureCanvas $name]]
    trace variable Configure($name-relief) w \
	    [namespace code [list ReconfigureCanvas $name]]
    trace variable Configure($name-width) w \
	    [namespace code [list ReconfigureCanvas $name]]
    trace variable Configure($name-borderwidth) w \
	    [namespace code [list ReconfigureCanvas $name]]
}

proc ::tkdvi::pagesel::ReconfigureCanvas {name name1 name2 op} {
    variable Configure
    variable State

    set n [string range $name2 [string last $name2 -] end]
    $State($name-canvas) configure $n $Configure($name2)
}

proc ::tkdvi::pagesel::pagesel {name args} {
    variable Configure
    variable State

    # Widget commands live in the global namespace
    if {"" != [namespace eval :: [list info command $name]]} {
	return -code error "command name \"$name\" already exists"
    }

    set Configure($name-toplevel) 0
    set idx [lsearch -exact $args -toplevel]
    if {$idx >= 0 && [expr {$idx+1}] < [llength $args]} {
	set Configure($name-toplevel) [lindex $args [expr {$idx+1}]]
    }

    if {$Configure($name-toplevel)} {
	if {[catch "toplevel $name -class TkDVIPageSel" result]} {
	    return -code error $result
	}
    } else {
	if {[catch "frame $name -class TkDVIPageSel" result]} {
	    return -code error $result
	}
    }
    rename $name "$name-tkdvi"
    set State($name-top) $name
    set State($name-topcmd) "$name-tkdvi"

    Defaults $name

    proc ::$name {method args} [format {
	if {[catch {::tkdvi::pagesel::Methods %s $method $args} result]} {
	    return -code error $result
	} else {
	    return $result
	}
    } $name]

    if {[catch "Opconfigure $name $args" result]} {
	return -code error $result
    }

    set State($name-canvas) [canvas $State($name-top).c \
	    -background $Configure($name-background) \
	    -relief $Configure($name-relief) \
	    -borderwidth $Configure($name-borderwidth) \
	    -width $Configure($name-width) \
	    -yscrollcommand [list $State($name-top).s set]]
    set State($name-scroll) [scrollbar $State($name-top).s -orient vertical \
	    -command [list $State($name-canvas) yview]]
    set m [menu $State($name-top).popup]
    $m add command -label "Mark all" -command [list ::$name mark all]
    $m add command -label "Mark none" -command [list ::$name mark none]
    $m add command -label "Mark even" -command [list ::$name mark even]
    $m add command -label "Mark odd" -command [list ::$name mark odd]
    $m add command -label "Toggle marks" -command [list ::$name mark toggle]
    set State($name-menu) $m

    WidgetSetup $name
    Traces $name

    return $name
}

proc ::tkdvi::pagesel::WidgetSetup {name args} {
    variable Configure
    variable State

    if {$Configure($name-scrollbar)} {
	grid $State($name-scroll) -row 0 -column 0 -sticky ns
    } else {
	grid remove $State($name-scroll)
    }
    grid $State($name-canvas) -row 0 -column 1 -sticky nsew
    grid rowconfigure $State($name-top) 0 -weight 1
    if {$Configure($name-popup)} {
	bind $State($name-canvas) <ButtonPress-3> \
		[namespace code [list Popup $name %X %Y]]
    } else {
	bind $State($name-canvas) <ButtonPress-3> {}
    }
}

proc ::tkdvi::pagesel::Methods {name method argList} {
    variable State
    switch -exact -- $method {
	addpages -
	flushpages -
	mark -
	current -
	configure {
	    if {[catch "Op$method $name $argList" result]} {
		regsub -- "Op$method" $result "$name $method" result
		return -code error $result
	    } else {
		return $result
	    }
	}
	default {
	    return -code error "\"$name $method\" is not defined"
	}
    }
}

proc ::tkdvi::pagesel::ConfigureInfo {name option} {
    variable Configure
    variable Options

    if {[info exists Configure(${name}${option})]} {
	set oo [string range $option 1 end]
	foreach {optClass defValue} $Options($oo) break
	return \
	    [list $option $oo $optClass $defValue $Configure(${name}${option})]
    }
    return -code error "option \"$option\" doesn't exist"
}

proc ::tkdvi::pagesel::Opconfigure {name args} {
    variable Configure

    if {[llength $args] == 0} {
	set result {}
	foreach v [array names Configure $name-*] {
	    lappend result [ConfigureInfo $name \
		    [string range $v [string length $name] end]]
	}
	return $result
    }

    if {[llength $args] == 1} {
	return [ConfigureInfo $name [lindex $args 0]]
    }

    if {[llength $args] % 2 != 0} {
	return -code error \
		"\"$name configure $args\": argument count must be even"
    }
    foreach {k v} $args {
	switch -exact -- $k {
	    -toplevel {
		return -code error "option \"-toplevel\" cannot be changed"
	    }
	    default {
		if {[info exists Configure(${name}${k})]} {
		    set Configure(${name}${k}) $v
		} else {
		    return -code error "unknown option \"$v\""
		}
	    }
	}
    }
}

proc ::tkdvi::pagesel::Opaddpages {name pages} {
    variable State
    variable Configure

    set n [llength $pages]
    set f [font create -family Helvetica -size 10]
    set h [font metrics $f -linespace]
    if {$h % 2 == 1} { incr h }
    set c $State($name-canvas)
    $c configure -scrollregion [list 0 0 40 [expr {$n*$h}]] \
	    -yscrollincrement $h

    $c delete all
    set y 0
    set b [$c cget -background]
    set i 0
    foreach p $pages {
	set State($name-pgItem,$i) \
		[$c create rectangle 2 $y 38 [expr {$y + $h - 1}] \
		-fill $b -outline {} -tags [list touch p-$i]]
	$c create text 25 $y -text $p -font $f -anchor n \
		-tags [list touch num p-$i]
	$c create rectangle 4 [expr {$y+2}] 8 [expr {$y+$h-3}] \
		-fill {} -outline {} -tags [list touch sel p-$i]
	incr y $h
	incr i
    }
    $c bind touch <Enter> \
	    [namespace code [list SetCurrItemBg $State($name-top) gray70]]
    $c bind touch <Leave> \
	    [namespace code [list SetCurrItemBg $State($name-top) $b]]
    $c bind touch <1> \
	    [namespace code [list ExecCmd $name]]
    $c bind touch <2> \
	    [namespace code [list ::$name mark item]]
    $c itemconfigure curr -outline black
}

proc ::tkdvi::pagesel::Popup {name x y} {
    variable State
    tk_popup $State($name-menu) $x $y
}

proc ::tkdvi::pagesel::ExecCmd {name} {
    variable State
    variable Configure
    set c $State($name-canvas)
    set t [$c gettags [$c find withtag current]]
    set t [lindex $t [lsearch -glob $t p-*]]
    set pg [string range $t 2 end]
    regsub {%p} $Configure($name-command) $pg execCmd
    eval $execCmd
}
proc ::tkdvi::pagesel::SetCurrItemBg {w color} {
    variable State
    set c $State($w-canvas)
    set t [$c gettags [$c find withtag current]]
    set t [lindex $t [lsearch -glob $t p-*]]
    set items [$c find withtag $t]
    $c itemconfigure [lindex $items 0] -fill $color
}

proc ::tkdvi::pagesel::Opcurrent {name page} {
    variable State
    set c $State($name-canvas)
    set item $State($name-pgItem,$page)
    if {[info exists State($name-current)]} {
	$c itemconfigure $State($name-current) -outline {}
    }
    $c itemconfigure $item -outline black
    set State($name-current) $item
}

proc ::tkdvi::pagesel::Opflushpages {name args} {
    variable State
    $State($name-canvas) delete all
}

proc ::tkdvi::pagesel::Opmark {name args} {
    variable State

    set what [lindex $args 0]
    switch -exact -- $what {
	item {
	    DrawMark $name -1 -1
	}
	all {
	    foreach p [array names State $name-pgItem,*] {
		set i [string range $p [expr {[string last , $p]+1}] end]
		DrawMark $name $i 1
	    }
	}
	none {
	    foreach p [array names State $name-pgItem,*] {
		set i [string range $p [expr {[string last , $p]+1}] end]
		DrawMark $name $i 0
	    }
	}
	even {
	    foreach p [array names State $name-pgItem,*] {
		set i [string range $p [expr {[string last , $p]+1}] end]
		DrawMark $name $i [expr {($i % 2) != 0}]
	    }
	}
	odd {
	    foreach p [array names State $name-pgItem,*] {
		set i [string range $p [expr {[string last , $p]+1}] end]
		DrawMark $name $i [expr {($i % 2) == 0}]
	    }
	}
	toggle {
	    foreach p [array names State $name-pgItem,*] {
		set i [string range $p [expr {[string last , $p]+1}] end]
		DrawMark $name $i -1
	    }
	}
	list {
	    set result {}
	    foreach i [$State($name-canvas) find withtag sel] {
		set t [$State($name-canvas) gettags $i]
		if {[lsearch -exact $t x] >= 0} {
		    set t [lindex $t [lsearch -glob $t p-*]]
		    lappend result [string range $t 2 end]
		}
	    }
	    return $result
	}
	default {
	    return -code error "bad option: must be \"item\", \"all\", \"none\", \"even\", \"odd\", \"toggle\" or \"list\""
	}
    }
}

proc ::tkdvi::pagesel::DrawMark {name page {value 0}} {
    variable State

    set c $State($name-canvas)
    if {$page == -1} {
	set item [$c find withtag current]
    } else {
	set item $State($name-pgItem,$page)
    }
    set t [$c gettags $item]
    set t [lindex $t [lsearch -glob $t p-*]]
    set i [lindex [$c find withtag $t] end]
    set iTags [$c gettags $i]
    set sel [lsearch -exact $iTags x]
    if {$value == -1} {
	if {$sel >= 0} {
	    set newValue 0
	} else {
	    set newValue 1
	}
    } else {
	set newValue $value
    }
    if {$newValue == 0} {
	$c itemconfigure $i -fill {} \
		-tags [lreplace $iTags $sel $sel]
    } else {
	$c itemconfigure $i -fill red -tags [concat $iTags x]
    }
}


    proc _selectAll {w mode} {
	upvar \#0 tkdvi::pagesel::$w state
	set c $state(c)
	
    }
    proc select {w start inc} {
    }
    proc selected {w} {
	upvar \#0 tkdvi::pagesel::$w state
	set c $state(c)
	set result {}
	foreach i [$c find withtag sel] {
	    set t [$c gettags $i]
	    if {[lsearch -exact $t x] >= 0} {
		set t [lindex $t [lsearch -glob $t p-*]]
		lappend result [string range $t 2 end]
	    }
	}
	return $result
    }
    proc command {w newCmd} {
	upvar \#0 tkdvi::pagesel::$w state
	set state(cmd) $newCmd
    }
    proc mkList {n} {
	set result {}
	for {set i 1} {$i <= $n} {incr i} { lappend result $i }
	return $result
    }

