saods9-data 7.2+dfsg-4 / usr / share / saods9 / src / catsym.tcl

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

package provide DS9 1.0

proc CATSymDef {} {
    global icatsym

    set icatsym(minrows) 8
    set icatsym(mincols) 8
}

proc CATSymDialog {parent} {
    upvar #0 $parent pvar
    global $parent

    set varname $pvar(symdl)
    upvar #0 $varname var
    global $varname

    global ds9
    global icatsym

    # main dialog
    set var(top) ".${varname}"
    set var(mb) ".${varname}mb"

    if [winfo exists $var(top)] {
	raise $var(top)
	return
    }

    # variables
    set var(parent) $parent
    set var(symdb) $pvar(symdb)

    global $var(symdb)
    set var(row) 1

    # initialize
    if {$var(row) <= [starbase_nrows $var(symdb)]} {
	set var(condition) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) condition]]
	set var(shape) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) shape]]
	set var(color) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) color]]
	set var(font) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) font]]
	set var(font,size) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) fontsize]]
	set var(font,weight) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) fontweight]]
	set var(font,slant) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) fontslant]]
	set var(text) [starbase_get $var(symdb) $var(row) \
			   [starbase_colnum $var(symdb) text]]
	set var(size) [starbase_get $var(symdb) $var(row) \
			   [starbase_colnum $var(symdb) size]]
	set var(size2) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) size2]]
	set var(units) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) units]]
	set var(angle) [starbase_get $var(symdb) $var(row) \
			    [starbase_colnum $var(symdb) angle]]
    }


    # create the window
    set w $var(top)
    set mb $var(mb)

    Toplevel $w $mb 7 [msgcat::mc {Symbol Editor}] "CATSymDestroy $varname"

    # menu
    $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
    menu $mb.file
    $mb.file add command -label [msgcat::mc {Apply}] \
	-command "CATSymApply $varname"
    $mb.file add separator
    $mb.file add command -label "[msgcat::mc {Save}]..." \
	-command "CATSymSave $varname"
    $mb.file add command -label "[msgcat::mc {Load}]..." \
	-command "CATSymLoad $varname"
    $mb.file add separator
    $mb.file add command -label [msgcat::mc {Add}] \
	-command "CATSymAdd $varname"
    $mb.file add command -label [msgcat::mc {Delete}] \
	-command "CATSymRemove $varname"
    $mb.file add separator
    $mb.file add command -label [msgcat::mc {Close}] \
	-command "CATSymDestroy $varname"

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

    ttk::label $f.tcondition -text [msgcat::mc {If}] 
    ttk::entry $f.condition -textvariable ${varname}(condition) -width 40
    ttk::button $f.bcondition -text [msgcat::mc {Edit}] \
	-command "CATEditDialog $varname condition $pvar(catdb)"
    ttk::label $f.tthen -text [msgcat::mc {Then}] 
    ttk::label $f.tshape -text [msgcat::mc {Shape}] 
    ttk::menubutton $f.shape -textvariable ${varname}(shape) -menu $f.shape.menu
    ttk::label $f.tcolor -text [msgcat::mc {Color}] 
    ColorMenuButton $f.color $varname color {}
    ttk::label $f.tfont -text [msgcat::mc {Font}] 
    FontMenuButton $f.font $varname font font,size font,weight font,slant {}
    ttk::label $f.ttext -text [msgcat::mc {Text}] 
    ttk::entry $f.text -textvariable ${varname}(text) -width 40
    ttk::button $f.btext -text [msgcat::mc {Edit}] \
	-command "CATEditDialog $varname text  $pvar(catdb)"
    ttk::label $f.tsize -text [msgcat::mc {Size/Radius}] 
    ttk::entry $f.size -textvariable ${varname}(size) -width 40
    ttk::button $f.bsize -text [msgcat::mc {Edit}] \
	-command "CATEditDialog $varname size $pvar(catdb)"
    ttk::label $f.tsize2 -text "[msgcat::mc {Size/Radius}] 2" 
    ttk::entry $f.size2 -textvariable ${varname}(size2) -width 40
    ttk::button $f.bsize2 -text [msgcat::mc {Edit}] \
	-command "CATEditDialog $varname size2 $pvar(catdb)"
    ttk::label $f.tunits -text [msgcat::mc {Units}] 
    tk_optionMenu $f.units ${varname}(units) \
	image physical degrees arcmin arcsec
    $f.units.menu configure
    ttk::label $f.tangle -text [msgcat::mc {Angle}] 
    ttk::entry $f.angle -textvariable ${varname}(angle) -width 40
    ttk::button $f.bangle -text [msgcat::mc {Edit}] \
	-command "CATEditDialog $varname angle $pvar(catdb)"

    menu $f.shape.menu
    $f.shape.menu add radiobutton  -label [msgcat::mc {Circle}] \
	-variable ${varname}(shape) -value {circle}
    $f.shape.menu add radiobutton  -label [msgcat::mc {Ellipse}] \
	-variable ${varname}(shape) -value {ellipse}
    $f.shape.menu add radiobutton  -label [msgcat::mc {Box}] \
	-variable ${varname}(shape) -value {box}
    $f.shape.menu add radiobutton  -label [msgcat::mc {Vector}] \
	-variable ${varname}(shape) -value {vector}
    $f.shape.menu add radiobutton  -label [msgcat::mc {Text}] \
	-variable ${varname}(shape) -value {text}
    $f.shape.menu add cascade -label [msgcat::mc {Point}] \
	-menu $f.shape.menu.point

    menu $f.shape.menu.point
    $f.shape.menu.point add radiobutton -label [msgcat::mc {Circle}] \
	-variable ${varname}(shape) -value {circle point}
    $f.shape.menu.point add radiobutton -label [msgcat::mc {Box}] \
	-variable ${varname}(shape) -value {box point}
    $f.shape.menu.point add radiobutton -label [msgcat::mc {Diamond}] \
	-variable ${varname}(shape) -value {diamond point}
    $f.shape.menu.point add radiobutton -label [msgcat::mc {Cross}] \
	-variable ${varname}(shape) -value {cross point}
    $f.shape.menu.point add radiobutton -label [msgcat::mc {X}] \
	-variable ${varname}(shape) -value {x point}
    $f.shape.menu.point add radiobutton -label [msgcat::mc {Arrow}] \
	-variable ${varname}(shape) -value {arrow point}
    $f.shape.menu.point add radiobutton -label [msgcat::mc {BoxCircle}] \
	-variable ${varname}(shape) -value {boxcircle point}

    grid $f.tcondition $f.condition $f.bcondition -padx 2 -pady 2 -sticky w
    grid $f.tthen -padx 2 -pady 2 -sticky w
    grid $f.tshape $f.shape -padx 2 -pady 2 -sticky w
    grid $f.tcolor $f.color -padx 2 -pady 2 -sticky w
    grid $f.tfont $f.font -padx 2 -pady 2 -sticky w
    grid $f.ttext $f.text $f.btext -padx 2 -pady 2 -sticky w
    grid $f.tsize $f.size $f.bsize -padx 2 -pady 2 -sticky w
    grid $f.tsize2 $f.size2 $f.bsize2 -padx 2 -pady 2 -sticky w
    grid $f.tunits $f.units -padx 2 -pady 2 -sticky w
    grid $f.tangle $f.angle $f.bangle -padx 2 -pady 2 -sticky w

    # Table
    set f [ttk::frame $w.tbl]

    set var(tbl) [table $f.t \
		      -state disabled \
		      -usecommand 0 \
		      -variable $var(symdb) \
		      -colorigin 1 \
		      -roworigin 0 \
		      -cols $icatsym(mincols) \
		      -rows $icatsym(minrows) \
		      -width -1 \
		      -height -1 \
		      -maxwidth 550 \
		      -maxheight 300 \
		      -titlerows 1 \
		      -xscrollcommand [list $f.xscroll set]\
		      -yscrollcommand [list $f.yscroll set]\
		      -selecttype row \
		      -selectmode single \
		      -anchor w \
		      -font [font actual TkDefaultFont] \
		      -browsecommand [list CATSymSelectCB $varname]
		 ]

    ttk::scrollbar $f.yscroll -command [list $var(tbl) yview] -orient vertical
    ttk::scrollbar $f.xscroll -command [list $var(tbl) xview] -orient horizontal

    grid $var(tbl) $f.yscroll -sticky news
    grid $f.xscroll -stick news
    grid rowconfigure $f 0 -weight 1
    grid columnconfigure $f 0 -weight 1

    # Buttons
    set f [ttk::frame $w.buttons]
    ttk::button $f.apply -text [msgcat::mc {Apply}] \
	-command "CATSymApply $varname"
    ttk::button $f.add -text [msgcat::mc {Add}] \
	-command "CATSymAdd $varname"
    ttk::button $f.remove -text [msgcat::mc {Delete}] \
	-command "CATSymRemove $varname"
    ttk::button $f.close -text [msgcat::mc {Close}] \
	-command "CATSymDestroy $varname"
    pack $f.apply $f.add $f.remove $f.close \
	-side left -expand true -padx 2 -pady 4

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

    CATSymTable $varname

    $var(tbl) selection set $var(row),1
}

proc CATSymDestroy {varname} {
    upvar #0 $varname var
    global $varname

    destroy $var(top)
    destroy $var(mb)

    unset var
}

proc CATSymApply {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)

    if {$var(row) != {}} {
	if {$var(row) <= [starbase_nrows $var(symdb)]} {
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) condition] $var(condition)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) shape] $var(shape)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) color] $var(color)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) font] $var(font)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) fontsize] $var(font,size)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) fontweight] $var(font,weight)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) fontslant] $var(font,slant)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) text] $var(text)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) size] $var(size)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) size2] $var(size2)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) units] $var(units)
	    starbase_set $var(symdb) $var(row) \
		[starbase_colnum $var(symdb) angle] $var(angle)
	}
    }

    CATSymUpdate $varname
}

proc CATSymAdd {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)
    global pcat

    set row [expr [starbase_nrows $var(symdb)]+1]
    starbase_rowins $var(symdb) $row
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) shape] $pcat(sym,shape)
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) color] $pcat(sym,color)
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) font] $pcat(sym,font)
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) fontsize] $pcat(sym,font,size)
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) fontweight] $pcat(sym,font,weight)
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) fontslant] $pcat(sym,font,slant)
    starbase_set $var(symdb) $row \
	[starbase_colnum $var(symdb) units] $pcat(sym,units)

    $var(tbl) selection clear all
    $var(tbl) selection set $row,1
    $var(tbl) see $row,1

    CATSymSelectCB $varname
    CATSymTable $varname
}

proc CATSymRemove {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)

    set ss "[$var(tbl) curselection]"
    set var(row) [string trim [lindex [split $ss ,] 0]]
    if {$var(row) != {}} {
	set nr [starbase_nrows $var(symdb)]
	if {$nr > 1 && $var(row) <= $nr} {
	    starbase_rowdel $var(symdb) $var(row)
	    set var(row) {}
	}
    }

    CATSymClear $varname
    CATSymTable $varname
}

proc CATSymSave {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)

    set fn [SaveFileDialog catsymfbox]
    if {$fn != {}} {
	starbase_write $var(symdb) $fn
    }
}

proc CATSymLoad {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)

    set fn [OpenFileDialog catsymfbox]
    if {$fn != {}} {
	if {[file exists $fn]} {
	    if [info exists $var(symdb)] {
		unset $var(symdb)
	    }
	    starbase_read $var(symdb) $fn
	    CATSymUpdate $varname
	} else {
	    Error "[msgcat::mc {Unable to open file}] $fn"
	    return
	}
    }
}

proc CATSymClear {varname} {
    upvar #0 $varname var
    global $varname

    $var(tbl) selection clear all

    set var(row) {}

    set var(condition) {}
    set var(shape) {}
    set var(color) {}
    set var(font) {}
    set var(font,size) {}
    set var(font,weight) {}
    set var(font,slant) {}
    set var(text) {}
    set var(size) {}
    set var(size2) {}
    set var(units) {}
    set var(angle) {}
}

# Support

proc CATSymDBInit {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)
    global pcat

    if [info exists $var(symdb)] {
	unset $var(symdb)
    }

    starbase_new $var(symdb) condition shape color \
	font fontsize fontweight fontslant text size size2 units angle
    starbase_rowins $var(symdb) 1
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) shape] $pcat(sym,shape)
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) color] $pcat(sym,color)
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) font] $pcat(sym,font)
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) fontsize] $pcat(sym,font,size)
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) fontweight] $pcat(sym,font,weight)
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) fontslant] $pcat(sym,font,slant)
    starbase_set $var(symdb) 1 \
	[starbase_colnum $var(symdb) units] $pcat(sym,units)
}

proc CATSymUpdate {varname} {
    upvar #0 $varname var
    global $varname

    CATGenerate $var(parent)
}

proc CATSymTable {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)
    global icatsym

    set nc [starbase_ncols $var(symdb)]
    if { $nc > $icatsym(mincols)} {
	$var(tbl) configure -cols $nc
    } else {
	$var(tbl) configure -cols $icatsym(mincols)
    }

    # add header row
    set nr [expr [starbase_nrows $var(symdb)]+1] 
    if {$nr > $icatsym(minrows)} {
	$var(tbl) configure -rows $nr
    } else {
	$var(tbl) configure -rows $icatsym(minrows)
    }
}

proc CATSymSelectCB {varname} {
    upvar #0 $varname var
    global $varname
    global $var(symdb)

    set ss "[$var(tbl) curselection]"
    set var(row) [string trim [lindex [split $ss ,] 0]]
    if {$var(row) != {}} {
	if {$var(row) <= [starbase_nrows $var(symdb)]} {
	    set var(condition) [starbase_get $var(symdb) $var(row) \
				    [starbase_colnum $var(symdb) condition]]
	    set var(shape) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) shape]]
	    set var(color) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) color]]
	    set var(font) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) font]]
	    set var(font,size) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) fontsize]]
	    set var(font,weight) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) fontweight]]
	    set var(font,slant) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) fontslant]]
	    set var(text) [starbase_get $var(symdb) $var(row) \
			       [starbase_colnum $var(symdb) text]]
	    set var(size) [starbase_get $var(symdb) $var(row) \
			       [starbase_colnum $var(symdb) size]]
	    set var(size2) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) size2]]
	    set var(units) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) units]]
	    set var(angle) [starbase_get $var(symdb) $var(row) \
				[starbase_colnum $var(symdb) angle]]
	    return
	}
    }

    CATSymClear $varname
}