saods9-data 7.3.2+repack-1 / usr / share / saods9 / src / cube.tcl

#  Copyright (C) 1999-2014
#  Smithsonian Astrophysical Observatory, Cambridge, MA, USA
#  For conditions of distribution and use, see copyright notice in "copyright"

package provide DS9 1.0

proc CubeDef {} {
    global icube
    global cube

    set icube(top) .cube
    set icube(mb) .cubemb
    set icube(id) 0

    set cube(lock) none
# needs work, at high values, but cropped, causes problems
#    set cube(format) {%.5g}
    set cube(axis) 2
    set cube(system) wcs
}

proc MatchCubeCurrent {sys} {
    global current

    if {$current(frame) != {}} {
	MatchCube $current(frame) $sys
    }
}

proc MatchCube {which sys} {
    global cube
    global ds9
    global rgb

    set naxes [$which get fits naxes]
    for {set ii 2} {$ii<=$naxes} {incr ii} {
	set slice($ii) [$which get fits slice $ii $sys]
    }

    foreach ff $ds9(frames) {
	if {$ff != $which} {
	    for {set ii 2} {$ii<=$naxes} {incr ii} {
		RGBEvalLock rgb(lock,slice) $ff "$ff update fits slice $ii $slice($ii) $sys"
	    }
	}
    }
}

proc LockCubeCurrent {} {
    global current
    
    if {$current(frame) != {}} {
	LockCube $current(frame)
    }
}

proc LockCube {which} {
    global cube

    switch -- $cube(lock) {
	none {}
	default {MatchCube $which $cube(lock)}
    }
}

proc CubeSlice {slice} {
    global dcube
    global cube

    global current
    global rgb
    global infobox

    RGBEvalLockCurrent rgb(lock,slice) "$current(frame) update fits slice $cube(axis) $slice"
    set dcube(image,$cube(axis)) $slice
    set dcube(wcs,$cube(axis)) [$current(frame) get coordinates $slice image $cube(system) $cube(axis)]
    set infobox(filename) [$current(frame) get fits file name root base]
}

proc CubeStop {} {
    global icube

    if {$icube(id)>0} {
	after cancel $icube(id)
	set icube(id) 0
    }
}

proc CubePlay {} {
    global icube

    if {$icube(id) == 0} {
	CubeTimer
    }
}

proc CubeTimer {} {
    global icube
    global dcube
    global cube

    global current
    global blink
    global rgb

    if {$current(frame) != {}} {
	if {[$current(frame) has fits]} {
	    set slice [$current(frame) get fits slice $cube(axis)]
	    if {$cube(axis)==2} {
		# get cropped version
		set ss [$current(frame) get crop 3d image]
		set first [lindex $ss 0]
		set last [lindex $ss 1]
	    } else {
		set first 1
		set last [$current(frame) get fits depth $cube(axis)]
	    }

	    if {$slice == $last} {
		set slice $first
	    } else {
		set slice [expr $slice+1]
	    }

	    CubeSlice $slice
	} else {
	    set dcube(image,$cube(axis)) 1
	    set dcube(wcs,$cube(axis)) 1
	}
	UpdateCube
    }

    set icube(id) [after $blink(interval) CubeTimer]
}

proc CubeFirst {} {
    global dcube
    global cube

    global current
    global rgb

    CubeStop

    if {$current(frame) != {}} {
	if {[$current(frame) has fits]} {
	    if {$cube(axis)==2} {
		# get cropped version
		set ss [$current(frame) get crop 3d image]
		set first [lindex $ss 0]
	    } else {
		set first 1
	    }
	    CubeSlice $first
	} else {
	    set dcube(image,$cube(axis)) 1
	    set dcube(wcs,$cube(axis)) 1
	}
	UpdateCube
    }
}

proc CubePrev {} {
    global dcube
    global cube

    global current
    global rgb

    CubeStop

    if {$current(frame) != {}} {
	if {[$current(frame) has fits]} {
	    set slice [$current(frame) get fits slice $cube(axis)]
	    if {$cube(axis)==2} {
		# get cropped version
		set ss [$current(frame) get crop 3d image]
		set first [lindex $ss 0]
		set last [lindex $ss 1]
	    } else {
		set first 1
		set last [$current(frame) get fits depth $cube(axis)]
	    }

	    if {$slice == $first} {
		set slice $last
	    } else {
		set slice [expr $slice-1]
	    }

	    CubeSlice $slice
	} else {
	    set dcube(image,$cube(axis)) 1
	    set dcube(wcs,$cube(axis)) 1
	}
	UpdateCube
    }
}

proc CubeNext {} {
    global dcube
    global cube

    global current
    global rgb

    CubeStop

    if {$current(frame) != {}} {
	if {[$current(frame) has fits]} {
	    set slice [$current(frame) get fits slice $cube(axis)]
	    if {$cube(axis)==2} {
		# get cropped version
		set ss [$current(frame) get crop 3d image]
		set first [lindex $ss 0]
		set last [lindex $ss 1]
	    } else {
		set first 1
		set last [$current(frame) get fits depth $cube(axis)]
	    }

	    if {$slice == $last} {
		set slice $first
	    } else {
		set slice [expr $slice+1]
	    }

	    CubeSlice $slice
	} else {
	    set dcube(image,$cube(axis)) 1
	    set dcube(wcs,$cube(axis)) 1
	}
	UpdateCube
    }
}

proc CubeLast {} {
    global dcube
    global cube

    global current
    global rgb

    CubeStop

    if {$current(frame) != {}} {
	if {[$current(frame) has fits]} {
	    if {$cube(axis)==2} {
		# get cropped version
		set ss [$current(frame) get crop 3d image]
		set last [lindex $ss 1]
	    } else {
		set last [$current(frame) get fits depth $cube(axis)]
	    }

	    CubeSlice $last
	} else {
	    set dcube(image,$cube(axis)) 1
	    set dcube(wcs,$cube(axis)) 1
	}
	UpdateCube
    }
}

proc CubeApply {ii} {
    global dcube
    global cube

    global current
    global rgb
    global infobox

    CubeStop

    if {$current(frame) != {}} {
	if {[$current(frame) has fits]} {
	    set ss [expr int([$current(frame) get coordinates $dcube(wcs,$ii) $cube(system) image $cube(axis)])]
	    
	    if {$ss<1} {
		set ss 1
	    }
	    set depth [$current(frame) get fits depth $ii]
	    if {$ss>$depth} {
		set ss $depth
	    }
	    set dcube(image,$ii) $ss
	    set dcube(wcs,$ii) [$current(frame) get coordinates $dcube(image,$ii) image $cube(system) $cube(axis)]
	    RGBEvalLockCurrent rgb(lock,slice) "$current(frame) update fits slice $ii $ss"
	    set infobox(filename) [$current(frame) get fits file name root base]
	} else {
	    set dcube(image,$cube(axis)) 1
	    set dcube(wcs,$cube(axis)) 1
	}
	UpdateCube
    }
}

proc UpdateCube {} {
    LockCubeCurrent
    UpdateMain
}

# used by backup
proc CubeDialog {} {
    global icube
    global dcube
    global cube

    global current
    global ds9
    global blink

    # see if we already have a window visible
    if [winfo exists $icube(top)] {
	raise $icube(top)
	return
    }

    # create the cube window
    set w $icube(top)
    set mb $icube(mb)

    Toplevel $w $mb 6 [msgcat::mc {Cube}] CubeDestroyDialog

    $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
    $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
    $mb add cascade -label [msgcat::mc {Interval}] -menu $mb.blink
    $mb add cascade -label [msgcat::mc {Coordinate}] -menu $mb.coord

    menu $mb.file
    $mb.file add command -label [msgcat::mc {First}] -command CubeFirst
    $mb.file add command -label [msgcat::mc {Previous}] -command CubePrev
    $mb.file add command -label [msgcat::mc {Stop}] -command CubeStop
    $mb.file add command -label [msgcat::mc {Play}] -command CubePlay
    $mb.file add command -label [msgcat::mc {Next}] -command CubeNext
    $mb.file add command -label [msgcat::mc {Last}] -command CubeLast
    $mb.file add separator
    $mb.file add command -label [msgcat::mc {Close}] \
	-command CubeDestroyDialog

    EditMenu $mb icube

    menu $mb.blink
    $mb.blink add radiobutton -label ".125 [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 125
    $mb.blink add radiobutton -label ".25 [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 250
    $mb.blink add radiobutton -label ".5 [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 500
    $mb.blink add radiobutton -label "1 [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 1000
    $mb.blink add radiobutton -label "2  [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 2000
    $mb.blink add radiobutton -label "4 [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 4000
    $mb.blink add radiobutton -label "8 [msgcat::mc {Seconds}]" \
	-variable blink(interval) -value 8000

    CoordMenu $mb.coord cube system 2 {} {} UpdateCubeDialog

    # Param
    set f [ttk::frame $w.param]

    set dcube(taxis) [ttk::label $f.taxis -text [msgcat::mc {Axis}]]
    set dcube(tslice) [ttk::label $f.tslice -text [msgcat::mc {Slice}]]
    set dcube(twcs) [ttk::label $f.twcs -textvariable dcube(vcoord) \
			 -anchor center]
    for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
	set dcube(chk,$ii) [ttk::radiobutton $f.chk$ii \
				-text [expr $ii+1] \
				-variable cube(axis) \
				-value $ii]
	set dcube(lslice,$ii) [ttk::label $f.slice$ii \
				  -textvariable dcube(image,$ii) \
				  -width 3 -anchor center]
	set dcube(sslice,$ii) [slider $f.scale$ii 0 100 {} \
				   dcube(wcs,$ii) [list CubeApply $ii] 4 10]
    }

    # Buttons
    set f [ttk::frame $w.buttons]
    ttk::button $f.first -text [msgcat::mc {First}] -width -6 -command CubeFirst
    ttk::button $f.prev -text [msgcat::mc {Previous}] -width -6 \
	-command CubePrev
    ttk::button $f.stop -text [msgcat::mc {Stop}] -width -6 -command CubeStop
    ttk::button $f.play -text [msgcat::mc {Play}] -width -6 -command CubePlay
    ttk::button $f.next -text [msgcat::mc {Next}] -width -6 -command CubeNext
    ttk::button $f.last -text [msgcat::mc {Last}] -width -6 -command CubeLast
    pack $f.first $f.prev $f.stop $f.play $f.next $f.last \
	-side left -expand true -padx 2 -pady 4

    # Fini
    ttk::separator $w.sep -orient horizontal
    pack $w.buttons $w.sep -side bottom -fill x
    pack $w.param -side top -fill both -expand true

    UpdateCubeDialog
}

proc CubeDestroyDialog {} {
    global icube
    global dcube

    CubeStop

    if {[winfo exists $icube(top)]} {
	destroy $icube(top)
	destroy $icube(mb)
    }

    unset dcube
}

proc UpdateCubeMenu {} {
    # can be changed by wcs
    SetCoordSystem cube system {} {}
}

proc UpdateCubeDialog {} {
    global icube
    global dcube
    global cube

    global current
    global ds9

    global debug
    if {$debug(tcl,update)} {
	puts stderr "UpdateCubeDialog"
    }

    CubeStop

    if {![winfo exists $icube(top)]} {
	return
    }

    # get number of axes
    if {$current(frame) != {}} {
	set naxes [$current(frame) get fits naxes]
    } else {
	set naxes 2
    }
    
    if {$current(frame) != {}} {
	set cube(frame) $current(frame)
	if {[$current(frame) has fits]} {
	    # now make sure we have the coord systems
	    AdjustCoordSystem3d cube system
	    CoordMenuEnable $icube(mb).coord cube system 2 {} {}
	} else {
	    CoordMenuReset $icube(mb).coord cube system 2 {} {}
	}
    }

    for {set ii 2} {$ii<=$naxes} {incr ii} {
	set depth 1
	set dcube(from,$ii) 1
	set dcube(to,$ii) 1

	if {$current(frame) != {}} {
	    if {[$current(frame) has fits]} {
		set depth [$current(frame) get fits depth $ii]

		if {$ii==2 && [$current(frame) has fits cube]} {
		    # get cropped version
		    set ss [$current(frame) get crop 3d $cube(system)]
		    set dcube(from,$ii) [lindex $ss 0]
		    set dcube(to,$ii) [lindex $ss 1]
		} else {
		    set dcube(from,$ii)	[$current(frame) get coordinates 1 image $cube(system) $ii]
		    set dcube(to,$ii) [$current(frame) get coordinates $depth image $cube(system) $ii]
		}
	    }
	}
    }
    
    # forget everything
    grid forget $dcube(tslice) $dcube(taxis) $dcube(twcs)
    for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
	grid forget $dcube(chk,$ii) $dcube(sslice,$ii) $dcube(lslice,$ii)
    }

    if {$naxes == 2} {
	# special case
	grid columnconfigure $icube(top).param 1 -weight 1
	grid columnconfigure $icube(top).param 2 -weight 0
	grid $dcube(tslice) $dcube(twcs) -padx 2 -pady 2 -sticky ew
	grid $dcube(lslice,2) $dcube(sslice,2) -padx 2 -pady 2 -sticky ew
    } else {
	# show it
	grid columnconfigure $icube(top).param 1 -weight 0
	grid columnconfigure $icube(top).param 2 -weight 1
	grid $dcube(taxis) $dcube(tslice) $dcube(twcs) \
	    -padx 2 -pady 2 -sticky ew
	for {set ii 2} {$ii<=$naxes} {incr ii} {
	    grid $dcube(chk,$ii) $dcube(lslice,$ii) \
		$dcube(sslice,$ii) -padx 2 -pady 2 -sticky ew
	}
    }

    # set intervals
    for {set ii 2} {$ii<=$naxes} {incr ii} {
	switch $cube(system) {
	    image {
		set dcube(from,$ii) [expr int($dcube(from,$ii))]
		set dcube(to,$ii) [expr int($dcube(to,$ii))]
		set dcube(vcoord) $cube(system)
	    }
	    default {
#		set dcube(from,$ii) [format $cube(format) $dcube(from,$ii)]
#		set dcube(to,$ii) [format $cube(format) $dcube(to,$ii)]
		set dcube(vcoord) $cube(system)
		if {$current(frame) != {}} {
		    if {[$current(frame) has fits]} {
			set w [string range $cube(system) 3 3]
			set key "CTYPE[expr $cube(axis)+1]$w"
			set tt [string trim [$current(frame) get fits header 1 keyword \{$key\}]]
			if {$tt != {}} {
			    set dcube(vcoord) $tt
			}
		    }
		}
	    }
	}
	SliderMinMax $dcube(sslice,$ii) $dcube(from,$ii) $dcube(to,$ii) 4
    }

    # reset cube(axis) if needed
    if {$cube(axis) > $naxes} {
	set cube(axis) $naxes
	if {$cube(axis) < 2} {
	    set cube(axis) 2
	}
    }

    # we must do this after the scale has been configured
    for {set ii 2} {$ii<=$naxes} {incr ii} {
	set dcube(image,$ii) 1
	set dcube(wcs,$ii) 1

	if {$current(frame) != {}} {
	    if {[$current(frame) has fits]} {
		set slice  [$current(frame) get fits slice $ii]
		set dcube(image,$ii) $slice
		set dcube(wcs,$ii) [$current(frame) get coordinates $slice image $cube(system) $ii]
	    }
	}
    }
}

proc CubeBackup {ch which} {
    switch [$which get type] {
	base -
	3d {CubeBackupBase $ch $which}
	rgb {CubeBackupRGB $ch $which}
    }
}

proc CubeBackupBase {ch which} {
    global ds9

    if [$which has fits cube] {
	for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
	    set depth [$which get fits depth $ii]
	    if {$depth>1} {
		puts $ch "$which update fits slice $ii [$which get fits slice $ii]"
	    } else {
		break
	    }
	}

	puts $ch "CubeDialog"
    }
}

proc CubeBackupRGB {ch which} {
    set sav [$which get rgb channel]
    foreach cc {red green blue} {
	$which rgb channel $cc
	puts $ch "$which rgb channel $cc"
	CubeBackupBase $ch $which
    }
    $which rgb channel $sav
    puts $ch "$which rgb channel $sav"
}

# Process Cmds

proc ProcessCubeCmd {varname iname} {
    upvar $varname var
    upvar $iname i

    global cube
    global dcube

    global blink
    global current
    global rgb

    CubeDialog

    switch -- [string tolower [lindex $var $i]] {
	match {
	    incr i
	    if {!([string range [lindex $var $i] 0 0] == "-")} {
		switch -- [lindex $var $i] {
		    {} {MatchCubeCurrent image}
		    default {MatchCubeCurrent [lindex $var $i]}
		}
	    } else {
		MatchCubeCurrent image
		incr i -1
	    }
	}
	lock {
	    incr i
	    if {!([string range [lindex $var $i] 0 0] == "-")} {
		switch -- [lindex $var $i] {
		    {} -
		    yes -
		    1 {set cube(lock) image}
		    no -
		    0 {set cube(lock) none}
		    default {set cube(lock) [lindex $var $i]}
		}
	    } else {
		set cube(lock) image
		incr i -1
	    }
	    LockCubeCurrent
	}
	open {}
	close {CubeDestroyDialog}
	play {CubePlay}
	stop {CubeStop}
	next {CubeNext}
	prev {CubePrev}
	first {CubeFirst}
	last {CubeLast}
	interval {
	    incr i
	    set blink(interval) [expr int([lindex $var $i]*1000)]
	}
	axis {
	    incr i; 
	    set item [lindex $var $i]
	    if {[string is integer $item]} {
		set cube(axis) [expr $item-1]
		if {$cube(axis) < 2} {
		    set cube(axis) 2
		}
	    }
	}
    	default {
	    # defaults
	    set ss [lindex $var $i]
	    set sys image
	    set axis 2

	    # sys
	    set item [lindex $var [expr $i+1]]
	    if {$item != {}} {
		if {!([string range $item 0 0] == "-")} {
		    incr i
		    if {[string is integer $item]} {
			set axis [expr $item-1]
		    } else {
			set sys $item
		    }

		    # axis
		    set item [lindex $var [expr $i+1]]
		    if {$item != {}} {
			if {!([string range $item 0 0] == "-")} {
			    incr i
			    if {[string is integer $item]} {
				set axis [expr $item-1]
			    }
			}
		    }
		}
	    }

	    if {[string is double $ss]} {
		set dcube(wcs,$axis) $ss
		set cube(system) $sys
		set cube(axis) $axis
		if {$cube(axis) < 2} {
		    set cube(axis) 2
		}
		CubeApply $cube(axis)
	    }
	}
    }
}

proc ProcessSendCubeCmd {proc id param} {
    global cube

    global current
    global blink

    switch -- [string tolower [lindex $param 0]] {
	lock {$proc $id "$cube(lock)\n"}
	interval {$proc $id "[expr $blink(interval)/1000.]\n"}
	axis {$proc $id "$cube(axis)\n"}
	default {
	    if {$current(frame) != {}} {
		$proc $id "[$current(frame) get fits slice $cube(axis)]\n"
	    } else {
		$proc $id "1\n"
	    }
	}
    }
}