tkgoodstuff/tcl/panelgeo.tcl

289 lines
8.1 KiB
Tcl
Raw Permalink Normal View History

############################################################
# Procedures to manage stack geometry and to
#
# TKGGrid --
# Place an item (pathname) into the stack currently being constructed.
# Stack (with grid) it onto the appropriate side, and configure it to
# "expand" in the dimension of the stack's orientation unless we are
# in (the top stack of) a screen-edge panel and "expand" is not an arg.
proc TKGGrid {pathname args} {
global TKG TKG_stackside
upvar \#0 $TKG(currentpanel)-pparams(screenedge) edge
set inscreenedge \
[expr ![string match $edge no] && \
[regexp {^\.[^.]*$} $TKG(stackprefix)]]
if [In -nosep $args] {
set sep 0
} else {
set sep $TKG(sep)
}
set w $TKG(stackprefix)
if {"$TKG_stackside(current)" == "top"} {
set r [llength [grid slaves $w -column 0]]
set slaves [grid slaves $w -column 0]
grid $pathname -sticky nsew -in $w \
-column 0 -row $r \
-padx $sep -pady $sep
if {!$inscreenedge || [In expand $args]} {
grid rowconfigure $w $r -weight 1
} else {
grid rowconfigure $w $r -weight 0
}
} else {
set c [llength [grid slaves $w -row 0]]
set slaves [grid slaves $w -row 0]
grid $pathname -sticky nsew -in $w \
-row 0 -column $c\
-padx $sep -pady $sep
if {!$inscreenedge || [In expand $args]} {
grid columnconfigure $w $c -weight 1
} else {
grid columnconfigure $w $c -weight 0
}
}
}
proc TKGRowCol {w} {
grid rowconfigure $w 0 -weight 1
grid columnconfigure $w 0 -weight 1
}
set TKG(switches,StartStack) {
{orientation ""}
{borderwidth ""}
{color ""}
{startpanel 0}
{iconside ""}
{title ""}
{screenedge no}
}
proc StartStack args {
global TKG TKG_stackside TKG_iconSide
upvar \#0 stack$TKG(stackindex)-sparams Parent
incr TKG(stackindex)
set paramsvar stack$TKG(stackindex)-sparams
upvar \#0 $paramsvar Stack
set switches $TKG(switches,StartStack)
TKGSetSwitchDefaults $paramsvar $switches
TKGParseArgs $paramsvar $args $switches "" StartStack
foreach v {borderwidth color iconside title} {
if [Empty $Stack($v)] {set Stack($v) $Parent($v)}
}
if ![info exists Stack(orientation)] {
if [string match $Parent(orientation) horizontal] {
set Stack(orientation) vertical
} else {set Stack(orientation) horizontal}
}
lappend TKG(pedigree) $TKG(stackindex)
if $Stack(startpanel) {
set TKG(stackprefix) .[string tolower $TKG(currentpanel)]
if ![winfo exists $TKG(stackprefix)] {
tkgtoplevel $TKG(stackprefix) -class Tkgoodstuff -relief raised\
-borderwidth $Stack(borderwidth) -background $Stack(color) \
-tile $TKG(paneltileimage)
}
wm withdraw $TKG(stackprefix)
wm title $TKG(stackprefix) $Stack(title)
} else {
set TKG(stackprefix) $TKG(stackprefix).stack$TKG(stackindex)
tkgframe $TKG(stackprefix) -relief ridge -borderwidth $Stack(borderwidth) \
-background $Stack(color) -tile $TKG(paneltileimage)
}
if { $Stack(orientation) == "vertical" } {
set TKG_stackside($TKG(stackindex)) top
grid columnconfigure $TKG(stackprefix) 0 -weight 1
} else {
set TKG_stackside($TKG(stackindex)) left
grid rowconfigure $TKG(stackprefix) 0 -weight 1
}
set TKG_stackside(current) $TKG_stackside($TKG(stackindex))
set TKG_iconSide($TKG(stackindex)) $Stack(iconside)
set TKG_iconSide(current) $Stack(iconside)
}
set TKG(switches,TKGStartPanel) {
{borderwidth ""}
{color ""}
{title ""}
{orientation ""}
{iconside ""}
{screenedge "no"}
}
proc TKGStartPanel {name args} {
global TKG TKG_panels TKG_prevpanel
upvar \#0 $name-pparams P
upvar \#0 $TKG(currentpanel)-pparams Prev
set switches $TKG(switches,TKGStartPanel)
TKGSetSwitchDefaults $name-pparams $switches
TKGParseArgs $name-pparams $args $switches {} TKGStartPanel
set TKG_prevpanel($name) $TKG(currentpanel)
set TKG(currentpanel) $name
set TKG_panels(.[string tolower $name]) 1
if ![string match $P(screenedge) no] {
if [In $P(screenedge) {left right}] {
set P(orientation) vertical
} else {
set P(orientation) horizontal
}
}
if {$P(orientation) == "horizontal"} {
if [Empty $P(iconside)] {
set P(iconside) left
}
} else {
if [Empty $P(iconside)] {
set P(iconside) top
}
}
foreach v {
orientation borderwidth color iconside title screenedge} {
if [Empty $P($v)] {set P($v) $Prev($v)}
lappend outargs -$v $P($v)
}
eval [concat StartStack -startpanel 1 $outargs]
}
proc TKGEndPanel {} {
global TKG TKG_prevpanel
set TKG(currentpanel) $TKG_prevpanel($TKG(currentpanel))
FinishStack 1
}
proc TKGPanelDismiss {panel} {
set w .[string tolower $panel]
wm withdraw $w
TKGDoHook TKGPanelDismiss_$w
global TKGPanelDismiss_$w TKG_postedpanels
TKGResetHook TKGPanelDismiss_$w
catch {unset TKG_postedpanels($w)}
}
proc TKGPanelButtonInvoke {butname panelname} {
global TKG TKG_postedpanels TKG_prevpanel
set w .[string tolower $panelname]
# if already posted, unpost
if [info exists TKG_postedpanels($w)] {
TKGPanelDismiss $panelname
return
}
upvar \#0 $butname-params P
set butpath $P(pathname)
set panelw [winfo toplevel $butpath]
set hook TKGPanelPost_$panelw
TKGDoHook $hook
TKGResetHook $hook
TKGAddToHook $hook "TKGPanelDismiss $panelname"
TKGAddToHook TKGPanelDismiss_$w "TKGResetHook $hook"
if ![string match $panelw .main-panel] {
TKGAddToHook TKGPanelDismiss_$panelw "TKGPanelDismiss $panelname"
}
regexp {([0-9]*)x([0-9]*)\+*(-*[0-9]*)\+*(-*[0-9]*)}\
[wm geometry $panelw] ww ww wh wx wy
set vw [winfo vrootwidth .]
set vh [winfo vrootheight .]
set bx [winfo rootx $butpath]
set by [winfo rooty $butpath]
set rh [winfo reqheight $w]
set rw [winfo reqwidth $w]
upvar \#0 [string trimleft $panelw .]-pparams(orientation) O
switch $O {
vertical {
if [string match -* $wx] {
set x [expr -([string trimleft $wx -] + $ww)]
} else {
set x +[expr $wx + $ww]
}
set y +$by
if {($y + $rh) > $vh} {
set y +[expr $vh - $rh]
}
} horizontal {
if [string match -* $wy] {
set y [expr -([string trimleft $wy -] + $wh)]
} else {
set y +[expr $wy + $wh]
}
set x +$bx
if {($x + $rw) > $vw} {
set x +[expr $vw - $rw]
}
}
}
wm geometry $w $x$y
wm deiconify $w
raise .main-panel
set TKG_postedpanels($w) 1
}
proc TKGPanelPlace {name args} {
global PutPanel$name
upvar \#0 \
[string tolower [join $name ~]]-panel-pparams(screenedge) \
edge
set w .[string tolower $name]-panel
if [string match $edge no] {
set geometry [set PutPanel${name}(geometry)]
if ![Empty $geometry] {
if [catch {wm geometry $w $geometry} err] {
TKGError $err
}
}
} else {
switch $edge {
left {
wm minsize $w 0 [winfo vrootheight .]
wm geometry $w +0+0
} right {
wm minsize $w 0 [winfo vrootheight .]
wm geometry $w -0+0
} top {
wm minsize $w [winfo vrootwidth .] 0
wm geometry $w +0+0
} bottom {
wm minsize $w [winfo vrootwidth .] 0
wm geometry $w +0-0
}
}
}
bind $w <Expose> "TKGPanelExpose $name"
wm deiconify $w
}
proc TKGPanelExpose {name} {
set lpanelname [string tolower $name]-panel
set w .$lpanelname
bind $w <Expose> ""
TKGDoHook TKG_postedhook-$lpanelname
}
proc FinishStack {{endpanel 0}} {
global TKG TKG_stackside TKG_iconSide
set childstack $TKG(stackprefix)
set TKG(pedigree) [lreplace $TKG(pedigree) end end]
set parentindex [lindex $TKG(pedigree) end ]
set TKG(stackprefix) \
[join [lreplace [split $TKG(stackprefix) .] end end] .]
if [Empty $TKG(stackprefix)] {
#back to another panel
set TKG(stackprefix) .[string tolower $TKG(currentpanel)]
}
set TKG_stackside(current) $TKG_stackside($parentindex)
set TKG_iconSide(current) $TKG_iconSide($parentindex)
if !$endpanel {TKGGrid $childstack -nosep; lower $childstack}
}
proc DoFill {} {
global TKG
set w .[string tolower $TKG(currentpanel)]
set i 0
while {[winfo exists $w.fill$i]} {incr i}
set pathname $w.fill$i
tkgframe $pathname -cursor top_left_arrow -tile $TKG(paneltileimage)
TKGGrid $pathname expand
}