Initial commit

1 files changed, 502 insertions, 0 deletions

diff --git a/ds9/library/catsym.tcl b/ds9/library/catsym.tcl
new file mode 100644
index 0000000..1dafc67
--- /dev/null
+++ b/ds9/library/catsym.tcl
@@ -0,0 +1,502 @@
+#  Copyright (C) 1999-2016
+#  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(width) [starbase_get $var(symdb) $var(row) \
+			    [starbase_colnum $var(symdb) width]]
+	set var(dash) [starbase_get $var(symdb) $var(row) \
+			    [starbase_colnum $var(symdb) dash]]
+	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"
+    $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+
+    # menu
+    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.twidth -text [msgcat::mc {Width}] 
+    WidthDashMenuButton $f.width $varname width dash {} {}
+    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.twidth $f.width -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) width] $var(width)
+	    starbase_set $var(symdb) $var(row) \
+		[starbase_colnum $var(symdb) dash] $var(dash)
+	    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) width] $pcat(sym,width)
+    starbase_set $var(symdb) $row \
+	[starbase_colnum $var(symdb) dash] $pcat(sym,dash)
+    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(width) {}
+    set var(dash) {}
+    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 width dash \
+	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) width] $pcat(sym,width)
+    starbase_set $var(symdb) 1 \
+	[starbase_colnum $var(symdb) dash] $pcat(sym,dash)
+    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(width) [starbase_get $var(symdb) $var(row) \
+				[starbase_colnum $var(symdb) width]]
+	    set var(dash) [starbase_get $var(symdb) $var(row) \
+				[starbase_colnum $var(symdb) dash]]
+	    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
+}