Tcl Source Code

Artifact 427766a461b7837c12ea3941d5479eed28daae6b:

Attachment "mv-window.tk" to ticket [657282ffff] added by tak416 2002-12-22 03:25:25.

---

if [regexp -nocase -- "power.*macintosh" $tcl_platform(machine)] {
	set XWIN(-x-gap) 0
} else {
	set XWIN(-x-gap) 4
}
catch {destroy .tasoc}
catch {destroy .tmain}

toplevel .tmain -class TopMain -bd 2 -background red -height 200 -width 200
toplevel .tasoc -class TopAssoc -bd 2 -background cyan -height 200 -width 200
catch {font delete myfont}
font create myfont -size 18 -family Time -weight bold
foreach {tw bg} {.tmain red .tasoc cyan} {
	label $tw.l1 -font myfont -text "Initialized" -bg $bg
	label $tw.l2 -font myfont -text " ... " -bg $bg
	label $tw.l3 -font myfont -text " ... " -bg $bg
	pack $tw.l1 $tw.l2 $tw.l3 -side top
}

update idletask

bind .tmain <Configure> {place-window .tmain .tasoc}
bind .tasoc <Configure> {set-window-orient .tasoc .tmain}

global DEBUG
if ![info exist DEBUG(-level)] {array set DEBUG {-level 2}}

proc get-geometry {aWin {show 0}} {
	if [regexp -nocase -- {(\d+)x(\d+)\+(-*\d+)\+(-*\d+)} [wm geometry $aWin] ma w h x y] {
		if {$show} {puts "geometry $aWin -w $w -h $h -x $x -y $y"}
		return [list -w $w -h $h -x $x -y $y -P $ma]
	} else {
		error "getting geometry for $aWin : [wm geometry $aWin]"
	}
	
}

proc set-window-orient {asoc-win main-win} {
	global TOPLOC

	array set asoc [get-geometry ${asoc-win}]
	array set main [get-geometry ${main-win}]
	${asoc-win}.l1 configure -text "asoc $asoc(-P)"
	${asoc-win}.l2 configure -text "main $main(-P)"

	if {$asoc(-x) > $main(-x)} {
		set TOPLOC(o,${asoc-win}) right
	} else {
		set TOPLOC(o,${asoc-win}) left
	}
	set TOPLOC(w,${asoc-win}) [array get asoc]
	mylog "set-window-orient:\n\t${main-win} ${main(-P)}\t${asoc-win} ${asoc(-P)}"
	${asoc-win}.l3 configure -text "orient $TOPLOC(o,${asoc-win})"
}

proc place-window {main-win asoc-win} {
	global TOPLOC

	array set main [get-geometry ${main-win}]
	array set asoc [get-geometry ${asoc-win}]
	${main-win}.l1 configure -text "main $main(-P)"
	${main-win}.l2 configure -text "asoc $asoc(-P)"
	if [info exist TOPLOC(o,${asoc-win})] {
		set orient $TOPLOC(o,${asoc-win})
	} else {
		set orient right
	}
	mylog "\nplace-window enter:\n\t${main-win} ${main(-P)}\t${asoc-win} ${asoc(-P)}"
	if {${orient} == "left"} {
		set x [expr $main(-x) - $asoc(-w) - $::XWIN(-x-gap)]
	} else {
		set x [expr $main(-x) + $main(-w) + $::XWIN(-x-gap)]
	}
	wm geometry ${asoc-win} +${x}+${main(-y)}
	mylog "\tMOVE ${asoc-win} to ${x}+${main(-y)}"
	update idletask
	array set main [set TOPLOC(w,${main-win}) [get-geometry ${main-win}]]
	array set asoc [set TOPLOC(w,${asoc-win}) [get-geometry ${asoc-win}]]
	mylog "place-window leave:\n\t${main-win} ${main(-P)}\t${asoc-win} ${asoc(-P)}"
	${main-win}.l3 configure -text "asoc $asoc(-P)"
}

proc mylog {msg} {
	global DEBUG

	if {$DEBUG(-level) > 0} {
		puts $msg
	}
	if [info exist DEBUG(fid)] {
		puts $DEBUG(fid) $msg
		flush $DEBUG(fid)
	}
}