summaryrefslogtreecommitdiffstats
path: root/ds9/library
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:01:15 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:01:15 (GMT)
commit12166aa342f7c8d905097e43a1f50e0775503069 (patch)
tree73a6e7296fbf9898633a02c2503a3e959789d8c3 /ds9/library
parentd4d595fa7fb12903db9227d33d48b2b00120dbd1 (diff)
downloadblt-12166aa342f7c8d905097e43a1f50e0775503069.zip
blt-12166aa342f7c8d905097e43a1f50e0775503069.tar.gz
blt-12166aa342f7c8d905097e43a1f50e0775503069.tar.bz2
Initial commit
Diffstat (limited to 'ds9/library')
-rw-r--r--ds9/library/2mass.tcl141
-rw-r--r--ds9/library/3d.tcl534
-rw-r--r--ds9/library/Makefile188
-rw-r--r--ds9/library/analysis.tcl1958
-rw-r--r--ds9/library/analysisparam.tcl176
-rw-r--r--ds9/library/annulus.tcl182
-rw-r--r--ds9/library/ar.tcl208
-rw-r--r--ds9/library/array.tcl167
-rw-r--r--ds9/library/backup.tcl802
-rw-r--r--ds9/library/bin.tcl830
-rw-r--r--ds9/library/block.tcl356
-rw-r--r--ds9/library/box.tcl126
-rw-r--r--ds9/library/boxannulus.tcl28
-rw-r--r--ds9/library/bpanda.tcl36
-rw-r--r--ds9/library/buttons.tcl310
-rw-r--r--ds9/library/cat.tcl1799
-rw-r--r--ds9/library/catcds.tcl246
-rw-r--r--ds9/library/catcdssrch.tcl471
-rw-r--r--ds9/library/catcdssrchdialog.tcl474
-rw-r--r--ds9/library/catcmd.tcl764
-rw-r--r--ds9/library/catcxc.tcl390
-rw-r--r--ds9/library/catdialog.tcl1302
-rw-r--r--ds9/library/catflt.tcl133
-rw-r--r--ds9/library/catmatch.tcl711
-rw-r--r--ds9/library/catned.tcl212
-rw-r--r--ds9/library/catopt.tcl57
-rw-r--r--ds9/library/catplot.tcl216
-rw-r--r--ds9/library/catreg.tcl395
-rw-r--r--ds9/library/catsdss.tcl176
-rw-r--r--ds9/library/catsimbad.tcl236
-rw-r--r--ds9/library/catskybot.tcl158
-rw-r--r--ds9/library/catsym.tcl502
-rw-r--r--ds9/library/catvot.tcl70
-rw-r--r--ds9/library/centroid.tcl115
-rw-r--r--ds9/library/circle.tcl108
-rw-r--r--ds9/library/colorbar.tcl1449
-rw-r--r--ds9/library/comm.tcl386
-rw-r--r--ds9/library/command.tcl918
-rw-r--r--ds9/library/compass.tcl99
-rw-r--r--ds9/library/composite.tcl136
-rw-r--r--ds9/library/contour.tcl1418
-rw-r--r--ds9/library/convert.tcl215
-rw-r--r--ds9/library/coord.tcl204
-rw-r--r--ds9/library/cpanda.tcl132
-rw-r--r--ds9/library/crop.tcl467
-rw-r--r--ds9/library/crosshair.tcl310
-rw-r--r--ds9/library/cube.tcl843
-rw-r--r--ds9/library/debug.tcl285
-rw-r--r--ds9/library/dialog.tcl585
-rwxr-xr-xds9/library/ds9.tcl603
-rw-r--r--ds9/library/ellipse.tcl126
-rw-r--r--ds9/library/ellipseannulus.tcl28
-rw-r--r--ds9/library/envi.tcl96
-rw-r--r--ds9/library/epanda.tcl38
-rw-r--r--ds9/library/error.tcl73
-rw-r--r--ds9/library/eso.tcl170
-rw-r--r--ds9/library/examine.tcl319
-rw-r--r--ds9/library/export.tcl398
-rw-r--r--ds9/library/external.tcl61
-rw-r--r--ds9/library/file.tcl307
-rw-r--r--ds9/library/fits.tcl408
-rw-r--r--ds9/library/frame.tcl2667
-rw-r--r--ds9/library/graph.tcl419
-rw-r--r--ds9/library/grid.tcl1550
-rw-r--r--ds9/library/group.tcl208
-rw-r--r--ds9/library/header.tcl195
-rw-r--r--ds9/library/help.tcl85
-rw-r--r--ds9/library/htp.tcl22
-rw-r--r--ds9/library/http.tcl54
-rw-r--r--ds9/library/hv.tcl931
-rw-r--r--ds9/library/hvform.tcl525
-rw-r--r--ds9/library/hvsup.tcl2089
-rw-r--r--ds9/library/iexam.tcl189
-rw-r--r--ds9/library/iis.tcl398
-rw-r--r--ds9/library/ime.tcl609
-rw-r--r--ds9/library/imgsvr.tcl585
-rw-r--r--ds9/library/import.tcl230
-rw-r--r--ds9/library/info.tcl1177
-rw-r--r--ds9/library/layout.tcl1086
-rw-r--r--ds9/library/line.tcl121
-rw-r--r--ds9/library/load.tcl534
-rw-r--r--ds9/library/macosx.tcl82
-rw-r--r--ds9/library/magnifier.tcl187
-rw-r--r--ds9/library/manalysis.tcl602
-rw-r--r--ds9/library/marker.tcl2076
-rw-r--r--ds9/library/markeranalysishist.tcl116
-rw-r--r--ds9/library/markeranalysispanda.tcl160
-rw-r--r--ds9/library/markeranalysisplot2d.tcl273
-rw-r--r--ds9/library/markeranalysisplot3d.tcl231
-rw-r--r--ds9/library/markeranalysisradial.tcl177
-rw-r--r--ds9/library/markeranalysisstats.tcl102
-rw-r--r--ds9/library/markerbase.tcl313
-rw-r--r--ds9/library/markerbaseannulus.tcl274
-rw-r--r--ds9/library/markerbaseannulusrect.tcl188
-rw-r--r--ds9/library/markerbasecenter.tcl91
-rw-r--r--ds9/library/markerbaseline.tcl99
-rw-r--r--ds9/library/markerbasepanda.tcl216
-rw-r--r--ds9/library/markerbasepandarect.tcl130
-rw-r--r--ds9/library/markerdialog.tcl292
-rw-r--r--ds9/library/mask.tcl297
-rw-r--r--ds9/library/mbin.tcl341
-rw-r--r--ds9/library/mcolor.tcl498
-rw-r--r--ds9/library/mecube.tcl133
-rw-r--r--ds9/library/medit.tcl321
-rw-r--r--ds9/library/menu.tcl586
-rw-r--r--ds9/library/mfile.tcl688
-rw-r--r--ds9/library/mframe.tcl1226
-rw-r--r--ds9/library/mhelp.tcl165
-rw-r--r--ds9/library/mosaic.tcl34
-rw-r--r--ds9/library/mosaicimage.tcl37
-rw-r--r--ds9/library/mosaicimageiraf.tcl87
-rw-r--r--ds9/library/mosaicimagewcs.tcl141
-rw-r--r--ds9/library/mosaicimagewfpc2.tcl93
-rw-r--r--ds9/library/mosaiciraf.tcl87
-rw-r--r--ds9/library/mosaicwcs.tcl148
-rw-r--r--ds9/library/movie.tcl534
-rw-r--r--ds9/library/mregion.tcl1103
-rw-r--r--ds9/library/mscale.tcl441
-rw-r--r--ds9/library/multiframe.tcl179
-rw-r--r--ds9/library/mview.tcl358
-rw-r--r--ds9/library/mwcs.tcl140
-rw-r--r--ds9/library/mzoom.tcl412
-rw-r--r--ds9/library/nameres.tcl254
-rw-r--r--ds9/library/nrrd.tcl142
-rw-r--r--ds9/library/nsvr.tcl287
-rw-r--r--ds9/library/nvss.tcl162
-rw-r--r--ds9/library/open.tcl119
-rw-r--r--ds9/library/pagesetup.tcl208
-rw-r--r--ds9/library/panner.tcl296
-rw-r--r--ds9/library/panzoom.tcl823
-rw-r--r--ds9/library/photo.tcl300
-rw-r--r--ds9/library/pixel.tcl295
-rw-r--r--ds9/library/plot.tcl1360
-rw-r--r--ds9/library/plotbar.tcl201
-rw-r--r--ds9/library/plotdialog.tcl511
-rw-r--r--ds9/library/plotelement.tcl17
-rw-r--r--ds9/library/plotline.tcl281
-rw-r--r--ds9/library/plotprint.tcl114
-rw-r--r--ds9/library/plotprocess.tcl1217
-rw-r--r--ds9/library/plotscatter.tcl256
-rw-r--r--ds9/library/point.tcl111
-rw-r--r--ds9/library/polygon.tcl84
-rw-r--r--ds9/library/prefs.tcl1004
-rw-r--r--ds9/library/prefsdialog.tcl317
-rw-r--r--ds9/library/print.tcl612
-rw-r--r--ds9/library/projection.tcl128
-rw-r--r--ds9/library/rgb.tcl365
-rw-r--r--ds9/library/rgbarray.tcl185
-rw-r--r--ds9/library/rgbcube.tcl163
-rw-r--r--ds9/library/rgbimage.tcl181
-rw-r--r--ds9/library/ruler.tcl117
-rw-r--r--ds9/library/samp.tcl1730
-rw-r--r--ds9/library/sao.tcl158
-rw-r--r--ds9/library/save.tcl251
-rw-r--r--ds9/library/saveimage.tcl271
-rw-r--r--ds9/library/scale.tcl1053
-rw-r--r--ds9/library/segment.tcl74
-rw-r--r--ds9/library/sfits.tcl64
-rw-r--r--ds9/library/shm.tcl251
-rw-r--r--ds9/library/sia.tcl499
-rw-r--r--ds9/library/siadialog.tcl488
-rw-r--r--ds9/library/skyview.tcl619
-rw-r--r--ds9/library/slider.tcl72
-rw-r--r--ds9/library/smooth.tcl304
-rw-r--r--ds9/library/smosaic.tcl25
-rw-r--r--ds9/library/smosaiciraf.tcl70
-rw-r--r--ds9/library/smosaicwcs.tcl70
-rw-r--r--ds9/library/source.tcl195
-rw-r--r--ds9/library/srgbcube.tcl68
-rw-r--r--ds9/library/starbase.tcl547
-rw-r--r--ds9/library/stdfbox.tcl547
-rw-r--r--ds9/library/stsci.tcl182
-rw-r--r--ds9/library/template.tcl130
-rw-r--r--ds9/library/text.tcl93
-rw-r--r--ds9/library/tkfbox.tcl1247
-rw-r--r--ds9/library/tsv.tcl162
-rw-r--r--ds9/library/url.tcl334
-rw-r--r--ds9/library/util.tcl1555
-rw-r--r--ds9/library/var.tcl21
-rw-r--r--ds9/library/vector.tcl165
-rw-r--r--ds9/library/vla.tcl173
-rw-r--r--ds9/library/vlss.tcl132
-rw-r--r--ds9/library/vo.tcl613
-rw-r--r--ds9/library/vot.tcl386
-rw-r--r--ds9/library/wcs.tcl1296
-rwxr-xr-xds9/library/win32.tcl27
-rw-r--r--ds9/library/xmfbox.tcl998
-rw-r--r--ds9/library/xmlrpc.tcl875
-rw-r--r--ds9/library/xpa.tcl2251
189 files changed, 80089 insertions, 0 deletions
diff --git a/ds9/library/2mass.tcl b/ds9/library/2mass.tcl
new file mode 100644
index 0000000..08a5527
--- /dev/null
+++ b/ds9/library/2mass.tcl
@@ -0,0 +1,141 @@
+# 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 2MASSDef {} {
+ global twomass
+ global itwomass
+
+ set itwomass(top) .twomass
+ set itwomass(mb) .twomassmb
+
+ set twomass(sky) fk5
+ set twomass(rformat) arcmin
+ set twomass(width) 15
+ set twomass(height) 15
+ set twomass(mode) new
+ set twomass(save) 0
+ set twomass(survey) j
+}
+
+proc 2MASSDialog {} {
+ global twomass
+ global itwomass
+ global wcs
+
+ if {[winfo exists $itwomass(top)]} {
+ raise $itwomass(top)
+ return
+ }
+
+ set varname dtwomass
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $itwomass(top)
+ set var(mb) $itwomass(mb)
+ set var(sky) $twomass(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $twomass(rformat)
+ set var(width) $twomass(width)
+ set var(height) $twomass(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(mode) $twomass(mode)
+ set var(save) $twomass(save)
+ set var(survey) $twomass(survey)
+
+ IMGSVRInit $varname "IPAC-2MASS [msgcat::mc {Server}]" \
+ 2MASSExec 2MASSAck ARDone ARError
+
+ $var(mb) add cascade -label Survey -menu $var(mb).survey
+ menu $var(mb).survey
+ $var(mb).survey add radiobutton -label {2MASS (J Band)} \
+ -variable ${varname}(survey) -value j
+ $var(mb).survey add radiobutton -label {2MASS (H Band)} \
+ -variable ${varname}(survey) -value h
+ $var(mb).survey add radiobutton -label {2MASS (K Band)} \
+ -variable ${varname}(survey) -value k
+
+ IMGSVRUpdate $varname
+}
+
+proc 2MASSExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+
+ } else {
+ set var(fn) [tmpnam {.fits.gz}]
+ }
+
+ # size - convert to arcsec
+ switch -- $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.*60.]
+ set hh [expr $var(height)*60.*60.]
+ }
+ arcmin {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcsec {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+ if {$rr>1024} {
+ set rr 1024
+ }
+
+ set foo "$var(x) $var(y)"
+
+ set var(query) [http::formatQuery objstr $foo size $rr band $var(survey)]
+ set url "http://irsa.ipac.caltech.edu/cgi-bin/Oasis/2MASSImg/nph-2massimg"
+ IMGSVRGetURL $varname $url
+}
+
+proc 2MASSAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the 2MASS
+
+This publication makes use of data products from the Two Micron All
+Sky Survey, which is a joint project of the University of
+Massachusetts and the Infrared Processing and Analysis
+Center/California Institute of Technology, funded by the National
+Aeronautics and Space Administration and the National Science
+Foundation.
+ }
+
+ SimpleTextDialog "${varname}ack" [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc Process2MASSCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ 2MASSDialog
+ IMGSVRProcessCmd $varname $iname dtwomass
+}
+
+proc ProcessSend2MASSCmd {proc id param} {
+ 2MASSDialog
+ IMGSVRProcessSendCmd $proc $id $param dtwomass
+}
diff --git a/ds9/library/3d.tcl b/ds9/library/3d.tcl
new file mode 100644
index 0000000..1315f1c
--- /dev/null
+++ b/ds9/library/3d.tcl
@@ -0,0 +1,534 @@
+# 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 3DDef {} {
+ global threed
+ global ithreed
+ global pthreed
+
+ set ithreed(top) .threed
+ set ithreed(mb) .threedmb
+ set ithreed(status) 0
+
+ set threed(az) 0
+ set threed(el) 0
+ set threed(scale) 1
+
+ set threed(method) mip
+ set threed(background) none
+ set threed(highlite) 1
+ set threed(highlite,color) cyan
+ set threed(border) 1
+ set threed(border,color) blue
+ set threed(compass) 0
+ set threed(compass,color) green
+
+ array set pthreed [array get threed]
+ unset pthreed(az)
+ unset pthreed(el)
+}
+
+# used by backup
+proc 3DDialog {} {
+ global threed
+ global ithreed
+ global ds9
+
+ # see if we already have a window visible
+ if {[winfo exists $ithreed(top)]} {
+ raise $ithreed(top)
+ return
+ }
+
+ # create the 3d window
+ set w $ithreed(top)
+ set mb $ithreed(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {3D}] 3DDestroyDialog
+ $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 {Render}] -menu $mb.render
+ $mb add cascade -label [msgcat::mc {Highlite}] -menu $mb.highlite
+ $mb add cascade -label [msgcat::mc {Border}] -menu $mb.border
+# $mb add cascade -label [msgcat::mc {Compass}] -menu $mb.compass
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command 3DApplyDialog
+ $mb.file add command -label [msgcat::mc {Reset}] -command 3DResetDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command 3DDestroyDialog
+
+ EditMenu $mb ithreed
+
+ menu $mb.render
+ $mb.render add radiobutton -label [msgcat::mc {MIP}] \
+ -variable threed(method) -value {mip} -command 3DRenderMethod
+ $mb.render add radiobutton -label [msgcat::mc {AIP}] \
+ -variable threed(method) -value {aip} -command 3DRenderMethod
+ $mb.render add separator
+ $mb.render add radiobutton -label [msgcat::mc {None}] \
+ -variable threed(background) -value {none} -command 3DBackground
+ $mb.render add radiobutton -label [msgcat::mc {Azimuth}] \
+ -variable threed(background) -value {azimuth} -command 3DBackground
+ $mb.render add radiobutton -label [msgcat::mc {Elevation}] \
+ -variable threed(background) -value {elevation} -command 3DBackground
+
+ menu $mb.highlite
+ $mb.highlite add checkbutton -label [msgcat::mc {Show}] \
+ -variable threed(highlite) -command 3DHighlite
+ $mb.highlite add separator
+ $mb.highlite add cascade -label [msgcat::mc {Color}] \
+ -menu $mb.highlite.color
+ ColorMenu $mb.highlite.color threed highlite,color 3DHighliteColor
+
+ menu $mb.border
+ $mb.border add checkbutton -label [msgcat::mc {Show}] \
+ -variable threed(border) -command 3DBorder
+ $mb.border add separator
+ $mb.border add cascade -label [msgcat::mc {Color}] \
+ -menu $mb.border.color
+ ColorMenu $mb.border.color threed border,color 3DBorderColor
+
+ menu $mb.compass
+ $mb.compass add checkbutton -label [msgcat::mc {Show}] -variable threed(compass) -command 3DCompass
+ $mb.compass add separator
+ $mb.compass add cascade -label [msgcat::mc {Color}] -menu $mb.compass.color
+ ColorMenu $mb.compass.color threed compass,color 3DCompassColor
+
+ # Param
+ set f [ttk::frame $w.param]
+ slider $f.elslider -90 90 [msgcat::mc {Elevation}] threed(el) \
+ [list 3DViewMotion]
+ slider $f.azslider -180 180 [msgcat::mc {Azimuth}] threed(az) \
+ [list 3DViewMotion]
+
+ bind $f.elslider.slider <ButtonPress-1> {3DViewButton}
+ bind $f.elslider.slider <ButtonRelease-1> {3DViewRelease}
+ bind $f.azslider.slider <ButtonPress-1> {3DViewButton}
+ bind $f.azslider.slider <ButtonRelease-1> {3DViewRelease}
+
+ grid $f.azslider -padx 2 -pady 2 -sticky ew
+ grid $f.elslider -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+ # for order of focus
+ raise $f.elslider
+
+ # Scale
+ set f [ttk::frame $w.scale]
+ ttk::label $f.tscale -text [msgcat::mc {Z Axis Scale}]
+ ttk::entry $f.scale -textvariable threed(scale) -width 7
+ grid $f.tscale $f.scale -padx 2 -pady 2 -sticky ew
+
+ # Status
+ set f [ttk::frame $w.status]
+ ttk::label $f.tstatus -text [msgcat::mc {Status}]
+ ttk::progressbar $f.status -variable ithreed(status) -length 350
+ grid $f.tstatus $f.status -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command 3DApplyDialog
+ ttk::button $f.reset -text [msgcat::mc {Reset}] -command 3DResetDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command 3DDestroyDialog
+ pack $f.apply $f.reset $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ ttk::separator $w.sep2 -orient horizontal
+ ttk::separator $w.sep3 -orient horizontal
+ pack $w.buttons $w.sep $w.status $w.sep2 -side bottom -fill x
+ pack $w.param $w.sep3 $w.scale -side top -fill x
+
+ Update3DDialog
+}
+
+proc 3DDestroyDialog {} {
+ global threed
+ global ithreed
+
+ if {[winfo exists $ithreed(top)]} {
+ destroy $ithreed(top)
+ destroy $ithreed(mb)
+ }
+}
+
+proc 3DApplyDialog {} {
+ global threed
+ global current
+ global grid
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d view $threed(az) $threed(el)
+ $current(frame) 3d scale $threed(scale)
+ if {$grid(view)} {
+ GridUpdateCurrent
+ }
+ }
+}
+
+proc 3DResetDialog {} {
+ global threed
+
+ set threed(az) 0
+ set threed(el) 0
+ 3DViewPoint
+ set threed(scale) 1
+ 3DScale
+}
+
+proc Update3DDialog {} {
+ global threed
+ global ithreed
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "Update3DDialog"
+ }
+
+ set w $ithreed(top)
+
+ if {[winfo exists $ithreed(top)] && $current(frame) != {}} {
+ set rr [$current(frame) get 3d view]
+ set threed(az) [lindex $rr 0]
+ set threed(el) [lindex $rr 1]
+ set threed(scale) [$current(frame) get 3d scale]
+ set threed(method) [$current(frame) get 3d method]
+ set threed(background) [$current(frame) get 3d background]
+ set threed(highlite) [$current(frame) get 3d highlite]
+ set threed(highlite,color) [$current(frame) get 3d highlite color]
+ set threed(border) [$current(frame) get 3d border]
+ set threed(border,color) [$current(frame) get 3d border color]
+ set threed(compass) [$current(frame) get 3d compass]
+ set threed(compass,color) [$current(frame) get 3d compass color]
+ }
+}
+
+proc 3DBackup {ch which} {
+ puts $ch "$which 3d view [$which get 3d view]"
+ puts $ch "$which 3d scale [$which get 3d scale]"
+ puts $ch "$which 3d method [$which get 3d method]"
+ puts $ch "$which 3d highlite [$which get 3d highlite]"
+ puts $ch "$which 3d border [$which get 3d border]"
+ puts $ch "$which 3d background [$which get 3d background]"
+ # this must come after panto and blockto
+ puts $ch "$which 3d view point [$which get 3d view point]"
+
+}
+
+proc 3DViewPoint {} {
+ global threed
+ global current
+ global grid
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d view $threed(az) $threed(el)
+ if {$grid(view)} {
+ GridUpdateCurrent
+ }
+ }
+}
+
+proc 3DViewButton {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d view begin $threed(az) $threed(el)
+ }
+}
+
+proc 3DViewMotion {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d view motion $threed(az) $threed(el)
+ }
+}
+
+proc 3DViewRelease {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d view end $threed(az) $threed(el)
+ }
+}
+
+proc 3DScale {} {
+ global threed
+ global current
+ global grid
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d scale $threed(scale)
+ if {$grid(view)} {
+ GridUpdateCurrent
+ }
+ }
+}
+
+proc 3DRenderMethod {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d method $threed(method)
+ }
+}
+
+proc 3DHighlite {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d highlite $threed(highlite)
+ }
+}
+
+proc 3DHighliteColor {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d highlite color $threed(highlite,color)
+ }
+}
+
+proc 3DBorder {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d border $threed(border)
+ }
+}
+
+proc 3DBorderColor {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d border color $threed(border,color)
+ }
+}
+
+proc 3DCompass {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d compass $threed(compass)
+ }
+}
+
+proc 3DCompassColor {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d compass color $threed(compass,color)
+ }
+}
+
+proc 3DBackground {} {
+ global threed
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) 3d background $threed(background)
+ }
+}
+
+# Prefs
+
+proc PrefsDialog3d {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {3D}]
+ lappend dprefs(tabs) [ttk::frame $w.threed]
+
+ set f [ttk::labelframe $w.threed.misc -text [msgcat::mc {Render}]]
+ ttk::label $f.tmethod -text [msgcat::mc {Method}]
+ ttk::menubutton $f.method -textvariable pthreed(method) \
+ -menu $f.method.menu
+ ttk::label $f.tbackground -text [msgcat::mc {Background}]
+ ttk::menubutton $f.background -textvariable pthreed(background) \
+ -menu $f.background.menu
+
+ grid $f.tmethod $f.method -padx 2 -pady 2 -sticky w
+ grid $f.tbackground $f.background -padx 2 -pady 2 -sticky w
+
+ set m $f.method.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {MIP}] \
+ -variable pthreed(method) -value {mip}
+ $m add radiobutton -label [msgcat::mc {AIP}] \
+ -variable pthreed(method) -value {aip}
+
+ set m $f.background.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {None}] \
+ -variable pthreed(background) -value {none}
+ $m add radiobutton -label [msgcat::mc {Azimuth}] \
+ -variable pthreed(background) -value {azimuth}
+ $m add radiobutton -label [msgcat::mc {Elevation}] \
+ -variable pthreed(background) -value {elevation}
+
+ set f [ttk::labelframe $w.threed.highlite -text [msgcat::mc {Highlite}]]
+ ttk::checkbutton $f.show -text [msgcat::mc {Show}] \
+ -variable pthreed(highlite)
+ ttk::label $f.tcolor -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color pthreed highlite,color {}
+
+ grid $f.show -padx 2 -pady 2 -sticky w
+ grid $f.tcolor $f.color -padx 2 -pady 2 -sticky w
+
+ set f [ttk::labelframe $w.threed.border -text [msgcat::mc {Border}]]
+ ttk::checkbutton $f.show -text [msgcat::mc {Show}] \
+ -variable pthreed(border)
+ ttk::label $f.tcolor -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color pthreed border,color {}
+
+ grid $f.show -padx 2 -pady 2 -sticky w
+ grid $f.tcolor $f.color -padx 2 -pady 2 -sticky w
+
+# set f [ttk::labelframe $w.threed.compass -text [msgcat::mc {Compass}]]
+# ttk::checkbutton $f.show -text [msgcat::mc {Show}] -variable pthreed(compass)
+# ttk::label $f.tcolor -text [msgcat::mc {Color}]
+# ColorMenuButton $f.color pthreed compass,color {}
+
+ grid $f.show -padx 2 -pady 2 -sticky w
+ grid $f.tcolor $f.color -padx 2 -pady 2 -sticky w
+
+ pack $w.threed.misc $w.threed.highlite $w.threed.border \
+ -side top -fill both -expand true
+}
+
+proc Process3DCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global threed
+
+ 3DDialog
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {}
+ close {3DDestroyDialog}
+ az {
+ incr i
+ set threed(az) [lindex $var $i]
+ 3DViewPoint
+ }
+ el {
+ incr i
+ set threed(el) [lindex $var $i]
+ 3DViewPoint
+ }
+ view -
+ vp {
+ incr i
+ set threed(az) [lindex $var $i]
+ incr i
+ set threed(el) [lindex $var $i]
+ 3DViewPoint
+ }
+ scale {
+ incr i
+ set threed(scale) [lindex $var $i]
+ 3DScale
+ }
+ method {
+ incr i
+ set threed(method) [lindex $var $i]
+ 3DRenderMethod
+ }
+ background {
+ incr i
+ set threed(background) [lindex $var $i]
+ 3DBackground
+ }
+ highlite {
+ incr i
+ switch [string tolower [lindex $var $i]] {
+ color {
+ incr i
+ set threed(highlite,color) [lindex $var $i]
+ 3DHighliteColor
+ }
+ default {
+ set threed(highlite) [FromYesNo [lindex $var $i]]
+ 3DHighlite
+ }
+ }
+ }
+ border {
+ incr i
+ switch [string tolower [lindex $var $i]] {
+ color {
+ incr i
+ set threed(border,color) [lindex $var $i]
+ 3DBorderColor
+ }
+ default {
+ set threed(border) [FromYesNo [lindex $var $i]]
+ 3DBorder
+ }
+ }
+ }
+ compass {
+ incr i
+ switch [string tolower [lindex $var $i]] {
+ color {
+ incr i
+ set threed(compass,color) [lindex $var $i]
+ 3DCompassColor
+ }
+ default {
+ set threed(compass) [FromYesNo [lindex $var $i]]
+ 3DCompass
+ }
+ }
+ }
+ default {Create3DFrame; incr i -1}
+ }
+}
+
+proc ProcessSend3DCmd {proc id param} {
+ global threed
+
+ switch -- [string tolower [lindex $param 0]] {
+ az {$proc $id "$threed(az)\n"}
+ el {$proc $id "$threed(el)\n"}
+ view -
+ vp {$proc $id "$threed(az) $threed(el)\n"}
+ scale {$proc $id "$threed(scale)\n"}
+ method {$proc $id "$threed(method)\n"}
+ background {$proc $id "$threed(background)\n"}
+ highlite {
+ switch [string tolower [lindex $param 1]] {
+ color {$proc $id "$threed(highlite,color)\n"}
+ default {$proc $id [ToYesNo $threed(highlite)]}
+ }
+ }
+ border {
+ switch [string tolower [lindex $param 1]] {
+ color {$proc $id "$threed(border,color)\n"}
+ default {$proc $id [ToYesNo $threed(border)]}
+ }
+ }
+ compass {
+ switch [string tolower [lindex $param 1]] {
+ color {$proc $id "$threed(compass,color)\n"}
+ default {$proc $id [ToYesNo $threed(compass)]}
+ }
+ }
+ }
+}
diff --git a/ds9/library/Makefile b/ds9/library/Makefile
new file mode 100644
index 0000000..ef058c0
--- /dev/null
+++ b/ds9/library/Makefile
@@ -0,0 +1,188 @@
+SCRIPTS = \
+ 2mass.tcl \
+ 3d.tcl \
+ array.tcl \
+ analysis.tcl \
+ analysisparam.tcl \
+ annulus.tcl \
+ ar.tcl \
+ backup.tcl \
+ bin.tcl \
+ box.tcl \
+ boxannulus.tcl \
+ bpanda.tcl \
+ buttons.tcl \
+ cat.tcl \
+ catcds.tcl \
+ catcdssrch.tcl \
+ catcdssrchdialog.tcl \
+ catcmd.tcl \
+ catcxc.tcl \
+ catdialog.tcl \
+ catflt.tcl \
+ catmatch.tcl \
+ catned.tcl \
+ catopt.tcl \
+ catplot.tcl \
+ catreg.tcl \
+ catsdss.tcl \
+ catsimbad.tcl \
+ catskybot.tcl \
+ catsym.tcl \
+ cattsv.tcl \
+ catvot.tcl \
+ centroid.tcl \
+ circle.tcl \
+ colorbar.tcl \
+ comm.tcl \
+ command.tcl \
+ compass.tcl \
+ composite.tcl \
+ contour.tcl \
+ convert.tcl \
+ coord.tcl \
+ cpanda.tcl \
+ crop.tcl \
+ crosshair.tcl \
+ cube.tcl \
+ debug.tcl \
+ dialog.tcl \
+ ellipse.tcl \
+ ellipseannulus.tcl \
+ envi.tcl \
+ epanda.tcl \
+ error.tcl \
+ eso.tcl \
+ examine.tcl \
+ export.tcl \
+ external.tcl \
+ file.tcl \
+ fits.tcl \
+ frame.tcl \
+ graph.tcl \
+ grid.tcl \
+ group.tcl \
+ header.tcl \
+ help.tcl \
+ http.tcl \
+ hv.tcl \
+ hvform.tcl \
+ hvsup.tcl \
+ iis.tcl \
+ imexam.tcl \
+ imgsvr.tcl \
+ import.tcl \
+ info.tcl \
+ layout.tcl \
+ line.tcl \
+ load.tcl \
+ magnifier.tcl \
+ marker.tcl \
+ markeranalysispanda.tcl \
+ markeranalysisplot2d.tcl \
+ markeranalysisplot3d.tcl \
+ markeranalysisradial.tcl \
+ markeranalysisstats.tcl \
+ markerbase.tcl \
+ markerbaseannulus.tcl \
+ markerbaseannulusrect.tcl \
+ markerbasecenter.tcl \
+ markerbaseline.tcl \
+ markerbasepanda.tcl \
+ markerbasepandarect.tcl \
+ markerdialog.tcl \
+ mask.tcl \
+ manalysis.tcl \
+ mbin.tcl \
+ mcolor.tcl \
+ mecube.tcl \
+ medit.tcl \
+ menu.tcl \
+ mfile.tcl \
+ mframe.tcl \
+ mhelp.tcl \
+ macosx.tcl \
+ macosxextra.tcl \
+ mosaicimage.tcl \
+ mosaicimageiraf.tcl \
+ mosaicimagewcs.tcl \
+ mosaicimagewfpc2.tcl \
+ mosaic.tcl \
+ mosaiciraf.tcl \
+ mosaicwcs.tcl \
+ movie.tcl \
+ mregion.tcl \
+ mscale.tcl \
+ multiframe.tcl \
+ mview.tcl \
+ mwcs.tcl \
+ mzoom.tcl \
+ nameres.tcl \
+ nrrd.tcl \
+ nsvr.tcl \
+ nvss.tcl \
+ pagesetup.tcl \
+ panner.tcl \
+ panzoom.tcl \
+ pixel.tcl \
+ photo.tcl \
+ plot.tcl \
+ plotbar.tcl \
+ plotdialog.tcl \
+ plotelement.tcl \
+ plotline.tcl \
+ plotprint.tcl \
+ plotprocess.tcl \
+ plotscatter.tcl \
+ point.tcl \
+ polygon.tcl \
+ prefs.tcl \
+ prefsdialog.tcl \
+ print.tcl \
+ projection.tcl \
+ open.tcl \
+ rgb.tcl \
+ rgbarray.tcl \
+ rgbcube.tcl \
+ rgbimage.tcl \
+ ruler.tcl \
+ samp.tcl \
+ sao.tcl \
+ save.tcl \
+ saveimage.tcl \
+ scale.tcl \
+ segment.tcl \
+ sfits.tcl \
+ shm.tcl \
+ skyview.tcl \
+ slider.tcl \
+ smosaic.tcl \
+ smosaiciraf.tcl \
+ smosaicwcs.tcl \
+ smooth.tcl \
+ source.tcl \
+ srgbcube.tcl \
+ starbase.tcl \
+ stdfbox.tcl \
+ stsci.tcl \
+ template.tcl \
+ text.tcl \
+ tkfbox.tcl \
+ url.tcl \
+ util.tcl \
+ var.tcl \
+ vector.tcl \
+ vla.tcl \
+ vo.tcl \
+ wcs.tcl \
+ win32.tcl \
+ xmfbox.tcl \
+ xpa.tcl
+
+.PHONY : msgs clean
+
+msgs :
+ grep 'msgcat::mc' $(SCRIPTS) | cut -d[ -f2 | sed -e 's/::mc/::mcset AAA /' -e 's/]/ ""/' | sort | uniq > ../msgs/tmpl.tcl
+
+clean :
+ $(RM) core *~ *#
diff --git a/ds9/library/analysis.tcl b/ds9/library/analysis.tcl
new file mode 100644
index 0000000..da1de2e
--- /dev/null
+++ b/ds9/library/analysis.tcl
@@ -0,0 +1,1958 @@
+# 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 AnalysisDef {} {
+ global ianalysis
+ global panalysis
+
+ global ds9
+
+ set ianalysis(menu,count) 0
+ set ianalysis(menu,hmenu,count) 0
+ set ianalysis(menu,hmenu) {}
+ set ianalysis(bind,count) 0
+ set ianalysis(param,count) 0
+ set ianalysis(param,seq) 0
+ set ianalysis(file) ".$ds9(app).ans"
+ set ianalysis(alt) ".$ds9(app).analysis"
+
+ # prefs only
+ set panalysis(log) 0
+ set panalysis(autoload) 1
+ set panalysis(user) {}
+ set panalysis(user2) {}
+ set panalysis(user3) {}
+ set panalysis(user4) {}
+}
+
+proc OpenAnalysisMenu {} {
+ set fn [OpenFileDialog analysisfbox]
+ if {$fn != {}} {
+ ProcessAnalysisFile $fn
+ }
+}
+
+proc ClearAnalysisMenu {} {
+ global pds9
+
+ if {$pds9(confirm)} {
+ if {[tk_messageBox -type okcancel -icon question -message [msgcat::mc {Clear External Analysis Commands?}]] != {ok}} {
+ return
+ }
+ }
+ ClearAnalysis
+}
+
+# Analysis Menu Delete
+proc ClearAnalysis {} {
+ global ds9
+ global ianalysis
+
+ # is something loaded?
+ if {$ianalysis(menu,count) == 0} {
+ return
+ }
+
+ # delete cascade menus
+ for {set ii 0} {$ii<$ianalysis(menu,hmenu,count)} {incr ii} {
+ destroy [lindex $ianalysis(menu,hmenu) $ii]
+ }
+ set ianalysis(menu,hmenu) {}
+ set ianalysis(menu,hmenu,count) 0
+
+ # clear menu
+ $ds9(mb).analysis delete $ds9(menu,size,analysis) end
+
+ for {set ii 0} {$ii<$ianalysis(menu,count)} {incr ii} {
+ unset ianalysis(menu,$ii,parent)
+ unset ianalysis(menu,$ii,item)
+ unset ianalysis(menu,$ii,template)
+ unset ianalysis(menu,$ii,cmd)
+ unset ianalysis(menu,$ii,inuse)
+ unset ianalysis(menu,$ii,var)
+ }
+ set ianalysis(menu,count) 0
+
+ # clear all bindings, first
+
+ foreach ff $ds9(frames) {
+ for {set ii 0} {$ii<$ianalysis(bind,count)} {incr ii} {
+ $ds9(canvas) bind $ff "$ianalysis(bind,$ii,item)" {}
+ }
+ }
+
+ # clear bindings
+
+ for {set ii 0} {$ii<$ianalysis(bind,count)} {incr ii} {
+ unset ianalysis(bind,$ii,item)
+ unset ianalysis(bind,$ii,template)
+ unset ianalysis(bind,$ii,cmd)
+ unset ianalysis(bind,$ii,inuse)
+ }
+ set ianalysis(bind,count) 0
+
+ # clear params
+
+ for {set ii 0} {$ii<$ianalysis(param,count)} {incr ii} {
+ for {set jj 0} {$jj<$ianalysis(param,$ii,count)} {incr jj} {
+ unset ianalysis(param,$ii,$jj,var)
+ unset ianalysis(param,$ii,$jj,type)
+ unset ianalysis(param,$ii,$jj,title)
+ unset ianalysis(param,$ii,$jj,default)
+ unset ianalysis(param,$ii,$jj,last)
+ unset ianalysis(param,$ii,$jj,value)
+ unset ianalysis(param,$ii,$jj,info)
+ }
+ unset ianalysis(param,$ii,count)
+ unset ianalysis(param,$ii)
+ }
+ set ianalysis(param,count) 0
+}
+
+proc InitAnalysisFile {} {
+ global ianalysis
+ global panalysis
+ global ds9
+
+ set done {}
+
+ # autoload
+ if {$panalysis(autoload)} {
+ foreach dir [list {.} "[GetEnvHome]/bin" {/usr/local/bin} {/opt/local/bin} {/soft/saord/bin}] {
+ foreach fn [glob -directory $dir -nocomplain "*.ds9"] {
+ if {[file exists $fn]} {
+ ProcessAnalysisFile $fn
+ lappend done $fn
+ }
+ }
+ }
+ }
+
+ # default name ds9.ans
+ # backward compatible ds9.analysis
+ foreach ff {{.} {~}} {
+ foreach gg {{} {.}} {
+ foreach ext {{ans} {analysis}} {
+ set fn "$ff/$gg$ds9(app).$ext"
+ if {[file exists $fn]} {
+ if {[lsearch $done $fn] == -1} {
+ ProcessAnalysisFile $fn
+ lappend done $fn
+ }
+ }
+ }
+ }
+ }
+
+ # user specified
+ foreach ii {{user} {user2} {user3} {user4}} {
+ if {[info exists panalysis($ii)]} {
+ set fn $panalysis($ii)
+ if {[file exists $fn]} {
+ if {[lsearch $done $fn] == -1} {
+ ProcessAnalysisFile $fn
+ lappend done $fn
+ }
+ }
+ }
+ }
+
+ UpdateAnalysisMenu
+}
+
+proc ProcessAnalysisFile {fn} {
+ global env
+
+ # check for simple file
+ if {[file exists "$fn"] &&
+ [file isfile "$fn"] &&
+ ![file executable "$fn"] &&
+ ![file isdirectory "$fn"]} {
+
+ set ch [open $fn r]
+ set data [read $ch]
+ close $ch
+
+ if {![ProcessAnalysis data]} {
+ Error "[msgcat::mc {Unable to process Analysis file}] $fn"
+ return
+ }
+
+ # add directory to path
+ set env(PATH) "[file dirname $fn]:$env(PATH)"
+ } else {
+ Error "[msgcat::mc {Unable to open file}] $fn"
+ }
+}
+
+proc ProcessAnalysis {varname} {
+ upvar $varname var
+
+ global ds9
+ global ianalysis
+
+ # simple check for ascii data
+ if {![string is ascii $var]} {
+ return 0
+ }
+
+ set state 1
+ set baseparent $ds9(mb).analysis
+ set currentparent $baseparent
+ set parentstack $baseparent
+
+ $baseparent add separator
+
+ set lines [split $var \n]
+ set l [llength $lines]
+
+ for {set ii 0} {$ii<$l} {incr ii} {
+ set line [string trim [lindex $lines $ii]]
+
+ # eat empty lines and comments for all except help
+ if {$state != 6} {
+ # empty line
+ if {[string length $line] == 0} continue
+
+ # comments
+ if {[string range $line 0 0] == "\#"} continue
+
+ # strip any end of line comments
+ set id [string first "\#" $line]
+ if {$id > 0} {
+ set line [string range $line 0 [expr $id-1]]
+ }
+ }
+
+ switch -- $state {
+ 1 {
+ # param
+ if {[lindex $line 0] == {param}} {
+ if {[lindex $line 1] != {}} {
+ set ianalysis(param,$ianalysis(param,count)) \
+ [lindex $line 1]
+ set ianalysis(param,$ianalysis(param,count),count) 0
+ set state 5
+ }
+ continue
+ }
+
+ # help
+ if {[lindex $line 0] == {help}} {
+ set id [string first " " $line]
+ if {$id > 0} {
+ set item [string range $line [expr $id+1] end]
+ } else {
+ set item Help
+ }
+
+ set i $ianalysis(menu,count)
+ set ianalysis(menu,$i,parent) $currentparent
+ set ianalysis(menu,$i,item) $item
+ set ianalysis(menu,$i,template) {*}
+ set ianalysis(menu,$i,cmd) {help}
+ set ianalysis(menu,$i,inuse) 0
+ set ianalysis(menu,$i,var) {}
+ $currentparent add command -label $item \
+ -command [list AnalysisTask $i menu]
+
+ set state 6
+ continue
+ }
+
+ # hmenu
+ if {[lindex $line 0] == {hmenu}} {
+ set id [string first " " $line]
+ if {$id > 0} {
+ set item [string range $line [expr $id+1] end]
+ } else {
+ set item Tasks
+ }
+
+ # make the menu label unique
+ set nmenu "$currentparent.hmenu$ianalysis(menu,hmenu,count)"
+ lappend ianalysis(menu,hmenu) $nmenu
+ incr ianalysis(menu,hmenu,count)
+
+ menu $nmenu
+ $currentparent add cascade -label "$item" -menu $nmenu
+
+ set currentparent $nmenu
+ lappend parentstack $currentparent
+ continue
+ }
+
+ # end hmenu
+ if {[lindex $line 0] == {endhmenu} ||
+ [lindex $line 0] == {end}} {
+ set parentstack [lreplace $parentstack end end]
+ set currentparent [lindex $parentstack end]
+ continue
+ }
+
+ if {[lindex $line 0] == {---}} {
+ $currentparent add separator
+ continue
+ }
+
+ # assume new command
+
+ set item "$line"
+ set template {}
+ set type {}
+ set cmd {}
+ set state 2
+ }
+
+ 2 {
+ set template "$line"
+ set state 3
+ }
+
+ 3 {
+ set type "$line"
+ set state 4
+ }
+
+ 4 {
+ set cmd "$line"
+ if {$item != {} && $template != {} &&
+ $type != {} && $cmd != {}} {
+ switch -- [lindex $type 0] {
+ bind {
+ set b [lindex $type 1]
+ if {$b != {}} {
+ set i $ianalysis(bind,count)
+ set ianalysis(bind,$i,item) "<$b>"
+ set ianalysis(bind,$i,template) "$template"
+ set ianalysis(bind,$i,cmd) "$cmd"
+ set ianalysis(bind,$i,inuse) 0
+ incr ianalysis(bind,count)
+ }
+ }
+ web {
+ set i $ianalysis(menu,count)
+ set ianalysis(menu,$i,parent) $currentparent
+ set ianalysis(menu,$i,item) $item
+ set ianalysis(menu,$i,template) "$template"
+ set ianalysis(menu,$i,cmd) {web}
+ set ianalysis(menu,$i,inuse) 0
+ set ianalysis(menu,$i,var) "$cmd"
+ $currentparent add command -label "$item" \
+ -command [list AnalysisTask $i menu]
+ incr ianalysis(menu,count)
+ }
+ menu {
+ set i $ianalysis(menu,count)
+ set ianalysis(menu,$i,parent) $currentparent
+ set ianalysis(menu,$i,item) "$item"
+ set ianalysis(menu,$i,template) "$template"
+ set ianalysis(menu,$i,cmd) "$cmd"
+ set ianalysis(menu,$i,inuse) 0
+ set ianalysis(menu,$i,var) {}
+ $currentparent add check -label "$item" \
+ -command [list AnalysisTask $i menu] \
+ -variable ianalysis(menu,$i,inuse) \
+ -selectcolor green
+ incr ianalysis(menu,count)
+ }
+ default {
+ # something really wrong here, abort
+ return 0
+ }
+ }
+ }
+ set state 1
+ }
+
+ 5 {
+ # end param
+ if {[lindex $line 0] == {endparam} ||
+ [lindex $line 0] == {end}} {
+ incr ianalysis(param,count)
+ set state 1
+ continue
+ }
+
+ if {[string range $line 0 0] == {@}} {
+ ParseIRAFParam [string range $line 1 end]
+ continue
+ }
+
+ set i $ianalysis(param,count)
+ set j $ianalysis(param,$i,count)
+ set ianalysis(param,$i,$j,var) [lindex $line 0]
+ set ianalysis(param,$i,$j,type) [lindex $line 1]
+ set ianalysis(param,$i,$j,title) [lindex $line 2]
+
+ # default can contain the full menu 'aaa|bbb|ccc'
+ set ianalysis(param,$i,$j,default) [lindex $line 3]
+ # set last to first item
+ set ianalysis(param,$i,$j,last) \
+ [lindex [split [lindex $line 3] |] 0]
+ # and set value to last
+ set ianalysis(param,$i,$j,value) \
+ $ianalysis(param,$i,$j,last)
+
+ set ianalysis(param,$i,$j,info) [lindex $line 4]
+ incr ianalysis(param,$i,count)
+ }
+
+ 6 {
+ # end help
+ if {[lindex $line 0] == {endhelp} ||
+ [lindex $line 0] == {end}} {
+ incr ianalysis(menu,count)
+ set state 1
+ continue
+ }
+
+ set i $ianalysis(menu,count)
+ append ianalysis(menu,$i,var) "$line\n"
+ }
+ }
+ }
+
+ # events
+ UnBindEventsCanvas
+ BindEventsCanvas
+
+ UpdateAnalysisMenu
+
+ return 1
+}
+
+proc AnalysisTask {i which {frame {}} {x 0} {y 0} {sync 0}} {
+ global ianalysis
+ global current
+
+ if {$frame == {}} {
+ set frame $current(frame)
+ }
+
+ switch -- $ianalysis($which,$i,cmd) {
+ help {
+ AnalysisText "at${which}${i}" $ianalysis($which,$i,item) \
+ $ianalysis($which,$i,var) insert
+ }
+ web {
+ if {$frame != {}} {
+ AnalysisWebDoit $i $which $frame $x $y $sync
+ }
+ }
+ default {
+ if {$frame != {}} {
+ AnalysisTaskDoit $i $which $frame $x $y $sync
+ }
+ }
+ }
+}
+
+proc AnalysisWebDoit {i which frame x y sync} {
+ global ianalysis
+ global panalysis
+
+ set cmd "$ianalysis($which,$i,var)"
+
+ # do select macro expansion
+
+ # escaped macros
+ SetEscapedMacros cmd
+
+ # $xpa_method
+ ParseXPAMethodMacro cmd
+
+ # $xpa
+ ParseXPAMacro cmd
+
+ # $vo_method
+ ParseVOMethodMacro cmd
+
+ # $xdim,$ydim,$bitpix
+ ParseXYBitpixMacro cmd $frame
+
+ # $filename[$regions]
+ ParseFilenameRegionMacro cmd $frame
+
+ # $filename
+ ParseFilenameMacro cmd $frame
+
+ # $filedialog
+ ParseFileDialogMacro cmd
+
+ # $regions
+ ParseRegionMacro cmd $frame
+
+ # $env
+ ParseEnvMacro cmd
+
+ # $pan
+ ParsePanMacro cmd $frame
+
+ # $value
+ ParseValueMacro cmd $frame $x $y
+
+ # $x,$y
+ ParseXYMacro cmd $frame $x $y
+
+ # $z
+ ParseZMacro cmd $frame
+
+ # escaped macros
+ UnsetEscapedMacros cmd
+
+ if {$panalysis(log)} {
+ SimpleTextDialog acmd [msgcat::mc {Analysis Commands}] \
+ 80 20 append bottom "$cmd\n"
+ }
+
+ HVAnalysisCmd "at${which}${i}" "$ianalysis($which,$i,item)" "$cmd" $sync
+}
+
+proc AnalysisTaskDoit {i which frame x y sync} {
+ global ianalysis
+ global pds9
+
+ if {[info exists ianalysis($which,$i,pid)]} {
+ set ianalysis($which,$i,inuse) 1
+
+ if {$pds9(confirm)} {
+ if {[tk_messageBox -type okcancel -icon question -message [msgcat::mc {This analysis task is already running. Do you wish to kill it?}]] != {ok}} {
+ return
+ }
+ }
+
+ if {[info exists ianalysis($which,$i,pid)]} {
+ if {$ianalysis($which,$i,pid)>0} {
+ eval "exec kill -9 $ianalysis($which,$i,pid)"
+ } else {
+ HVAnalysisCancel $which $i
+ }
+ }
+
+ return
+ }
+
+ # don't turn on til task has started
+ set ianalysis($which,$i,inuse) 0
+
+ set ianalysis($which,$i,start) {}
+ set ianalysis($which,$i,start,fn) {}
+ set ianalysis($which,$i,start,url) {}
+ set ianalysis($which,$i,finish) {}
+ set ianalysis($which,$i,result) {}
+ set ianalysis($which,$i,plot,title) {}
+ set ianalysis($which,$i,plot,xaxis) {}
+ set ianalysis($which,$i,plot,yaxis) {}
+ set ianalysis($which,$i,plot,dim) 2
+ set ianalysis($which,$i,image) {}
+
+ set cmd $ianalysis($which,$i,cmd)
+
+ # escaped macros
+ SetEscapedMacros cmd
+
+ # $data
+ ParseDataMacro cmd $which $i
+
+ # $xpa_method
+ ParseXPAMethodMacro cmd
+
+ # $xpa
+ ParseXPAMacro cmd
+
+ # $vo_method
+ ParseVOMethodMacro cmd
+
+ # $xdim,$ydim,$bitpix
+ ParseXYBitpixMacro cmd $frame
+
+ # $filename[$regions]
+ ParseFilenameRegionMacro cmd $frame
+
+ # $filename
+ ParseFilenameMacro cmd $frame
+
+ # $filedialog
+ ParseFileDialogMacro cmd
+
+ # $regions
+ ParseRegionMacro cmd $frame
+
+ # $env
+ ParseEnvMacro cmd
+
+ # $cen
+ ParsePanMacro cmd $frame
+
+ # $value
+ ParseValueMacro cmd $frame $x $y
+
+ # $x,$y
+ ParseXYMacro cmd $frame $x $y
+
+ # $z
+ ParseZMacro cmd $frame
+
+ # $message
+ if {![ParseMessageMacro cmd]} {
+ AnalysisTaskEnd $which $i
+ return
+ }
+
+ # $entry
+ if {![ParseEntryMacro cmd]} {
+ AnalysisTaskEnd $which $i
+ return
+ }
+
+ # $param
+ if {![ParseParamMacro cmd]} {
+ AnalysisTaskEnd $which $i
+ return
+ }
+
+ # $text
+ ParseTextMacro cmd $which $i
+
+ # $plot
+ ParsePlotMacro cmd $which $i
+
+ # $null
+ ParseNullMacro cmd $which $i
+
+ # $url
+ ParseURLMacro cmd $which $i
+
+ # $geturl
+ # do this next to last
+ ParseGetURLMacro cmd $which $i
+
+ # $image
+ # do this last
+ ParseImageMacro cmd $which $i
+
+ # escaped macros
+ UnsetEscapedMacros cmd
+
+ # ok, we are off and running
+ set ianalysis($which,$i,inuse) 1
+
+ switch -- $ianalysis($which,$i,start) {
+ geturl {
+ AnalysisGetURL $which $i $sync
+ }
+ default {
+ AnalysisPipe $which $i $cmd $sync
+ }
+ }
+}
+
+proc AnalysisPipe {which i cmd sync} {
+ global ianalysis
+ global panalysis
+ global current
+
+ switch -- $ianalysis($which,$i,start) {
+ data {$current(frame) save fits image file "\{$ianalysis($which,$i,start,fn)\}"}
+ url {GetFileURL $ianalysis($which,$i,start,url) ianalysis($which,$i,start,fn)}
+ }
+
+ # last step, change all '][' into ',' so that multiple filters work right
+ regsub -all {\]\[} $cmd "," cmd
+
+ # log the command, if necessary
+ if {$panalysis(log)} {
+ SimpleTextDialog acmd [msgcat::mc {Analysis Commands}] \
+ 80 20 append bottom "$cmd\n"
+ }
+
+ switch -- $ianalysis($which,$i,finish) {
+ null {
+ # nothing is returned, so there is aways an error,
+ # however, the command will be executed.
+ catch {open "| $cmd"}
+ global errorInfo
+ set errorInfo {}
+ AnalysisTaskEnd $which $i
+ return
+ }
+ default {
+ if {[catch {set ch [open "| $cmd"]}]} {
+ Error [msgcat::mc {An error has occurred invoking the Analysis task}]
+ AnalysisTaskEnd $which $i
+ return
+ }
+ set ianalysis($which,$i,pid) [pid $ch]
+
+ switch -- $ianalysis($which,$i,finish) {
+ image {
+ switch -- $ianalysis($which,$i,image) {
+ new {CreateFrame}
+ rgb {CreateRGBFrame}
+ 3d {Create3DFrame}
+ current {}
+ }
+ global loadParam
+ set loadParam(load,type) channel
+ set loadParam(load,layer) {}
+ set loadParam(channel,name) $ch
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {}
+ set loadParam(file,name) \
+ "[string tolower [lindex $ianalysis($which,$i,item) 0]].fits"
+
+ StartLoad
+ ProcessLoad
+ FinishLoad
+
+ AnalysisTaskEnd $which $i
+ }
+ default {
+ if {$sync} {
+ AnalysisReaderAppend $ch $which $i
+ AnalysisReaderFinish $ch $which $i
+ } else {
+ fileevent $ch readable \
+ [list AnalysisReader $ch $which $i]
+ fconfigure $ch -blocking 0 -buffering none
+ }
+ }
+ }
+ }
+ }
+}
+
+proc AnalysisReader {ch which i} {
+ global ianalysis
+
+ if {[eof $ch]} {
+ AnalysisReaderFinish $ch $which $i
+ return
+ }
+ AnalysisReaderAppend $ch $which $i
+}
+
+proc AnalysisReaderAppend {ch which i} {
+ global ianalysis
+
+ set r [read $ch]
+ # for real-time update
+ switch -- $ianalysis($which,$i,finish) {
+ text {
+ AnalysisText "at${which}${i}" $ianalysis($which,$i,item) $r append
+
+ global debug
+ if {$debug(tcl,idletasks)} {
+ puts stderr "AnalysisReader"
+ }
+ update idletasks
+ }
+ }
+ append ianalysis($which,$i,result) $r
+}
+
+proc AnalysisReaderFinish {ch which i} {
+ global ianalysis
+
+ catch {close $ch}
+
+ switch -- $ianalysis($which,$i,finish) {
+ null -
+ image -
+ text {}
+ plot {
+ PlotLine "at${which}${i}" \
+ $ianalysis($which,$i,item) \
+ $ianalysis($which,$i,plot,title) \
+ $ianalysis($which,$i,plot,xaxis) \
+ $ianalysis($which,$i,plot,yaxis) \
+ $ianalysis($which,$i,plot,dim) \
+ $ianalysis($which,$i,result)
+ }
+ plotstdin {
+ AnalysisPlotStdin line "at${which}${i}" $ianalysis($which,$i,item) \
+ $ianalysis($which,$i,result)
+ }
+ default {puts stdout $ianalysis($which,$i,result)}
+ }
+
+ AnalysisTaskEnd $which $i
+}
+
+proc AnalysisPlotStdin {type w wtt result} {
+ # if no result, just return
+ if {$result == {}} {
+ return
+ }
+
+ # check for $ERROR
+ set id [string first {$ERROR} $result]
+ if {$id >= 0} {
+ AnalysisText "${w}e" $wtt \
+ [string range $result [expr $id+1] end] append
+ return
+ }
+
+ # check for ERROR:
+ set id [string first {ERROR:} $result]
+ if {$id >= 0} {
+ AnalysisText "${w}e" $wtt [string range $result $id end] append
+ return
+ }
+
+ # check for $BEGINTEXT/$ENDTEXT
+ # assume each is followed by a \n, so skip it
+ if {[string range $result 0 9] == {$BEGINTEXT}} {
+ set eid [string first {$ENDTEXT} $result]
+ if {$eid > 0} {
+ AnalysisText "${w}t" $wtt \
+ [string range $result 11 [expr $eid-1]] append
+ set result [string range $result [expr $eid+9] end]
+ } else {
+ # looks like all text
+ AnalysisText "${w}t" $wtt [string range $result 11 end] append
+ return
+ }
+ }
+
+ # now find the title, x axis label, y axis label, and dimension
+ set id [string first "\n" $result]
+ set tt [string range $result 0 $id]
+ set rr [string range $result [expr $id+1] end]
+
+ set l [llength $tt]
+ set t [join [lrange $tt 0 [expr $l-4]]]
+ set x [lindex $tt [expr $l-3]]
+ set y [lindex $tt [expr $l-2]]
+ set d [lindex $tt [expr $l-1]]
+
+ if {$d != {} && $rr != {}} {
+ switch $type {
+ line {PlotLine $w $wtt $t $x $y $d $rr}
+ bar {PlotBar $w $wtt $t $x $y $d $rr}
+ scatter {PlotScatter $w $wtt $t $x $y $d $rr}
+ }
+ } else {
+ Error "[msgcat::mc {Error}] [string range $tt 0 40]"
+ }
+}
+
+proc AnalysisGetURL {which i sync} {
+ global ianalysis
+ global panalysis
+
+ if {![ParseURL $ianalysis($which,$i,start,url) r]} {
+ Error [msgcat::mc {An error has occurred invoking the Analysis task}]
+ AnalysisTaskEnd $which $i
+ return
+ }
+
+ # format all spaces and brackets
+ set url {}
+ regsub -all { } $ianalysis($which,$i,start,url) "%20" url
+ regsub -all {\[} $url "%5B" url
+ regsub -all {\]} $url "%5D" url
+
+ if {$panalysis(log)} {
+ SimpleTextDialog acmd [msgcat::mc {Analysis Commands}] \
+ 80 20 append bottom "$url\n"
+ }
+
+ set ianalysis($which,$i,pid) -1
+ HVAnalysisURL $which $i $url $sync
+}
+
+proc AnalysisProcessGetURL {which i result} {
+ global ianalysis
+
+ set ianalysis($which,$i,result) $result
+ switch -- $ianalysis($which,$i,finish) {
+ text {AnalysisText "at${which}${i}" $ianalysis($which,$i,item) \
+ $ianalysis($which,$i,result) append}
+ plot {PlotLine "at${which}${i}" \
+ $ianalysis($which,$i,item) \
+ $ianalysis($which,$i,plot,title) \
+ $ianalysis($which,$i,plot,xaxis) \
+ $ianalysis($which,$i,plot,yaxis) \
+ $ianalysis($which,$i,plot,dim) \
+ $ianalysis($which,$i,result)}
+ plotstdin {AnalysisPlotStdin line "at${which}${i}" \
+ $ianalysis($which,$i,item) \
+ $ianalysis($which,$i,result)}
+ image {
+ set fn "[string tolower [lindex $ianalysis($which,$i,item) 0]].fits"
+ LoadVar result $fn {} {}
+ }
+ default {Error $ianalysis($which,$i,result)}
+ }
+}
+
+proc AnalysisTaskEnd {which i} {
+ global ianalysis
+
+ set ianalysis($which,$i,inuse) 0
+ if {$ianalysis($which,$i,start,fn) != {}} {
+ if {[file exists $ianalysis($which,$i,start,fn)]} {
+ catch {file delete -force $ianalysis($which,$i,start,fn)}
+ }
+ }
+
+ if {[info exists ianalysis($which,$i,pid)]} {
+ unset ianalysis($which,$i,pid)
+ }
+ unset ianalysis($which,$i,start)
+ unset ianalysis($which,$i,start,fn)
+ unset ianalysis($which,$i,start,url)
+ unset ianalysis($which,$i,finish)
+ unset ianalysis($which,$i,result)
+ unset ianalysis($which,$i,plot,title)
+ unset ianalysis($which,$i,plot,xaxis)
+ unset ianalysis($which,$i,plot,yaxis)
+ unset ianalysis($which,$i,plot,dim)
+ unset ianalysis($which,$i,image)
+}
+
+proc SetEscapedMacros {cmdname} {
+ upvar $cmdname cmd
+ global xpa
+
+ set seq "WaJaWaJaW"
+ if {[regexp {\$\$} $cmd]} {
+ # fill with tempory sequence
+ regsub -all {\$\$} $cmd $seq cmd
+ }
+}
+
+proc UnsetEscapedMacros {cmdname} {
+ upvar $cmdname cmd
+ global xpa
+
+ set seq "WaJaWaJaW"
+ if {[regexp $seq $cmd]} {
+ # reset to $
+ regsub -all $seq $cmd {\$} cmd
+ }
+}
+
+proc ParseDataMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\$data.?\|}
+ if {[regexp $exp $cmd]} {
+ set ianalysis($which,$i,start) data
+ set ianalysis($which,$i,start,fn) [tmpnam {.fits}]
+
+ regsub $exp $cmd "cat \{$ianalysis($which,$i,start,fn)\} |" cmd
+ }
+}
+
+proc ParseVOMethodMacro {cmdname} {
+ upvar $cmdname cmd
+ global pvo
+
+ if {[regexp {\$vo_method} $cmd]} {
+ regsub -all {\$vo_method} $cmd $pvo(method) cmd
+ }
+}
+
+proc ParseXPAMethodMacro {cmdname} {
+ upvar $cmdname cmd
+ global ds9
+
+ if {[regexp {\$xpa_method} $cmd]} {
+ regsub -all {\$xpa_method} $cmd [XPAMethod] cmd
+ }
+}
+
+proc ParseXPAMacro {cmdname} {
+ upvar $cmdname cmd
+ global ds9
+
+ if {[regexp {\$xpa} $cmd]} {
+ regsub -all {\$xpa} $cmd $ds9(title) cmd
+ }
+}
+
+proc ParseXYBitpixMacro {cmdname frame} {
+ upvar $cmdname cmd
+
+ if {$frame != {}} {
+ if {[regexp {\$width} $cmd]} {
+ regsub -all {\$width} $cmd [$frame get fits width] cmd
+ }
+
+ if {[regexp {\$height} $cmd]} {
+ regsub -all {\$height} $cmd [$frame get fits height] cmd
+ }
+
+ if {[regexp {\$depth} $cmd]} {
+ regsub -all {\$depth} $cmd [$frame get fits depth 2] cmd
+ }
+
+ if {[regexp {\$bitpix} $cmd]} {
+ regsub -all {\$bitpix} $cmd [$frame get fits bitpix] cmd
+ }
+
+ if {[regexp {\$xdim} $cmd]} {
+ regsub -all {\$xdim} $cmd [$frame get fits width] cmd
+ }
+
+ if {[regexp {\$ydim} $cmd]} {
+ regsub -all {\$ydim} $cmd [$frame get fits height] cmd
+ }
+ }
+}
+
+proc ParseFilenameRegionMacro {cmdname frame} {
+ upvar $cmdname cmd
+
+ set exp {(\$filename)\[(\$regions\(([^)]*)\))\]}
+ while {[regexp $exp $cmd foo fn reg pp]} {
+ set type ds9
+ set prop {}
+ set sys physical
+ set sky fk5
+ set format degrees
+
+ # default for mosaics
+ if {$frame != {}} {
+ if {[$frame has fits mosaic]} {
+ set sys wcs
+ }
+ }
+
+ foreach p [split $pp ,] {
+ switch -- $p {
+ ds9 -
+ ciao -
+ saotng -
+ saoimage -
+ pros -
+ xy {set type $p}
+
+ include {append prop {include = yes }}
+ exclude {append prop {include = no }}
+ source {append prop {source = yes }}
+ background {append prop {source = no }}
+
+ image -
+ physical -
+ detector -
+ amplifier
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {set sys $p}
+
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {
+ if {"$sys"=="physical"} {
+ set sys wcs
+ }
+ set sky $p
+ }
+
+ hms {set format sexagesimal}
+ sexagesimal -
+ degrees {set format $p}
+ }
+ }
+
+ SubstFilenameRegion cmd $frame $exp $type $prop $sys $sky $format
+ }
+
+ set exp {(\$filename)\[(\$regions)\]}
+ while {[regexp $exp $cmd foo fn reg]} {
+ set type ds9
+ set prop {}
+ set sys physical
+ set sky fk5
+ set format degrees
+
+ # default for mosaics
+ if {$frame != {}} {
+ if {[$frame has fits mosaic]} {
+ set sys wcs
+ }
+ }
+
+ SubstFilenameRegion cmd $frame $exp $type $prop $sys $sky $format
+ }
+}
+
+proc SubstFilenameRegion {cmdname frame exp type prop sys sky format} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set fn [$frame get fits file name full]
+ set region [string trimright [$frame marker list $type $sys $sky $format yes $prop] ";"]
+
+ if {$region != {}} {
+ set sub {}
+ foreach f $fn {
+ append sub "$f\[$region\] "
+ }
+ } else {
+ set sub $fn
+ }
+
+ # substitute
+ # ok, we need to check the length
+ if {[string length $region] > 256} {
+ # since we are writing to a file,
+ # we don't have to worry about quoting
+ # special characters
+ set fn [tmpnam {.reg}]
+ incr ianalysis(param,seq)
+
+ if {![catch {set ch [open "$fn" w]}]} {
+ puts $ch "$sub"
+ close $ch
+ }
+
+ regsub $exp $cmd "\@$fn" cmd
+
+ } else {
+ CleanFileName sub
+ regsub $exp $cmd $sub cmd
+ }
+}
+
+proc ParseFilenameMacro {cmdname frame} {
+ upvar $cmdname cmd
+
+ set exp {\$filename\(([^)]*)\)}
+ if {[regexp $exp $cmd foo pp]} {
+ switch $pp {
+ root -
+ root,base {
+ set sub [join [$frame get fits file name root base]]
+ CleanFileName sub
+ regsub -all $exp $cmd $sub cmd
+ }
+ full -
+ full,base {
+ set sub [join [$frame get fits file name full base]]
+ CleanFileName sub
+ regsub -all $exp $cmd $sub cmd
+ }
+ }
+ }
+
+ set exp {\$filename}
+ if {[regexp $exp $cmd]} {
+ set sub [join [$frame get fits file name full]]
+ CleanFileName sub
+ regsub -all $exp $cmd $sub cmd
+ }
+}
+
+proc ParseFileDialogMacro {cmdname} {
+ upvar $cmdname cmd
+
+ set exp {\$filedialog\(open\)}
+ if {[regexp $exp $cmd]} {
+ set sub [OpenFileDialog analysisparamfbox]
+ regsub -all $exp $cmd $sub cmd
+ }
+
+ set exp {\$filedialog\(save\)}
+ if {[regexp $exp $cmd]} {
+ set sub [SaveFileDialog analysisparamfbox]
+ regsub -all $exp $cmd $sub cmd
+ }
+}
+
+proc CleanFileName {varname} {
+ upvar $varname sub
+
+ # we have to quote {"}, else problems down the road
+ regsub -all {\"} $sub {\\"} sub
+
+ # we have to quote {&}, else problems down the road
+ regsub -all {\&} $sub {\\&} sub
+}
+
+proc ParseRegionMacro {cmdname frame} {
+ upvar $cmdname cmd
+
+ set exp {\$regions\(([^)]*)\)}
+while {[regexp $exp $cmd foo pp]} {
+
+ set type ds9
+ set prop {}
+ set sys physical
+ set sky fk5
+ set format degrees
+
+ # default for mosaics
+ if {$frame != {}} {
+ if {[$frame has fits mosaic]} {
+ set sys wcs
+ }
+ }
+
+ foreach p [split $pp ,] {
+ switch -- $p {
+ ds9 -
+ ciao -
+ saotng -
+ saoimage -
+ pros -
+ xy {set type $p}
+
+ include {append prop {include = yes }}
+ exclude {append prop {include = no }}
+ source {append prop {source = yes }}
+ background {append prop {source = no }}
+
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {set sys $p}
+
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {
+ if {"$sys"=="physical"} {
+ set sys wcs
+ }
+ set sky $p
+ }
+
+ hms {set format sexagesimal}
+ sexagesimal -
+ degrees {set format $p}
+ }
+ }
+
+ SubstRegion cmd $frame $exp $type $prop $sys $sky $format
+}
+
+# SAOtng format
+set exp {\$((|include|exclude|source|background)_)?regions(_(|degrees|hms|pixels))?}
+while {[regexp $exp $cmd foo a prop b sys]} {
+
+ # check valid props
+ switch -- $prop {
+ include {set prop {include = yes}}
+ exclude {set prop {include = no}}
+ source {set prop {source = yes}}
+ background {set prop {source = no}}
+ default {set prop {}}
+ }
+
+ # check valid coordinate systems
+ set sky fk5
+ switch -- $sys {
+ degrees {set sys wcs; set format degrees}
+ hms {set sys wcs; set format sexagesimal}
+ pixels -
+ default {set sys physical; set format degrees}
+ }
+
+ SubstRegion cmd $frame $exp ds9 $prop $sys $sky $format
+}
+}
+
+proc SubstRegion {cmdname frame exp type prop sys sky format} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ # get any regions
+ set region [string trimright [$frame marker list $type $sys $sky $format yes $prop] ";"]
+
+ # substitute
+ # ok, we need to check the length
+ if {[string length $region] > 8192} {
+ # since we are writing to a file, we don't have to worry about quoting
+ # special characters
+ set fn [tmpnam {.reg}]
+ incr ianalysis(param,seq)
+
+ if {![catch {set ch [open "$fn" w]}]} {
+ puts $ch "$region"
+ close $ch
+ }
+
+ regsub $exp $cmd "\@$fn" cmd
+
+ } else {
+ # we have to quote {"}, else problems down the road
+ regsub -all {\"} $region {\\"} region
+
+ # we have to quote {&}, else problems down the road
+ regsub -all {\&} $region {\\&} region
+
+ regsub $exp $cmd $region cmd
+ }
+}
+
+proc ParseEnvMacro {cmdname} {
+ upvar $cmdname cmd
+ global env
+
+ set exp {\$env\(([^)]*)\)}
+if {[regexp $exp $cmd foo ee]} {
+ if {[info exists env($ee)]} {
+ regsub -all $exp $cmd "$env($ee)" cmd
+ } else {
+ regsub -all $exp $cmd {} cmd
+ }
+}
+}
+
+proc ParsePanMacro {cmdname frame} {
+ upvar $cmdname cmd
+
+ set exp {\$pan\(([^)]*)\)}
+if {[regexp $exp $cmd foo pp]} {
+ set sys physical
+ set sky fk5
+ set format degrees
+
+ foreach p [split $pp ,] {
+ switch -- $p {
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {set sys $p}
+
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {set sky $p; set sys wcs}
+
+ hms {set format sexagesimal}
+ sexagesimal -
+ degrees {set format $p}
+ }
+ }
+
+ set coord [$frame get cursor $sys $sky $format]
+ regsub -all $exp $cmd "[lindex $coord 0],[lindex $coord 1]" cmd
+
+ return
+}
+
+# no args
+
+set exp {\$pan}
+if {[regexp $exp $cmd foo1]} {
+ set coord [$frame get cursor physical]
+ regsub -all $exp $cmd "[lindex $coord 0],[lindex $coord 1]" cmd
+}
+}
+
+proc ParseValueMacro {cmdname frame x y} {
+ upvar $cmdname cmd
+
+ # menu items will not have a frame arg
+ if {$frame == {}} {
+ return
+ }
+
+ set exp1 {\$value}
+ if {[regexp $exp1 $cmd foo]} {
+ set vv [$frame get value canvas $x $y]
+ regsub -all $exp1 $cmd "$vv" cmd
+ }
+}
+
+proc ParseXYMacro {cmdname frame x y} {
+ upvar $cmdname cmd
+
+ # menu items will not have a frame arg
+ if {$frame == {}} {
+ return
+ }
+
+ set exp1 {\$x\(([^)]*)\)}
+set exp2 {\$y\(([^)]*)\)}
+if {[regexp $exp1 $cmd foo pp] && [regexp $exp2 $cmd foo2 pp2]} {
+ set sys physical
+ set sky fk5
+ set format degrees
+
+ foreach p [split $pp ,] {
+ switch -- $p {
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {set sys $p}
+
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {set sky $p; set sys wcs}
+
+ hms {set format sexagesimal}
+ sexagesimal -
+ degrees {set format $p}
+ }
+ }
+
+ switch -- $sys {
+ image -
+ physical -
+ detector -
+ amplifier {set coord [$frame get coordinates $x $y $sys]}
+ default {set coord [$frame get coordinates $x $y $sys $sky $format]}
+ }
+
+ regsub -all $exp1 $cmd [lindex $coord 0] cmd
+ regsub -all $exp2 $cmd [lindex $coord 1] cmd
+
+ return
+}
+
+# no args
+
+set exp1 {\$x}
+set exp2 {\$y}
+if {[regexp $exp1 $cmd foo1] && [regexp $exp2 $cmd foo2]} {
+ set coord [$frame get coordinates $x $y physical]
+
+ regsub -all $exp1 $cmd [lindex $coord 0] cmd
+ regsub -all $exp2 $cmd [lindex $coord 1] cmd
+}
+}
+
+proc ParseZMacro {cmdname frame} {
+ upvar $cmdname cmd
+
+ # menu items will not have a frame arg
+ if {$frame == {}} {
+ return
+ }
+
+ set sl [$frame get fits slice]
+
+ # args
+ set exp1 {\$z\(([^)]*)\)}
+ if {[regexp $exp1 $cmd foo pp]} {
+ set sys $pp
+ set coord [$frame get coordinates $sl image $sys 2]
+ regsub -all $exp1 $cmd "$coord" cmd
+ return
+ }
+
+ # no args
+ # look for '$z"'
+ set exp1 {\$z\"}
+ if {[regexp $exp1 $cmd foo1]} {
+ regsub -all $exp1 $cmd "$sl\"" cmd
+ }
+ # look for "$z "
+ set exp1 {\$z\s}
+ if {[regexp $exp1 $cmd foo1]} {
+ regsub -all $exp1 $cmd "$sl " cmd
+ }
+}
+
+proc ParseMessageMacro {cmdname} {
+ upvar $cmdname cmd
+
+ # two args
+ set exp {\|?.?\$message\((ok|okcancel|yesno),([^)]*)\).?\|?}
+while {[regexp $exp $cmd foo type message]} {
+ regsub $exp $cmd {} cmd
+ if {![AnalysisMessage $type $message]} {
+ return 0
+ }
+}
+
+# one args
+set exp {\|?.?\$message\(([^)]*)\).?\|?}
+while {[regexp $exp $cmd foo message]} {
+ regsub $exp $cmd {} cmd
+ AnalysisMessage ok $message
+}
+
+return 1
+}
+
+proc ParseEntryMacro {cmdname} {
+ upvar $cmdname cmd
+
+ # one args
+ set exp {\|?.?\$entry\(([^)]*)\).?\|?}
+while {[regexp $exp $cmd foo message]} {
+ set result {}
+ if {![AnalysisEntry $message result]} {
+ return 0
+ }
+ regsub $exp $cmd $result cmd
+}
+
+return 1
+}
+
+proc ParseParamMacro {cmdname} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\$param\(([^)]*)\).?;?}
+while {[regexp $exp $cmd foo param]} {
+ regsub $exp $cmd {} cmd
+ if {![AnalysisParam cmd $param]} {
+ return 0
+ }
+}
+return 1
+}
+
+proc ParseTextMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp1 {\|.?\$text}
+ set exp2 {\|\&.?\$text}
+ if {[regexp $exp1 $cmd]} {
+ regsub $exp1 $cmd {} cmd
+
+ set ianalysis($which,$i,finish) text
+ } elseif {[regexp $exp2 $cmd]} {
+ regsub $exp2 $cmd { 2>@ stdout} cmd
+
+ set ianalysis($which,$i,finish) text
+ }
+}
+
+proc ParseNullMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\|.?\$null}
+ if {[regexp $exp $cmd]} {
+ regsub $exp $cmd {} cmd
+
+ set ianalysis($which,$i,finish) null
+ }
+}
+
+proc ParsePlotMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\|.?\$plot\(([^,]+),([^,]+),([^,]+),([^)]+)\)}
+if {[regexp $exp $cmd foo \
+ ianalysis($which,$i,plot,title) \
+ ianalysis($which,$i,plot,xaxis) \
+ ianalysis($which,$i,plot,yaxis) \
+ ianalysis($which,$i,plot,dim)]} {
+ regsub $exp $cmd {} cmd
+
+ set ianalysis($which,$i,finish) plot
+}
+
+set exp {\|.?\$plot\(stdin\)}
+if {[regexp $exp $cmd]} {
+ regsub $exp $cmd {} cmd
+
+ set ianalysis($which,$i,finish) plotstdin
+}
+
+set exp {\|.?\$plot}
+if {[regexp $exp $cmd]} {
+ regsub $exp $cmd {} cmd
+
+ set ianalysis($which,$i,finish) plot
+}
+}
+
+proc ParseURLMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\$url\((.*)\) \|}
+ if {[regexp $exp $cmd foo ianalysis($which,$i,start,url)]} {
+ set ianalysis($which,$i,start) url
+ set ianalysis($which,$i,start,fn) [tmpnam {.fits}]
+
+ regsub $exp $cmd "cat \{$ianalysis($which,$i,start,fn)\} |" cmd
+ }
+}
+
+proc ParseGetURLMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\$geturl\((.*)\)}
+ if {[regexp $exp $cmd foo ianalysis($which,$i,start,url)]} {
+ set ianalysis($which,$i,start) geturl
+ set ianalysis($which,$i,start,fn) [tmpnam {.fits}]
+
+ regsub $exp $cmd {} cmd
+ }
+}
+
+proc ParseImageMacro {cmdname which i} {
+ upvar $cmdname cmd
+ global ianalysis
+
+ set exp {\|.?\$image\(([^)]*)\)}
+if {[regexp $exp $cmd foo ianalysis($which,$i,image)]} {
+ regsub $exp $cmd {} cmd
+
+ set ianalysis($which,$i,finish) image
+}
+
+set exp {\|.?\$image}
+if {[regexp $exp $cmd]} {
+ regsub $exp $cmd {} cmd
+
+ set ianalysis($which,$i,finish) image
+}
+}
+
+proc AnalysisText {tt title txt method} {
+ if {$txt != {} && $txt != "\n"} {
+ SimpleTextDialog ${tt}txt $title 80 20 $method bottom $txt
+ }
+}
+
+proc AnalysisMessage {type message} {
+ if {$type == {}} {
+ set type ok
+ }
+
+ switch -- [tk_messageBox -message $message -type $type] {
+ ok {return 1}
+ yes {return 1}
+ cancel {return 0}
+ default {return 0}
+ }
+}
+
+proc AnalysisEntry {message resultvar} {
+ upvar $resultvar result
+
+ return [EntryDialog [msgcat::mc {Entry}] $message 60 result]
+}
+
+proc AnalysisPrefOpen {varname} {
+ upvar $varname var
+
+ FileLast analysisfbox $var
+ set var [OpenFileDialog analysisfbox]
+}
+
+# Cmds
+
+proc ProcessAnalysisCmd {varname iname buf fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global ime
+ global ianalysis
+
+ switch -- [string tolower [lindex $var $i]] {
+ message {
+ incr i
+ switch [string tolower [lindex $var $i]] {
+ ok -
+ okcancel -
+ retrycancel -
+ yesno -
+ yesnocancel {
+ AnalysisMessage [lindex $var $i] [lindex $var [expr $i+1]]
+ incr i
+ }
+ default {
+ AnalysisMessage ok [lindex $var $i]
+ }
+ }
+ }
+ text {
+ if {$buf != {}} {
+ AnalysisText apXPA Analysis $buf append
+ } elseif {$fn != {}} {
+ if {[file exists $fn]} {
+ set ch [open $fn r]
+ set txt [read $ch]
+ close $ch
+ AnalysisText apXPA Analysis $txt append
+ }
+ } else {
+ incr i
+ AnalysisText apXPA Analysis [lindex $var $i] append
+ }
+ }
+ plot {
+ # for backward compatibility
+ # used by chandra-ed
+ # use xpa plot instead
+
+ incr i
+ if {$buf != {}} {
+ ProcessAnalysisPlotCmd $varname $iname $buf
+ } elseif {$fn != {}} {
+ if {[file exists $fn]} {
+ set ch [open $fn r]
+ set rr [read $ch]
+ close $ch
+ ProcessAnalysisPlotCmd $varname $iname $rr
+ }
+ } else {
+ ProcessAnalysisPlotCmd $varname $iname {}
+ }
+ }
+ load {
+ if {$buf != {}} {
+ ProcessAnalysis buf
+ } elseif {$fn != {}} {
+ ProcessAnalysisFile $fn
+ } else {
+ incr i
+ ProcessAnalysisFile [lindex $var $i]
+ }
+ }
+ clear {
+ ClearAnalysis
+ incr i
+ switch -- [lindex $var $i] {
+ load {
+ if {$buf != {}} {
+ ProcessAnalysis buf
+ } elseif {$fn != {}} {
+ ProcessAnalysisFile $fn
+ } else {
+ incr i
+ ProcessAnalysisFile [lindex $var $i]
+ }
+ }
+ default {incr i -1}
+ }
+ }
+ mode {
+ incr i
+ switch -- [lindex $var $i] {
+ stats -
+ statistics {set ime(task) stats}
+ hist -
+ histogram {set ime(task) hist}
+ radial -
+ radialprofile {set ime(task) radial}
+ 2d -
+ plot2d {set ime(task) plot2d}
+ 3d -
+ plot3d {set ime(task) plot3d}
+ }
+
+ ProcessRealizeDS9
+ IMEChangeTask
+ }
+ task {
+ incr i
+ if {[string is integer [lindex $var $i]]} {
+ AnalysisTask [lindex $var $i] menu
+ } else {
+ # invoke by name
+ for {set ii 0} {$ii<$ianalysis(menu,count)} {incr ii} {
+ if {[string equal -nocase $ianalysis(menu,$ii,item) [lindex $var $i]]} {
+ AnalysisTask $ii menu
+ }
+ }
+ }
+ }
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ AnalysisTask [lindex $var $i] menu
+ } else {
+ ProcessAnalysisFile [lindex $var $i]
+ }
+ }
+ }
+}
+
+proc ProcessAnalysisPlotCmd {varname iname buf} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ global iap
+ switch -- [string tolower [lindex $var $i]] {
+ stdin {AnalysisPlotStdin line $iap(tt) {} $buf}
+ default {
+ PlotLine $iap(tt) Plot \
+ [lindex $var [expr $i+0]] \
+ [lindex $var [expr $i+1]] \
+ [lindex $var [expr $i+2]] \
+ [lindex $var [expr $i+3]] \
+ $buf
+ incr i 3
+ }
+ }
+}
+
+proc ProcessSendAnalysisCmd {proc id param sock fn} {
+ global ianalysis
+ global ime
+
+ set result {}
+ switch -- [string tolower [lindex $param 0]] {
+ entry {
+ AnalysisEntry [lrange $param 1 end] result
+ append result "\n"
+ $proc $id $result
+ }
+ mode {$proc $id "$ime(task)\n"}
+ task {
+ # invoke by name
+ for {set ii 0} {$ii<$ianalysis(menu,count)} {incr ii} {
+ append result "$ii $ianalysis(menu,$ii,item)\n"
+ }
+ $proc $id $result
+ }
+ lock {$proc $id "$ime(lock)\n"}
+ default {
+ for {set i 0} {$i<$ianalysis(menu,count)} {incr i} {
+ append result "\#$i menu"
+ append result "\n$ianalysis(menu,$i,item)"
+ append result "\n$ianalysis(menu,$i,template)"
+ if {$ianalysis(menu,$i,cmd) != {web}} {
+ append result "\nmenu"
+ append result "\n$ianalysis(menu,$i,cmd)"
+ } else {
+ append result "\n$ianalysis(menu,$i,cmd)"
+ append result "\n$ianalysis(menu,$i,var)"
+ }
+ append result "\n\n"
+ }
+ for {set i 0} {$i<$ianalysis(bind,count)} {incr i} {
+ set key [string range $ianalysis(bind,$i,item) 1 1]
+ append result "\#$i bind"
+ append result "\nbind key $ianalysis(bind,$i,item)"
+ append result "\n$ianalysis(bind,$i,template)"
+ append result "\nbind $key"
+ append result "\n$ianalysis(bind,$i,cmd)"
+ append result "\n\n"
+ }
+ ProcessSend $proc $id $sock $fn {.ans} $result
+ }
+ }
+}
diff --git a/ds9/library/analysisparam.tcl b/ds9/library/analysisparam.tcl
new file mode 100644
index 0000000..a45711b
--- /dev/null
+++ b/ds9/library/analysisparam.tcl
@@ -0,0 +1,176 @@
+# 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 AnalysisParam {strname param} {
+ upvar $strname str
+ global ianalysis
+ global ed
+
+ global ds9
+ global pds9
+
+ # find it
+ for {set i 0} {$i<$ianalysis(param,count)} {incr i} {
+ if {$ianalysis(param,$i) == "$param"} {
+ break
+ }
+ }
+ if {$i == $ianalysis(param,count)} {
+ return
+ }
+
+ set w {.param}
+
+ set ed(ok) 0
+
+ DialogCreate $w $param ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ for {set j 0} {$j<$ianalysis(param,$i,count)} {incr j} {
+ set ianalysis(param,$i,$j,value) $ianalysis(param,$i,$j,last)
+ ttk::label $f.l$j -text "$ianalysis(param,$i,$j,title)"
+ switch -- $ianalysis(param,$i,$j,type) {
+ entry {
+ ttk::entry $f.a$j \
+ -textvariable ianalysis(param,$i,$j,value) \
+ -width 40
+ }
+ checkbox {
+ ttk::checkbutton $f.a$j -text {} \
+ -variable ianalysis(param,$i,$j,value)
+ }
+ menu {
+ set l [split $ianalysis(param,$i,$j,default) |]
+ ttk::menubutton $f.a$j \
+ -text "$ianalysis(param,$i,$j,value)" \
+ -menu $f.a$j.menu
+ set m [menu $f.a$j.menu]
+ for {set k 0} {$k<[llength $l]} {incr k} {
+ $m add command -label [lindex $l $k] \
+ -command "AnalysisParamMenu ianalysis(param,$i,$j,value) [lindex $l $k] $f.a$j"
+ }
+ }
+ }
+ ttk::label $f.i$j -text "$ianalysis(param,$i,$j,info)" \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+
+ grid $f.l$j $f.a$j $f.i$j -padx 2 -pady 2 -sticky w
+ }
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ for {set j 0} {$j<$ianalysis(param,$i,count)} {incr j} {
+ set exp "\\\$$ianalysis(param,$i,$j,var)"
+ if {[regexp $exp $str]} {
+ regsub -all $exp $str "$ianalysis(param,$i,$j,value)" str
+ }
+ set ianalysis(param,$i,$j,last) $ianalysis(param,$i,$j,value)
+ }
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc AnalysisParamMenu {varname value menu} {
+ upvar $varname var
+
+ set var $value
+ $menu configure -text $value
+}
+
+proc ParseIRAFParam {filename} {
+ global ianalysis
+ global env
+
+ # we are only concerned with unix like os
+ set uparm {}
+ if {[info exists env(UPARM)]} {
+ set uparm "$env(UPARM)/$filename"
+ }
+ set iraf {}
+ if {[info exists env(HOME)]} {
+ set iraf "$env(HOME)/$filename"
+ }
+
+ if {[file exists "$filename"]} {
+ catch {set ch [open "$filename"]}
+ } elseif {[file exists "$uparm"]} {
+ catch {set ch [open "$uparm"]}
+ } elseif {[file exists "$iraf"]} {
+ catch {set ch [open "$iraf"]}
+ } else {
+ return
+ }
+
+ set i $ianalysis(param,count)
+
+ while {[gets $ch line] >= 0} {
+ set exp {([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*)}
+ if {[regexp $exp $line foo p1 p2 p3 p4 p5 p6 p7]} {
+ if {$p1 != {mode}} {
+ regsub -all {\"} $p4 {} p4
+ regsub -all {\"} $p7 {} p7
+ set j $ianalysis(param,$i,count)
+ set ianalysis(param,$i,$j,var) "$p1"
+ if {$p3 == {h}} {
+ set ianalysis(param,$i,$j,title) "(${p1})"
+ } else {
+ set ianalysis(param,$i,$j,title) "$p1"
+ }
+ set ianalysis(param,$i,$j,info) "$p7"
+ incr ianalysis(param,$i,count)
+ switch -- $p2 {
+ b {
+ set ianalysis(param,$i,$j,type) checkbox
+ set ianalysis(param,$i,$j,default) [FromYesNo $p4]
+ set ianalysis(param,$i,$j,last) [FromYesNo $p4]
+ set ianalysis(param,$i,$j,value) [FromYesNo $p4]
+ }
+ s {
+ if {$p5 != {}} {
+ set ianalysis(param,$i,$j,type) menu
+ set ianalysis(param,$i,$j,default) "$p5"
+ } else {
+ set ianalysis(param,$i,$j,type) entry
+ set ianalysis(param,$i,$j,default) "$p4"
+ }
+ set ianalysis(param,$i,$j,last) "$p4"
+ set ianalysis(param,$i,$j,value) "$p4"
+ }
+ default {
+ set ianalysis(param,$i,$j,type) entry
+ set ianalysis(param,$i,$j,default) "$p4"
+ set ianalysis(param,$i,$j,last) "$p4"
+ set ianalysis(param,$i,$j,value) "$p4"
+ }
+ }
+ }
+ }
+ }
+
+ close $ch
+}
diff --git a/ds9/library/annulus.tcl b/ds9/library/annulus.tcl
new file mode 100644
index 0000000..1ccaba2
--- /dev/null
+++ b/ds9/library/annulus.tcl
@@ -0,0 +1,182 @@
+# 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 AnnulusDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ set var(method) dist
+
+ # procs
+ set var(which) annulus
+ set var(proc,apply) AnnulusApply
+ set var(proc,close) AnnulusClose
+ set var(proc,generate) AnnulusGenerate
+ set var(proc,coordCB) AnnulusCoordCB
+ set var(proc,editCB) AnnulusEditCB
+ set var(proc,distCB) AnnulusDistCB
+
+ # base
+ MarkerBaseAnnulusDialog $varname
+
+ # menus
+ MarkerBaseAnnulusMethodMenu $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisRadialDialog $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback edit AnnulusEditCB $varname
+ $var(frame) marker $var(id) callback end edit AnnulusEditCB $varname
+
+ set f $var(top).param
+
+ # Annuli
+ ttk::label $f.tinner -text [msgcat::mc {Inner}]
+ ttk::label $f.touter -text [msgcat::mc {Outer}]
+ ttk::label $f.tradius -text [msgcat::mc {Radius}]
+ ttk::entry $f.inner -textvariable ${varname}(inner) -width 13
+ ttk::entry $f.outer -textvariable ${varname}(outer) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list AnnulusDistCB $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+ ttk::label $f.tannuli -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable ${varname}(annuli) -width 13
+
+ grid x $f.tinner $f.touter -padx 2 -pady 2 -sticky w
+ grid $f.tradius $f.inner $f.outer $f.uradius -padx 2 -pady 2 -sticky w
+ grid $f.tannuli $f.annuli -padx 2 -pady 2 -sticky w
+
+ # Radius
+ set f [ttk::labelframe $var(top).radius -text [msgcat::mc {Radius}] \
+ -padding 2]
+
+ set var(annulitxt) [text $f.txt \
+ -height 10 \
+ -width 15 \
+ -wrap none \
+ -font [font actual TkDefaultFont] \
+ -yscrollcommand [list $f.yscroll set] \
+ ]
+ ttk::scrollbar $f.yscroll -command [list $var(annulitxt) yview] \
+ -orient vertical
+
+ grid $var(annulitxt) $f.yscroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ # Radius Fini
+ grid $var(top).radius -row 0 -column 1 -sticky news
+ grid rowconfigure $var(top) 0 -weight 1
+ grid columnconfigure $var(top) 1 -weight 1
+
+ # init - do this last
+ AnnulusDistCB $varname
+}
+
+# actions
+
+proc AnnulusClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback edit AnnulusEditCB
+ $var(frame) marker $var(id) delete callback end edit AnnulusEditCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc AnnulusApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set levels {}
+ regsub -all "\n" "[$var(annulitxt) get 1.0 end]" " " levels
+ # and trim any trailing spaces
+ set levels [string trimright $levels " "]
+
+ if {$levels != {}} {
+ $var(frame) marker $var(id) annulus radius "\{$levels\}" \
+ $var(dcoord) $var(dformat)
+ }
+
+ MarkerBaseCenterApply $varname
+}
+
+proc AnnulusGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseAnnulusGenerateCircle $varname
+}
+
+# callbacks
+
+proc AnnulusCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "AnnulusCoordCB"
+ }
+
+ MarkerAnalysisRadialSystem $varname
+ MarkerAnalysisStatsSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+}
+
+proc AnnulusEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "AnnulusEditCB"
+ }
+
+ set t [$var(frame) get marker $var(id) annulus radius \
+ $var(dcoord) $var(dformat)]
+
+ set last [expr [llength $t]-1]
+ set var(inner) [lindex $t 0]
+ set var(outer) [lindex $t $last]
+ set var(annuli) $last
+
+ $var(annulitxt) delete 1.0 end
+ $var(annulitxt) insert end "$t"
+}
+
+proc AnnulusDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "AnnulusDistCB"
+ }
+
+ AnnulusEditCB $varname
+}
diff --git a/ds9/library/ar.tcl b/ds9/library/ar.tcl
new file mode 100644
index 0000000..5864b9d
--- /dev/null
+++ b/ds9/library/ar.tcl
@@ -0,0 +1,208 @@
+# 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 ARInit {varname next} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(sync) 0
+ set var(proc,next) $next
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(status) {}
+}
+
+proc ARApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARStatus $varname {}
+
+ $var(mb).file entryconfig [msgcat::mc {Retrieve}] -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Cancel}] -state normal
+
+ $var(apply) configure -state disabled
+ $var(cancel) configure -state normal
+}
+
+proc ARCancel {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # set state to 0 so that we don't process the finish proc
+ set var(active) 0
+
+ if {[info exists var(token)]} {
+ http::reset $var(token)
+ }
+}
+
+proc ARDestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARCancel $varname
+
+ if {[winfo exists $var(top)]} {
+ destroy $var(top)
+ destroy $var(mb)
+ }
+
+ unset $varname
+}
+
+proc ARReset {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(active) 0
+
+ if {[info exists var(token)]} {
+ http::cleanup $var(token)
+ unset var(token)
+ }
+
+ $var(mb).file entryconfig [msgcat::mc {Retrieve}] -state normal
+ $var(mb).file entryconfig [msgcat::mc {Cancel}] -state disabled
+
+ $var(apply) configure -state normal
+ $var(cancel) configure -state disabled
+}
+
+proc ARDone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(status) [msgcat::mc {Done}]
+ ARReset $varname
+}
+
+proc ARCancelled {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(status) [msgcat::mc {Cancelled}]
+ ARReset $varname
+}
+
+proc ARError {varname message} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(status) [string range $message 0 80]
+ ARReset $varname
+}
+
+proc ARStatus {varname message} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(status) [string range $message 0 80]
+}
+
+proc ARClear {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(status) {}
+}
+
+proc ARCoord {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global pds9
+
+ switch -- $var(sky) {
+ fk4 -
+ fk5 -
+ icrs {
+ $var(xname) configure -text "\u03b1" \
+ -font "$ds9(times) $pds9(font,size)"
+ $var(yname) configure -text "\u03b4" \
+ -font "$ds9(times) $pds9(font,size)"
+ }
+ galactic {
+ $var(xname) configure -text {l} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ $var(yname) configure -text {b} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ }
+ ecliptic {
+ $var(xname) configure -text "\u03bb" \
+ -font "$ds9(times) $pds9(font,size)"
+ $var(yname) configure -text "\u03b2" \
+ -font "$ds9(times) $pds9(font,size)"
+ }
+ }
+}
+
+proc AREditMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ $var(mb) add cascade -label [msgcat::mc {Edit}] -menu $var(mb).edit
+ EditMenu $var(mb) $varname
+ $var(mb).edit add separator
+ $var(mb).edit add command -label [msgcat::mc {Clear}] \
+ -command "ARClear $varname"
+}
+
+proc ARSkyFormat {w varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(skyformat,msg) [msgcat::mc $var(skyformat)]
+ ttk::menubutton $w -textvariable ${varname}(skyformat,msg) -menu $w.menu
+ menu $w.menu
+ $w.menu add radiobutton -label [msgcat::mc {Degrees}] \
+ -variable ${varname}(skyformat) -value degrees \
+ -command "ARSkyFormatMenu $varname"
+ $w.menu add radiobutton -label {Sexagesimal} \
+ -variable ${varname}(skyformat) -value sexagesimal \
+ -command "ARSkyFormatMenu $varname"
+}
+
+proc ARSkyFormatMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(skyformat,msg) $var(skyformat)
+}
+
+proc ARRFormat {w varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(rformat,msg) [msgcat::mc $var(rformat)]
+ ttk::menubutton $w -textvariable ${varname}(rformat,msg) -menu $w.menu
+ menu $w.menu
+ $w.menu add radiobutton -label [msgcat::mc {Degrees}] \
+ -variable ${varname}(rformat) -value degrees \
+ -command "ARRFormatMenu $varname"
+ $w.menu add radiobutton -label [msgcat::mc {ArcMin}] \
+ -variable ${varname}(rformat) -value arcmin \
+ -command "ARRFormatMenu $varname"
+ $w.menu add radiobutton -label [msgcat::mc {ArcSec}] \
+ -variable ${varname}(rformat) -value arcsec \
+ -command "ARRFormatMenu $varname"
+}
+
+proc ARRFormatMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(rformat,msg) $var(rformat)
+}
+
diff --git a/ds9/library/array.tcl b/ds9/library/array.tcl
new file mode 100644
index 0000000..efe9027
--- /dev/null
+++ b/ds9/library/array.tcl
@@ -0,0 +1,167 @@
+# 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 ImportArrayFile {fn layer} {
+ global loadParam
+
+ set loadParam(file,type) array
+ set loadParam(file,mode) {}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+ set loadParam(load,layer) $layer
+
+ # check for stdin/gz
+ ConvertArrayFile
+ ProcessLoad
+}
+
+proc ImportArrayAlloc {path fn layer} {
+ global loadParam
+
+ set loadParam(file,type) array
+ set loadParam(file,mode) {}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc ImportArraySocket {sock fn layer} {
+ global loadParam
+
+ set loadParam(file,type) array
+ set loadParam(file,mode) {}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc ExportArrayFile {fn opt} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save array file "\{$fn\}" $opt
+}
+
+proc ExportArraySocket {sock opt} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save array socket $sock $opt
+}
+
+proc ProcessArrayCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ if {[ProcessArrayBackwardCmd $varname $iname $sock $fn]} {
+ return
+ }
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not suppported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![ImportArraySocket $sock $param $layer]} {
+ InitError xpa
+ ImportArrayFile $param $layer
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ ImportArrayAlloc $fn $param $layer
+ } else {
+ ImportArrayFile $param $layer
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendArrayCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set opt [string tolower [lindex $param 0]]
+ if {$sock != {}} {
+ # xpa
+ ExportArraySocket $sock $opt
+ } elseif {$fn != {}} {
+ # comm
+ ExportArrayFile $fn $opt
+ $proc $id {} $fn
+ }
+}
+
+# backward compatibility
+proc ProcessArrayBackwardCmd {varname iname sock fn} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ set vvar $var
+ set ii $i
+
+ switch -- [string tolower [lindex $var $i]] {
+ rgb {
+ set vvar [lreplace $var 0 0]
+ ProcessRGBArrayCmd vvar ii $sock $fn
+ return 1
+ }
+ new {
+ switch -- [string tolower [lindex $var [expr $i+1]]] {
+ rgb {
+ set vvar [lreplace $var 1 1]
+ ProcessRGBArrayCmd vvar ii $sock $fn
+ return 1
+ }
+ }
+ }
+ }
+
+ return 0
+}
+
diff --git a/ds9/library/backup.tcl b/ds9/library/backup.tcl
new file mode 100644
index 0000000..37cc314
--- /dev/null
+++ b/ds9/library/backup.tcl
@@ -0,0 +1,802 @@
+# 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 BackupDialog {} {
+ set fn [SaveFileDialog backupfbox]
+ if {[string length $fn] != 0} {
+ Backup $fn
+ }
+}
+
+proc Backup {fn} {
+ global ds9
+ global current
+
+ # script, always overwrite if present
+ if {[catch {set ch [open $fn w]}]} {
+ Error [msgcat::mc {An error has occurred during backup}]
+ return
+ }
+
+ # aux directory, create if needed
+ set dir "${fn}.dir"
+ if {[file exists $dir]} {
+ if {![file isdirectory $dir]} {
+ Error [msgcat::mc {An error has occurred during backup}]
+ return
+ }
+ } else {
+ if {[catch {file mkdir $dir}]} {
+ Error [msgcat::mc {An error has occurred during backup}]
+ return
+ }
+ }
+
+ # update any tags
+ if {$current(frame) != {}} {
+ $current(frame) colorbar tag "\{[$current(colorbar) get tag]\}"
+ }
+
+ # check for newer backup version
+ puts $ch "global ds9"
+ puts $ch "set vv [lindex $ds9(version) 0]"
+
+ puts $ch "\# this is a check for to ensure a match between the"
+ puts $ch "\# current ds9 version matches the prefs version"
+ puts $ch "switch -- \[string compare \$vv \[lindex \$ds9(version)\ 0\]\] {"
+ puts $ch " -1 {"
+ puts $ch " if {\[tk_messageBox -type yesno -icon question -message \[msgcat::mc {DS9 has detected an older backup file, do you wish to continue?}\]\] == {no}} {"
+ puts $ch " return"
+ puts $ch " }"
+ puts $ch " }"
+ puts $ch " 0 {}"
+ puts $ch " 1 {"
+ puts $ch " tk_messageBox -type ok -icon warning -message \[msgcat::mc {DS9 has detected a newer version of a backup file and therefore will not process this file.}\]"
+ puts $ch " return"
+ puts $ch " }"
+ puts $ch "}"
+
+ # and file find proc
+ puts $ch "proc BackupFindFile {varname} {"
+ puts $ch " upvar \$varname var"
+ puts $ch ""
+ puts $ch " set id \[string first \"\\\[\" \$var(file,name)\]"
+ puts $ch " if {\$id > 0} {"
+ puts $ch " set fn \[string range \$var(file,name) 0 \[expr \$id-1\]\]"
+ puts $ch " set ext \[string range \$var(file,name) \$id end\]"
+ puts $ch " } else {"
+ puts $ch " set fn \$var(file,name)"
+ puts $ch " set ext {}"
+ puts $ch " }"
+ puts $ch ""
+ puts $ch " if {!\[file exists \$fn\]} {"
+ puts $ch " Error \"\[msgcat::mc {Unable to load}\] \$fn\""
+ puts $ch " global fitsfbox"
+ puts $ch " set fn \[OpenFileDialog fitsfbox\]"
+ puts $ch " if {\$fn == {}} {"
+ puts $ch " Error \[msgcat::mc {An error has occurred during restore}\]"
+ puts $ch " return 0"
+ puts $ch " }"
+ puts $ch " if {!\[file exists \$fn\]} {"
+ puts $ch " Error \[msgcat::mc {An error has occurred during restore}\]"
+ puts $ch " return 0"
+ puts $ch " }"
+ puts $ch " set var(file,name) \"\$fn\$ext\""
+ puts $ch " }"
+ puts $ch ""
+ puts $ch " return 1"
+ puts $ch "}"
+
+ # Panner
+ PannerBackup $ch
+
+ # Colorbar
+ ColorbarBackupCmaps $ch $dir
+ ColorbarBackup $ch colorbar
+ ColorbarBackup $ch colorbarrgb
+
+ # Frames
+ foreach ff $ds9(frames) {
+ if {![$ff has iis]} {
+ BackupFrame $ch $ff $dir
+ }
+ }
+
+ # Geometry
+ BackupGUI $ch
+
+ # User Plots
+ PlotBackup $ch $dir
+
+ # all done
+ close $ch
+}
+
+proc RestoreDialog {} {
+ set fn [OpenFileDialog backupfbox]
+ if {[string length $fn] != 0} {
+ Restore $fn
+ }
+}
+
+proc Restore {fn} {
+ global ds9
+ global pds9
+
+ if {[string length $fn] == 0} {
+ return
+ }
+
+ # clear all frames
+ DeleteAllFrames
+
+ # kill all image server dialogs
+ foreach dlg [list dtwomass dsao deso dstsci dvla dnvss dskyview dvlss] {
+ global $dlg
+ if {[array exists $dlg]} {
+ ARDestroy $dlg
+ }
+ }
+
+ # kill all simple text dialogs
+ global istxt
+ foreach varname $istxt(dialogs) {
+ SimpleTextDestroy $varname
+ }
+
+ # kill all cats
+ global icat
+ foreach varname $icat(cats) {
+ CATDestroy $varname
+ }
+
+ # kill all plots
+ global iap
+ foreach varname $iap(windows) {
+ PlotDestroy $varname
+ }
+
+ set dir [file dirname $fn]
+ set ffn [lindex [file split $fn] end]
+ set cd [pwd]
+ cd $dir
+
+ # fix a problem with 6.1.2
+ global prefs
+ set rr $prefs(version)
+
+ # ok, this is a major kludge to fix a major booboo.
+ # Beta versions generated backup save sets with vv set to
+ # something like '7.4b7'. We need to remove the 'b7' part.
+ set src {}
+ if {![catch {set ch [open "$ffn" r]}]} {
+ set src [read $ch]
+ close $ch
+ } else {
+ Error [msgcat::mc {An error has occurred during restore}]
+ return
+ }
+
+ set aa [string first {set vv } $src]
+ set bb [string first {# this is} $src]
+ if {$aa != -1 && $bb != -1 && $aa < $bb} {
+ set bb [expr $bb -2]
+ set ver [string range $src $aa $bb]
+ set ll [string first {b} $ver]
+ if {$ll != -1} {
+ set ll [expr $ll -1]
+ set src [string replace $src $aa $bb [string range $ver 0 $ll]]
+ }
+ } else {
+ Error [msgcat::mc {An error has occurred during restore}]
+ return
+ }
+
+ # and load the world
+ if {[catch {eval $src}]} {
+ Error [msgcat::mc {An error has occurred during restore}]
+ global debug
+ if {$debug(tcl,restore)} {
+ global errorInfo
+ puts stderr "$errorInfo"
+ }
+ return
+ }
+
+ # historical note, vv contains version number of save set originator
+ if {![info exists vv]} {
+ set vv [lindex $ds9(version) 0]
+ }
+
+ # fix 6.1.2
+ if {$vv == {6.1.2}} {
+ set prefs(version) $rr
+ }
+
+ # fix any prefs
+ FixPrefs $vv
+
+ # reset standard dialog
+ switch $ds9(wm) {
+ x11 {set pds9(dialog) motif}
+ aqua -
+ win32 {set pds9(dialog) native}
+ }
+
+ # return to start dir
+ cd $cd
+
+ # and update it
+ UpdateGraphGrid
+ LayoutOrient
+ UpdateActiveFrames
+ ChangeMode
+ UpdateDS9
+}
+
+proc BackupFrame {ch which dir} {
+ set fdir [file join $dir $which]
+ set rdir "./[lindex [file split $dir] end]/$which"
+
+ # create dir if needed
+ if {![file isdirectory $fdir]} {
+ if {[catch {file mkdir $fdir}]} {
+ Error [msgcat::mc {An error has occurred during backup}]
+ return
+ }
+ }
+
+ # frame
+ set type [$which get type]
+ puts $ch "CreateNameNumberFrame $which $type"
+ switch -- $type {
+ base {BackupFrameLoad $ch $which $fdir $rdir {}}
+ 3d {
+ BackupFrameLoad $ch $which $fdir $rdir {}
+ puts $ch "3DDialog"
+ }
+ rgb {
+ foreach cc {{} red green blue} {
+ BackupFrameLoad $ch $which $fdir $rdir $cc
+ }
+ puts $ch "RGBDialog"
+ }
+ }
+
+ MagnifierFrameBackup $ch $which
+ ColorFrameBackup $ch $which
+ ColormapFrameBackup $ch $which
+
+ DS9Backup $ch $which
+ CubeBackup $ch $which
+ RGBBackup $ch $which
+ BinBackup $ch $which
+ ScaleBackup $ch $which
+ PanZoomBackup $ch $which
+ # Block need to be before Crop
+ BlockBackup $ch $which
+ CropBackup $ch $which
+ # must be after Pan and Block
+ 3DBackup $ch $which
+ MarkerBackup $ch $which $fdir $rdir
+ CentroidBackup $ch $which
+ WCSBackup $ch $which $fdir $rdir
+ MaskBackup $ch $which
+ SmoothBackup $ch $which
+ ContourBackup $ch $which $fdir $rdir
+ GridBackup $ch $which
+ CATBackup $ch $which $fdir $rdir
+}
+
+proc BackupFrameLoad {ch which fdir rdir channel} {
+ set base $which$channel
+ set seq 1
+
+ set varname $base
+ global $varname
+ if {![info exists $varname]} {
+ # special case
+ set varname "$base.$seq"
+ global $varname
+ }
+
+ while {[info exists $varname]} {
+ if {$channel != {}} {
+ puts $ch "$which rgb channel $channel"
+ }
+
+ array set param [array get $varname]
+ switch $param(load,type) {
+ mmap -
+ mmapincr -
+ smmap -
+ shared -
+ sshared {
+ if {![BackupFrameLoadMMap param $fdir $rdir]} {
+ Error [msgcat::mc {An error has occurred during backup}]
+ return
+ }
+ }
+ alloc -
+ allocgz {
+ if {![BackupFrameLoadMMap param $fdir $rdir]} {
+ BackupFrameLoadAlloc $which param $fdir $rdir
+ }
+ }
+ channel -
+ socket -
+ socketgz -
+ var {BackupFrameLoadAlloc $which param $fdir $rdir}
+ photo {
+ if {[BackupFrameLoadMMap param $fdir $rdir]} {
+ puts $ch "global bcktmp"
+ puts $ch "if {\[catch {image create photo -file $param(file,name)} bcktmp\]} {"
+ puts $ch "Error \[msgcat::mc {An error has occurred during restore}\]"
+ puts $ch "return"
+ puts $ch "}"
+ } else {
+ BackupFrameLoadAlloc $which param $fdir $rdir
+ }
+ }
+ }
+
+ puts $ch "global loadParam"
+ puts $ch "array set loadParam \[list [array get param]\]"
+
+ switch $param(load,type) {
+ photo {
+ puts $ch "set loadParam(var,name) \$bcktmp"
+ }
+ }
+
+ puts $ch "if \[BackupFindFile loadParam\] {"
+ puts $ch " ProcessLoad"
+ puts $ch "}"
+
+ switch $param(load,type) {
+ photo {
+ puts $ch "image delete \$bcktmp"
+ }
+ }
+
+ incr seq
+ set varname "$base.$seq"
+ global $varname
+ }
+}
+
+proc BackupFrameLoadMMap {varname fdir rdir} {
+ upvar $varname param
+
+ global pds9
+
+ set id [string first "\[" $param(file,name)]
+ if {$id > 0} {
+ set fn [string range $param(file,name) 0 [expr $id-1]]
+ set ext [string range $param(file,name) $id end]
+ } else {
+ set fn $param(file,name)
+ set ext {}
+ }
+
+ if {![file exists $fn]} {
+ return 0
+ }
+
+ # special case, we use 'stdin' for input from stdin, ignore
+ if {$fn == {stdin}} {
+ return 0
+ }
+
+ if {$pds9(backup)} {
+ # look for sym links
+ switch [file type $fn] {
+ file {}
+ link {set fn [file readlink $fn]}
+ default {
+ return 0
+ }
+ }
+
+ set src [lindex [file split $fn] end]
+ if {![file exists [file join $fdir $src]]} {
+ if {[catch {file copy $fn $fdir}]} {
+ return 0
+ }
+ }
+ set param(file,name) "$rdir/[lindex [file split $fn] end]$ext"
+ } else {
+ if {[file pathtype $param(file,name)] == {relative}} {
+ set param(file,name) [file join [pwd] $param(file,name)]
+ }
+ }
+
+ # special case: mmap to allocgz via ConvertFitsFile/ConvertArrayFile
+ if {[info exists param(file,fn)]} {
+ set param(file,fn) $param(file,name)
+ }
+ return 1
+}
+
+proc BackupFrameLoadAlloc {which varname fdir rdir} {
+ upvar $varname param
+
+ set ff [$which get fits file name root base]
+ set id [string first "\[" $ff]
+ if {$id > 0} {
+ set fn [string range $ff 0 [expr $id-1]]
+ } else {
+ set fn $ff
+ }
+
+ if {$ff == {}} {
+ set ff ds9.fits
+ set fn ds9.fits
+ }
+
+ set ffn [file join $fdir $fn]
+ switch $param(file,type) {
+ fits {
+ switch $param(file,mode) {
+ {} {
+ if {[$which has fits bin]} {
+ $which save fits table file \"$ffn\"
+ } else {
+ $which save fits image file \"$ffn\"
+ }
+ }
+
+ {rgb cube} {$which save fits rgb cube file \"$ffn\"}
+ {rgb image} {$which save fits rgb image file \"$ffn\"}
+ {ext cube} {$which save fits image file \"$ffn\"}
+
+ default {
+ if {[string range $param(file,mode) 0 5] == {mosaic}} {
+ $which save fits mosaic image file "\{$ffn\}"
+ }
+ }
+ }
+ }
+ array {
+ switch $param(file,mode) {
+ {} {$which save fits image file \"$ffn\"}
+ {rgb cube} {$which save fits rgb cube file \"$ffn\"}
+ }
+ }
+ nrrd {$which save fits image file \"$ffn\"}
+ photo {
+ switch -- [$which get type] {
+ base -
+ 3d {$which save fits image file \"$ffn\"}
+ rgb {
+ $which save fits rgb cube file \"$ffn\"
+ set param(file,mode) {rgb cube}
+ }
+ }
+ }
+ }
+
+ set param(load,type) mmapincr
+ set param(file,type) fits
+ # use $fn as we are not saving multiple extentions if present
+ set param(file,name) "[file join $rdir $fn]"
+}
+
+proc BackupGUI {ch} {
+
+ # Basic
+
+ global pds9
+ puts $ch "global pds9"
+ puts $ch "array set pds9 \{ [array get pds9] \}"
+
+ global current
+ puts $ch "global current"
+ puts $ch "array set current \{ [array get current] \}"
+ global pcurrent
+ puts $ch "global pcurrent"
+ puts $ch "array set pcurrent \{ [array get pcurrent] \}"
+
+ global view
+ puts $ch "global view"
+ puts $ch "array set view \{ [array get view] \}"
+ global pview
+ puts $ch "global pview"
+ puts $ch "array set pview \{ [array get pview] \}"
+
+ global canvas
+ puts $ch "global canvas"
+ puts $ch "array set canvas \{ [array get canvas] \}"
+
+ global phttp
+ puts $ch "global phttp"
+ puts $ch "array set phttp \{ [array get phttp] \}"
+
+ global pbuttons
+ puts $ch "global pbuttons"
+ puts $ch "array set pbuttons \{ [array get pbuttons] \}"
+
+ global ppanner
+ puts $ch "global ppanner"
+ puts $ch "array set ppanner \{ [array get ppanner] \}"
+
+ global pmagnifier
+ puts $ch "global pmagnifier"
+ puts $ch "array set pmagnifier \{ [array get pmagnifier] \}"
+
+ global colorbar
+ puts $ch "global colorbar"
+ puts $ch "array set colorbar \{ [array get colorbar] \}"
+
+ global saveimage
+ puts $ch "global saveimage"
+ puts $ch "array set saveimage \{ [array get saveimage] \}"
+
+ # don't save prefs(version), keep the current, not the save set version
+ # removed after 6.1.2
+ # global prefs
+ # puts $ch "global prefs"
+ # puts $ch "array set prefs \{ [array get prefs] \}"
+
+ global debug
+ puts $ch "global debug"
+ puts $ch "array set debug \{ [array get debug] \}"
+
+ # File
+
+ global ps
+ puts $ch "global ps"
+ puts $ch "array set ps \{ [array get ps] \}"
+ global pps
+ puts $ch "global pps"
+ puts $ch "array set pps \{ [array get pps] \}"
+
+ # Frame
+
+ global rgb
+ puts $ch "global rgb"
+ puts $ch "array set rgb \{ [array get rgb] \}"
+
+ global threed
+ puts $ch "global threed"
+ puts $ch "array set threed \{ [array get threed] \}"
+
+ global blink
+ puts $ch "global blink"
+ puts $ch "array set blink \{ [array get blink] \}"
+ global pblink
+ puts $ch "global pblink"
+ puts $ch "array set pblink \{ [array get pblink] \}"
+
+ global tile
+ puts $ch "global tile"
+ puts $ch "array set tile \{ [array get tile] \}"
+ global ptile
+ puts $ch "global ptile"
+ puts $ch "array set ptile \{ [array get ptile] \}"
+
+ global crosshair
+ puts $ch "global crosshair"
+ puts $ch "array set crosshair \{ [array get crosshair] \}"
+
+ global cube
+ puts $ch "global cube"
+ puts $ch "array set cube \{ [array get cube] \}"
+
+ # Bin
+
+ global bin
+ puts $ch "global bin"
+ puts $ch "array set bin \{ [array get bin] \}"
+ global pbin
+ puts $ch "global pbin"
+ puts $ch "array set pbin \{ [array get pbin] \}"
+
+ # Zoom
+
+ global panzoom
+ puts $ch "global panzoom"
+ puts $ch "array set panzoom \{ [array get panzoom] \}"
+ global ppanzoom
+ puts $ch "global ppanzoom"
+ puts $ch "array set ppanzoom \{ [array get ppanzoom] \}"
+
+ # Crop
+
+ global crop
+ puts $ch "global crop"
+ puts $ch "array set crop \{ [array get crop] \}"
+
+ # Scale
+
+ global scale
+ puts $ch "global scale"
+ puts $ch "array set scale \{ [array get scale] \}"
+ global pscale
+ puts $ch "global pscale"
+ puts $ch "array set pscale \{ [array get pscale] \}"
+
+ global minmax
+ puts $ch "global minmax"
+ puts $ch "array set minmax \{ [array get minmax] \}"
+ global pminmax
+ puts $ch "global pminmax"
+ puts $ch "array set pminmax \{ [array get pminmax] \}"
+
+ global zscale
+ puts $ch "global zscale"
+ puts $ch "array set zscale \{ [array get zscale] \}"
+ global pzscale
+ puts $ch "global pzscale"
+ puts $ch "array set pzscale \{ [array get pzscale] \}"
+
+ # Region
+
+ global marker
+ puts $ch "global marker"
+ puts $ch "array set marker \{ [array get marker] \}"
+ global pmarker
+ puts $ch "global pmarker"
+ puts $ch "array set pmarker \{ [array get pmarker] \}"
+
+ global centroid
+ puts $ch "global centroid"
+ puts $ch "array set centroid \{ [array get centroid] \}"
+
+ # WCS
+
+ global wcs
+ puts $ch "global wcs"
+ puts $ch "array set wcs \{ [array get wcs] \}"
+ global pwcs
+ puts $ch "global pwcs"
+ puts $ch "array set pwcs \{ [array get pwcs] \}"
+
+ # Analysis
+
+ global ime
+ puts $ch "global ime"
+ puts $ch "array set ime \{ [array get ime] \}"
+ global pime
+ puts $ch "global pime"
+ puts $ch "array set pime \{ [array get pime] \}"
+
+ global pgraph
+ puts $ch "global pgraph"
+ puts $ch "array set pgraph \{ [array get pgraph] \}"
+
+ global pcoord
+ puts $ch "global pcoord"
+ puts $ch "array set pcoord \{ [array get pcoord] \}"
+
+ global pexamine
+ puts $ch "global pexamine"
+ puts $ch "array set pexamine \{ [array get pexamine] \}"
+
+ global pixel
+ puts $ch "global pixel"
+ puts $ch "array set pixel \{ [array get pixel] \}"
+
+ global mask
+ puts $ch "global mask"
+ puts $ch "array set mask \{ [array get mask] \}"
+ global pmask
+ puts $ch "global pmask"
+ puts $ch "array set pmask \{ [array get pmask] \}"
+
+ global contour
+ puts $ch "global contour"
+ puts $ch "array set contour \{ [array get contour] \}"
+ global pcontour
+ puts $ch "global pcontour"
+ puts $ch "array set pcontour \{ [array get pcontour] \}"
+
+ global grid
+ puts $ch "global grid"
+ puts $ch "array set grid \{ [array get grid] \}"
+ global pgrid
+ puts $ch "global pgrid"
+ puts $ch "array set pgrid \{ [array get pgrid] \}"
+
+ global block
+ puts $ch "global block"
+ puts $ch "array set block \{ [array get block] \}"
+ global pblock
+ puts $ch "global pblock"
+ puts $ch "array set pblock \{ [array get pblock] \}"
+
+ global smooth
+ puts $ch "global smooth"
+ puts $ch "array set smooth \{ [array get smooth] \}"
+ global psmooth
+ puts $ch "global psmooth"
+ puts $ch "array set psmooth \{ [array get psmooth] \}"
+
+ global pnres
+ puts $ch "global pnres"
+ puts $ch "array set pnres \{ [array get pnres] \}"
+
+ global sao
+ puts $ch "global sao"
+ puts $ch "array set sao \{ [array get sao] \}"
+
+ global eso
+ puts $ch "global eso"
+ puts $ch "array set eso \{ [array get eso] \}"
+
+ global stsci
+ puts $ch "global stsci"
+ puts $ch "array set stsci \{ [array get stsci] \}"
+
+ global twomass
+ puts $ch "global twomass"
+ puts $ch "array set twomass \{ [array get twomass] \}"
+
+ global nvss
+ puts $ch "global nvss"
+ puts $ch "array set nvss \{ [array get nvss] \}"
+
+ global vlss
+ puts $ch "global vlss"
+ puts $ch "array set vlss \{ [array get vlss] \}"
+
+ global skyview
+ puts $ch "global skyview"
+ puts $ch "array set skyview \{ [array get skyview] \}"
+
+ global cat
+ puts $ch "global cat"
+ puts $ch "array set cat \{ [array get cat] \}"
+ global pcat
+ puts $ch "global pcat"
+ puts $ch "array set pcat \{ [array get pcat] \}"
+
+ global vla
+ puts $ch "global vla"
+ puts $ch "array set vla \{ [array get vla] \}"
+
+ global pvo
+ puts $ch "global pvo"
+ puts $ch "array set pvo \{ [array get pvo] \}"
+
+ global pap
+ puts $ch "global pap"
+ puts $ch "array set pap \{ [array get pap] \}"
+
+ global panalysis
+ puts $ch "global panalysis"
+ puts $ch "array set panalysis \{ [array get panalysis] \}"
+
+ global active
+ puts $ch "global active"
+ puts $ch "array set active \{ [array get active] \}"
+}
+
+proc ProcessBackupCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ set fn [lindex $var $i]
+ if {$fn != {}} {
+ FileLast backupfbox $fn
+ Backup $fn
+ } else {
+ Error [msgcat::mc {Unable to open file}]
+ }
+}
+
+proc ProcessRestoreCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ set fn [lindex $var $i]
+ if {$fn != {}} {
+ FileLast backupfbox $fn
+ Restore $fn
+ } else {
+ Error [msgcat::mc {Unable to open file}]
+ }
+}
diff --git a/ds9/library/bin.tcl b/ds9/library/bin.tcl
new file mode 100644
index 0000000..cdcfbe5
--- /dev/null
+++ b/ds9/library/bin.tcl
@@ -0,0 +1,830 @@
+# 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 BinDef {} {
+ global bin
+ global ibin
+ global pbin
+ global tcl_platform
+
+ set ibin(top) .bl
+ set ibin(mb) .blmb
+
+ set bin(lock) 0
+ set bin(function) sum
+ set bin(factor) { 1 1 }
+ set bin(depth) 1
+ set bin(buffersize) 1024
+
+ array set pbin [array get bin]
+
+ # prefs only
+ set pbin(wheel) 0
+ set pbin(wheel,factor) 1.2
+ # special case
+ switch -- $tcl_platform(os) {
+ Darwin {
+ switch [lindex [split $tcl_platform(osVersion) {.}] 0] {
+ 11 {set pbin(wheel,factor) 1.01}
+ }
+ }
+ }
+}
+
+proc Bin {bx by} {
+ global current
+
+ if {$current(frame) != {}} {
+ BinFrame $current(frame) $bx $by
+ }
+}
+
+proc BinFrame {which bx by} {
+ global bin
+ global current
+ global rgb
+
+ RGBEvalLock rgb(lock,bin) $which [list $which bin factor $bx $by]
+ if {$which == $current(frame)} {
+ set bin(factor) "[$current(frame) get bin factor]"
+ }
+ UpdateBin
+}
+
+proc BinAbout {x y} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin about $x $y]
+ UpdateBin
+ }
+}
+
+proc BinAboutCenter {} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin about center]
+ UpdateBin
+ }
+}
+
+proc BinCols {x y z} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ if {![$current(frame) has bin column $x]} {
+ Error "[msgcat::mc {Invalid Column Name}] $x"
+ return
+ }
+ if {![$current(frame) has bin column $y]} {
+ Error "[msgcat::mc {Invalid Column Name}] $y"
+ return
+ }
+ if {$z!={""}} {
+ if {![$current(frame) has bin column $z]} {
+ Error "[msgcat::mc {Invalid Column Name}] $z"
+ return
+ }
+ }
+
+ RGBEvalLockCurrent rgb(lock,bin) "$current(frame) bin cols \{$x\} \{$y\} \{$z\}"
+ UpdateBin
+ }
+}
+
+proc BinFilter {str} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) "$current(frame) bin filter \{\{$str\}\}"
+ UpdateBin
+ }
+}
+
+proc BinToFit {} {
+ global current
+ global bin
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin to fit]
+ set bin(factor) "[$current(frame) get bin factor]"
+ UpdateBin
+ }
+}
+
+proc ChangeBinFactor {} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin factor to $bin(factor)]
+ UpdateBin
+ }
+}
+
+proc ChangeBinDepth {} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin depth $bin(depth)]
+ UpdateBin
+ }
+}
+
+proc ChangeBinFunction {} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin function $bin(function)]
+ UpdateBin
+ }
+}
+
+proc ChangeBinBufferSize {} {
+ global bin
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,bin) [list $current(frame) bin buffer size $bin(buffersize)]
+ UpdateBin
+ }
+}
+
+proc UpdateBin {} {
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateBin"
+ }
+
+ LockBinCurrent
+ UpdateBinDialog
+ UpdateCrosshairDialog
+ UpdateCropDialog
+ UpdateCubeDialog
+ UpdateScaleDialog
+ UpdateContourScale
+ UpdateContourDialog
+ UpdateWCSDialog
+ UpdateGraphXAxis $current(frame)
+ UpdateGraphYAxis $current(frame)
+ UpdateMain
+}
+
+proc BinDialog {} {
+ global bin
+ global ibin
+ global dbin
+ global ds9
+
+ # see if we already have a window visible
+
+ if {[winfo exists $ibin(top)]} {
+ raise $ibin(top)
+ return
+ }
+
+ # create the window
+ set w $ibin(top)
+ set mb $ibin(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Binning Parameters}] BinDestroyDialog
+ $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 {Method}] -menu $mb.method
+ $mb add cascade -label [msgcat::mc {Bin}] -menu $mb.bin
+ $mb add cascade -label [msgcat::mc {Buffer}] -menu $mb.buffer
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command BinApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Update Filter}] \
+ -command BinUpdateFilterDialog
+ $mb.file add command -label [msgcat::mc {Clear Filter}] \
+ -command BinClearFilterDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command BinDestroyDialog
+
+ EditMenu $mb ibin
+
+ menu $mb.method
+ $mb.method add radiobutton -label [msgcat::mc {Average}] \
+ -variable bin(function) -value average -command ChangeBinFunction
+ $mb.method add radiobutton -label [msgcat::mc {Sum}] \
+ -variable bin(function) -value sum -command ChangeBinFunction
+
+ menu $mb.bin
+ $mb.bin add command -label [msgcat::mc {Bin In}] \
+ -command {Bin .5 .5}
+ $mb.bin add command -label [msgcat::mc {Bin Out}] \
+ -command {Bin 2 2}
+ $mb.bin add command -label [msgcat::mc {Bin Fit}] \
+ -command BinToFit
+ $mb.bin add separator
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 1" \
+ -variable bin(factor) -value { 1 1 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 2" \
+ -variable bin(factor) -value { 2 2 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 4" \
+ -variable bin(factor) -value { 4 4 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 8" \
+ -variable bin(factor) -value { 8 8 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 16" \
+ -variable bin(factor) -value { 16 16 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 32" \
+ -variable bin(factor) -value { 32 32 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 64" \
+ -variable bin(factor) -value { 64 64 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 128" \
+ -variable bin(factor) -value { 128 128 } -command ChangeBinFactor
+ $mb.bin add radiobutton -label "[msgcat::mc {Bin}] 256" \
+ -variable bin(factor) -value { 256 256 } -command ChangeBinFactor
+
+ menu $mb.buffer
+ $mb.buffer add radiobutton -label {128x128} \
+ -variable bin(buffersize) -value 128 -command ChangeBinBufferSize
+ $mb.buffer add radiobutton -label {256x256} \
+ -variable bin(buffersize) -value 256 -command ChangeBinBufferSize
+ $mb.buffer add radiobutton -label {512x512} \
+ -variable bin(buffersize) -value 512 -command ChangeBinBufferSize
+ $mb.buffer add radiobutton -label {1024x1024} \
+ -variable bin(buffersize) -value 1024 -command ChangeBinBufferSize
+ $mb.buffer add radiobutton -label {2048x2048} \
+ -variable bin(buffersize) -value 2048 -command ChangeBinBufferSize
+ $mb.buffer add radiobutton -label {4096x4096} \
+ -variable bin(buffersize) -value 4096 -command ChangeBinBufferSize
+ $mb.buffer add radiobutton -label {8192x8192} \
+ -variable bin(buffersize) -value 8192 -command ChangeBinBufferSize
+
+ # Columns
+ set f [ttk::labelframe $w.cols -text [msgcat::mc {Bin Columns}] -padding 2]
+
+ ttk::label $f.title -text [msgcat::mc {Column}]
+ ttk::label $f.titlefactor -text [msgcat::mc {Bin}]
+ ttk::label $f.titlemin -text [msgcat::mc {Min}]
+ ttk::label $f.titlemax -text [msgcat::mc {Max}]
+ ttk::menubutton $f.x -textvariable dbin(xcol) -menu $f.x.m -width 10
+ ttk::entry $f.xfactor -textvariable dbin(factor,x) -width 8
+ ttk::label $f.xmin -textvariable dbin(xcol,min) -width 12 -relief groove
+ ttk::label $f.xmax -textvariable dbin(xcol,max) -width 12 -relief groove
+ ttk::menubutton $f.y -textvariable dbin(ycol) -menu $f.y.m -width 10
+ ttk::entry $f.yfactor -textvariable dbin(factor,y) -width 8
+ ttk::label $f.ymin -textvariable dbin(ycol,min) -width 12 -relief groove
+ ttk::label $f.ymax -textvariable dbin(ycol,max) -width 12 -relief groove
+
+ grid $f.title $f.titlefactor $f.titlemin $f.titlemax -padx 2 -pady 2
+ grid $f.x $f.xfactor $f.xmin $f.xmax -padx 2 -pady 2
+ grid $f.y $f.yfactor $f.ymin $f.ymax -padx 2 -pady 2
+
+ # Center
+ set f [ttk::labelframe $w.center -text [msgcat::mc {Bin Center}] -padding 2]
+ ttk::entry $f.x -textvariable dbin(x) -width 12
+ ttk::entry $f.y -textvariable dbin(y) -width 12
+ ttk::checkbutton $f.auto -text [msgcat::mc {or center of data}] \
+ -variable dbin(auto)
+ grid $f.x $f.y $f.auto -padx 2 -pady 2
+
+ # Filter
+ set f [ttk::labelframe $w.filter -text [msgcat::mc {Bin Filter}] -padding 2]
+ set dbin(filter,entry) \
+ [ttk::entry $f.filter -textvariable dbin(filter) -width 40]
+ grid $f.filter -padx 2 -pady 2
+
+ # Bin 3rd Column
+ set f [ttk::labelframe $w.z -text [msgcat::mc {Bin 3rd Column}] -padding 2]
+ ttk::label $f.title -text [msgcat::mc {Column}]
+ ttk::label $f.titledepth -text [msgcat::mc {Depth}]
+ ttk::label $f.titlemin -text [msgcat::mc {Min}]
+ ttk::label $f.titlemax -text [msgcat::mc {Max}]
+
+ ttk::menubutton $f.z -textvariable dbin(zcol) -menu $f.z.m -width 10
+ ttk::entry $f.depth -textvariable dbin(depth) -width 8
+ ttk::entry $f.min -textvariable dbin(zcol,min) -width 12
+ ttk::entry $f.max -textvariable dbin(zcol,max) -width 12
+
+ grid $f.title $f.titledepth $f.titlemin $f.titlemax -padx 2 -pady 2
+ grid $f.z $f.depth $f.min $f.max -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command BinApplyDialog
+ ttk::button $f.update -text [msgcat::mc {Update Filter}] \
+ -command BinUpdateFilterDialog
+ ttk::button $f.clear -text [msgcat::mc {Clear Filter}] \
+ -command BinClearFilterDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command BinDestroyDialog
+ pack $f.apply $f.update $f.clear $f.close \
+ -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ grid $w.cols -sticky news
+ grid $w.center -sticky news
+ grid $w.filter -sticky news
+ grid $w.z -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid rowconfigure $w 2 -weight 1
+ grid rowconfigure $w 3 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ $w.cols.xfactor select range 0 end
+
+ set dbin(auto) 0
+ set dbin(minmax) 1
+
+ UpdateBinDialog
+}
+
+proc PopUp {b m l cmd} {
+ global ds9
+
+ destroy $m
+
+ menu $m -tearoff 0
+ set cnt -1
+ for {set ii 0} {$ii<[llength $l]} {incr ii} {
+ $m add command -label [lindex $l $ii] \
+ -command "global dbin;set $b [lindex $l $ii]; $cmd"
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 0
+ $m entryconfig $ii -columnbreak 1
+ }
+ }
+}
+
+proc BlankPopUp {m} {
+ destroy $m
+ menu $m -tearoff 0
+}
+
+proc UpdateBinDialog {} {
+ global bin
+ global ibin
+ global dbin
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateBinDialog"
+ }
+
+ if {![winfo exists $ibin(top)]} {
+ return
+ }
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set w $ibin(top)
+
+ set bf "[$current(frame) get bin factor]"
+ set dbin(factor,x) [lindex $bf 0]
+ set dbin(factor,y) [lindex $bf 1]
+ set dbin(depth) [$current(frame) get bin depth]
+
+ if {[$current(frame) has fits bin]} {
+
+ set cols [$current(frame) get bin cols]
+ set colslist "[$current(frame) get bin list]"
+
+ set dbin(xcol) [lindex $cols 0]
+ set dbin(ycol) [lindex $cols 1]
+ PopUp dbin(xcol) $w.cols.x.m $colslist UpdateXCol
+ PopUp dbin(ycol) $w.cols.y.m $colslist UpdateYCol
+
+ set mm [$current(frame) get bin cols minmax \{$dbin(xcol)\}]
+ set dbin(xcol,min) [lindex $mm 0]
+ set dbin(xcol,max) [lindex $mm 1]
+
+ set mm [$current(frame) get bin cols minmax \{$dbin(ycol)\}]
+ set dbin(ycol,min) [lindex $mm 0]
+ set dbin(ycol,max) [lindex $mm 1]
+
+ set cursor [$current(frame) get bin cursor]
+ set dbin(x) [lindex $cursor 0]
+ set dbin(y) [lindex $cursor 1]
+
+ set dbin(filter) [$current(frame) get bin filter]
+
+ set dbin(zcol) [lindex $cols 2]
+ PopUp dbin(zcol) $w.z.z.m $colslist UpdateZCol
+ set mm [$current(frame) get bin cols dim \{$dbin(zcol)\}]
+ set dbin(zcol,min) [lindex $mm 0]
+ set dbin(zcol,max) [lindex $mm 1]
+
+ } else {
+ set dbin(xcol) {}
+ set dbin(xcol,min) {}
+ set dbin(xcol,max) {}
+ set dbin(ycol) {}
+ set dbin(ycol,min) {}
+ set dbin(ycol,max) {}
+
+ set dbin(x) {}
+ set dbin(y) {}
+
+ set dbin(filter) {}
+
+ set dbin(zcol) {}
+ set dbin(zcol,min) {}
+ set dbin(zcol,max) {}
+
+ BlankPopUp $w.cols.x.m
+ BlankPopUp $w.cols.y.m
+ BlankPopUp $w.z.z.m
+ }
+}
+
+proc UpdateXCol {} {
+ global current
+ global dbin
+
+ if {$current(frame) != {}
+ && [$current(frame) has fits bin]
+ && $dbin(xcol) != {}} {
+
+ set mm [$current(frame) get bin cols minmax \{$dbin(xcol)\}]
+ set dbin(xcol,min) [lindex $mm 0]
+ set dbin(xcol,max) [lindex $mm 1]
+ } else {
+ set dbin(xcol,min) {}
+ set dbin(xcol,max) {}
+ }
+}
+
+proc UpdateYCol {} {
+ global current
+ global dbin
+
+ if {$current(frame) != {}
+ && [$current(frame) has fits bin]
+ && $dbin(ycol) != {}} {
+
+ set mm [$current(frame) get bin cols minmax \{$dbin(ycol)\}]
+ set dbin(ycol,min) [lindex $mm 0]
+ set dbin(ycol,max) [lindex $mm 1]
+ } else {
+ set dbin(ycol,min) {}
+ set dbin(ycol,max) {}
+ }
+}
+
+proc UpdateZCol {} {
+ global current
+ global dbin
+
+ if {$current(frame) != {}
+ && [$current(frame) has fits bin]
+ && $dbin(zcol) != {}} {
+
+ if {$dbin(minmax)} {
+ set mm [$current(frame) get bin cols dim \{$dbin(zcol)\}]
+ set dbin(zcol,min) [lindex $mm 0]
+ set dbin(zcol,max) [lindex $mm 1]
+ }
+ } else {
+ set dbin(zcol,min) {}
+ set dbin(zcol,max) {}
+ }
+}
+
+proc BinApplyDialog {} {
+ global bin
+ global dbin
+ global current
+ global rgb
+
+ if {$current(frame) == {}} {
+ # reset
+ set dbin(auto) 0
+ return
+ }
+
+ # clean up filter if needed
+ set dbin(filter) [string trimleft $dbin(filter)]
+ set dbin(filter) [string trimright $dbin(filter)]
+
+ # delete any markers if needed
+ if {[$current(frame) has fits bin]} {
+ set foo [$current(frame) get bin cols]
+ set xcol [lindex $foo 0]
+ set ycol [lindex $foo 1]
+
+ if {$xcol != $dbin(xcol) || $ycol != $dbin(ycol)} {
+ $current(frame) marker delete all
+ }
+ }
+
+ if {$dbin(depth)>1} {
+ CubeDialog
+
+ if {$dbin(auto)} {
+ if {$dbin(factor,x) != {}
+ && $dbin(factor,y) != {}
+ && $dbin(depth) != {}
+ && $dbin(zcol,min) != {}
+ && $dbin(zcol,max) != {}
+ && $dbin(xcol) != {}
+ && $dbin(ycol) != {}
+ && $dbin(zcol) != {}} {
+
+ RGBEvalLockCurrent rgb(lock,bin) \
+ [list $current(frame) bin to $dbin(factor,x) $dbin(factor,y) $dbin(depth) $dbin(zcol,min) $dbin(zcol,max) about center \{$dbin(xcol)\} \{$dbin(ycol)\} \{$dbin(zcol)\} \{$dbin(filter)\}]
+ }
+ } else {
+ if {$dbin(factor,x) != {}
+ && $dbin(factor,y) != {}
+ && $dbin(depth) != {}
+ && $dbin(zcol,min) != {}
+ && $dbin(zcol,max) != {}
+ && $dbin(x) != {}
+ && $dbin(y) != {}
+ && $dbin(xcol) != {}
+ && $dbin(ycol) != {}
+ && $dbin(zcol) != {}} {
+
+ RGBEvalLockCurrent rgb(lock,bin) \
+ [list $current(frame) bin to $dbin(factor,x) $dbin(factor,y) $dbin(depth) $dbin(zcol,min) $dbin(zcol,max) about $dbin(x) $dbin(y) \{$dbin(xcol)\} \{$dbin(ycol)\} \{$dbin(zcol)\} \{$dbin(filter)\}]
+ }
+ }
+ } else {
+ if {$dbin(auto)} {
+ if {$dbin(factor,x) != {}
+ && $dbin(factor,y) != {}
+ && $dbin(xcol) != {}
+ && $dbin(ycol) != {}} {
+
+ RGBEvalLockCurrent rgb(lock,bin) \
+ [list $current(frame) bin to $dbin(factor,x) $dbin(factor,y) about center \{$dbin(xcol)\} \{$dbin(ycol)\} \{$dbin(filter)\}]
+ }
+ } else {
+ if {$dbin(factor,x) != {}
+ && $dbin(factor,y) != {}
+ && $dbin(x) != {}
+ && $dbin(y) != {}
+ && $dbin(xcol) != {}
+ && $dbin(ycol) != {}} {
+
+ RGBEvalLockCurrent rgb(lock,bin) \
+ [list $current(frame) bin to $dbin(factor,x) $dbin(factor,y) about $dbin(x) $dbin(y) \{$dbin(xcol)\} \{$dbin(ycol)\} \{$dbin(filter)\}]
+ }
+ }
+ }
+
+ UpdateScaleMenu
+ UpdateBinMenu
+ UpdateBin
+
+ # reset
+ set dbin(auto) 0
+}
+
+proc BinUpdateFilterDialog {} {
+ global dbin
+ global current
+
+ $dbin(filter,entry) delete 0 end
+ if {$current(frame) != {}} {
+ $dbin(filter,entry) insert 0 \
+ [$current(frame) marker list ds9 physical fk5 degrees yes]
+ }
+}
+
+proc BinClearFilterDialog {} {
+ global dbin
+
+ $dbin(filter,entry) delete 0 end
+}
+
+proc BinDestroyDialog {} {
+ global ibin
+ global dbin
+
+ if {[winfo exists $ibin(top)]} {
+ destroy $ibin(top)
+ destroy $ibin(mb)
+ }
+
+ unset dbin
+}
+
+proc MatchBinCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchBin $current(frame)
+ }
+}
+
+proc MatchBin {which} {
+ global ds9
+ global rgb
+
+ set factor [$which get bin factor]
+ set depth [$which get bin depth]
+ set filter [$which get bin filter]
+ set size [$which get bin buffer size]
+ set function [$which get bin function]
+ set cols [$which get bin cols]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,bin) $ff [list $ff bin factor to $factor]
+ RGBEvalLock rgb(lock,bin) $ff [list $ff bin depth $depth]
+ RGBEvalLock rgb(lock,bin) $ff "$ff bin filter \{\{$filter\}\}"
+ RGBEvalLock rgb(lock,bin) $ff [list $ff bin buffer size $size]
+ RGBEvalLock rgb(lock,bin) $ff [list $ff bin function $function]
+ RGBEvalLock rgb(lock,bin) $ff "$ff bin cols \{\{[lindex $cols 0]\}\} \{\{[lindex $cols 1]\}\} \{\{[lindex $cols 2]\}\}"
+ }
+ }
+}
+
+proc LockBinCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockBin $current(frame)
+ }
+}
+
+proc LockBin {which} {
+ global bin
+
+ if {$bin(lock)} {
+ MatchBin $which
+ }
+}
+
+proc BinBackup {ch which} {
+ switch [$which get type] {
+ base -
+ 3d {BinBackupBase $ch $which}
+ rgb {BinBackupRGB $ch $which}
+ }
+}
+
+proc BinBackupBase {ch which} {
+ puts $ch "$which bin factor to [$which get bin factor]"
+ puts $ch "$which bin depth [$which get bin depth]"
+ puts $ch "$which bin filter \{\"[$which get bin filter]\"\}"
+ puts $ch "$which bin buffer size [$which get bin buffer size]"
+ set pos [$which get bin cursor]
+ if {$pos != {}} {
+ puts $ch "$which bin about $pos"
+ }
+ puts $ch "$which bin function [$which get bin function]"
+ set cols [$which get bin cols]
+ if {$cols != {}} {
+ puts $ch "$which bin cols \{\"[lindex $cols 0]\"\} \{\"[lindex $cols 1]\"\} \{\"[lindex $cols 2]\"\} "
+ }
+}
+
+proc BinBackupRGB {ch which} {
+ set sav [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ puts $ch "$which rgb channel $cc"
+ BinBackupBase $ch $which
+ }
+ $which rgb channel $sav
+ puts $ch "$which rgb channel $sav"
+}
+
+# Process Cmds
+
+proc ProcessBinCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global bin
+
+ switch -- [string tolower [lindex $var $i]] {
+ close {BinDestroyDialog}
+ open {BinDialog}
+ match {MatchBinCurrent}
+ lock {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set bin(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set bin(lock) 1
+ incr i -1
+ }
+ LockBinCurrent
+ }
+ about {
+ incr i
+ switch [lindex $var $i] {
+ center {
+ BinAboutCenter
+ }
+ default {
+ BinAbout [lindex $var [expr $i+0]] [lindex $var [expr $i+1]]
+ incr i
+ }
+ }
+ }
+ buffersize {
+ incr i
+ set bin(buffersize) [lindex $var $i]
+ ChangeBinBufferSize
+ }
+ cols {
+ BinCols \"[lindex $var [expr $i+1]]\" \"[lindex $var [expr $i+2]]\" \"\"
+ incr i 2
+ }
+ colsz {
+ BinCols \"[lindex $var [expr $i+1]]\" \"[lindex $var [expr $i+2]]\" \"[lindex $var [expr $i+3]]\"
+ incr i 3
+ }
+ factor {
+ incr i
+ set bx [lindex $var $i]
+ set by [lindex $var [expr $i+1]]
+ # note: the spaces are needed so that the menus are in sync
+ if {$by != {} && [string is double $by]} {
+ set bin(factor) " $bx $by "
+ incr i
+ } else {
+ set bin(factor) " $bx $bx "
+ }
+ ChangeBinFactor
+ }
+ depth {
+ incr i
+ set bin(depth) [lindex $var $i]
+ ChangeBinDepth
+ }
+ filter {
+ incr i
+ BinFilter [lindex $var $i]
+ }
+ function {
+ incr i
+ set bin(function) [string tolower [lindex $var $i]]
+ ChangeBinFunction
+ }
+ in {Bin .5 .5}
+ out {Bin 2 2}
+ to {
+ # eat the 'fit'
+ incr i
+ BinToFit
+ }
+ }
+}
+
+proc ProcessSendBinCmd {proc id param} {
+ global bin
+ global current
+
+ switch -- [string tolower [lindex $param 0]] {
+ lock {$proc $id [ToYesNo $bin(lock)]}
+ about {
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get bin cursor]\n"
+ }
+ }
+ buffersize {$proc $id "$bin(buffersize)\n"}
+ cols {
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get bin cols]\n"
+ }
+ }
+ factor {$proc $id "$bin(factor)\n"}
+ depth {$proc $id "$bin(depth)\n"}
+ filter {
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get bin filter]\n"
+ }
+ }
+ function {$proc $id "$bin(function)\n"}
+ }
+}
+
diff --git a/ds9/library/block.tcl b/ds9/library/block.tcl
new file mode 100644
index 0000000..f474f2d
--- /dev/null
+++ b/ds9/library/block.tcl
@@ -0,0 +1,356 @@
+# 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 BlockDef {} {
+ global iblock
+ global block
+ global pblock
+
+ set iblock(top) .blk
+ set iblock(mb) .blkmb
+
+ set block(lock) 0
+ set block(factor) { 1 1 }
+
+ array set pblock [array get block]
+}
+
+proc BlockToFit {} {
+ global block
+ global current
+
+ if {$current(frame) != {}} {
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,block) [list $current(frame) block to fit]
+ ResetWatchCursor
+ set block(factor) [$current(frame) get block factor]
+ UpdateBlock
+ }
+}
+
+proc ChangeBlock {} {
+ global block
+ global current
+
+ if {$current(frame) != {}} {
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,block) [list $current(frame) block to $block(factor)]
+ ResetWatchCursor
+ UpdateBlock
+ }
+}
+
+proc Block {bx by} {
+ global block
+ global current
+
+ if {$current(frame) != {}} {
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,block) [list $current(frame) block $bx $by]
+ set block(factor) [$current(frame) get block factor]
+ ResetWatchCursor
+ UpdateBlock
+ }
+}
+
+proc UpdateBlock {} {
+ global current
+
+ LockBlockCurrent
+ UpdateBlockDialog
+ UpdateCrosshairDialog
+ UpdateCropDialog
+ UpdateCubeDialog
+ UpdateScaleDialog
+ UpdateContourScale
+ UpdateContourDialog
+ UpdateWCSDialog
+ UpdateGraphXAxis $current(frame)
+ UpdateGraphYAxis $current(frame)
+ UpdateMain
+
+ UpdateHeaderDialog
+}
+
+proc BlockDialog {} {
+ global block
+ global iblock
+ global dblock
+ global ds9
+ global current
+
+ # see if we already have a window visible
+ if {[winfo exists $iblock(top)]} {
+ raise $iblock(top)
+ return
+ }
+
+ # create the window
+ set w $iblock(top)
+ set mb $iblock(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Block Parameters}] \
+ BlockDestroyDialog
+
+ $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 {Block}] -menu $mb.block
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command BlockApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command BlockDestroyDialog
+
+ EditMenu $mb iblock
+
+ menu $mb.block
+ $mb.block add command -label [msgcat::mc {Block In}] -command {Block .5 .5}
+ $mb.block add command -label [msgcat::mc {Block Out}] -command {Block 2 2}
+ $mb.block add command -label [msgcat::mc {Block Fit}] -command BlockToFit
+ $mb.block add separator
+ $mb.block add radiobutton -label "[msgcat::mc {Block}] 1" \
+ -variable block(factor) -value { 1 1 } -command ChangeBlock
+ $mb.block add radiobutton -label "[msgcat::mc {Block}] 2" \
+ -variable block(factor) -value { 2 2 } -command ChangeBlock
+ $mb.block add radiobutton -label "[msgcat::mc {Block}] 4" \
+ -variable block(factor) -value { 4 4 } -command ChangeBlock
+ $mb.block add radiobutton -label "[msgcat::mc {Block}] 8" \
+ -variable block(factor) -value { 8 8 } -command ChangeBlock
+ $mb.block add radiobutton -label "[msgcat::mc {Block}] 16" \
+ -variable block(factor) -value { 16 16 } -command ChangeBlock
+ $mb.block add radiobutton -label "[msgcat::mc {Block}] 32" \
+ -variable block(factor) -value { 32 32 } -command ChangeBlock
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.blocktitle -text [msgcat::mc {Block}]
+ ttk::entry $f.blockx -textvariable dblock(x) -width 14
+ ttk::entry $f.blocky -textvariable dblock(y) -width 14
+
+ grid $f.blocktitle $f.blockx $f.blocky -padx 2 -pady 2
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command BlockApplyDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command BlockDestroyDialog
+ pack $f.apply $f.close -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
+
+ $w.param.blockx select range 0 end
+
+ UpdateBlockDialog
+}
+
+proc BlockApplyDialog {} {
+ global block
+ global iblock
+ global dblock
+ global current
+
+ if {$current(frame) != {}} {
+ set block(factor) "$dblock(x) $dblock(y)"
+ RGBEvalLockCurrent rgb(lock,block) [list $current(frame) block to $block(factor)]
+
+ LockFrameCurrent
+ UpdateGraphXAxis $current(frame)
+ UpdateBlockDialog
+ RefreshInfoBox $current(frame)
+ }
+}
+
+proc BlockDestroyDialog {} {
+ global iblock
+ global dblock
+
+ if {[winfo exists $iblock(top)]} {
+ destroy $iblock(top)
+ destroy $iblock(mb)
+ }
+
+ unset dblock
+}
+
+proc UpdateBlockDialog {} {
+ global block
+ global iblock
+ global dblock
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateBlockDialog"
+ }
+
+ if {![winfo exists $iblock(top)]} {
+ return
+ }
+
+ if {$current(frame) != {}} {
+ set zz [$current(frame) get block factor]
+ set dblock(x) [lindex $zz 0]
+ set dblock(y) [lindex $zz 1]
+ } else {
+ set dblock(x) {}
+ set dblock(y) {}
+ }
+}
+
+proc UpdateBlockMenu {} {
+ global block
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateBlockMenu"
+ }
+
+ if {$current(frame) != {}} {
+ set block(factor) [$current(frame) get block factor]
+ }
+}
+
+proc MatchBlockCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchBlock $current(frame)
+ }
+}
+
+proc MatchBlock {which} {
+ global ds9
+ global rgb
+
+ set factor [$which get block factor]
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,block) $ff [list $ff block to $factor]
+ }
+ }
+}
+
+proc LockBlockCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockBlock $current(frame)
+ }
+}
+
+proc LockBlock {which} {
+ global block
+
+ if {$block(lock)} {
+ MatchBlock $which
+ }
+}
+
+proc BlockBackup {ch which} {
+ switch [$which get type] {
+ base -
+ 3d {BlockBackupBase $ch $which}
+ rgb {BlockBackupRGB $ch $which}
+ }
+}
+
+proc BlockBackupBase {ch which} {
+ set factor [$which get block factor]
+ puts $ch "$which block to $factor"
+}
+
+proc BlockBackupRGB {ch which} {
+ set sav [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ puts $ch "$which rgb channel $cc"
+ BlockBackupBase $ch $which
+ }
+ $which rgb channel $sav
+ puts $ch "$which rgb channel $sav"
+}
+
+proc ProcessBlockCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ global block
+ switch -- [string tolower [lindex $var $i]] {
+ open {BlockDialog}
+ close {BlockDestroyDialog}
+ match {MatchBlockCurrent}
+ lock {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set block(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set block(lock) 1
+ incr i -1
+ }
+ LockBlockCurrent
+ }
+ in {Block .5 .5}
+ out {Block 2 2}
+ to {
+ switch -- [string tolower [lindex $var [expr $i+1]]] {
+ fit {
+ BlockToFit
+ incr i
+ }
+ default {
+ set b1 [lindex $var [expr $i+1]]
+ set b2 [lindex $var [expr $i+2]]
+ if {[string is double $b2] && $b2 != {}} {
+ set block(factor) " $b1 $b2 "
+ incr i 2
+ } else {
+ set block(factor) " $b1 $b1 "
+ incr i
+ }
+ ChangeBlock
+ }
+ }
+ }
+ default {
+ set b1 [lindex $var $i]
+ set b2 [lindex $var [expr $i+1]]
+ if {[string is double $b2] && $b2 != {}} {
+ Block $b1 $b2
+ incr i
+ } else {
+ Block $b1 $b1
+ }
+ }
+ }
+}
+
+proc ProcessSendBlockCmd {proc id param} {
+ global block
+
+ switch -- [lindex $param 0] {
+ lock {$proc $id [ToYesNo $block(lock)]}
+ default {
+ set z1 [lindex $block(factor) 0]
+ set z2 [lindex $block(factor) 1]
+ if {$z1 != $z2} {
+ $proc $id "$block(factor)\n"
+ } else {
+ $proc $id "$z1\n"
+ }
+ }
+ }
+}
+
diff --git a/ds9/library/box.tcl b/ds9/library/box.tcl
new file mode 100644
index 0000000..b28d84b
--- /dev/null
+++ b/ds9/library/box.tcl
@@ -0,0 +1,126 @@
+# 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 BoxDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ # procs
+ set var(proc,apply) BoxApply
+ set var(proc,close) BoxClose
+ set var(proc,coordCB) BoxCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisHistogramDialog $varname
+ MarkerAnalysisPlot3dDialog $varname
+
+ # init
+ BoxEditCB $varname
+ MarkerBaseCenterRotateCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback edit BoxEditCB $varname
+ $var(frame) marker $var(id) callback rotate \
+ MarkerBaseCenterRotateCB $varname
+
+ set f $var(top).param
+
+ # Radius
+ ttk::label $f.tradius -text Size
+ ttk::entry $f.radius1 -textvariable ${varname}(radius1) -width 13
+ ttk::entry $f.radius2 -textvariable ${varname}(radius2) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list BoxEditCB $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid $f.tradius $f.radius1 $f.radius2 $f.uradius -padx 2 -pady 2 -sticky w
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc BoxClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback edit BoxEditCB
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc BoxApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(radius1) != {} &&
+ $var(radius2) !={}} {
+ $var(frame) marker $var(id) box radius \
+ $var(radius1) $var(radius2) $var(dcoord) $var(dformat)
+ }
+
+ MarkerBaseCenterRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc BoxCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "BoxCoordCB"
+ }
+
+ MarkerAnalysisStatsSystem $varname
+ MarkerAnalysisPlot3dSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+proc BoxEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "BoxEditCB"
+ }
+
+ set r [$var(frame) get marker $var(id) box radius \
+ $var(dcoord) $var(dformat)]
+ set var(radius1) [lindex $r 0]
+ set var(radius2) [lindex $r 1]
+}
diff --git a/ds9/library/boxannulus.tcl b/ds9/library/boxannulus.tcl
new file mode 100644
index 0000000..733e822
--- /dev/null
+++ b/ds9/library/boxannulus.tcl
@@ -0,0 +1,28 @@
+# 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 BoxAnnulusDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(which) boxannulus
+ set var(proc,apply) MarkerBaseAnnulusRectApply
+ set var(proc,close) MarkerBaseAnnulusRectClose
+ set var(proc,generate) MarkerBaseAnnulusGenerateBox
+ set var(proc,coordCB) MarkerBaseAnnulusRectCoordCB
+ set var(proc,editCB) MarkerBaseAnnulusRectEditCB
+ set var(proc,distCB) MarkerBaseAnnulusRectDistCB
+
+ # base
+ MarkerBaseAnnulusRectDialog $varname size Width Height
+}
diff --git a/ds9/library/bpanda.tcl b/ds9/library/bpanda.tcl
new file mode 100644
index 0000000..d7d6af8
--- /dev/null
+++ b/ds9/library/bpanda.tcl
@@ -0,0 +1,36 @@
+# 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 BpandaDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(which) bpanda
+ set var(proc,apply) MarkerBasePandaRectApply
+ set var(proc,close) MarkerBasePandaRectClose
+ set var(proc,generate) BpandaGenerate
+ set var(proc,coordCB) MarkerBasePandaRectCoordCB
+ set var(proc,editCB) MarkerBasePandaRectEditCB
+ set var(proc,distCB) MarkerBasePandaRectDistCB
+
+ # base panda rect dialog
+ MarkerBasePandaRectDialog $varname
+}
+
+proc BpandaGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseAnnulusGenerateBox $varname
+ MarkerBasePandaGenerateAngles $varname
+}
diff --git a/ds9/library/buttons.tcl b/ds9/library/buttons.tcl
new file mode 100644
index 0000000..d9af3a5
--- /dev/null
+++ b/ds9/library/buttons.tcl
@@ -0,0 +1,310 @@
+# 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 ButtonsDef {} {
+ global pbuttons
+
+ # TButtonBar class bindings
+ ttk::copyBindings TButton TButtonBar
+ bind TButtonBar <Enter> {}
+ bind TButtonBar <Leave> {}
+
+ ButtonsFileDef
+ ButtonsEditDef
+ ButtonsViewDef
+ ButtonsFrameDef
+ ButtonsBinDef
+ ButtonsZoomDef
+ ButtonsScaleDef
+ ButtonsColorDef
+ ButtonsRegionDef
+ ButtonsWCSDef
+ ButtonsAnalysisDef
+ ButtonsHelpDef
+}
+
+proc CreateButtons {} {
+ global ds9
+ global buttons
+
+ set ds9(buttons) [ttk::frame $ds9(main).buttons]
+ set ds9(buttons,sep) [ttk::separator $ds9(main).sbuttons -orient horizontal]
+
+ set buttons(majorPrev) $ds9(buttons).file
+ set buttons(majorCurrent) $ds9(buttons).file
+
+ ttk::frame $ds9(buttons).major
+ RadioButton $ds9(buttons).major.file \
+ [string tolower [msgcat::mc {File}]] \
+ buttons(majorCurrent) $ds9(buttons).file MajorButton
+ RadioButton $ds9(buttons).major.edit \
+ [string tolower [msgcat::mc {Edit}]] \
+ buttons(majorCurrent) $ds9(buttons).edit MajorButton
+ RadioButton $ds9(buttons).major.view \
+ [string tolower [msgcat::mc {View}]] \
+ buttons(majorCurrent) $ds9(buttons).view MajorButton
+ RadioButton $ds9(buttons).major.frame \
+ [string tolower [msgcat::mc {Frame}]] \
+ buttons(majorCurrent) $ds9(buttons).frame MajorButton
+ RadioButton $ds9(buttons).major.bin \
+ [string tolower [msgcat::mc {Bin}]] \
+ buttons(majorCurrent) $ds9(buttons).bin MajorButton
+ RadioButton $ds9(buttons).major.zoom \
+ [string tolower [msgcat::mc {Zoom}]] \
+ buttons(majorCurrent) $ds9(buttons).zoom MajorButton
+ RadioButton $ds9(buttons).major.scale \
+ [string tolower [msgcat::mc {Scale}]] \
+ buttons(majorCurrent) $ds9(buttons).scale MajorButton
+ RadioButton $ds9(buttons).major.color \
+ [string tolower [msgcat::mc {Color}]] \
+ buttons(majorCurrent) $ds9(buttons).color MajorButton
+ RadioButton $ds9(buttons).major.region \
+ [string tolower [msgcat::mc {Region}]] \
+ buttons(majorCurrent) $ds9(buttons).region MajorButton
+ RadioButton $ds9(buttons).major.wcs \
+ [string tolower [msgcat::mc {WCS}]] \
+ buttons(majorCurrent) $ds9(buttons).wcs MajorButton
+ RadioButton $ds9(buttons).major.analysis \
+ [string tolower [msgcat::mc {Analysis}]] \
+ buttons(majorCurrent) $ds9(buttons).analysis MajorButton
+ RadioButton $ds9(buttons).major.help \
+ [string tolower [msgcat::mc {Help}]] \
+ buttons(majorCurrent) $ds9(buttons).help MajorButton
+
+ global pbuttons
+ array set pbuttons {
+ major,file 1
+ major,edit 1
+ major,view 1
+ major,frame 1
+ major,bin 1
+ major,zoom 1
+ major,scale 1
+ major,color 1
+ major,region 1
+ major,wcs 1
+ major,analysis 1
+ major,help 1
+ }
+
+ set buttons(major) "
+ $ds9(buttons).major.file pbuttons(major,file)
+ $ds9(buttons).major.edit pbuttons(major,edit)
+ $ds9(buttons).major.view pbuttons(major,view)
+ $ds9(buttons).major.frame pbuttons(major,frame)
+ $ds9(buttons).major.bin pbuttons(major,bin)
+ $ds9(buttons).major.zoom pbuttons(major,zoom)
+ $ds9(buttons).major.scale pbuttons(major,scale)
+ $ds9(buttons).major.color pbuttons(major,color)
+ $ds9(buttons).major.region pbuttons(major,region)
+ $ds9(buttons).major.wcs pbuttons(major,wcs)
+ $ds9(buttons).major.analysis pbuttons(major,analysis)
+ $ds9(buttons).major.help pbuttons(major,help)
+ "
+ CreateButtonsFile
+ CreateButtonsEdit
+ CreateButtonsView
+ CreateButtonsFrame
+ CreateButtonsBin
+ CreateButtonsZoom
+ CreateButtonsScale
+ CreateButtonsColor
+ CreateButtonsRegion
+ CreateButtonsWCS
+ CreateButtonsAnalysis
+ CreateButtonsHelp
+
+ LayoutButtons
+}
+
+proc ButtonButton {button text cmd} {
+ ttk::button $button \
+ -class TButtonBar \
+ -text $text \
+ -command $cmd \
+ -width -1 \
+ -takefocus 0
+}
+
+proc RadioButton {button text varname value cmd} {
+ ttk::button $button \
+ -class TButtonBar \
+ -text $text \
+ -width -1 \
+ -takefocus 0 \
+ -command "RadioButtonSim $button $varname \{$value\} \{$cmd\}"
+
+ # setup trace on $varname, so that all buttons that use this variable
+ # will be updated when the variable is changed
+ uplevel #0 trace variable $varname w \
+ [list "RadioButtonCB $button \{$value\}"]
+
+ # setup <Map> event so that anytime the button is redrawn,
+ # it is updated
+ bind $button <Map> "ButtonMap %W $varname"
+}
+
+proc CheckButton {button text varname cmd} {
+ ttk::button $button \
+ -class TButtonBar \
+ -text $text \
+ -width -1 \
+ -takefocus 0 \
+ -command "CheckButtonSim $button $varname \{$cmd\}"
+
+ uplevel #0 trace variable $varname w [list "CheckButtonCB $button"]
+
+ bind $button <Map> "ButtonMap %W $varname"
+}
+
+proc ButtonMap {button varname} {
+ upvar #0 $varname var
+ set vv $var
+
+ # delay slightly, I don't know why this is needed
+ after 10 [list set $varname $vv]
+}
+
+proc RadioButtonSim {button varname value cmd} {
+ uplevel #0 [list set $varname $value]
+ eval $cmd
+}
+
+proc RadioButtonCB {button value varname id op} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ if {[$button cget -state] != {disabled}} {
+ switch $ds9(wm) {
+ x11 {
+ if {$var($id) == $value} {
+ $button configure -state active
+ } else {
+ $button configure -state normal
+ }
+ }
+ aqua -
+ win32 {
+ if {$var($id) == $value} {
+ $button configure -default active
+ } else {
+ $button configure -default normal
+ }
+ }
+ }
+ }
+}
+
+proc CheckButtonSim {button varname cmd} {
+ upvar #0 $varname var
+ uplevel #0 [list set $varname [expr !$var]]
+ eval $cmd
+}
+
+proc CheckButtonCB {button varname id op} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ if {[$button cget -state] != {disabled}} {
+ switch $ds9(wm) {
+ x11 {
+ if {$var($id)} {
+ $button configure -state active
+ } else {
+ $button configure -state normal
+ }
+ }
+ aqua -
+ win32 {
+ if {$var($id)} {
+ $button configure -default active
+ } else {
+ $button configure -default normal
+ }
+ }
+ }
+ }
+}
+
+proc LayoutButtons {} {
+ global ds9
+ global buttons
+ global view
+
+ pack forget $ds9(buttons).major
+ switch $view(layout) {
+ horizontal {
+ $ds9(buttons) configure -width 0
+ pack propagate $ds9(buttons) on
+ pack $ds9(buttons).major -side top -fill x -expand true
+ }
+ vertical {
+ $ds9(buttons) configure -width 125
+ pack propagate $ds9(buttons) off
+ pack $ds9(buttons).major -side top -fill x -expand true -anchor n
+ }
+ }
+
+ UpdateButtons buttons(major)
+ UpdateButtons buttons(file)
+ UpdateButtons buttons(edit)
+ UpdateButtons buttons(view)
+ UpdateButtons buttons(frame)
+ UpdateButtons buttons(bin)
+ UpdateButtons buttons(zoom)
+ UpdateButtons buttons(scale)
+ UpdateButtons buttons(color)
+ UpdateButtons buttons(region)
+ UpdateButtons buttons(wcs)
+ UpdateButtons buttons(analysis)
+ UpdateButtons buttons(help)
+
+ MajorButton
+}
+
+proc MajorButton {} {
+ global buttons
+ global view
+
+ pack forget $buttons(majorPrev)
+ switch $view(layout) {
+ horizontal {
+ pack $buttons(majorCurrent) -side top -fill x -expand true
+ }
+ vertical {
+ pack $buttons(majorCurrent) -side bottom -fill x -expand true -anchor s
+ }
+ }
+ set buttons(majorPrev) $buttons(majorCurrent)
+}
+
+proc UpdateButtons {varname} {
+ upvar #0 $varname var
+
+ foreach {which what} $var {
+ pack forget $which
+ }
+ foreach {which what} $var {
+ ShowButton $which $what
+ }
+}
+
+proc ShowButton {which varname} {
+ upvar #0 $varname var
+ global view
+
+ if {$var} {
+ switch $view(layout) {
+ horizontal {pack $which -side left -fill both -expand true}
+ vertical {pack $which -side top -fill both -expand true}
+ }
+ }
+}
+
diff --git a/ds9/library/cat.tcl b/ds9/library/cat.tcl
new file mode 100644
index 0000000..e3b748b
--- /dev/null
+++ b/ds9/library/cat.tcl
@@ -0,0 +1,1799 @@
+# 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 CATDef {} {
+ global cat
+ global icat
+ global pcat
+ global wcs
+
+ set icat(cats) {}
+
+ set icat(rformat) arcmin
+ set icat(width) 15
+ set icat(height) 15
+ set icat(max) 5000
+ set icat(allrows) 1
+ set icat(allcols) 0
+ set icat(show) 1
+ set icat(edit) 0
+ set icat(panto) 1
+
+ set icat(minrows) 20
+ set icat(mincols) 10
+
+ set icat(key) {}
+ set icat(key,update) {}
+
+ set icat(match1) {}
+ set icat(match2) {}
+ set icat(return) 1and2
+ set icat(error) 5
+ set icat(eformat) arcsec
+ set icat(function) 1and2
+ set icat(unique) 1
+
+ set icat(def) { \
+ {- {Database} db} \
+ {{NED} catned ned ned} \
+ {{SIMBAD} catsimbad simbad simbad} \
+ {{DENIS} catdenis cds {B/denis}} \
+ {{SkyBot} catskybot skybot skybot} \
+ {- {Optical} opt} \
+ {{ASCC-2.5} catascss cds {I/280A/ascc01}} \
+ {{AAVSO} cataavso cds {B/vsx}} \
+ {{Carlsberg Meridian 14} catcmc cds {I/304}}\
+ {{GSC 1.2} catgsc1 cds {I/254/out}} \
+ {{GSC 2.2} catgsc2 cds {I/271/out}} \
+ {{GSC 2.3} catgsc3 cds {I/305/out}} \
+ {{AC 2000.2} catac cds {I/275/ac2002}} \
+ {{NOMAD} catnomad cds {I/297/out}} \
+ {{PPMX} catppmx cds {I/312}} \
+ {{SAO J2000} catsao cds {I/131A/sao}} \
+ {{SDSS Release 5} catsdss5 cds {II/276}} \
+ {{SDSS Release 6} catsdss6 cds {II/282}} \
+ {{SDSS Release 7} catsdss7 cds {II/294}} \
+ {{SDSS Release 8} catsdss8 cds {II/306}} \
+ {{SDSS Release 9} catsdss9 cds {V/139}} \
+ {{Tycho-2} cattycho cds {I/259/tyc2}} \
+ {{USNO-A2.0} catua2 cds {I/252/out}} \
+ {{USNO-B1.0} catub1 cds {I/284/out}} \
+ {{USNO UCAC2} catucac2 cds {I/289/out}} \
+ {{USNO UCAC2 Bright Star Sup} catucac2sup cds {I/294A}} \
+ {{USNO UCAC3} catucac3 cds {I/315}} \
+ {{USNO UCAC4} catucac4 cds {I/322A}} \
+ {{USNO URAT1} caturat1 cds {I/329}} \
+ {- {Infrared} ir} \
+ {{2MASS Point Sources} cat2mass cds {II/246/out}}\
+ {{IRAS Point Sources} catiras cds {II/125}}\
+ {- {High Energy} hea} \
+ {{Chandra Source} catcsc cxc {Current Release}}
+ {{2XMMi Source} catxmm cds {IX/40/xmm2is}} \
+ {{Second ROSAT PSPC} catrosat cds {IX/30}} \
+ {- {Radio} radio} \
+ {{FIRST Survey} catfirst cds {VIII/71/first}} \
+ {{NVSS} catnvss cds {VIII/65/nvss}} \
+ {- {Observation Logs} log} \
+ {{Chandra Archive} catchandralog cds {B/chandra/chandra}} \
+ {{CFHT Exposures} catcfhtlog cds {B/cfht/chfht}} \
+ {{ESO Science Archive} catesolog cds {B/eso/safcat}} \
+ {{HST Archive} cathstlog cds {B/hst/hstlog}} \
+ {{XMM Observation} catxmmlog cds {B/xmm/xmmlog}} \
+ }
+
+ set cat(id) 0
+ set cat(sym,font,msg) {}
+
+ # prefs only
+ set pcat(server) cds
+ set pcat(loc) 500
+ set pcat(sym,shape) {circle point}
+ set pcat(sym,color) green
+ set pcat(sym,width) 1
+ set pcat(sym,dash) 0
+ set pcat(sym,units) physical
+ set pcat(sym,font) helvetica
+ set pcat(sym,font,size) 10
+ set pcat(sym,font,weight) normal
+ set pcat(sym,font,slant) roman
+ set pcat(vot) 1
+}
+
+# Load via HTTP
+
+proc CATGetURL {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGetURL $varname $var(url)?$var(query)"
+ }
+
+ ARStatus $varname [msgcat::mc {Loading}]
+
+ global ihttp
+ if {$var(sync)} {
+ if {![catch {set var(token) [http::geturl $var(url) \
+ -query $var(query) \
+ -timeout $ihttp(timeout) \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ CATGetURLFinish $varname $var(token)
+ } else {
+ ARError $varname "[msgcat::mc {Unable to locate URL}] $var(url)"
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $var(url) \
+ -query $var(query) \
+ -timeout $ihttp(timeout) \
+ -command \
+ [list CATGetURLFinish $varname] \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ } else {
+ ARError $varname "[msgcat::mc {Unable to locate URL}] $var(url)"
+ }
+ }
+}
+
+proc CATGetURLIncr {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGetURLIncr $varname $var(url)?$var(query)"
+ }
+
+ ARStatus $varname [msgcat::mc {Loading}]
+
+ global ihttp
+ if {$var(sync)} {
+ if {![catch {set var(token) [http::geturl $var(url) \
+ -query $var(query) \
+ -timeout $ihttp(timeout) \
+ -handler \
+ [list $var(proc,reader) $var(catdb)] \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ CATGetURLFinish $varname $var(token)
+ } else {
+ ARError $varname "[msgcat::mc {Unable to locate URL}] $var(url)"
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $var(url) \
+ -query $var(query) \
+ -timeout $ihttp(timeout) \
+ -handler \
+ [list $var(proc,reader) $var(catdb)] \
+ -command \
+ [list CATGetURLFinish $varname] \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ } else {
+ ARError $varname "[msgcat::mc {Unable to locate URL}] $var(url)"
+ }
+ }
+}
+
+proc CATGetURLFinish {varname token} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGetURLFinish $varname"
+ }
+
+ if {!($var(active))} {
+ ARCancelled $varname
+ return
+ }
+
+ upvar #0 $token t
+
+ # Code
+ set code [http::ncode $token]
+
+ # Meta
+ set meta $t(meta)
+
+ # Log it
+ HTTPLog $token
+
+ # Result?
+ switch -- $code {
+ {} -
+ 200 -
+ 203 -
+ 404 -
+ 503 {
+ if {[info exist ${varname}(proc,parser)]} {
+ eval [list $var(proc,parser) $var(catdb) $token]
+ }
+
+ ARDone $varname
+ eval $var(proc,done) $varname
+ }
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $meta {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGetURLFinish redirect $code to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset var(token)
+
+ set var(url) $value
+ eval $var(proc,load) $varname
+ }
+ }
+ }
+
+ default {ARError $varname "[msgcat::mc {Error code was returned}] $code"}
+ }
+}
+
+proc CATLoad {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # clear previous db
+ global $var(catdb)
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATLoad $varname $var(url)?$var(query)"
+ }
+
+ set var(proc,done) CATLoadDone
+ set var(proc,load) CATLoad
+ CATGetURL $varname
+ return
+}
+
+proc CATLoadIncr {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # clear previous db
+ global $var(catdb)
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATLoadIncr $varname $var(url)?$var(query)"
+ }
+
+ set var(proc,done) CATLoadDone
+ set var(proc,load) CATLoadIncr
+ CATGetURLIncr $varname
+ return
+}
+
+proc CATLoadDone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATLoadDone $varname"
+ }
+
+ CATSortMenu $varname
+ CATConfigCols $varname
+ CATColsMenu $varname
+ CATTable $varname
+
+ CATDialogUpdate $varname
+}
+
+# Load via File
+
+proc CATLoadSBFile {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set fn [OpenFileDialog catfbox]
+ if {$fn != {}} {
+ CATLoadFn $varname $fn starbase_read
+ }
+}
+
+proc CATLoadVOTFile {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set fn [OpenFileDialog catvotfbox]
+ if {$fn != {}} {
+ CATLoadFn $varname $fn VOTRead
+ }
+}
+
+proc CATLoadTSVFile {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set fn [OpenFileDialog cattsvfbox]
+ if {$fn != {}} {
+ CATLoadFn $varname $fn TSVRead
+ }
+}
+
+# used by backup
+proc CATLoadFn {varname fn reader} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATLoadFn $varname $fn $reader"
+ }
+
+ ARStatus $varname [msgcat::mc {Loading Catalog}]
+
+ CATOff $varname
+ CATSet $varname {} {} $fn
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(width) {}
+ set var(height) {}
+
+ if {[file exists $fn]} {
+ $reader $var(catdb) $fn
+ } else {
+ Error "[msgcat::mc {Unable to open file}] $fn"
+ return
+ }
+
+ ARDone $varname
+ CATLoadDone $varname
+}
+
+# Save via File
+
+proc CATSaveSBFile {varname} {
+ set fn [SaveFileDialog catfbox]
+ CATSaveFn $varname $fn starbase_write
+}
+
+proc CATSaveVOTFile {varname} {
+ set fn [SaveFileDialog catvotfbox]
+ CATSaveFn $varname $fn VOTWrite
+}
+
+proc CATSaveTSVFile {varname} {
+ set fn [SaveFileDialog cattsvfbox]
+ CATSaveFn $varname $fn TSVWrite
+}
+
+proc CATSaveFn {varname fn writer} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ if {$fn == {}} {
+ return
+ }
+
+ # do we have a db?
+ if {![CATValidDB $var(tbldb)]} {
+ return
+ }
+
+ $writer $var(tbldb) $fn
+ ARDone $varname
+}
+
+# Other procedures
+
+proc CATStatusRows {varname rowlist} {
+ upvar #0 $varname var
+ global $varname
+
+ # rowlist start at 1
+ if {[llength $rowlist]>0} {
+ ARStatus $varname "[msgcat::mc {Row}] [join $rowlist {,}]"
+ } else {
+ ARStatus $varname {}
+ }
+}
+
+proc CATOff {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global $var(catdb)
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+ global $var(tbldb)
+ if {[info exists $var(tbldb)]} {
+ unset $var(tbldb)
+ }
+ set db $var(tbldb)
+ set ${db}(Nrows) {}
+
+ $var(tbl) selection clear all
+
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ $var(frame) marker catalog $varname delete
+ }
+ }
+
+ CATSortMenu $varname
+ CATColsMenu $varname
+ set var(filter) {}
+ set var(sort) {}
+ set var(colx) {}
+ set var(coly) {}
+
+ set var(blink) 0
+
+ # plot window?
+ if {$var(plot)} {
+ PlotDestroy $var(plot,var)
+ set var(plot) 0
+ set var(plot,var) {}
+ set var(plot,x) {}
+ set var(plot,xerr) {}
+ set var(plot,y) {}
+ set var(plot,yerr) {}
+ }
+
+ CATDialogUpdate $varname
+}
+
+# used by backup
+proc CATTable {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ global icat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATTable $varname"
+ }
+
+ if {![CATValidDB $var(catdb)]} {
+ return
+ }
+
+ # delete any previous tbldb
+ set db ${varname}tbldb
+ global $db
+ if {[info exists $db]} {
+ unset $db
+ }
+
+ # clear the selection
+ $var(tbl) selection clear all
+
+ # clear regions
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ $var(frame) marker catalog $varname delete
+ }
+ }
+
+ if {$var(filter) == {} && $var(sort) == {}} {
+ set var(tbldb) $var(catdb)
+ } else {
+ set var(tbldb) ${varname}tbldb
+ global $var(tbldb)
+ if {![CATFltSort $varname]} {
+ Error "[msgcat::mc {Unable to evaluate filter}] $var(filter)"
+ if {[info exists $var(tbldb)]} {
+ unset $var(tbldb)
+ }
+ set var(tbldb) $var(catdb)
+ }
+ }
+
+ global $var(tbldb)
+ $var(tbl) configure -variable $var(tbldb)
+ $var(found) configure -textvariable ${var(tbldb)}(Nrows)
+
+# starbase_writefp $var(catdb) stdout
+# starbase_writefp $var(tbldb) stdout
+
+ if {[starbase_nrows $var(tbldb)] == 0} {
+ ARStatus $varname [msgcat::mc {No Items Found}]
+ return
+ }
+
+ set nc [starbase_ncols $var(tbldb)]
+ if { $nc > $icat(mincols)} {
+ $var(tbl) configure -cols $nc
+ } else {
+ $var(tbl) configure -cols $icat(mincols)
+ }
+
+ # add header
+ set nr [expr [starbase_nrows $var(tbldb)]+1]
+ if {$nr > $icat(minrows)} {
+ $var(tbl) configure -rows $nr
+ } else {
+ $var(tbl) configure -rows $icat(minrows)
+ }
+
+ CATGenerate $varname
+
+ # regenerate the plot if needed
+ if {$var(plot)} {
+ CATPlotGenerate $varname
+ }
+
+ set nr [starbase_nrows $var(tbldb)]
+ if {$nr >= $var(max) && !$var(allrows)} {
+ ARStatus $varname "$nr [msgcat::mc {rows of data have been downloaded. More may be available. You may wish to adjust the maximum allowed}]"
+ }
+}
+
+proc CATGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGenerate $varname"
+ }
+
+ # do we have a db?
+ if {![CATValidDB $var(tbldb)]} {
+ return
+ }
+
+ ARStatus $varname [msgcat::mc {Plotting Regions}]
+
+ # delete any previous
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ $var(frame) marker catalog $varname delete
+ }
+ }
+
+ if {$var(show)} {
+ global reg
+ set reg {}
+ CATReg $varname {} 1 reg
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ if {[catch {$var(frame) marker catalog command ds9 var reg}]} {
+ ARError $varname "[msgcat::mc {Internal Parse Error}]"
+ return
+ }
+ }
+ }
+ }
+
+ ARStatus $varname [msgcat::mc Done]
+}
+
+proc CATGenerateRegions {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGenerateRegions $varname"
+ }
+
+ # do we have a db?
+ if {![CATValidDB $var(tbldb)]} {
+ return
+ }
+
+ ARStatus $varname [msgcat::mc {Generating Regions}]
+
+ global reg
+ set reg {}
+ CATReg $varname {} 0 reg
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ if {[catch {$var(frame) marker command ds9 var reg}]} {
+ ARError $varname "[msgcat::mc {Internal Parse Error}]"
+ return
+ }
+ }
+ }
+
+ ARStatus $varname [msgcat::mc Done]
+}
+
+proc CATGenerateUpdate {varname row} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATGenerateUpdate $varname $row"
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ set id [$var(frame) get marker catalog "\{${varname}.${row}\}" id]
+ set sel [$var(frame) get marker catalog $id select]
+ set hh [$var(frame) get marker catalog $id highlite]
+
+ $var(frame) marker catalog "\{${varname}.${row}\}" delete
+ global reg
+ set reg {}
+ CATReg $varname $row 1 reg
+ if {$reg != {}} {
+ $var(frame) marker catalog command ds9 var reg
+
+ set id [$var(frame) get marker catalog "\{${varname}.${row}\}" id]
+ if {$sel} {
+ $var(frame) marker catalog "\{${varname}.${row}\}" select
+ }
+ if {$hh} {
+ $var(frame) marker catalog "\{${varname}.${row}\}" highlite
+ }
+ }
+ unset reg
+}
+
+proc CATSet {varname format catalog title} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSet $varname :$format:$catalog:$title:"
+ }
+
+ set var(format) $format
+ set var(catalog) $catalog
+ set var(title) $title
+ set var(filter) {}
+ set var(colx) {}
+ set var(coly) {}
+ set var(sort) {}
+ set var(sort,dir) "-increasing"
+}
+
+proc CATValidDB {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[info exists var(Nrows)] &&
+ [info exists var(Ncols)] &&
+ [info exists var(HLines)] &&
+ [info exists var(Header)]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc CATAnalysisMenu {} {
+ global icat
+ global ds9
+
+ set mm "$ds9(mb).analysis.cat"
+ set nn {}
+
+ foreach ff $icat(def) {
+ set ll [lindex $ff 0]
+ set ww [lindex $ff 1]
+ set ss [lindex $ff 2]
+ set cc [lindex $ff 3]
+
+ if {$ll != {-}} {
+ $mm.$nn add command -label $ll \
+ -command [list CATDialog $ww $ss $cc $ll apply]
+ } else {
+ set nn "$ss"
+ menu $mm.$nn
+ $mm add cascade -label $ww -menu $mm.$nn
+ }
+ }
+}
+
+proc CATServerMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(mb) add cascade -label [msgcat::mc {Catalog Server}] \
+ -menu $var(mb).server
+ menu $var(mb).server
+ $var(mb).server add radiobutton -label {CDS, Strasbourg France} \
+ -variable ${varname}(server) -value cds
+ $var(mb).server add radiobutton -label {CFA, Boston USA} \
+ -variable ${varname}(server) -value sao
+ $var(mb).server add radiobutton -label {CADC, Canada} \
+ -variable ${varname}(server) -value cadc
+ $var(mb).server add radiobutton -label {ADAC, Tokyo Japan} \
+ -variable ${varname}(server) -value adac
+ $var(mb).server add radiobutton -label {IUCAA, Pune India} \
+ -variable ${varname}(server) -value iucaa
+ $var(mb).server add radiobutton -label {INASAN, Russia} \
+ -variable ${varname}(server) -value inasan
+ $var(mb).server add radiobutton -label {BEJING, China} \
+ -variable ${varname}(server) -value bejing
+ $var(mb).server add radiobutton -label {CAMBRIDGE, UK} \
+ -variable ${varname}(server) -value cambridge
+ $var(mb).server add radiobutton -label {UKIRT, Hawaii USA} \
+ -variable ${varname}(server) -value ukirt
+}
+
+proc CATSortMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global ds9
+
+ set m $var(sortmenu).menu
+ catch {destroy $m}
+
+ menu $m -tearoff 0
+ $m add command -label {} -command "CATSortCmd $varname {}"
+ if {[CATValidDB $var(catdb)]} {
+ set cnt -1
+ foreach col [starbase_columns $var(catdb)] {
+ $m add command -label $col -command "CATSortCmd $varname \{$col\}"
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 0
+ $m entryconfig $col -columnbreak 1
+ }
+ }
+ }
+}
+
+proc CATSortCmd {varname val} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(sort) $val
+ CATTable $varname
+}
+
+# backward backup compatibility version 6.1
+proc CATRADECMenu {varname} {
+ CATColsMenu $varname
+}
+
+# used by backup
+proc CATColsMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global ds9
+
+ set m $var(ramenu).menu
+ catch {destroy $m}
+
+ menu $m -tearoff 0
+ if {[CATValidDB $var(catdb)]} {
+ set cnt -1
+ foreach col [starbase_columns $var(catdb)] {
+ $m add command -label $col -command "CATColXCmd $varname \{$col\}"
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 0
+ $m entryconfig $col -columnbreak 1
+ }
+ }
+ }
+
+ set m $var(decmenu).menu
+ catch {destroy $m}
+
+ menu $m -tearoff 0
+ if {[CATValidDB $var(catdb)]} {
+ set cnt -1
+ foreach col [starbase_columns $var(catdb)] {
+ $m add command -label $col -command "CATColYCmd $varname \{$col\}"
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 0
+ $m entryconfig $col -columnbreak 1
+ }
+ }
+ }
+}
+
+proc CATColXCmd {varname val} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(colx) $val
+ CATGenerate $varname
+}
+
+proc CATColYCmd {varname val} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(coly) $val
+ CATGenerate $varname
+}
+
+proc CATColsCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ CATColsUpdate $varname
+ CATGenerate $varname
+}
+
+proc CATConfigCols {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ set var(colx) {}
+ set var(coly) {}
+
+ if {![CATValidDB $var(catdb)]} {
+ return
+ }
+
+ if {[starbase_ncols $var(catdb)] < 2} {
+ return
+ }
+
+ # determine psystem/psky if present in cat header
+ # psystem has already been adjusted based on loaded fits at menu creation
+ switch -- $var(psystem) {
+ image -
+ physical -
+ amplifier -
+ detector {
+ set cols {
+ "X" "Y"
+ }
+ foreach {colx coly} $cols {
+ if {!([lsearch [starbase_columns $var(catdb)] $colx] == -1) &&
+ !([lsearch [starbase_columns $var(catdb)] $coly] == -1)} {
+ set var(colx) $colx
+ set var(coly) $coly
+ return
+ }
+
+ # try lower case
+ set colx [string tolower $colx]
+ set coly [string tolower $coly]
+ if {!([lsearch [starbase_columns $var(catdb)] $colx] == -1) &&
+ !([lsearch [starbase_columns $var(catdb)] $coly] == -1)} {
+ set var(colx) $colx
+ set var(coly) $coly
+ return
+ }
+ }
+
+ # default
+ set var(colx) [starbase_colname $var(catdb) 1]
+ set var(coly) [starbase_colname $var(catdb) 2]
+
+ return
+ }
+ default {
+ if {[info commands $var(frame)] == {}} {
+ # linear
+ set var(colx) [starbase_colname $var(catdb) 1]
+ set var(coly) [starbase_colname $var(catdb) 2]
+
+ return
+ } elseif {![$var(frame) has wcs equatorial $var(psystem)]} {
+ # linear
+ set var(colx) [starbase_colname $var(catdb) 1]
+ set var(coly) [starbase_colname $var(catdb) 2]
+
+ return
+ } else {
+ if {![catch {starbase_hdrget $var(catdb) equinox} sys]} {
+ switch -- $sys {
+ 1950.0 -
+ B1950 {
+ set var(psystem) wcs
+ set var(psky) fk4
+ }
+ 2000.0 -
+ J2000 {
+ set var(psystem) wcs
+ set var(psky) fk5
+ }
+ }
+ }
+
+ switch -- $var(psky) {
+ fk5 -
+ icrs {
+ set cols {
+ "_RAJ2000" "_DEJ2000"
+ "_RAJ2000" "_DECJ2000"
+ "RAJ2000" "DEJ2000"
+ "RAJ2000" "DECJ2000"
+ "RA_J2000" "DE_J2000"
+ "RA_J2000" "DEC_J2000"
+ "RA (J2000)" "Dec (J2000)"
+ "RA" "DEC"
+ "RA" "DECL"
+ "RA" "Dec"
+ "RA(deg)" "DEC(deg)"
+ }
+ if {[CATConfigColsSearch $varname $cols]} {
+ return
+ }
+
+ # next, look for an UCD (via VOTABLE)
+ set db $var(catdb)
+ upvar #0 $db T
+ for {set cc 0} {$cc < $T(Ncols)} {incr cc} {
+ if {[info exists ${db}(Ucd)]} {
+ switch -- [string tolower [string range [lindex $T(Ucd) $cc] 0 8]] {
+ pos.eq.ra {set var(colx) [lindex $T(Header) $cc]}
+ pos.eq.de {set var(coly) [lindex $T(Header) $cc]}
+ }
+ }
+ }
+
+ if {$var(colx) != {} && $var(coly) != {}} {
+ return
+ }
+ }
+ fk4 {
+ set cols {
+ "_RAB1950" "_DEB1950"
+ "RA_B1950" "DEC_B1950"
+ "RA (B1950)" "Dec (1950)"
+ "RA" "DEC"
+ "RA" "DECL"
+ "RA" "Dec"
+ "RA(deg)" "DEC(deg)"
+ }
+ if {[CATConfigColsSearch $varname $cols]} {
+ return
+ }
+ }
+ galactic {
+ set cols {
+ "_GLON" "_GLAT"
+ "LON" "LAT"
+ "LON.Gal(deg)" "LAT.Gal(deg)"
+ }
+ if {[CATConfigColsSearch $varname $cols]} {
+ return
+ }
+ }
+ ecliptic {
+ set cols {
+ "_ELON" "_ELAT"
+ "LON.Ecl(deg)" "LAT.Ecl(deg)"
+ }
+ if {[CATConfigColsSearch $varname $cols]} {
+ return
+ }
+ }
+ }
+
+ # default
+ set var(colx) [starbase_colname $var(catdb) 1]
+ set var(coly) [starbase_colname $var(catdb) 2]
+ }
+ }
+ }
+}
+
+proc CATConfigColsSearch {varname cols} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ foreach {colx coly} $cols {
+ if {!([lsearch [starbase_columns $var(catdb)] $colx] == -1) &&
+ !([lsearch [starbase_columns $var(catdb)] $coly] == -1)} {
+ set var(colx) $colx
+ set var(coly) $coly
+ return 1
+ }
+
+ # try lower case
+ set colx [string tolower $colx]
+ set coly [string tolower $coly]
+ if {!([lsearch [starbase_columns $var(catdb)] $colx] == -1) &&
+ !([lsearch [starbase_columns $var(catdb)] $coly] == -1)} {
+ set var(colx) $colx
+ set var(coly) $coly
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# Other interface
+
+proc CATTool {} {
+ CATDialog cattool {} {} [msgcat::mc {Catalog Tool}] none
+}
+
+proc CATClearFrame {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker catalog delete all
+ }
+}
+
+proc CATUpdateWCS {} {
+ global icat
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker catalog delete all
+
+ foreach varname $icat(cats) {
+ upvar #0 $varname var
+ global $varname
+
+ CATGenerate $varname
+
+ # regenerate the plot if needed
+ if {$var(plot)} {
+ CATPlotGenerate $varname
+ }
+ }
+ }
+}
+
+proc CATUpdateFont {} {
+ global icat
+
+ foreach varname $icat(cats) {
+ upvar #0 $varname var
+ global $varname
+
+ $var(tbl) configure -font [font actual TkDefaultFont]
+ }
+}
+
+proc CATBackup {ch which fdir rdir} {
+ global icat
+
+ foreach varname $icat(cats) {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(frame) == $which} {
+ set catdb ${varname}catdb
+ global $catdb
+
+ puts $ch "CATDialog $varname {} {} {} none"
+ if {[starbase_nrows $var(catdb)]>500} {
+ # external file
+ set fn $fdir/${varname}.cat
+ set rfn $rdir/${varname}.cat
+
+ catch {file delete -force $fn}
+ CATSaveFn $varname "$fn" VOTWrite
+ puts $ch "CATLoadFn $varname \"$rfn\" VOTRead"
+ } else {
+ # internal var
+ puts $ch "global $catdb"
+ puts $ch "array set $catdb \{ [array get $catdb] \}"
+ }
+ puts $ch "global $varname"
+ puts $ch "array set $varname \{ [array get $varname] \}"
+
+ set symdb ${varname}symdb
+ global $symdb
+ puts $ch "global $symdb"
+ puts $ch "array set $symdb \{ [array get $symdb] \}"
+
+ puts $ch "CATColsMenu $varname"
+ puts $ch "CATTable $varname"
+ }
+ }
+}
+
+proc PrefsDialogCatalog {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Catalogs}]
+ lappend dprefs(tabs) [ttk::frame $w.cat]
+
+ # Catalog
+ set f [ttk::labelframe $w.cat.param -text [msgcat::mc {Catalogs}]]
+
+ ttk::label $f.stitle -text [msgcat::mc {Server}]
+ ttk::menubutton $f.svr -textvariable pcat(server) -menu $f.svr.menu
+ ttk::label $f.shtitle -text [msgcat::mc {Shape}]
+ ttk::menubutton $f.shape -textvariable pcat(sym,shape) -menu $f.shape.menu
+ ttk::checkbutton $f.vot -variable pcat(vot) \
+ -text [msgcat::mc {Download VOTABLE format if available}]
+ ttk::label $f.loctitle -text [msgcat::mc {IAU Location Code}]
+ ttk::entry $f.loc -textvariable pcat(loc) -width 7
+
+ global pcat
+ ttk::label $f.ctitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color pcat sym,color {}
+
+ ttk::label $f.cwidth -text [msgcat::mc {Width}]
+ WidthDashMenuButton $f.width pcat sym,width sym,dash {} {}
+
+ ttk::label $f.ftitle -text [msgcat::mc {Font}]
+ FontMenuButton $f.font pcat sym,font sym,font,size \
+ sym,font,weight, sym,font,slant {}
+
+ menu $f.svr.menu
+ $f.svr.menu add radiobutton -label {CDS} \
+ -variable pcat(server) -value cds
+ $f.svr.menu add radiobutton -label {SAO} \
+ -variable pcat(server) -value sao
+ $f.svr.menu add radiobutton -label {CADC} \
+ -variable pcat(server) -value cadc
+ $f.svr.menu add radiobutton -label {ADAC} \
+ -variable pcat(server) -value adac
+ $f.svr.menu add radiobutton -label {IUCAA} \
+ -variable pcat(server) -value iucaa
+ $f.svr.menu add radiobutton -label {BEJING} \
+ -variable pcat(server) -value bejing
+ $f.svr.menu add radiobutton -label {CAMBRIDGE UK} \
+ -variable pcat(server) -value cambridge
+ $f.svr.menu add radiobutton -label {UKIRT HAWAII} \
+ -variable pcat(server) -value ukirt
+
+ menu $f.shape.menu
+ $f.shape.menu add radiobutton -label [msgcat::mc {Circle}] \
+ -variable pcat(sym,shape) -value circle
+ $f.shape.menu add radiobutton -label [msgcat::mc {Ellipse}] \
+ -variable pcat(sym,shape) -value ellipse
+ $f.shape.menu add radiobutton -label [msgcat::mc {Box}] \
+ -variable pcat(sym,shape) -value box
+ $f.shape.menu add radiobutton -label [msgcat::mc {Text}] \
+ -variable pcat(sym,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 pcat(sym,shape) -value {circle point}
+ $f.shape.menu.point add radiobutton -label [msgcat::mc {Box}] \
+ -variable pcat(sym,shape) -value {box point}
+ $f.shape.menu.point add radiobutton -label [msgcat::mc {Diamond}] \
+ -variable pcat(sym,shape) -value {diamond point}
+ $f.shape.menu.point add radiobutton -label [msgcat::mc {Cross}] \
+ -variable pcat(sym,shape) -value {cross point}
+ $f.shape.menu.point add radiobutton -label [msgcat::mc {X}] \
+ -variable pcat(sym,shape) -value {x point}
+ $f.shape.menu.point add radiobutton -label [msgcat::mc {Arrow}] \
+ -variable pcat(sym,shape) -value {arrow point}
+ $f.shape.menu.point add radiobutton -label [msgcat::mc {BoxCircle}] \
+ -variable pcat(sym,shape) -value {boxcircle point}
+ $f.shape.menu.point add separator
+
+ grid $f.stitle $f.svr -padx 2 -pady 2 -sticky w
+ grid $f.shtitle $f.shape -padx 2 -pady 2 -sticky w
+ grid $f.ctitle $f.color -padx 2 -pady 2 -sticky w
+ grid $f.cwidth $f.width -padx 2 -pady 2 -sticky w
+ grid $f.ftitle $f.font -padx 2 -pady 2 -sticky w
+ grid $f.loctitle - - $f.loc -padx 2 -pady 2 -sticky w
+ grid $f.vot - - - -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+# Process Cmds
+
+proc ProcessCatalogCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global icat
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ {} {CATTool}
+
+ file -
+ import -
+ load {
+ incr i
+ set reader VOTRead
+ switch -- [lindex $var $i] {
+ xml -
+ vot {incr i; set reader VOTRead}
+ sb -
+ starbase {incr i; set reader starbase_read}
+ csv -
+ tsv {incr i; set reader TSVRead}
+ }
+
+ set fn [lindex $var $i]
+ if {$fn != {}} {
+ CATDialog cattool {} {} {} none
+ CATLoadFn [lindex $icat(cats) end] $fn $reader
+ FileLast catfbox $fn
+ }
+ }
+
+ allcols -
+ allrows -
+ cancel -
+ clear -
+ close -
+ coordinate -
+ crosshair -
+ dec -
+ edit -
+ export -
+ filter -
+ header -
+ hide -
+ location -
+ match -
+ maxrows -
+ name -
+ panto -
+ plot -
+ print -
+ psky -
+ psystem -
+ ra -
+ regions -
+ retrieve -
+ samp -
+ save -
+ server -
+ show -
+ size -
+ sky -
+ skyformat -
+ sort -
+ symbol -
+ system -
+ update -
+ x -
+ y {ProcessCatalog $varname $iname [lindex $icat(cats) end]}
+
+ default {
+ # another command
+ if {[string range $item 0 0] == "-"} {
+ CATTool
+ incr i -1
+ return
+ }
+
+ # existing cat or load new one?
+ set ref $item
+
+ # backward compatibility
+ if {[string range $ref 0 2] == {cat}} {
+ set ref [string range $ref 3 end]
+ }
+
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ file -
+ import -
+ load {incr i -1}
+
+ allcols -
+ allrows -
+ cancel -
+ clear -
+ close -
+ coordinate -
+ crosshair -
+ dec -
+ edit -
+ export -
+ filter -
+ header -
+ hide -
+ location -
+ match -
+ maxrows -
+ name -
+ panto -
+ plot -
+ print -
+ psky -
+ psystem -
+ ra -
+ regions -
+ retrieve -
+ samp -
+ save -
+ server -
+ show -
+ size -
+ sky -
+ skyformat -
+ sort -
+ symbol -
+ system -
+ update -
+ x -
+ y {ProcessCatalog $varname $iname cat${ref}}
+
+ default {
+ # ok, new catalog
+ incr i -1
+ set item [string tolower [lindex $var $i]]
+
+ # backward compatibility
+ switch $item {
+ cds {incr i; set item [string tolower [lindex $var $i]]}
+ cxc {set item csc}
+ }
+
+ # see if its from our list of cats
+ foreach mm $icat(def) {
+ set ll [lindex $mm 0]
+ set ww [lindex $mm 1]
+ set ss [lindex $mm 2]
+ set cc [lindex $mm 3]
+
+ if {$ll != {-} && "cat${item}" == $ww} {
+ CATDialog $ww $ss $cc $ll sync
+ return
+ }
+ }
+
+ # not a default, assume other name
+ CATDialog catcds cds $item $item sync
+ }
+ }
+ }
+ }
+}
+
+proc ProcessCatalog {varname iname cvarname} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ global icat
+ global pcat
+ global current
+
+ # we should have a catalog now
+ global $cvarname
+ upvar #0 $cvarname cvar
+
+ if {![info exists cvar(top)]} {
+ Error "[msgcat::mc {Unable to find catalog window}] $cvarname"
+ return
+ }
+ if {![winfo exists $cvar(top)]} {
+ Error "[msgcat:: mc {Unable to find catalog window}] $cvarname"
+ return
+ }
+
+ # now, process it
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ allrows {set cvar(allrows) 1}
+ allcols {set cvar(allcols) 1}
+ cancel {ARCancel $cvarname}
+ clear {CATOff $cvarname}
+ close {CATDestroy $cvarname}
+ coordinate {
+ incr i
+ set cvar(x) [lindex $var $i]
+ incr i
+ set cvar(y) [lindex $var $i]
+ incr i
+ set cvar(sky) [lindex $var $i]
+ }
+ crosshair {CATCrosshair $cvarname}
+ edit {
+ incr i
+ set cvar(edit) [FromYesNo [lindex $var $i]]
+ CATEdit $cvarname
+ }
+ export -
+ save {
+ incr i
+ set writer VOTWrite
+ switch -- [lindex $var $i] {
+ xml -
+ vot {incr i; set writer VOTWrite}
+ sb -
+ starbase {incr i; set writer starbase_write}
+ csv -
+ tsv {incr i; set writer TSVWrite}
+ }
+
+ set fn [lindex $var $i]
+ CATSaveFn $cvarname $fn $writer
+ FileLast catfbox $fn
+ }
+ filter {
+ incr i
+ set item [lindex $var $i]
+ switch -- $item {
+ load {
+ incr i
+ set fn [lindex $var $i]
+ if {[catch {open $fn r} fp]} {
+ Error "[msgcat::mc {Unable to open file}] $fn: $fp"
+ return
+ }
+ set flt [read -nonewline $fp]
+ catch {regsub {\n} $flt " " $flt}
+ set cvar(filter) [string trim $flt]
+ catch {close $fp}
+ }
+ default {
+ set cvar(filter) $item
+ }
+ }
+ CATTable $cvarname
+ }
+ header {CATHeader $cvarname}
+ hide {
+ set cvar(show) 0
+ CATGenerate $cvarname
+ }
+ location {
+ incr i
+ set cvar(loc) [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ match {
+ incr i
+ set item [lindex $var $i]
+ switch -- $item {
+ error {
+ incr i
+ set icat(error) [lindex $var $i]
+ incr i
+ set icat(eformat) [lindex $var $i]
+ }
+ function {incr i; set icat(function) [lindex $var $i]}
+ unique {incr i; set icat(unique) [FromYesNo [lindex $var $i]]}
+ return {incr i; set icat(return) [lindex $var $i]}
+ default {
+ set icat(match1) "cat[lindex $var $i]"
+ incr i
+ set icat(match2) "cat[lindex $var $i]"
+ CATMatch $current(frame) $icat(match1) $icat(match2)
+ }
+ }
+ }
+ maxrows {
+ incr i
+ set cvar(max) [lindex $var $i]
+ }
+ name {
+ incr i
+ set cvar(name) [lindex $var $i]
+ }
+ panto {
+ incr i
+ set cvar(panto) [FromYesNo [lindex $var $i]]
+ }
+ plot {
+ incr i
+ set cvar(plot,x) [lindex $var $i]
+ incr i
+ set cvar(plot,y) [lindex $var $i]
+ incr i
+ set cvar(plot,xerr) [lindex $var $i]
+ incr i
+ set cvar(plot,yerr) [lindex $var $i]
+ CATPlotGenerate $cvarname
+ }
+ print {CATPrint $cvarname}
+ psky {
+ incr i
+ set cvar(psky) [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ psystem {
+ incr i
+ set cvar(psystem) [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ regions {CATGenerateRegions $cvarname}
+ retrieve -
+ retreive {CATApply $cvarname 1}
+ samp {
+ global ds9
+ global samp
+
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ send {
+ incr i
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,votable) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendTableLoadVotable $key $cvarname
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ broadcast {SAMPSendTableLoadVotable {} $cvarname}
+ default {
+ SAMPSendTableLoadVotable {} $cvarname
+ incr i -1
+ }
+ }
+ }
+ server {
+ incr i
+ set cvar(server) [lindex $var $i]
+ }
+ size {
+ incr i
+ set cvar(width) [lindex $var $i]
+ incr i
+ set cvar(height) [lindex $var $i]
+ incr i
+ set cvar(rformat) [lindex $var $i]
+ set cvar(rformat,msg) $cvar(rformat)
+ }
+ show {
+ set cvar(show) 1
+ CATGenerate $cvarname
+ }
+ sky {
+ incr i
+ set cvar(sky) [lindex $var $i]
+ CoordMenuButtonCmd $cvarname system sky \
+ [list CATWCSMenuUpdate $cvarname]
+ }
+ skyformat {
+ incr i
+ set cvar(skyformat) [lindex $var $i]
+ }
+ sort {
+ incr i
+ set cvar(sort) [lindex $var $i]
+ incr i
+ switch -- [lindex $var $i] {
+ incr {
+ set cvar(sort,dir) "-increasing"
+ }
+ decr {
+ set cvar(sort,dir) "-decreasing"
+ }
+ }
+ CATTable $cvarname
+ }
+ symbol {
+ global $cvar(symdb)
+ set row 1
+ incr i
+ if {[string is integer [lindex $var $i]]} {
+ set row [lindex $var $i]
+ incr i
+ }
+
+ switch -- [lindex $var $i] {
+ add {
+ set row [expr [starbase_nrows $cvar(symdb)]+1]
+ starbase_rowins $cvar(symdb) $row
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) shape] $pcat(sym,shape)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) color] $pcat(sym,color)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) width] $pcat(sym,width)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) font] $pcat(sym,font)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) fontsize] \
+ $pcat(sym,font,size)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) fontweight] \
+ $pcat(sym,font,weight)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) fontslant] \
+ $pcat(sym,font,slant)
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) units] $pcat(sym,units)
+ CATGenerate $cvarname
+ }
+ angle {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) angle] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ color {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) color] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ condition {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) condition] \
+ [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ font {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) font] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ fontsize {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) fontsize] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ fontweight {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) fontweight] \
+ [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ fontslant {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) fontslant] \
+ [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ load {
+ incr i
+ set fn [lindex $var $i]
+ if {[file exists $fn]} {
+ starbase_read $cvar(symdb) $fn
+ CATGenerate $cvarname
+ } else {
+ Error "[msgcat::mc {Unable to open file}] $fn"
+ return
+ }
+ }
+ remove {
+ starbase_rowdel $cvar(symdb) $row
+ CATGenerate $cvarname
+ }
+ save {
+ incr i
+ starbase_write $cvar(symdb) [lindex $var $i]
+ }
+ size {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) size] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ size2 {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) size2] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ shape {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) shape] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ text {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) text] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ units {
+ incr i
+ starbase_set $cvar(symdb) $row \
+ [starbase_colnum $cvar(symdb) units] [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ }
+ }
+ system {
+ incr i
+ set cvar(system) [lindex $var $i]
+ CoordMenuButtonCmd $cvarname system sky \
+ [list CATWCSMenuUpdate $cvarname]
+ }
+ update {CATUpdate $cvarname}
+ x -
+ ra {
+ incr i
+ set cvar(colx) [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ y -
+ dec {
+ incr i
+ set cvar(coly) [lindex $var $i]
+ CATGenerate $cvarname
+ }
+ }
+}
+
+proc ProcessSendCatalogCmd {proc id param sock fn} {
+ global icat
+
+ set cc [lindex $icat(cats) end]
+ switch -- [string tolower [lindex $param 0]] {
+ header {}
+ default {
+ set cc [lindex $param 0]
+ set param [lreplace $param 0 0]
+ }
+ }
+
+ switch -- [string tolower [lindex $param 0]] {
+ {} {$proc $id "$icat(cats)\n"}
+ header {ProcessSend $proc $id $sock $fn {.txt} "[CATGetHeader $cc]\n"}
+ }
+}
diff --git a/ds9/library/catcds.tcl b/ds9/library/catcds.tcl
new file mode 100644
index 0000000..b6100c4
--- /dev/null
+++ b/ds9/library/catcds.tcl
@@ -0,0 +1,246 @@
+# 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 CATCDS {varname} {
+ upvar #0 $varname var
+ global $varname
+ global pcat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDS $varname"
+ }
+
+ # go for votable or tsv
+ if {$pcat(vot)} {
+ set var(proc,parser) VOTParse
+ } else {
+ set var(proc,reader) CATCDSReader
+ }
+
+ # url
+ set site [CATCDSURL $var(server)]
+ set cgidir {viz-bin}
+ if {$pcat(vot)} {
+ set script {votable}
+ } else {
+ set script {asu-tsv}
+ }
+ set var(url) "http://$site/$cgidir/$script"
+
+ # query
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ switch -- $var(sky) {
+ fk4 -
+ fk5 -
+ icrs {set xx [h2d [Sex2H $var(x)]]}
+ galactic -
+ ecliptic {set xx [Sex2D $var(x)]}
+ }
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ if {$yy>0} {
+ set yy "+$yy"
+ }
+
+ switch -- $var(sky) {
+ fk4 {set eq "B1950"}
+ fk5 -
+ icrs {set eq "J2000"}
+ galactic {set eq "Gal"}
+ ecliptic {set eq "Ecl"}
+ }
+
+ switch -- $var(rformat) {
+ degrees {set cr "-c.rd"}
+ arcmin {set cr "-c.rm"}
+ arcsec {set cr "-c.rs"}
+ }
+
+ set ww $var(width)
+ set hh $var(height)
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ set query [http::formatQuery -source $var(catalog) -c $xx$yy -c.eq $eq $cr $rr -oc.form dec]
+
+ if {$pcat(vot)} {
+ append query "&[http::formatQuery -out.form VOTable]"
+ } else {
+ append query "&[http::formatQuery -out.form Tab-Separated-Values]"
+ }
+
+ switch -- $var(psky) {
+ fk4 {append query "&[http::formatQuery -out.add _RAB,_DEB]"}
+ fk5 -
+ icrs {append query "&[http::formatQuery -out.add _RAJ,_DEJ]"}
+ galactic {append query "&[http::formatQuery -out.add _GLON,_GLAT]"}
+ ecliptic {append query "&[http::formatQuery -out.add _ELON,_ELAT]"}
+ }
+
+ # options
+ if {!$var(allrows)} {
+ append query "&-out.max=$var(max)"
+ }
+ if {$var(allcols)} {
+ append query "&-out.all"
+ }
+
+ # url?query
+ set var(query) $query
+
+ if {$pcat(vot)} {
+ CATLoad $varname
+ } else {
+ CATLoadIncr $varname
+ }
+}
+
+proc CATCDSReader {t sock token} {
+ upvar #0 $t T
+ global $t
+
+ set result 0
+
+ if { ![info exists ${t}(state)] } {
+ set T(state) 0
+ }
+
+ switch -- $T(state) {
+ 0 {
+ # init db
+ fconfigure $sock -blocking 1
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) 1
+ }
+
+ 1 {
+ # process header
+ incr ${t}(HLines)
+ set n $T(HLines)
+ if {[gets $sock line] == -1} {
+ set T(state) -1
+ set T(HLines) [expr $T(HLines) - 1]
+ set T(Nrows) 0
+ set T(Ncols) 0
+ return 0
+ }
+
+ set result [string length "$line"]
+ set T(H_$n) $line
+ if {[regexp -- {^ *(-)+ *(\t *(-)+ *)*} $line]} {
+ # remove units line, but save first
+ unset T(H_$n)
+ incr ${t}(HLines) -1
+ incr n -1
+ set units $T(H_$n)
+ set T(H_$n) $line
+
+ # clean up header column name
+ set hh $T(H_[expr $n-1])
+ regsub -all {\[} $hh {} hh
+ regsub -all {\]} $hh {} hh
+ set T(H_[expr $n-1]) $hh
+
+ # cols
+ set T(Header) [split $T(H_[expr $n-1]) "\t"]
+ set T(Unit) [split $units "\t"]
+ set T(Dashes) [split $T(H_$n) "\t"]
+ set T(Ndshs) [llength $T(Dashes)]
+
+ starbase_colmap $t
+ set T(state) 2
+ }
+ }
+
+ 2 {
+ # process table
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ } else {
+ set result [string length "$line"]
+ set line [string trim $line]
+
+ if {$line != {}} {
+ # check for beginning of another table
+ if {[string range $line 0 0] == "#"} {
+ set T(state) 3
+ return $result
+ }
+
+ # check for garbage at start of line
+ if {![string is double [lindex $line 0]]} {
+ set T(state) 3
+ return $result
+ }
+
+ # ok, save it
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols $t]
+ set c 1
+ foreach val [split $line "\t"] {
+ set T($r,$c) $val
+ incr c
+ }
+ for {} {$c <= $NCols} {incr c} {
+ set T($r,$c) {}
+ }
+ }
+ }
+ }
+
+ 3 {
+ # finished, eat everything else
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ }
+ }
+ }
+
+ return $result
+}
+
+proc CATCDSURL {server} {
+ switch -- $server {
+ cds {return {vizier.u-strasbg.fr}}
+ sao {return {vizier.cfa.harvard.edu}}
+ cadc {return {vizier.hia.nrc.ca}}
+ adac {return {vizier.nao.ac.jp}}
+ iucaa {return {vizier.iucaa.ernet.in}}
+ inasan {return {vizier.inasan.ru}}
+ bejing {return {data.bao.ac.cn}}
+ cambridge {return {vizier.ast.cam.ac.uk}}
+ ukirt {return {www.ukirt.jach.hawaii.edu}}
+ }
+}
+
+proc CATCDSAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for CDS
+
+This research has made use of the VizieR catalogue access tool, CDS,
+Strasbourg, France. VizieR is a joint effort of
+CDS (Centre de Données astronomiques de Strasbourg) and
+ESA-ESRIN (Information Systems Division).
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 10 insert top $msg
+}
diff --git a/ds9/library/catcdssrch.tcl b/ds9/library/catcdssrch.tcl
new file mode 100644
index 0000000..4449e70
--- /dev/null
+++ b/ds9/library/catcdssrch.tcl
@@ -0,0 +1,471 @@
+# 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 CATCDSSrchDef {} {
+ global icatcdssrch
+
+ set icatcdssrch(minrows) 11
+ set icatcdssrch(mincols) 2
+
+ set icatcdssrch(list,wave,param) {-kw.Wavelength}
+ set icatcdssrch(list,wave) [list none Radio IR optical UV EUV X-ray Gamma-ray]
+ set icatcdssrch(list,mission,param) {-kw.Mission}
+ set icatcdssrch(list,mission) [list none AKARI ANS ASCA BeppoSAX CGRO Chandra COBE Copernicus CoRoT Einstein ESO EUVE EXOSAT FAUST Fermi FUSE GALEX GINGA GRANAT Herschel HEAO Hipparcos HST HUT INTEGRAL IRAS ISO IUE Kepler MSX OAO-2 ORFEUS Planck ROSAT RXTE SAS-1 SAS-2 SMM SOHO Spitzer STEREO Suzaku Swift TD1 UIT ULYSSES WISE WMAP WUPPE XMM]
+ set icatcdssrch(list,astro,param) {-kw.Astronomy}
+ set icatcdssrch(list,astro) [list none Abundances Ages AGN Associations Atomic_Data Binaries:cataclysmic Binaries:eclipsing Binaries:spectroscopic BL_Lac_objects Blue_objects Clusters_of_galaxies Constellations Diameters Earth Ephemerides Equivalent_widths Extinction Galaxies Galaxies:Markarian Galaxies:spectra Globular_Clusters Gravitational_lensing HII_regions Interstellar_Medium Magnetic_fields Masers Masses Models Multiple_Stars Nebulae Nonstellar Novae Obs_Log Open_Clusters Orbits Parallaxes Photometry Photometry:intermediate-band Photometry:narrow-band Photometry:surface Photometry:wide-band Planetary_Nebulae Planets+Asteroids Polarization Positional_Data Proper_Motions Pulsars QSOs Redshifts Rotational_Velocities Seyfert_Galaxies Spectral_Classification Spectrophotometry Spectroscopy Stars Stars:early-typeStars:Emission Stars:late-type Stars:peculiar Stars:variable Stars:white_dwarf Stars:WR Sun SuperNovae SuperNovae_Remnants Velocities YSOs]
+}
+
+proc CATCDSSrchLoadFile {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchLoad $varname"
+ }
+
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ set fn [OpenFileDialog catcdssrchfbox]
+ if {$fn != {}} {
+ if {[file exists $fn]} {
+ starbase_read $var(catdb) $fn
+ } else {
+ Error "[msgcat::mc {Unable to open file}] $fn"
+ return
+ }
+
+ CATCDSSrchTable $varname
+ }
+}
+
+proc CATCDSSrchSaveFile {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ set fn [SaveFileDialog catcdssrchfbox]
+ if {$fn != {}} {
+ starbase_write $var(catdb) $fn
+ }
+}
+
+proc CATCDSSrchClear {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+}
+
+proc CATCDSSrchCatalog {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchCatalog $varname"
+ }
+
+ set row 0
+ foreach ss [$var(tbl) curselection] {
+ set rr [lindex [split $ss ,] 0]
+ if {$rr != $row} {
+ set id [starbase_get $var(catdb) $rr 1]
+ set title [starbase_get $var(catdb) $rr 2]
+ if {$id != {}} {
+ # can't use id, it may have / or +
+ CATDialog catcds cds $id $title apply
+ }
+ set row $rr
+ }
+ }
+}
+
+proc CATCDSSrch {varname} {
+ upvar #0 $varname var
+ global $varname
+ global pcat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrch $varname"
+ }
+
+ # go for votable or tsv
+ if {$pcat(vot)} {
+ set var(proc,parser) CATCDSSrchVOTParse
+ } else {
+ set var(proc,reader) CATCDSSrchReader
+ }
+
+ #url
+ set site [CATCDSURL $var(server)]
+ set cgidir {viz-bin}
+ if {$pcat(vot)} {
+ set script {votable}
+ } else {
+ set script {asu-tsv}
+ }
+ set var(url) "http://$site/$cgidir/$script"
+
+ # defaults
+ set query {-meta}
+ append query "&[http::formatQuery -out.max 1000]"
+
+ if {$pcat(vot)} {
+ append query "&[http::formatQuery -out.form VOTable]"
+ } else {
+ append query "&[http::formatQuery -out.form Tab-Separated-Values]"
+ }
+
+ if {$var(source) != {}} {
+ append query "&[http::formatQuery -source $var(source)]"
+ }
+ if {$var(words) !={}} {
+ append query "&[http::formatQuery -words $var(words)]"
+ }
+ if {$var(wave) !={}} {
+ append query "&[http::formatQuery $var(list,wave,param) $var(wave)]"
+ }
+ if {$var(mission) !={}} {
+ append query "&[http::formatQuery $var(list,mission,param) $var(mission)]"
+ }
+ if {$var(astro) !={}} {
+ append query "&[http::formatQuery $var(list,astro,param) $var(astro)]"
+ }
+
+ set var(query) $query
+
+ if {$pcat(vot)} {
+ CATCDSSrchLoad $varname
+ } else {
+ CATCDSSrchLoadIncr $varname
+ }
+}
+
+proc CATCDSSrchLoad {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchLoad $varname"
+ }
+
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ set var(proc,done) CATCDSSrchDone
+ set var(proc,load) CATCDSSrchLoad
+ CATGetURL $varname
+ return
+}
+
+proc CATCDSSrchLoadIncr {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchLoadIncr $varname"
+ }
+
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ set var(proc,done) CATCDSSrchDone
+ set var(proc,load) CATCDSSrchLoadIncr
+ CATGetURLIncr $varname
+ return
+}
+
+proc CATCDSSrchDone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ CATCDSSrchTable $varname
+}
+
+proc CATCDSSrchReader {t sock token} {
+ upvar #0 $t T
+ global $t
+
+ set result 0
+
+ if { ![info exists ${t}(state)] } {
+ set T(state) 0
+ }
+
+ switch -- $T(state) {
+ 0 {
+ # init db
+ fconfigure $sock -blocking 1
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ # create header
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) "Resource\tDescription"
+ set T(Header) [split $T(H_$n) "\t"]
+
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) "--------\t-----------"
+
+ set T(Dashes) [split $T(H_$n) "\t"]
+ set T(Ndshs) [llength $T(Dashes)]
+
+ starbase_colmap $t
+
+ set T(state) 1
+ }
+
+ 1 {
+ # process RESOURCE
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ return $result
+ }
+
+ set result [string length "$line"]
+ set line [string trim $line]
+ if {$line != {}} {
+ switch -- [string range $line 0 4] {
+ "#RESO" {
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+ set T($r,1) {}
+ set T($r,2) {}
+
+ set T(state) 2
+ }
+ }
+ }
+ }
+
+ 2 {
+ # process Description
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ return $result
+ }
+
+ set result [string length "$line"]
+ set line [string trim $line]
+ set r $T(Nrows)
+ if {$line != {}} {
+ switch -- [string range $line 0 4] {
+ "#Name" {
+ set T($r,1) [string trim [lindex [split $line {:}] 1]]
+ set T(state) 3
+ }
+ }
+ }
+ }
+
+ 3 {
+ # new style process description
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ return $result
+ }
+
+ set result [string length "$line"]
+ set line [string trim $line]
+ if {$line != {}} {
+ switch -- [string range $line 0 4] {
+ "#Titl" {
+ # eat it
+ }
+ default {
+ set r $T(Nrows)
+ if {$r>0} {
+ set val [string trim [string range $line 5 end]]
+ catch {set T($r,2) "$val"}
+ set T(state) 1
+ }
+ }
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+proc CATCDSSrchVOTParse {t token} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ if {$debug(tcl,cat)} {
+ set fp [open debug.xml w]
+ puts $fp [http::data $token]
+ close $fp
+ }
+
+ set xml [xml::parser \
+ -characterdatacommand [list CATCDSSrchVOTCharCB $t] \
+ -elementstartcommand [list CATCDSSrchVOTElemStartCB $t] \
+ -elementendcommand [list CATCDSSrchVOTElemEndCB $t] \
+ -ignorewhitespace 1 \
+ ]
+
+ set T(tree,state) {}
+ set T(tree,prev) {}
+ if {[catch {$xml parse [http::data $token]} err]} {
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchVOTParse: $err"
+ }
+ }
+
+ $xml free
+}
+
+proc CATCDSSrchVOTCharCB {t data} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ switch -- $T(tree,state) {
+ DESCRIPTION {
+ set data [string trim $data]
+ if {$data != {}} {
+ switch -- $T(tree,prev) {
+ RESOURCE {
+ set r $T(Nrows)
+ set T($r,2) [lindex [split $data "\n"] 0]
+
+ set T(tree,prev) {}
+ }
+ }
+ }
+ }
+ }
+
+ # sometimes, we get a bogus call, (ignore whitespace does not work)
+ set T(tree,state) {}
+ return {}
+}
+
+proc CATCDSSrchVOTElemStartCB {t name attlist args} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ switch -- $name {
+ VOTABLE {
+ # init db
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ # create header
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) "Resource\tDescription"
+ set T(Header) [split $T(H_$n) "\t"]
+
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) "--------\t-----------"
+
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+ set T(Ndshs) [llength $T(Header)]
+
+ starbase_colmap $t
+ }
+ RESOURCE {
+ set fname {}
+ set id {}
+ set type {}
+ foreach {key value} $attlist {
+ switch -- [string tolower $key] {
+ name {set fname "$value"}
+ id {set id "$value"}
+ type {set type $value}
+ }
+ }
+
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+ set T($r,1) $fname
+ set T($r,2) {}
+
+ set T(tree,prev) $name
+ }
+ }
+
+ set ${t}(tree,state) $name
+
+ return {}
+}
+
+proc CATCDSSrchVOTElemEndCB {t name args} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ # we can't count on this being called for all end-tags
+ switch -- $name {
+ VOTABLE {
+ # ok, we're done
+ return -code break
+ }
+ }
+ return {}
+}
+
+proc CATCDSSrchTable {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global icatcdssrch
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchTable $varname"
+ }
+
+# starbase_writefp $var(catdb) stdout
+
+ global $var(catdb)
+ $var(tbl) configure -variable $var(catdb)
+
+ if {[starbase_nrows $var(catdb)] == 0} {
+ ARStatus $varname [msgcat::mc {No Items Found}]
+ return
+ }
+
+ set nc [starbase_ncols $var(catdb)]
+ $var(tbl) configure -cols $nc
+
+ # add header row
+ set nr [expr [starbase_nrows $var(catdb)]+1]
+ if {$nr > $icatcdssrch(minrows)} {
+ $var(tbl) configure -rows $nr
+ } else {
+ $var(tbl) configure -rows $icatcdssrch(minrows)
+ }
+
+ ARStatus $varname "[starbase_nrows $var(catdb)] [msgcat::mc {Items Found}]"
+}
diff --git a/ds9/library/catcdssrchdialog.tcl b/ds9/library/catcdssrchdialog.tcl
new file mode 100644
index 0000000..84cf474
--- /dev/null
+++ b/ds9/library/catcdssrchdialog.tcl
@@ -0,0 +1,474 @@
+# 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 CATCDSSrchDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global pcat
+ global icatcdssrch
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchDialog $varname"
+ }
+
+ # main dialog
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # defaults
+ # maybe modified if pcat(vot)
+ set var(list,wave,param) $icatcdssrch(list,wave,param)
+ set var(list,wave) $icatcdssrch(list,wave)
+ set var(list,mission,param) $icatcdssrch(list,mission,param)
+ set var(list,mission) $icatcdssrch(list,mission)
+ set var(list,astro,param) $icatcdssrch(list,astro,param)
+ set var(list,astro) $icatcdssrch(list,astro)
+
+ # AR variables
+ set var(status) {}
+ set var(sync) 0
+
+ # CATCDSSrch variables
+ set var(catdb) ${varname}catdb
+ set var(server) $pcat(server)
+
+ set var(source) {}
+ set var(words) {}
+ set var(wave) {}
+ set var(mission) {}
+ set var(astro) {}
+
+ # create the window
+ set w $var(top)
+ set mb $var(mb)
+
+ Toplevel $w $mb 7 [msgcat::mc {Search for Catalogs}] \
+ "CATCDSSrchDestroy $varname"
+
+ # file
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Retrieve}] \
+ -command "CATCDSSrchApply $varname"
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname"
+ $mb.file add command -label [msgcat::mc {Load}] \
+ -command "CATCDSSrchCatalog $varname"
+ $mb.file add command -label [msgcat::mc {Clear}] \
+ -command "CATCDSSrchClear $varname"
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load}]..." \
+ -command "CATCDSSrchLoadFile $varname"
+ $mb.file add command -label "[msgcat::mc {Save}]..." \
+ -command "CATCDSSrchSaveFile $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command "CATCDSSrchDestroy $varname"
+
+ # edit
+ AREditMenu $varname
+
+ # catalog server
+ CATServerMenu $varname
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::frame $f.name
+ ttk::frame $f.words
+ ttk::frame $f.srch
+ pack $f.name -side top -fill x -expand true
+ pack $f.words -side top -fill x -expand true
+ pack $f.srch -side bottom -fill both -expand true
+
+ # param name
+ ttk::label $f.name.title -text [msgcat::mc {Name or Designation}]
+ ttk::entry $f.name.source -textvariable ${varname}(source)
+ pack $f.name.title -side top -anchor w -padx 2 -pady 2
+ pack $f.name.source -side top -anchor w -padx 2 -pady 2 -fill x -expand true
+
+ # param keywords
+ ttk::label $f.words.title \
+ -text [msgcat::mc {Words matching title, description}]
+ ttk::entry $f.words.key -textvariable ${varname}(words) -width 45
+ pack $f.words.title -side top -anchor w -padx 2 -pady 2
+ pack $f.words.key -side top -anchor w -padx 2 -pady 2 -fill x -expand true
+
+ # param search
+ ttk::frame $f.srch.wave
+ ttk::frame $f.srch.mission
+ ttk::frame $f.srch.astro
+ pack $f.srch.wave $f.srch.mission $f.srch.astro \
+ -side left -fill both -expand true -padx 2 -pady 2
+
+ # param search wave
+ ttk::frame $f.srch.wave.f
+ ttk::label $f.srch.wave.title -text [msgcat::mc {Wavelength}]
+ pack $f.srch.wave.title -side top -anchor w
+ pack $f.srch.wave.f -side bottom -fill both -expand true \
+ -anchor w -padx 2 -pady 2
+
+ ttk::scrollbar $f.srch.wave.f.scroll \
+ -command [list $f.srch.wave.f.list yview]
+ set ${varname}(listbox,wave) [listbox $f.srch.wave.f.list \
+ -yscroll \
+ [list $f.srch.wave.f.scroll set] \
+ -setgrid true \
+ -selectmode browse \
+ -exportselection 0 \
+ -listvariable ${varname}(list,wave)]
+ grid $f.srch.wave.f.list $f.srch.wave.f.scroll -sticky news
+ grid rowconfigure $f.srch.wave.f 0 -weight 1
+ grid columnconfigure $f.srch.wave.f 0 -weight 1
+
+ # param search mission
+ ttk::frame $f.srch.mission.f
+ ttk::label $f.srch.mission.title -text [msgcat::mc {Mission}]
+ pack $f.srch.mission.title -side top -anchor w
+ pack $f.srch.mission.f -side bottom -fill both -expand true \
+ -anchor w -padx 2 -pady 2
+
+ ttk::scrollbar $f.srch.mission.f.scroll \
+ -command [list $f.srch.mission.f.list yview]
+ set ${varname}(listbox,mission) [listbox $f.srch.mission.f.list \
+ -yscroll \
+ [list $f.srch.mission.f.scroll set] \
+ -setgrid true \
+ -selectmode browse \
+ -exportselection 0 \
+ -listvariable ${varname}(list,mission)]
+ grid $f.srch.mission.f.list $f.srch.mission.f.scroll \
+ -sticky news
+ grid rowconfigure $f.srch.mission.f 0 -weight 1
+ grid columnconfigure $f.srch.mission.f 0 -weight 1
+
+ # param search astro
+ ttk::frame $f.srch.astro.f
+ ttk::label $f.srch.astro.title -text [msgcat::mc {Astronomy}]
+ pack $f.srch.astro.title -side top -anchor w
+ pack $f.srch.astro.f -side bottom -fill both -expand true \
+ -anchor w -padx 2 -pady 2
+
+ ttk::scrollbar $f.srch.astro.f.scroll \
+ -command [list $f.srch.astro.f.list yview]
+ set ${varname}(listbox,astro) [listbox $f.srch.astro.f.list \
+ -yscroll \
+ [list $f.srch.astro.f.scroll set] \
+ -setgrid true \
+ -selectmode browse \
+ -exportselection 0 \
+ -listvariable ${varname}(list,astro)]
+ grid $f.srch.astro.f.list $f.srch.astro.f.scroll -sticky news
+ grid rowconfigure $f.srch.astro.f 0 -weight 1
+ grid columnconfigure $f.srch.astro.f 0 -weight 1
+
+ # Table
+ set f [ttk::frame $w.tbl]
+
+ set var(tbl) [table $f.t \
+ -state disabled \
+ -usecommand 0 \
+ -variable $var(catdb) \
+ -colorigin 1 \
+ -roworigin 0 \
+ -cols $icatcdssrch(mincols) \
+ -rows $icatcdssrch(minrows) \
+ -colstretchmode all \
+ -width -1 \
+ -height -1 \
+ -maxwidth 400 \
+ -maxheight 190 \
+ -titlerows 1 \
+ -xscrollcommand [list $f.xscroll set]\
+ -yscrollcommand [list $f.yscroll set]\
+ -selecttype row \
+ -selectmode extended \
+ -anchor w \
+ -font [font actual TkDefaultFont]
+ ]
+
+ 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
+
+ # Status
+ set f [ttk::frame $w.status]
+
+ ttk::label $f.title -text [msgcat::mc {Status}]
+ ttk::label $f.item -textvariable ${varname}(status)
+ pack $f.title $f.item -side left -anchor w -padx 2 -pady 2
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+
+ set var(apply) [ttk::button $f.apply \
+ -text [msgcat::mc {Retrieve}] \
+ -command "CATCDSSrchApply $varname"]
+ set var(cancel) [ttk::button $f.cancel \
+ -text [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname" -state disabled]
+ ttk::button $f.catalog -text [msgcat::mc {Load}] \
+ -command "CATCDSSrchCatalog $varname"
+ ttk::button $f.clear -text [msgcat::mc {Clear}] \
+ -command "CATCDSSrchClear $varname"
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command "CATCDSSrchDestroy $varname"
+ pack $f.apply $f.cancel $f.catalog $f.clear $f.close \
+ -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ ttk::separator $w.stbl -orient horizontal
+ ttk::separator $w.sstatus -orient horizontal
+ pack $w.buttons $w.sstatus $w.status $w.stbl -side bottom -fill x
+ pack $w.param $w.sep -side top -fill x
+ pack $w.tbl -side top -fill both -expand true
+
+ ARStatus $varname {}
+
+ # initialize
+ $var(listbox,wave) selection set 0
+ $var(listbox,mission) selection set 0
+ $var(listbox,astro) selection set 0
+ $w.param.name.source select range 0 end
+}
+
+proc CATCDSSrchApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global icatcdssrch
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchApply $varname"
+ }
+
+ set id [$var(listbox,wave) curselection]
+ if {$id > 0} {
+ set var(wave) [lindex $var(list,wave) $id]
+ } else {
+ set var(wave) {}
+ }
+ set id [$var(listbox,mission) curselection]
+ if {$id > 0} {
+ set var(mission) [lindex $var(list,mission) $id]
+ } else {
+ set var(mission) {}
+ }
+ set id [$var(listbox,astro) curselection]
+ if {$id > 0} {
+ set var(astro) [lindex $var(list,astro) $id]
+ } else {
+ set var(astro) {}
+ }
+
+ ARApply $varname
+ ARStatus $varname [msgcat::mc {Searching for catalogs}]
+
+ CATCDSSrch $varname
+}
+
+proc CATCDSSrchDestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchDestroy $varname"
+ }
+
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ ARDestroy $varname
+}
+
+proc CATCDSSrchConfig {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchConfig $varname"
+ }
+
+ set site [CATCDSURL $var(server)]
+ set cgidir {viz-bin}
+ set script {votable}
+
+ set var(url) "http://$site/$cgidir/$script"
+ set var(query) [http::formatQuery -meta.aladin all]
+
+ CATCDSSrchConfigLoad $varname
+ return
+}
+
+proc CATCDSSrchConfigLoad {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchConfigLoad $varname"
+ }
+
+ set var(proc,parser) CATCDSSrchConfigParse
+ set var(proc,done) CATCDSSrchConfigDone
+ set var(proc,load) CATCDSSrchConfigLoad
+ CATGetURL $varname
+ return
+}
+
+proc CATCDSSrchConfigDone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchConfigDone $varname"
+ }
+
+ CATCDSSrchConfigParse
+}
+
+proc CATCDSSrchConfigParse {t token} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchConfigParse"
+ }
+ if {$debug(tcl,cat)} {
+ set fp [open debug.xml w]
+ puts $fp [http::data $token]
+ close $fp
+ }
+
+ set xml [xml::parser \
+ -elementstartcommand [list CATCDSSrchConfigElemStartCB $t] \
+ -elementendcommand [list CATCDSSrchConfigElemEndCB $t] \
+ -ignorewhitespace 1 \
+ ]
+
+ set T(tree,enable) 0
+ set T(tree,state) {}
+ if {[catch {$xml parse [http::data $token]} err]} {
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCDSSrchConfigParse: $err"
+ }
+ }
+ unset ${t}(tree,enable)
+ unset ${t}(tree,state)
+
+ $xml free
+}
+
+proc CATCDSSrchConfigElemStartCB {t name attlist args} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ # hardcoded
+ set varname catcdssrch1
+ upvar #0 $varname var
+ global $varname
+
+ switch -- $name {
+ RESOURCE {
+ set id {}
+ set type {}
+ foreach {key value} $attlist {
+ switch -- [string tolower $key] {
+ type {set type "$value"}
+ id {set id "$value"}
+ }
+ }
+ if {[string tolower $id] == "vizier"} {
+ set T(tree,enable) 1
+
+ set ${varname}(list,wave) [list none]
+ set ${varname}(list,mission) [list none]
+ set ${varname}(list,astro) [list none]
+ }
+ }
+ PARAM {
+ if {$T(tree,enable)} {
+ set id {}
+ set fname {}
+ foreach {key value} $attlist {
+ switch -- [string tolower $key] {
+ name {set fname "$value"}
+ id {set id "$value"}
+ }
+ }
+ set T(tree,state) [string trim [string tolower $id]]
+ switch -- $T(tree,state) {
+ wavelength {set ${varname}(list,wave,param) $fname}
+ mission {set ${varname}(list,mission,param) $fname}
+ astronomy {set ${varname}(list,astro,param) $fname}
+ }
+
+ }
+ }
+ VALUES {}
+ OPTION {
+ if {$T(tree,enable)} {
+ set item {}
+ foreach {key value} $attlist {
+ switch -- [string tolower $key] {
+ value {set item "$value"}
+ }
+ }
+ if {$item != {}} {
+ global icatcdssrch
+ switch -- $T(tree,state) {
+ wavelength {lappend ${varname}(list,wave) $item}
+ mission {lappend ${varname}(list,mission) $item}
+ astronomy {lappend ${varname}(list,astro) $item}
+ }
+ }
+ }
+ }
+ }
+
+ return {}
+}
+
+proc CATCDSSrchConfigElemEndCB {t name args} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ # we can't count on this being called for all end-tags
+ switch -- $name {
+ RESOURCE {
+ # ok, we're done
+ set T(tree,enable) 0
+ return -code break
+ }
+ }
+
+ return {}
+}
diff --git a/ds9/library/catcmd.tcl b/ds9/library/catcmd.tcl
new file mode 100644
index 0000000..2124e22
--- /dev/null
+++ b/ds9/library/catcmd.tcl
@@ -0,0 +1,764 @@
+# 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
+
+# Table Commands
+
+proc CATSelectCmd {varname ss rc} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSelectCmd $varname $ss $rc"
+ }
+
+ if {$var(edit)} {
+ CATSelectEditCmd $varname $ss $rc
+ } else {
+ CATSelectBrowseCmd $varname $ss $rc
+ }
+}
+
+proc CATSelectEditCmd {varname ss rc} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSelectEditCmd $varname $rc"
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ $var(frame) marker catalog $varname unselect
+
+ set last [lindex [split $ss ,] 0]
+ set next [lindex [split $rc ,] 0]
+
+ if {[string is integer -strict $last]} {
+ CATGenerateUpdate $varname $last
+ }
+
+ if {[string is integer -strict $next]} {
+ set mk "\{${varname}.${next}\}"
+ CATPanTo $varname $mk
+ $var(frame) marker catalog $mk select
+ }
+}
+
+proc CATSelectBrowseCmd {varname ss rc} {
+ upvar #0 $varname var
+ global $varname
+
+ # starts at 1
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSelectBrowseCmd $varname ss=$ss rc=$rc"
+ }
+
+ global $var(catdb)
+ if {![CATValidDB $var(catdb)]} {
+ return
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ $var(frame) marker catalog $varname unhighlite
+
+ # init timer vars
+ set var(blink,count) 0
+ set var(blink,marker) {}
+
+ # now see the current selection
+ set last [lindex [split $ss ,] 0]
+ set row [lindex [split $rc ,] 0]
+
+ # needed for plot, status, samp
+ # starts at 0
+ set rowlist {}
+ foreach sel [$var(tbl) curselection] {
+ set rr [lindex [split $sel ,] 0]
+ lappend rowlist $rr
+ }
+ set rowlist [lsort -unique $rowlist]
+
+ # kludge
+ # tktable can return bogus numbers if arrow keys are used
+ # try to fix
+ if {$row == 0} {
+ set row 1
+ }
+ if {[llength $rowlist] <= 1} {
+ set rowlist $row
+ }
+
+ foreach rr $rowlist {
+ lappend ${varname}(blink,marker) "\{${varname}.${rr}\}"
+ }
+
+ # status
+ CATStatusRows $varname $rowlist
+
+ # plot
+ if {$var(plot)} {
+ PlotHighliteElement $var(plot,var) $rowlist
+ }
+
+ # samp
+ SAMPSendTableRowListCmd $varname $rowlist
+
+ # panto
+ CATPanTo $varname [lindex $var(blink,marker) 0]
+
+ # start timer, if needed
+ if {!$var(blink)} {
+ set var(blink) 1
+ CATSelectTimer $varname
+ }
+}
+
+proc CATSelectRows {varname src rowlist} {
+ upvar #0 $varname var
+ global $varname
+
+ # just in case?
+ set rowlist [lsort -unique $rowlist]
+
+ # rows start at 1
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSelectRows $varname $src $rowlist"
+ }
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ global $var(catdb)
+ if {![CATValidDB $var(catdb)]} {
+ return
+ }
+
+ # rowlist can be empty
+ if {$rowlist == {}} {
+ if {[info exists ${varname}(tbl)]} {
+ $var(tbl) selection clear all
+ }
+ $var(frame) marker catalog $varname unhighlite
+ return
+ }
+
+ if {[info exists ${varname}(tbl)]} {
+ $var(tbl) selection clear all
+ foreach rr $rowlist {
+ $var(tbl) selection set $rr,1
+ }
+ $var(tbl) see [lindex $rowlist 0],1
+ }
+
+ $var(frame) marker catalog $varname unhighlite
+
+ # init timer vars
+ set var(blink,count) 0
+ set var(blink,marker) {}
+
+ foreach rr $rowlist {
+ lappend ${varname}(blink,marker) "\{${varname}.${rr}\}"
+ }
+
+ # status
+ CATStatusRows $varname $rowlist
+
+ # source of call
+ switch $src {
+ samp {
+ if {$var(plot)} {
+ PlotHighliteElement $var(plot,var) $rowlist
+ }
+ }
+ plot {
+ SAMPSendTableRowListCmd $varname $rowlist
+ }
+ }
+
+ # panto
+ CATPanTo $varname [lindex $var(blink,marker) 0]
+
+ # start timer, if needed
+ if {!$var(blink)} {
+ set var(blink) 1
+ CATSelectTimer $varname
+ }
+}
+
+proc CATPanTo {varname mk} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ # pan to first region
+ if {$var(panto) && $mk != {}} {
+ set tt [$var(frame) get marker catalog $mk tag]
+ if {$tt!={}} {
+ set cc [$var(frame) get marker catalog $tt center \
+ $var(psystem) $var(psky)]
+ PanToFrame $var(frame) [lindex $cc 0] [lindex $cc 1] \
+ $var(psystem) $var(psky)
+ }
+ }
+}
+
+proc CATSelectTimer {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ switch -- $var(blink) {
+ 0 {
+ set var(blink) 0
+ set var(blink,count) 0
+ set var(blink,marker) {}
+ }
+ 1 {
+ foreach mm $var(blink,marker) {
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ $var(frame) marker catalog $mm highlite
+ }
+ }
+ }
+
+ incr ${varname}(blink,count)
+ if {$var(blink,count) < 5} {
+ set var(blink) 2
+ } else {
+ set var(blink) 0
+ }
+
+ after 250 [list CATSelectTimer $varname]
+ }
+ 2 {
+ foreach mm $var(blink,marker) {
+ if {[info commands $var(frame)] != {}} {
+ if {[$var(frame) has fits]} {
+ $var(frame) marker catalog $mm unhighlite
+ }
+ }
+ }
+ set var(blink) 1
+
+ after 250 [list CATSelectTimer $varname]
+ }
+ }
+}
+
+# Marker Callbacks
+# call backs can't call other procs
+proc CATHighliteCB {tag id} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATHighliteCB $tag $id"
+ }
+
+ set t [split $tag .]
+ set varname [lindex $t 0]
+ set row [lindex $t 1]
+
+ upvar #0 $varname var
+ global $varname
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ if {!$var(blink)} {
+ if {[info exists ${varname}(tbl)]} {
+ $var(tbl) selection set $row,1
+ $var(tbl) see $row,1
+ }
+ }
+}
+
+proc CATUnhighliteCB {tag id} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATUnhighliteCB $tag $id"
+ }
+
+ set t [split $tag .]
+ set varname [lindex $t 0]
+ set row [lindex $t 1]
+
+ upvar #0 $varname var
+ global $varname
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ if {!$var(blink)} {
+ if {[info exists ${varname}(tbl)]} {
+ $var(tbl) selection clear $row,1
+ }
+ }
+}
+
+proc CATEditCB {tag id} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATEditCB $tag $id"
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ set t [split $tag .]
+ set varname [lindex $t 0]
+ set row [lindex $t 1]
+ set szcol [lindex $t 2]
+ set sz2col [lindex $t 3]
+ set units [lindex $t 4]
+ set angcol [lindex $t 5]
+
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ # shape
+ set shape [$var(frame) get marker catalog $id type]
+
+ # skyformat
+ switch -- $units {
+ degrees -
+ arcmin -
+ arcsec {
+ set skyformat $units
+ }
+ default {
+ set skyformat degrees
+ }
+ }
+
+ # get center and format
+ switch $shape {
+ circle {
+ if {$szcol>0} {
+ set rr [$var(frame) get marker catalog $id $shape radius \
+ $var(psystem) $skyformat]
+ starbase_set $var(tbldb) $row $szcol $rr
+ }
+ }
+ ellipse -
+ box {
+ if {$szcol>0 && $sz2col>0} {
+ set rr [$var(frame) get marker catalog $id $shape radius \
+ $var(psystem) $skyformat]
+ starbase_set $var(tbldb) $row $szcol [lindex $rr 0]
+ starbase_set $var(tbldb) $row $sz2col [lindex $rr 1]
+ }
+ }
+ vector {
+ if {$szcol>0} {
+ set ll [$var(frame) get marker catalog $id $shape length \
+ $var(psystem) $skyformat]
+ starbase_set $var(tbldb) $row $szcol $ll
+ }
+
+ if {$angcol>0} {
+ set ang [$var(frame) get marker catalog $id angle \
+ $var(psystem) $p(sky)]
+ starbase_set $var(tbldb) $row $angcol $ang
+ }
+ }
+ default {}
+ }
+}
+
+proc CATMoveCB {tag id} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATMoveCB $tag $id"
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ set t [split $tag .]
+ set varname [lindex $t 0]
+ set row [lindex $t 1]
+
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ # center
+ set coord [$var(frame) get marker catalog $id center \
+ $var(psystem) $var(sky) degrees]
+
+ starbase_set $var(tbldb) $row [starbase_colnum $var(tbldb) $var(colx)] \
+ [lindex $coord 0]
+ starbase_set $var(tbldb) $row [starbase_colnum $var(tbldb) $var(coly)] \
+ [lindex $coord 1]
+}
+
+proc CATRotateCB {tag id} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATRotateCB $tag $id"
+ }
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATMoveCB $tag $id"
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ set t [split $tag .]
+ set varname [lindex $t 0]
+ set row [lindex $t 1]
+ set angcol [lindex $t 2]
+
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ # shape
+ set shape [$var(frame) get marker catalog $id type]
+
+ # get center and format
+ switch $shape {
+ ellipse -
+ box {
+ if {$angcol>0} {
+ set ang [$var(frame) get marker catalog $id angle \
+ $var(psystem) $var(sky)]
+ starbase_set $var(tbldb) $row $angcol $ang
+ }
+ }
+ default {}
+ }
+}
+
+proc CATDeleteCB {tag id} {
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATDeleteCB $tag $id"
+ }
+}
+
+# Tcl Commands
+
+proc CATButton {which x y} {
+ global imarker
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATButton $which $x $y"
+ }
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # see if we are on a handle
+ set h [$which get marker catalog handle $x $y]
+ set id [lindex $h 0]
+ set imarker(handle) [lindex $h 1]
+
+ if {$imarker(handle)} {
+ $which marker catalog $id edit begin $imarker(handle)
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # else, see if we are on a segment of a polygon
+ set h [$which get marker catalog polygon segment $x $y]
+ set id [lindex $h 0]
+ set segment [lindex $h 1]
+ if {$segment} {
+ $which marker catalog $id create polygon vertex $segment $x $y
+ $which marker catalog $id edit begin $imarker(handle)
+ set imarker(handle) [expr 4+$segment+1]
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # else, see if we are on a marker
+ set id [$which get marker catalog id $x $y]
+ if {$id != 0} {
+ # select
+ if {[$which get marker catalog $id property select]} {
+ $which marker catalog select only $x $y
+ $which marker catalog move begin $x $y
+ set imarker(motion) beginMove
+ return
+ }
+ # highlite
+ if {[$which get marker catalog $id property highlite]} {
+ $which marker catalog $id highlite only
+ $which marker catalog $id move back
+ set imarker(motion) none
+ return
+ }
+ }
+
+ # see if any markers are selected
+ if {[$which get marker catalog select number]>0} {
+ $which marker catalog unselect all
+ set imarker(motion) none
+ return
+ }
+
+ # see if any markers are selected
+ if {[$which get marker catalog highlite number]>0} {
+ $which marker catalog unhighlite all
+ set imarker(motion) none
+ return
+ }
+
+ set imarker(motion) none
+ set imarker(handle) -1
+}
+
+proc CATShift {which x y} {
+ global imarker
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATShift $which $x $y"
+ }
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # see if we are on a handle
+ set h [$which get marker catalog handle $x $y]
+ set id [lindex $h 0]
+ set imarker(handle) [lindex $h 1]
+
+ if {$imarker(handle)} {
+ $which marker catalog $id rotate begin
+ set imarker(motion) beginRotate
+ return
+ }
+
+ # else, see if we are on a marker
+ if {[$which marker catalog select toggle $x $y]} {
+ $which marker catalog move begin $x $y
+ set imarker(motion) beginMove
+ return
+ }
+
+ if {[$which marker catalog highlite toggle $x $y]} {
+ set imarker(motion) none
+ return
+ }
+
+ # else, start a region select
+ $which region catalog select begin $x $y
+ # $which region catalog highlite begin $x $y
+ set imarker(motion) shiftregion
+}
+
+proc CATMotion {which x y} {
+ global imarker
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATMotion $which $x $y"
+ }
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ switch -- $imarker(motion) {
+ none {}
+
+ beginMove -
+ move {
+ $which marker catalog move motion $x $y
+ set imarker(motion) move
+ }
+
+ beginEdit -
+ edit {
+ $which marker catalog edit motion $x $y $imarker(handle)
+ set imarker(motion) edit
+ }
+
+ beginRotate -
+ rotate {
+ $which marker catalog rotate motion $x $y $imarker(handle)
+ set imarker(motion) rotate
+ }
+
+ region -
+ shiftregion {
+ $which region catalog select motion $x $y
+ # $which region catalog highlite motion $x $y
+ }
+ }
+}
+
+proc CATRelease {which x y} {
+ global imarker
+ global samp
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATRelease $which $x $y"
+ }
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ switch -- $imarker(motion) {
+ none {}
+ beginMove -
+ beginRotate {}
+ beginEdit {}
+ move {$which marker catalog move end}
+ edit {$which marker catalog edit end}
+ rotate {$which marker catalog rotate end}
+ region {
+ $which region catalog select end
+ $which region catalog catalog highlite end
+ }
+ shiftregion {
+ $which region catalog select shift end
+ $which region catalog highlite shift end
+ }
+ }
+
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ # plot, stats, samp
+ set rr {}
+ foreach mm [$which get marker catalog highlite] {
+ lappend rr [string trim [lindex [$which get marker catalog $mm tag] 1]]
+ }
+
+ if {$rr != {}} {
+ set rr [lsort $rr]
+ set varname {}
+ set rowlist {}
+ foreach ss $rr {
+ set tt [split $ss {.}]
+ set varr [lindex $tt 0]
+ set row [lindex $tt 1]
+ if {$varname != $varr} {
+ # dump what we have
+ if {$varname != {}} {
+ upvar #0 $varname var
+ global $varname
+
+ # status
+ CATStatusRows $varname $rowlist
+ # plot
+ if {$var(plot)} {
+ PlotHighliteElement $var(plot,var) $rowlist
+ }
+ # samp
+ if {[info exists samp]} {
+ if {$samp(apps,votable) != {}} {
+ SAMPSendTableRowListCmd $varname $rowlist
+ }
+ }
+ }
+
+ # now a new list
+ set varname $varr
+ set rowlist {}
+ }
+ lappend rowlist $row
+ }
+
+ if {$varname != {}} {
+ upvar #0 $varname var
+ global $varname
+
+ # status
+ CATStatusRows $varname $rowlist
+ #plot
+ if {$var(plot)} {
+ PlotHighliteElement $var(plot,var) $rowlist
+ }
+ # samp
+ if {[info exists samp]} {
+ if {$samp(apps,votable) != {}} {
+ SAMPSendTableRowListCmd $varname $rowlist
+ }
+ }
+ }
+ }
+}
diff --git a/ds9/library/catcxc.tcl b/ds9/library/catcxc.tcl
new file mode 100644
index 0000000..6580650
--- /dev/null
+++ b/ds9/library/catcxc.tcl
@@ -0,0 +1,390 @@
+# 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 CATCXC {varname} {
+ upvar #0 $varname var
+ global $varname
+ global pcat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCXC $varname"
+ }
+
+ # go for votable or tsv
+ if {$pcat(vot)} {
+ CATCXCVOT $varname
+ } else {
+ CATCXCTSV $varname
+ }
+}
+
+proc CATCXCVOT {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCXCVOT $varname"
+ }
+
+ set var(proc,parser) VOTParse
+
+ # coord (degrees)
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ set xx [h2d [Sex2H $var(x)]]
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ # size (degrees)
+ switch $var(rformat) {
+ degrees {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ # output
+ if {$var(allcols)} {
+ set type 3
+ } else {
+ set type 2
+ }
+
+ # query
+ set var(query) [http::formatQuery RA $xx DEC $yy SR $rr VERB $type]
+ set var(url) "http://cda.cfa.harvard.edu/cscvo/coneSearch"
+
+ CATLoad $varname
+}
+
+proc CATCXCTSV {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATCXCTSV $varname"
+ }
+
+ set var(proc,reader) CATCXCReader
+
+ # coord (degrees)
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ switch -- $var(sky) {
+ fk4 -
+ fk5 -
+ icrs {set xx [h2d [Sex2H $var(x)]]}
+ galactic -
+ ecliptic {set xx [Sex2D $var(x)]}
+ }
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ # size (arcmin)
+ switch $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcmin {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcsec {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ # output
+ if {$var(allcols)} {
+ set type observation
+ } else {
+ set type master
+ }
+
+ # query
+ set var(query) "ra=$xx&dec=$yy&sr=$rr&type=$type"
+
+ # rows
+ if {!$var(allrows)} {
+ append var(query) "&rows=$var(max)"
+ }
+
+ set var(url) "http://cda.cfa.harvard.edu/cscds9/coneSearch"
+
+ CATLoadIncr $varname
+}
+
+proc CATCXCReader {t sock token} {
+ upvar #0 $t T
+ global $t
+
+ set result 0
+
+ if { ![info exists ${t}(state)] } {
+ set T(state) 0
+ }
+
+ switch -- $T(state) {
+ 0 {
+ # init db
+ fconfigure $sock -blocking 1
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) 1
+ }
+
+ 1 {
+ # process header
+ if {[gets $sock line] == -1} {
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) -1
+ return $result
+ }
+
+ set result [string length "$line"]
+
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) $line
+
+ if {[regexp -- {^ *(-)+ *(\t *(-)+ *)*} $line]} {
+ # clean up header column name
+ set hh $T(H_[expr $n-1])
+ regsub -all {\[} $hh {} hh
+ regsub -all {\]} $hh {} hh
+ set T(H_[expr $n-1]) $hh
+
+ # cols
+ set T(Header) [split $T(H_[expr $n-1]) "\t"]
+ set T(Dashes) [split $T(H_$n) "\t"]
+ set T(Ndshs) [llength $T(Dashes)]
+ starbase_colmap $t
+ set T(state) 2
+
+ # these are hard coded
+ set T(Id) $T(Header)
+ set T(DataType) {}
+ set T(ArraySize) {}
+ set T(Unit) {}
+ set T(Ucd) {}
+ # name
+ lappend T(DataType) {char}
+ lappend T(ArraySize) {*}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # ra
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {deg}
+ lappend T(Ucd) {pos.eq.ra;meta.main}
+ # dec
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {deg}
+ lappend T(Ucd) {pos.eq.dec;meta.main}
+ # err_ellipse_r0
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # err_ellipse_r1
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # err_ellipse_ang
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {deg}
+ lappend T(Ucd) {}
+ # conf_flag
+ lappend T(DataType) {boolean}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # extent_flag
+ lappend T(DataType) {boolean}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # sat_src_flag
+ lappend T(DataType) {boolean}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # flux_aper90_b
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # flux_aper90_hilim_b
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # flux_aper90_lolim_b
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # significance
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # hard_hm
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # hard_ms
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # var_intra_index_b
+ lappend T(DataType) {int}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ # var_inter_index_b
+ lappend T(DataType) {int}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+
+ if {[llength $T(Header)] > 17} {
+ # obsid
+ lappend T(DataType) {int}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # ra_aper
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {deg}
+ lappend T(Ucd) {}
+ # dec_aper
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {deg}
+ lappend T(Ucd) {}
+ # mjr_axis_aper
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # mnr_axis_aper
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {}
+ lappend T(Ucd) {}
+ # pos_angle_aper
+ lappend T(DataType) {float}
+ lappend T(ArraySize) {}
+ lappend T(Unit) {deg}
+ lappend T(Ucd) {}
+ }
+ }
+ }
+
+ 2 {
+ # process table
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ } else {
+ set result [string length "$line"]
+ set line [string trim $line]
+
+ if {$line != {}} {
+ # ok, save it
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols $t]
+ set c 1
+ foreach val [split $line "\t"] {
+ set T($r,$c) $val
+ incr c
+ }
+ for {} {$c <= $NCols} {incr c} {
+ set T($r,$c) {}
+ }
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+proc CATCXCAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for CXC
+
+Request for Acknowledgment of Use of the Chandra Source Catalog
+
+Users are kindly requested to acknowledge in the acknowledgment
+section of any resulting publications their use of the Chandra Source
+Catalog.
+
+This will help us greatly to keep track of catalog usage, information
+that is essential for providing full accountability of our work and
+services, as well as for planning future services.
+
+The following language is suggested:
+
+This research has made use of data obtained from the Chandra Source
+Catalog, provided by the Chandra X-ray Center (CXC) as part of the
+Chandra Data Archive.
+
+We would like to remind you that it is also very helpful for us if you
+could include Dataset Identifiers in the manuscript. The Dataset
+Identifier for the Chandra Source Catalog is:
+
+ADS/Sa.CXO#CSC
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 10 insert top $msg
+}
diff --git a/ds9/library/catdialog.tcl b/ds9/library/catdialog.tcl
new file mode 100644
index 0000000..8e0096d
--- /dev/null
+++ b/ds9/library/catdialog.tcl
@@ -0,0 +1,1302 @@
+# 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
+
+# used by backup
+proc CATDialog {varname format catalog title action} {
+ global cat
+ global icat
+ global pcat
+ global ds9
+
+ global pds9
+ global wcs
+
+ # first determine if aready in use, then increment
+ if {[lsearch $icat(cats) $varname] >= 0} {
+ incr cat(id)
+ append varname $cat(id)
+ }
+
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATDialog $varname:$format:$catalog:$title:$action"
+ }
+
+ # main dialog
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ global current
+ if {$current(frame) == {}} {
+ return
+ }
+
+ # AR variables
+ ARInit $varname CATServer
+
+ # CAT variables
+ lappend icat(cats) $varname
+
+ set var(catdb) ${varname}catdb
+ set var(tbldb) ${varname}tbldb
+ set var(symdb) ${varname}symdb
+ set var(symdl) ${varname}symdl
+ set var(fltdl) ${varname}fltdl
+
+ set var(frame) $current(frame)
+
+ set var(server) $pcat(server)
+ set var(loc) $pcat(loc)
+
+ set var(system) $wcs(system)
+ set var(sky) $wcs(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $icat(rformat)
+ set var(width) $icat(width)
+ set var(height) $icat(height)
+ set var(max) $icat(max)
+ set var(allrows) $icat(allrows)
+ set var(allcols) $icat(allcols)
+ set var(show) $icat(show)
+ set var(edit) $icat(edit)
+ set var(panto) $icat(panto)
+
+ set var(psystem) $var(system)
+ set var(psky) $var(sky)
+
+ set var(blink) 0
+ set var(blink,count) 0
+ set var(blink,marker) {}
+
+ set var(plot) 0
+ set var(plot,var) {}
+ set var(plot,x) {}
+ set var(plot,xerr) {}
+ set var(plot,y) {}
+ set var(plot,yerr) {}
+
+ CATSet $varname $format $catalog $title
+ CATSymDBInit $varname
+
+ # create the window
+ set w $var(top)
+ set mb $var(mb)
+
+ set tt $title
+
+ Toplevel $w $mb 7 $tt "CATDestroy $varname"
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+ CATServerMenu $varname
+ NSVRServerMenu $varname
+ $mb add cascade -label [msgcat::mc {Symbol}] -menu $mb.symbol
+ $mb add cascade -label [msgcat::mc {Preferences}] -menu $mb.prefs
+
+ # file
+ menu $mb.file
+ $mb.file add command -label "[msgcat::mc {Load}]..." \
+ -command [list CATLoadVOTFile $varname]
+ $mb.file add command -label "[msgcat::mc {Save}]..." \
+ -command [list CATSaveVOTFile $varname]
+ $mb.file add separator
+ $mb.file add cascade -label [msgcat::mc {Import}] -menu $mb.file.import
+ $mb.file add cascade -label [msgcat::mc {Export}] -menu $mb.file.export
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Retrieve}] \
+ -command [list CATApply $varname 0]
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command [list ARCancel $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Filter}] \
+ -command [list CATTable $varname]
+ $mb.file add command -label [msgcat::mc {Clear}] \
+ -command [list CATOff $varname]
+ $mb.file add separator
+ $mb.file add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(show) -command [list CATGenerate $varname]
+ $mb.file add checkbutton -label [msgcat::mc {Edit}] \
+ -variable ${varname}(edit) -command [list CATEdit $varname]
+ $mb.file add separator
+ $mb.file add cascade -label [msgcat::mc {SAMP}] -menu $mb.file.samp
+ $mb.file add command -label [msgcat::mc {Plot}] \
+ -command [list CATPlot $varname]
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Display Header}]..." \
+ -command [list CATHeader $varname]
+ $mb.file add command -label [msgcat::mc {Acknowledgment}] \
+ -command [list CATAck $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Update from Current Frame}] \
+ -command [list CATUpdate $varname]
+ $mb.file add command \
+ -label [msgcat::mc {Update from Current Crosshair}] \
+ -command [list CATCrosshair $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Copy to Regions}] \
+ -command [list CATGenerateRegions $varname]
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Print}]..." \
+ -command [list CATPrint $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command [list CATDestroy $varname]
+
+ # Import
+ menu $mb.file.import
+ $mb.file.import add command -label "[msgcat::mc {Starbase}]..." \
+ -command [list CATLoadSBFile $varname]
+ $mb.file.import add command -label "[msgcat::mc {Tab-Separated-Value}]..." \
+ -command [list CATLoadTSVFile $varname]
+
+ # Export
+ menu $mb.file.export
+ $mb.file.export add command -label "[msgcat::mc {Starbase}]..." \
+ -command [list CATSaveSBFile $varname]
+ $mb.file.export add command -label "[msgcat::mc {Tab-Separated-Value}]..." \
+ -command [list CATSaveTSVFile $varname]
+
+ # SAMP
+ menu $mb.file.samp
+ $mb.file.samp add command -label [msgcat::mc {Connect}] \
+ -command SAMPConnect
+ $mb.file.samp add command -label [msgcat::mc {Disconnect}] \
+ -command SAMPDisconnect
+ $mb.file.samp add separator
+ $mb.file.samp add cascade -label [msgcat::mc {Send}] \
+ -menu $mb.file.samp.send
+
+ menu $mb.file.samp.send
+ $mb.file.samp.send add command -label [msgcat::mc {Broadcast}] \
+ -command [list SAMPSendTableLoadVotable {} $varname]
+ $mb.file.samp.send add separator
+
+ # edit
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -command "CATCut $varname" -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command "CATCopy $varname" -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -command "EntryPaste $var(top)" -accelerator "${ds9(ctrl)}V"
+ $mb.edit add separator
+ $mb.edit add command -label [msgcat::mc {Clear}] \
+ -command [list ARClear $varname]
+
+ # symbol
+ global $var(symdb)
+ set flt $var(symdb)
+ set sn [starbase_colnum $var(symdb) shape]
+ set cn [starbase_colnum $var(symdb) color]
+ set wn [starbase_colnum $var(symdb) width]
+ set dn [starbase_colnum $var(symdb) dash]
+ set fn [starbase_colnum $var(symdb) font]
+ set fs [starbase_colnum $var(symdb) fontsize]
+ set fw [starbase_colnum $var(symdb) fontweight]
+ set fl [starbase_colnum $var(symdb) fontslant]
+
+ menu $mb.symbol
+ $mb.symbol add cascade -label [msgcat::mc {Shape}] -menu $mb.symbol.shape
+ $mb.symbol add cascade -label [msgcat::mc {Color}] -menu $mb.symbol.color
+ $mb.symbol add cascade -label [msgcat::mc {Width}] -menu $mb.symbol.width
+ $mb.symbol add cascade -label [msgcat::mc {Font}] -menu $mb.symbol.font
+ $mb.symbol add separator
+ $mb.symbol add command -label "[msgcat::mc {Advanced}]..." \
+ -command [list CATSymDialog $varname]
+
+ menu $mb.symbol.shape
+ $mb.symbol.shape add radiobutton -label [msgcat::mc {Circle}] \
+ -variable ${flt}(1,$sn) -value circle \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape add radiobutton -label [msgcat::mc {Ellipse}] \
+ -variable ${flt}(1,$sn) -value ellipse \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape add radiobutton -label [msgcat::mc {Box}] \
+ -variable ${flt}(1,$sn) -value box \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape add radiobutton -label [msgcat::mc {Text}] \
+ -variable ${flt}(1,$sn) -value text \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape add cascade -label [msgcat::mc {Point}] \
+ -menu $mb.symbol.shape.point
+
+ menu $mb.symbol.shape.point
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {Circle}] \
+ -variable ${flt}(1,$sn) -value {circle point} \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {Box}] \
+ -variable ${flt}(1,$sn) -value {box point} \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {Diamond}] \
+ -variable ${flt}(1,$sn) -value {diamond point} \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {Cross}] \
+ -variable ${flt}(1,$sn) -value {cross point} \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {X}] \
+ -variable ${flt}(1,$sn) -value {x point} \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {Arrow}] \
+ -variable ${flt}(1,$sn) -value {arrow point} \
+ -command [list CATGenerate $varname]
+ $mb.symbol.shape.point add radiobutton -label [msgcat::mc {BoxCircle}]\
+ -variable ${flt}(1,$sn) -value {boxcircle point} \
+ -command [list CATGenerate $varname]
+
+ ColorMenu $mb.symbol.color $flt 1,$cn [list CATGenerate $varname]
+
+ WidthDashMenu $mb.symbol.width $flt 1,$wn 1,$dn \
+ [list CATGenerate $varname] [list CATGenerate $varname]
+
+ FontMenu $mb.symbol.font $flt 1,$fn 1,$fs 1,$fw 1,$fl \
+ [list CATGenerate $varname]
+
+ menu $mb.prefs
+ $mb.prefs add checkbutton -label [msgcat::mc {Pan To}] \
+ -variable ${varname}(panto)
+ $mb.prefs add separator
+ $mb.prefs add checkbutton -label [msgcat::mc {All Rows}] \
+ -variable ${varname}(allrows)
+ $mb.prefs add checkbutton -label [msgcat::mc {All Columns}] \
+ -variable ${varname}(allcols)
+
+ # Catalog
+ set f [ttk::labelframe $w.cat -text [msgcat::mc {Catalog}] -padding 2]
+
+ ttk::label $f.ttitle -text [msgcat::mc {Name}]
+ ttk::label $f.title -textvariable ${varname}(title) \
+ -relief groove -width 60 -anchor w
+
+ ttk::label $f.tcat -text [msgcat::mc {Identification}]
+ ttk::label $f.cat -textvariable ${varname}(catalog) \
+ -relief groove -width 60 -anchor w
+
+ ttk::label $f.tref -text [msgcat::mc {Reference}]
+ ttk::label $f.ref -text [string range $varname 3 end] \
+ -relief groove -width 13 -anchor w
+
+ ttk::label $f.loctitle -text [msgcat::mc {IAU Location Code}]
+ ttk::entry $f.loc -textvariable ${varname}(loc) -width 7
+
+ grid $f.ttitle $f.title -padx 2 -pady 2 -sticky w
+ grid $f.tcat $f.cat -padx 2 -pady 2 -sticky w
+ grid $f.tref $f.ref -padx 2 -pady 2 -sticky w
+ grid $f.loctitle $f.loc -padx 2 -pady 2 -sticky w
+
+ # Object
+ set f [ttk::labelframe $w.obj -text [msgcat::mc {Object}] -padding 2]
+
+ ttk::label $f.nametitle -text [msgcat::mc {Name}]
+ ttk::entry $f.name -textvariable ${varname}(name) -width 60
+
+ set var(xname) [ttk::label $f.xtitle -text {} -width 1]
+ ttk::entry $f.x -textvariable ${varname}(x) -width 14
+ set var(yname) [ttk::label $f.ytitle -text {} -width 1]
+ ttk::entry $f.y -textvariable ${varname}(y) -width 14
+
+ CoordMenuButton $f.coord $varname system 0 sky skyformat \
+ [list CATWCSMenuUpdate $varname]
+ CoordMenuEnable $f.coord.menu $varname system 0 sky skyformat
+
+ ttk::button $f.update -text [msgcat::mc {Update}] \
+ -command [list CATUpdate $varname]
+
+ ttk::label $f.wtitle -text [msgcat::mc {Width}]
+ ttk::entry $f.w -textvariable ${varname}(width) -width 14
+ ttk::label $f.htitle -text [msgcat::mc {Height}]
+ ttk::entry $f.h -textvariable ${varname}(height) -width 14
+
+ ARRFormat $f.rformat $varname
+
+ grid $f.nametitle $f.name - - - - -padx 2 -pady 2 -sticky w
+ grid $f.xtitle $f.x $f.ytitle $f.y $f.coord $f.update \
+ -padx 2 -pady 2 -sticky w
+ grid $f.wtitle $f.w $f.htitle $f.h $f.rformat -padx 2 -pady 2 -sticky w
+
+ # Param
+ set f [ttk::labelframe $w.param -text [msgcat::mc {Table}] -padding 2]
+
+ ttk::label $f.mfilter -text [msgcat::mc {Filter}]
+ ttk::entry $f.filter -textvariable ${varname}(filter) -width 50
+ ttk::button $f.bfilter -text [msgcat::mc {Edit}] \
+ -command [list CATEditDialog $varname filter $var(catdb)]
+
+ ttk::label $f.msort -text [msgcat::mc {Sort}]
+ set var(sortmenu) [ttk::menubutton $f.sort \
+ -textvariable ${varname}(sort) \
+ -menu $f.sort.menu -width 14]
+ ttk::radiobutton $f.isort -text [msgcat::mc {Increase}] \
+ -variable ${varname}(sort,dir) -value "-increasing" \
+ -command [list CATTable $varname]
+ ttk::radiobutton $f.dsort -text [msgcat::mc {Decrease}] \
+ -variable ${varname}(sort,dir) -value "-decreasing" \
+ -command [list CATTable $varname]
+
+ ttk::label $f.mtitle -text [msgcat::mc {Max Rows}]
+ ttk::entry $f.max -textvariable ${varname}(max) -width 14
+
+ ttk::label $f.ftitle -text [msgcat::mc {Found}]
+ set var(found) [ttk::label $f.found \
+ -width 14 -relief groove -anchor w]
+
+ set var(raname) [ttk::label $f.ra -text {} -width 3]
+ set var(ramenu) [ttk::menubutton $f.ram -textvariable \
+ ${varname}(colx) -menu $f.ram.menu -width 14]
+ set var(decname) [ttk::label $f.dec -text {} -width 3]
+ set var(decmenu) [ttk::menubutton $f.decm -textvariable \
+ ${varname}(coly) -menu $f.decm.menu -width 14]
+
+ CoordMenuButton $f.pcoord $varname psystem 1 psky {} \
+ [list CATColsCmd $varname]
+ CoordMenuEnable $f.pcoord.menu $varname psystem 1 psky {}
+
+ grid $f.mfilter $f.filter - - $f.bfilter \
+ -padx 2 -pady 2 -sticky w
+ grid $f.msort $f.sort $f.isort $f.dsort \
+ -padx 2 -pady 2 -sticky w
+ grid $f.mtitle $f.max $f.ftitle $f.found \
+ -padx 2 -pady 2 -sticky w
+ grid $var(raname) $var(ramenu) $var(decname) $var(decmenu) $f.pcoord \
+ -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(tbldb) \
+ -colorigin 1 \
+ -roworigin 0 \
+ -cols $icat(mincols) \
+ -rows $icat(minrows) \
+ -width -1 \
+ -height -1 \
+ -maxwidth 300 \
+ -maxheight 300 \
+ -titlerows 1 \
+ -xscrollcommand [list $f.xscroll set]\
+ -yscrollcommand [list $f.yscroll set]\
+ -selecttype row \
+ -selectmode extended \
+ -anchor w \
+ -font [font actual TkDefaultFont] \
+ -browsecommand [list CATSelectCmd $varname %s %S] \
+ ]
+
+ 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
+
+ # Status
+ set f [ttk::frame $w.status]
+
+ ttk::label $f.title -text [msgcat::mc {Status}]
+ ttk::label $f.item -textvariable ${varname}(status)
+
+ grid $f.title $f.item -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+
+ ButtonButton $f.load [msgcat::mc {Load}] [list CATLoadVOTFile $varname]
+ ButtonButton $f.save [msgcat::mc {Save}] [list CATSaveVOTFile $varname]
+
+ set var(apply) [ttk::button $f.apply \
+ -text [msgcat::mc {Retrieve}] \
+ -command "CATApply $varname 0"]
+ set var(cancel) [ttk::button $f.cancel -text \
+ [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname" -state disabled]
+ ttk::button $f.filter -text [msgcat::mc {Filter}] \
+ -command [list CATTable $varname]
+ ttk::button $f.clear -text [msgcat::mc {Clear}] \
+ -command [list CATOff $varname]
+ set var(samp) [ttk::button $f.samp \
+ -text [msgcat::mc {SAMP}] \
+ -command "SAMPSendTableLoadVotable {} $varname"]
+ ttk::button $f.plot -text [msgcat::mc {Plot}] \
+ -command [list CATPlot $varname]
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command [list CATDestroy $varname]
+
+ pack $f.apply $f.cancel $f.filter $f.clear $f.samp $f.plot $f.close \
+ -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ ttk::separator $w.stbl -orient horizontal
+ ttk::separator $w.sstatus -orient horizontal
+ pack $w.buttons $w.sstatus $w.status $w.stbl -side bottom -fill x
+ pack $w.cat $w.obj $w.param -side top -fill x
+ pack $w.tbl -side top -fill both -expand true
+
+ # needs to go after sort menu button is defined
+ CATSortMenu $varname
+ CATColsMenu $varname
+ CATColsUpdate $varname
+ switch $var(format) {
+ cds {$mb entryconfig [msgcat::mc {Catalog Server}] -state normal}
+ cxc -
+ ned -
+ skybot -
+ sdss -
+ simbad {
+ $mb entryconfig [msgcat::mc {Catalog Server}] -state disabled
+ }
+ }
+
+ ARCoord $varname
+ CATUpdate $varname
+ CATDialogUpdate $varname
+
+ ARStatus $varname {}
+
+ switch -- $action {
+ apply {CATApply $varname 0}
+ sync {CATApply $varname 1}
+ none {}
+ }
+
+ # return the actual varname
+ return $varname
+}
+
+proc CATDialogUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global samp
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATDialogUpdate $varname"
+ }
+
+ # do we have a db?
+ if {[CATValidDB $var(tbldb)]} {
+ $var(mb).file entryconfig [msgcat::mc {Filter}] -state normal
+ $var(mb).file entryconfig [msgcat::mc {Clear}] -state normal
+ $var(mb).file entryconfig [msgcat::mc {Plot}] -state normal
+ $var(mb).file entryconfig "[msgcat::mc {Display Header}]..." \
+ -state normal
+ $var(mb).file entryconfig [msgcat::mc {Copy to Regions}] -state normal
+ $var(mb).file entryconfig "[msgcat::mc {Print}]..." -state normal
+
+ $var(top).buttons.filter configure -state normal
+ $var(top).buttons.clear configure -state normal
+ $var(top).buttons.plot configure -state normal
+ } else {
+ $var(mb).file entryconfig [msgcat::mc {Filter}] -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Clear}] -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Plot}] -state disabled
+ $var(mb).file entryconfig "[msgcat::mc {Display Header}]..." \
+ -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Copy to Regions}] -stat disabled
+ $var(mb).file entryconfig "[msgcat::mc {Print}]..." -state disabled
+
+ $var(top).buttons.filter configure -state disabled
+ $var(top).buttons.clear configure -state disabled
+ $var(top).buttons.plot configure -state disabled
+ }
+
+ set m $var(mb).file.samp
+ set ss [expr $ds9(menu,start)+2]
+
+ if {[info exists samp]} {
+ # menu
+ $m entryconfig [msgcat::mc {Send}] -state normal
+ $m entryconfig [msgcat::mc {Connect}] -state disabled
+ $m entryconfig [msgcat::mc {Disconnect}] -state normal
+
+ if {[$m.send index end] >= $ss} {
+ $m.send delete $ss end
+ }
+
+ foreach args $samp(apps,votable) {
+ foreach {id name} $args {
+ $m.send add command -label $name \
+ -command "SAMPSendTableLoadVotable $id $varname"
+ }
+ }
+
+ # button
+ $var(samp) configure -state normal
+ } else {
+ # menu
+ $m entryconfig [msgcat::mc {Send}] -state disabled
+ $m entryconfig [msgcat::mc {Connect}] -state normal
+ $m entryconfig [msgcat::mc {Disconnect}] -state disabled
+
+ # button
+ $var(samp) configure -state disabled
+ }
+
+}
+
+proc CATAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ switch $var(format) {
+ cds {CATCDSAck $varname}
+ cxc {CATCXCAck $varname}
+ ned {CATNEDAck $varname}
+ skybot {CATSkyBotAck $varname}
+ sdss {CATSDSSAck $varname}
+ simbad {CATSIMBADAck $varname}
+ }
+}
+
+proc CATApply {varname sync} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATApply $varname $sync"
+ }
+
+ if {$var(catalog) == {}} {
+ Error [msgcat::mc {No Catalog specified}]
+ return
+ }
+
+ set var(sync) $sync
+ ARApply $varname
+ if {$var(name) != {}} {
+ set var(sky) fk5
+ CoordMenuButtonCmd $varname system sky {}
+ CATWCSMenuUpdate $varname
+
+ NSVRServer $varname
+ } else {
+ CATServer $varname
+ }
+}
+
+proc CATCopy {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set w [focus -displayof $var(top)]
+ if {$w == $var(tbl)} {
+ CATCopyTable $varname
+ } else {
+ EntryCopy $var(top)
+ }
+}
+
+proc CATCut {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set w [focus -displayof $var(top)]
+ if {$w == $var(tbl)} {
+ CATCopyTable $varname
+ } else {
+ EntryCut $var(top)
+ }
+}
+
+proc CATCopyTable {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set w [focus -displayof $var(top)]
+
+ set sel [$var(tbl) curselection]
+ set data {}
+ set row [lindex [split [lindex $sel 0] ,] 0]
+ foreach ss $sel {
+ set rr [lindex [split $ss ,] 0]
+ if {$rr != $row} {
+ append data "\n"
+ set row $rr
+ } else {
+ if {$data != {}} {
+ append data "\t"
+ }
+ }
+ append data "[$var(tbl) get $ss]"
+ }
+ append data "\n"
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
+}
+
+proc CATCrosshair {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ if {[$var(frame) has wcs equatorial $var(system)]} {
+ set coord [$var(frame) get crosshair \
+ $var(system) $var(sky) $var(skyformat)]
+ set var(x) [lindex $coord 0]
+ set var(y) [lindex $coord 1]
+ set var(name) {}
+ }
+}
+
+proc CATDestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ global $var(tbldb)
+ global $var(symdb)
+ global $var(symdl)
+ global icat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATDestroy $varname"
+ }
+
+ # stop timer if needed
+ if {$var(blink)} {
+ set var(blink) 0
+ after cancel [list CATSelectTimer $varname]
+ }
+
+ # frame may have been deleted
+ if {[info commands $var(frame)] != {}} {
+ # unhighlite any makers
+ if {[$var(frame) has fits]} {
+ $var(frame) marker catalog $varname unhighlite
+ }
+ }
+
+ upvar #0 $var(symdl) svar
+ if {[info exists svar(top)]} {
+ if {[winfo exists $svar(top)]} {
+ CATSymDestroy $var(symdl)
+ }
+ }
+
+ if {[info exists $var(symdb)]} {
+ unset $var(symdb)
+ }
+ if {[info exists $var(tbldb)]} {
+ unset $var(tbldb)
+ }
+ if {[info exists $var(catdb)]} {
+ unset $var(catdb)
+ }
+
+ set ii [lsearch $icat(cats) $varname]
+ if {$ii>=0} {
+ set icat(cats) [lreplace $icat(cats) $ii $ii]
+ }
+
+ # plot window?
+ if {$var(plot)} {
+ PlotDestroy $var(plot,var)
+ }
+
+ ARDestroy $varname
+}
+
+proc CATEdit {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ $var(frame) marker catalog unselect all
+ $var(frame) marker catalog unhighlite all
+
+ CATGenerate $varname
+
+ # regenerate the plot if needed
+ if {$var(plot)} {
+ CATPlotGenerate $varname
+ }
+
+ if {$var(edit)} {
+ $var(tbl) configure \
+ -state normal \
+ -selectmode single
+ } else {
+ $var(tbl) configure \
+ -state disabled \
+ -selectmode extended
+ }
+}
+
+proc CATGetHeader {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ set t $var(tbldb)
+ upvar #0 $t T
+
+ if {[CATValidDB $var(tbldb)]} {
+ set hdr {}
+
+ # header
+ set nl [expr $T(HLines)-2]
+ for {set ll 1} {$ll <= $nl} {incr ll} {
+ append hdr "$T(H_$ll)\n"
+ }
+ append hdr "\n"
+
+ # dump cols stats
+ set nc $T(Ncols)
+ for {set cc 1} {$cc <= $nc} {incr cc} {
+ append hdr "# name=[lindex $T(Header) [expr $cc-1]] "
+ if {[info exists ${t}(DataType)]} {
+ append hdr "datatype=[lindex $T(DataType) [expr $cc-1]] "
+ }
+
+ if {[info exists ${t}(Id)]} {
+ if {[lindex $T(Id) [expr $cc-1]] != {}} {
+ append hdr "id=[lindex $T(Id) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(ArraySize)]} {
+ if {[lindex $T(ArraySize) [expr $cc-1]] != {}} {
+ append hdr "arraysize=[lindex $T(ArraySize) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(Width)]} {
+ if {[lindex $T(Width) [expr $cc-1]] != {}} {
+ append hdr "width=[lindex $T(Width) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(Precision)]} {
+ if {[lindex $T(Precision) [expr $cc-1]] != {}} {
+ append hdr "precision=[lindex $T(Precision) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(Unit)]} {
+ if {[lindex $T(Unit) [expr $cc-1]] != {}} {
+ append hdr "unit=[lindex $T(Unit) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(Ref)]} {
+ if {[lindex $T(Ref) [expr $cc-1]] != {}} {
+ append hdr "ref=[lindex $T(Ref) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(Ucd)]} {
+ if {[lindex $T(Ucd) [expr $cc-1]] != {}} {
+ append hdr "ucd=[lindex $T(Ucd) [expr $cc-1]] "
+ }
+ }
+
+ if {[info exists ${t}(Description)]} {
+ if {[lindex $T(Description) [expr $cc-1]] != {}} {
+ append hdr "[lindex $T(Description) [expr $cc-1]] "
+ }
+ }
+ append hdr "\n"
+ }
+
+ return $hdr
+ }
+ return {}
+}
+
+proc CATHeader {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ SimpleTextDialog ${varname}hdr "$var(title) [msgcat::mc {Header}]" \
+ 80 20 insert top [CATGetHeader $varname]
+}
+
+proc CATKey {which key} {
+ global icat
+ global ds9
+
+ set icat(key) $key
+ set icat(key,update) {}
+
+ $which marker catalog key
+ foreach rr $icat(key,update) {
+ eval "CATGenerateUpdate [lindex $rr 0] [lindex $rr 1]"
+ }
+
+ set icat(key) {}
+ set icat(key,update) {}
+}
+
+proc CATPageSetup {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ switch $ds9(wm) {
+ x11 -
+ aqua {}
+ win32 {win32 pm pagesetup}
+ }
+}
+
+proc CATPrint {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ global ds9
+ switch $ds9(wm) {
+ x11 -
+ aqua -
+ win32 {CATPSPrint $varname}
+ wwin32 {win32 pm print text [::textutil::tabify::untabify2 [starbase_write_ $var(tbldb)] 12]}
+ }
+}
+
+proc CATPSPrint {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[PRPrintDialog]} {
+ if {[catch {CATPostScript $varname} printError]} {
+ Error "[msgcat::mc {An error has occurred while printing}] $printError"
+ }
+ }
+}
+
+proc CATPostScript {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ global ps
+
+ if {$ps(dest) == "file"} {
+ set ch [open "| cat > $ps(filename,txt)" w]
+ } else {
+ set ch [open "| $ps(cmd)" w]
+ }
+
+ starbase_writefp $var(tbldb) $ch
+ close $ch
+}
+
+proc CATServer {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATServer $varname"
+ }
+
+ if {($var(x) != {}) &&
+ ($var(y) != {}) &&
+ ($var(width) != {}) &&
+ ($var(height) != {})} {
+
+ ARStatus $varname "Searching [string range $var(title) 0 50]"
+
+ switch $var(format) {
+ cds {CATCDS $varname}
+ cxc {CATCXC $varname}
+ ned {CATNED $varname}
+ skybot {CATSkyBot $varname}
+ sdss {CATSDSS $varname}
+ simbad {CATSIMBAD $varname}
+ }
+ } else {
+ ARError $varname [msgcat::mc {Please specify width, height, and either name or (ra,dec)}]
+ }
+}
+
+proc CATUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATUpdate $varname"
+ }
+
+ if {[info commands $var(frame)] == {}} {
+ return
+ }
+
+ if {![$var(frame) has fits]} {
+ return
+ }
+
+ if {[$var(frame) has wcs equatorial $var(system)]} {
+ set coord [$var(frame) get fits center \
+ $var(system) $var(sky) $var(skyformat)]
+ set var(x) [lindex $coord 0]
+ set var(y) [lindex $coord 1]
+
+ set size [$var(frame) get fits size \
+ $var(system) $var(sky) $var(rformat)]
+ set var(width) [lindex $size 0]
+ set var(height) [lindex $size 1]
+ set var(name) {}
+ }
+}
+
+proc CATWCSMenuUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARCoord $varname
+
+ set var(psystem) $var(system)
+ set var(psky) $var(sky)
+ CoordMenuButtonCmd $varname psystem psky {}
+ CATColsUpdate $varname
+}
+
+proc CATColsUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global pds9
+
+ switch $var(psystem) {
+ image -
+ physical -
+ detector -
+ amplifier {
+ $var(raname) configure -text {X} \
+ -font [font actual TkDefaultFont]
+ $var(decname) configure -text {Y} \
+ -font [font actual TkDefaultFont]
+ }
+ default {
+ if {[$var(frame) has wcs equatorial $var(psystem)]} {
+ switch $var(psky) {
+ fk4 -
+ fk5 -
+ icrs {
+ $var(raname) configure -text "\u03b1" \
+ -font "$ds9(times) $pds9(font,size)"
+ $var(decname) configure -text "\u03b4" \
+ -font "$ds9(times) $pds9(font,size)"
+ }
+ galactic {
+ $var(raname) configure -text {l} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ $var(decname) configure -text {b} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ }
+ ecliptic {
+ $var(raname) configure -text "\u03bb" \
+ -font "$ds9(times) $pds9(font,size)"
+ $var(decname) configure -text "\u03b2" \
+ -font "$ds9(times) $pds9(font,size)"
+ }
+ }
+ } else {
+ $var(raname) configure -text {X} \
+ -font [font actual TkDefaultFont]
+ $var(decname) configure -text {Y} \
+ -font [font actual TkDefaultFont]
+ }
+ }
+ }
+}
+
+# Edit Dialog
+
+proc CATEditDialog {varname which db} {
+ upvar #0 $varname var
+ global $varname
+ global ds9
+ global ed
+
+ set w ".${varname}edit"
+ set mb ".${varname}editmb"
+
+ set ed(ok) 0
+ set ed(text) $w.param.txt
+
+ DialogCreate $w [msgcat::mc {Edit}] ed(ok)
+
+ $w configure -menu $mb
+ menu $mb
+
+ # file
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command {set ed(ok) 1}
+ $mb.file add command -label [msgcat::mc {Clear}] \
+ -command CATEditClear
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load}]..." \
+ -command CATEditLoad
+ $mb.file add command -label "[msgcat::mc {Save}]..." \
+ -command CATEditSave
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command {set ed(ok) 0}
+
+ # edit
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Undo}] \
+ -command "$ed(text) edit undo" -accelerator "${ds9(ctrl)}Z"
+ $mb.edit add command -label [msgcat::mc {Redo}] \
+ -command "$ed(text) edit redo" -accelerator "${ds9(shiftctrl)}Z"
+ $mb.edit add separator
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -command "tk_textCut $ed(text)" -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command "tk_textCopy $ed(text)" -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -command "tk_textPaste $ed(text)" -accelerator "${ds9(ctrl)}V"
+
+ global $db
+ # column
+ $mb add cascade -label [msgcat::mc {Column}] -menu $mb.col
+ if {[info exists $mb.col]} {
+ destroy $mb.col
+ }
+ menu $mb.col
+ if {[CATValidDB $db]} {
+ set cnt -1
+ foreach col [starbase_columns $db] {
+ $mb.col add command -label "$col" \
+ -command "$ed(text) insert insert \{\$$col\}"
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 0
+ $mb.col entryconfig $col -columnbreak 1
+ }
+ }
+ }
+
+ # operator
+ $mb add cascade -label [msgcat::mc {Operator}] -menu $mb.op
+ menu $mb.op
+ $mb.op add command -label {-} \
+ -command "$ed(text) insert insert {-}"
+ $mb.op add command -label {!} \
+ -command "$ed(text) insert insert {!}"
+ $mb.op add command -label {(} \
+ -command "$ed(text) insert insert {(}"
+ $mb.op add command -label {)} \
+ -command "$ed(text) insert insert {)}"
+ $mb.op add separator
+ $mb.op add command -label {*} \
+ -command "$ed(text) insert insert {*}"
+ $mb.op add command -label {/} \
+ -command "$ed(text) insert insert {/}"
+ $mb.op add command -label {%} \
+ -command "$ed(text) insert insert {%}"
+ $mb.op add command -label {+} \
+ -command "$ed(text) insert insert {+}"
+ $mb.op add command -label {-} \
+ -command "$ed(text) insert insert {-}"
+ $mb.op add separator
+ $mb.op add command -label {<} \
+ -command "$ed(text) insert insert {<}"
+ $mb.op add command -label {>} \
+ -command "$ed(text) insert insert {>}"
+ $mb.op add command -label {<=} \
+ -command "$ed(text) insert insert {<=}"
+ $mb.op add command -label {>=} \
+ -command "$ed(text) insert insert {>=}"
+ $mb.op add command -label {==} \
+ -command "$ed(text) insert insert {==}"
+ $mb.op add command -label {!=} \
+ -command "$ed(text) insert insert {!=}"
+ $mb.op add separator
+ $mb.op add command -label {&&} \
+ -command "$ed(text) insert insert {&&}"
+ $mb.op add command -label {||} \
+ -command "$ed(text) insert insert {||}"
+
+ # operator
+ $mb add cascade -label [msgcat::mc {Math Function}] -menu $mb.math
+ menu $mb.math
+ $mb.math add command -label {acos} \
+ -command "$ed(text) insert insert {acos()}"
+ $mb.math add command -label {asin} \
+ -command "$ed(text) insert insert {asin()}"
+ $mb.math add command -label {atan} \
+ -command "$ed(text) insert insert {atan()}"
+ $mb.math add command -label {atan2} \
+ -command "$ed(text) insert insert {atan2(,)}"
+ $mb.math add command -label {ceil} \
+ -command "$ed(text) insert insert {ceil()}"
+ $mb.math add command -label {cos} \
+ -command "$ed(text) insert insert {cos()}"
+ $mb.math add command -label {cosh} \
+ -command "$ed(text) insert insert {cosh()}"
+ $mb.math add command -label {exp} \
+ -command "$ed(text) insert insert {exp()}"
+ $mb.math add command -label {floor} \
+ -command "$ed(text) insert insert {floor()}"
+ $mb.math add command -label {fmod} \
+ -command "$ed(text) insert insert {fmod(,)}"
+ $mb.math add command -label {hypot} \
+ -command "$ed(text) insert insert {hypot(,)}"
+ $mb.math add command -label {log} \
+ -command "$ed(text) insert insert {log()}"
+ $mb.math add command -label {log10} \
+ -command "$ed(text) insert insert {log10()}"
+ $mb.math add command -label {pow} \
+ -command "$ed(text) insert insert {pow(,)}"
+ $mb.math add command -label {sin} \
+ -command "$ed(text) insert insert {sin()}"
+ $mb.math add command -label {sinh} \
+ -command "$ed(text) insert insert {sinh()}"
+ $mb.math add command -label {sqrt} \
+ -command "$ed(text) insert insert {sqrt()}"
+ $mb.math add command -label {tan} \
+ -command "$ed(text) insert insert {tan()}"
+ $mb.math add command -label {tanh} \
+ -command "$ed(text) insert insert {tanh()}"
+ $mb.math add command -label {abs} \
+ -command "$ed(text) insert insert {abs()}"
+ $mb.math add command -label {double} \
+ -command "$ed(text) insert insert {double()}"
+ $mb.math add command -label {int} \
+ -command "$ed(text) insert insert {int()}"
+ $mb.math add command -label {round} \
+ -command "$ed(text) insert insert {round()}"
+
+ # Text
+ set f [ttk::frame $w.param]
+
+ text $f.txt \
+ -height 10 \
+ -width 60 \
+ -yscrollcommand "$f.yscroll set" \
+ -xscrollcommand "$f.xscroll set" \
+ -undo true \
+ -wrap none
+ ttk::scrollbar $f.yscroll -command [list $ed(text) yview] \
+ -orient vertical
+ ttk::scrollbar $f.xscroll -command [list $ed(text) xview] \
+ -orient horizontal
+
+ grid $ed(text) $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.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.clear -text [msgcat::mc {Clear}] -command CATEditClear
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.clear $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ pack $w.param -side top -fill both -expand true
+ pack $w.buttons $w.sep -side bottom -fill x
+
+ $ed(text) insert end $var($which)
+ $ed(text) see end
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+
+ if {$ed(ok)} {
+ set flt [$ed(text) get 1.0 end]
+ catch {regsub {\n} $flt " " flt}
+ set var($which) [string trim $flt]
+ }
+
+ DialogDismiss $w
+ destroy $mb
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc CATEditClear {} {
+ global ed
+
+ $ed(text) delete 1.0 end
+}
+
+proc CATEditSave {} {
+ global ed
+
+ set fn [SaveFileDialog catfltfbox]
+ if {$fn != {}} {
+ if {[catch {open $fn w} fp]} {
+ Error "[msgcat::mc {Unable to open file}] $fn: $fp"
+ return
+ }
+ set flt [$ed(text) get 1.0 end]
+ catch {regsub {\n} $flt " " flt}
+ puts $fp [string trim $flt]
+ catch {close $fp}
+ }
+}
+
+proc CATEditLoad {} {
+ global ed
+
+ set fn [OpenFileDialog catfltfbox]
+ if {$fn != {}} {
+ if {[catch {open $fn r} fp]} {
+ Error "[msgcat::mc {Unable to open file}] $fn: $fp"
+ return
+ }
+ $ed(text) delete 1.0 end
+ $ed(text) insert end [read -nonewline $fp]
+ $ed(text) see end
+ catch {close $fp}
+ }
+}
+
+proc UpdateCATDialog {} {
+ global icat
+
+ foreach varname $icat(cats) {
+ CATDialogUpdate $varname
+ }
+}
+
+
diff --git a/ds9/library/catflt.tcl b/ds9/library/catflt.tcl
new file mode 100644
index 0000000..ba6709c
--- /dev/null
+++ b/ds9/library/catflt.tcl
@@ -0,0 +1,133 @@
+# 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 CATFltSort {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ global $var(tbldb)
+
+ upvar #0 $var(catdb) catsrc
+ upvar #0 $var(tbldb) catdest
+
+ # create header
+ set catdest(Header) $catsrc(Header)
+ starbase_colmap catdest
+
+ set catdest(Ndshs) [llength $catdest(Header)]
+ set catdest(Nrows) 0
+ set catdest(HLines) $catsrc(HLines)
+ set catdest(Dashes) $catsrc(Dashes)
+
+ # optional
+ if {[info exists catsrc(DataType)]} {
+ set catdest(DataType) $catsrc(DataType)
+ }
+ if {[info exists catsrc(Id)]} {
+ set catdest(Id) $catsrc(Id)
+ }
+ if {[info exists catsrc(ArraySize)]} {
+ set catdest(ArraySize) $catsrc(ArraySize)
+ }
+ if {[info exists catsrc(Width)]} {
+ set catdest(Width) $catsrc(Width)
+ }
+ if {[info exists catsrc(Precision)]} {
+ set catdest(Precision) $catsrc(Precision)
+ }
+ if {[info exists catsrc(Unit)]} {
+ set catdest(Unit) $catsrc(Unit)
+ }
+ if {[info exists catsrc(Ref)]} {
+ set catdest(Ref) $catsrc(Ref)
+ }
+ if {[info exists catsrc(Ucd)]} {
+ set catdest(Ucd) $catsrc(Ucd)
+ }
+ if {[info exists catsrc(Description)]} {
+ set catdest(Description) $catsrc(Description)
+ }
+
+ for {set ii 1} {$ii<=$catsrc(HLines)} {incr ii} {
+ set catdest(H_$ii) $catsrc(H_$ii)
+ }
+
+ for {set jj 1} {$jj<=$catsrc(Ncols)} {incr jj} {
+ set catdest(0,$jj) $catsrc(0,$jj)
+ }
+
+ # sort?
+ set order {}
+ if {$var(sort) != {}} {
+ set col $catsrc($var(sort))
+
+ for {set ii 1} {$ii<=$catsrc(Nrows)} {incr ii} {
+ set val $catsrc($ii,$col)
+ # if blank, set to 0
+ if {$val == {}} {
+ set val 0
+ }
+ lappend order "[list $ii $val]"
+ }
+
+ # first try as real, if error, then ascii
+ if {[catch {lsort $var(sort,dir) -real -index 1 $order} oo]} {
+ set oo [lsort $var(sort,dir) -ascii -index 1 $order]
+ }
+ set order $oo
+ } else {
+ for {set ii 1} {$ii<=$catsrc(Nrows)} {incr ii} {
+ lappend order "[list $ii {}]"
+ }
+ }
+
+ # data
+ set kk 0
+ for {set ii 1} {$ii<=$catsrc(Nrows)} {incr ii} {
+ set id [lindex [lindex $order [expr $ii-1]] 0]
+ # now filter
+ set pass 1
+ if {$var(filter) != {}} {
+ # eval all colnames
+ foreach col $catsrc(Header) {
+ set col [string trim $col]
+ set val $catsrc($id,$catsrc($col))
+ # here's a tough one--
+ # what to do if the column is blank
+ # for now, just set it to '0'
+ if {[string trim "$val"] == {}} {
+ set val 0
+ }
+ eval "set \{$col\} \{$val\}"
+ }
+ # subst any columv vars
+ if {[catch {subst $var(filter)} ff]} {
+ return 0
+ }
+ # evaluate filter
+ if {[catch {expr $ff} result]} {
+ return 0
+ }
+ # do we keep the row?
+ if {!$result} {
+ set pass 0
+ }
+ }
+
+ if {$pass} {
+ incr kk
+ for {set jj 1} {$jj<=$catsrc(Ncols)} {incr jj} {
+ set catdest($kk,$jj) $catsrc($id,$jj)
+ }
+ }
+ }
+
+ # success
+ set catdest(Nrows) $kk
+ return 1
+}
+
+
diff --git a/ds9/library/catmatch.tcl b/ds9/library/catmatch.tcl
new file mode 100644
index 0000000..bbd01ba
--- /dev/null
+++ b/ds9/library/catmatch.tcl
@@ -0,0 +1,711 @@
+# 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 CATMatchFrame {} {
+ global icat
+ global current
+
+ # find all cats for frame
+ set cats {}
+ foreach varname $icat(cats) {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(frame) == $current(frame)} {
+ lappend cats $varname
+ }
+ }
+
+ if {[llength $cats] < 2} {
+ Warning [msgcat::mc {At least 2 different catalogs are required}]
+ return
+ }
+
+ if {[CATMatchDialog $cats]} {
+ if {$icat(match1) != {} &&
+ $icat(match2) != {} &&
+ $icat(match1) != $icat(match2)} {
+ CATMatch $current(frame) $icat(match1) $icat(match2)
+ } else {
+ Warning [msgcat::mc {At least 2 different catalogs are required}]
+ }
+ }
+}
+
+proc CATMatchDialog {cats} {
+ global ds9
+ global ed
+ global icat
+
+ set w {.catmat}
+ set mb {.catmatmb}
+
+ set ed(top) $w
+ set ed(mb) $mb
+ set ed(ok) 0
+
+ set ed(match1) [lindex $cats 0]
+ set varname $ed(match1)
+ upvar #0 $varname var
+ global $varname
+ set ed(match1,msg) $var(title)
+
+ set ed(match2) [lindex $cats 1]
+ set varname $ed(match2)
+ upvar #0 $varname var
+ global $varname
+ set ed(match2,msg) $var(title)
+
+ set ed(error) $icat(error)
+ set ed(rformat) $icat(eformat)
+ set ed(function) $icat(function)
+ set ed(unique) $icat(unique)
+ set ed(return) $icat(return)
+
+ DialogCreate $w [msgcat::mc {Match}] ed(ok)
+
+ $w configure -menu $mb
+ menu $mb
+
+ # file
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command {set ed(ok) 1}
+ $mb.file add command -label [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+
+ # edit
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+ EditMenu $mb ed
+
+ # param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.tmatch -text [msgcat::mc {Match}]
+ ttk::menubutton $f.match1 -textvariable ed(match1,msg) -menu $f.match1.menu
+ ttk::label $f.tand -text [msgcat::mc {and}]
+ ttk::menubutton $f.match2 -textvariable ed(match2,msg) -menu $f.match2.menu
+
+ CATMatchDialogCatsMenu $f match1 $cats
+ CATMatchDialogCatsMenu $f match2 $cats
+
+ ttk::label $f.terror -text [msgcat::mc {Error}]
+ ttk::entry $f.error -textvariable ed(error) -width 14
+ ARRFormat $f.eformat ed
+
+ ttk::label $f.tfunction -text [msgcat::mc {Function}]
+ ttk::menubutton $f.function -textvariable ed(function,msg) \
+ -menu $f.function.menu
+ menu $f.function.menu -tearoff 0
+ $f.function.menu add radiobutton -variable ed(function) \
+ -label "1 [msgcat::mc {and}] 2" \
+ -value 1and2 -command [list CATMatchDialogFunctionMenu $f]
+ $f.function.menu add radiobutton -variable ed(function) \
+ -label "1 [msgcat::mc {not}] 2" \
+ -value 1not2 -command [list CATMatchDialogFunctionMenu $f]
+ $f.function.menu add radiobutton -variable ed(function) \
+ -label "2 [msgcat::mc {not}] 1" \
+ -value 2not1 -command [list CATMatchDialogFunctionMenu $f]
+ ttk::checkbutton $f.unique -text [msgcat::mc {Unique}] -variable ed(unique)
+
+ ttk::label $f.treturn -text [msgcat::mc {Return}]
+ ttk::menubutton $f.return -textvariable ed(return,msg) \
+ -menu $f.return.menu
+ menu $f.return.menu -tearoff 0
+ $f.return.menu add radiobutton -variable ed(return) \
+ -label "1 [msgcat::mc {and}] 2" \
+ -value 1and2 -command [list CATMatchDialogReturnMenu $f]
+ $f.return.menu add radiobutton -variable ed(return) \
+ -label "1 [msgcat::mc {only}]" \
+ -value 1only -command [list CATMatchDialogReturnMenu $f]
+ $f.return.menu add radiobutton -variable ed(return) \
+ -label "2 [msgcat::mc {only}]" \
+ -value 2only -command [list CATMatchDialogReturnMenu $f]
+
+ grid $f.tmatch $f.match1 $f.tand $f.match2 -padx 2 -pady 2 -sticky ew
+ grid $f.terror $f.error x $f.eformat -padx 2 -pady 2 -sticky w
+ grid $f.tfunction $f.function x $f.unique -padx 2 -pady 2 -sticky ew
+ grid $f.treturn $f.return -padx 2 -pady 2 -sticky ew
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ pack $w.param -side top -fill both -expand true
+ pack $w.buttons $w.sep -side bottom -fill x
+
+ CATMatchDialogFunctionMenu $w.param
+ CATMatchDialogReturnMenu $w.param
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+
+ if {$ed(ok)} {
+ set icat(match1) $ed(match1)
+ set icat(match2) $ed(match2)
+ set icat(error) $ed(error)
+ set icat(eformat) $ed(rformat)
+ set icat(function) $ed(function)
+ set icat(unique) $ed(unique)
+ set icat(return) $ed(return)
+ }
+
+ DialogDismiss $w
+ destroy $mb
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc CATMatchDialogFunctionMenu {f} {
+ global ed
+
+ switch $ed(function) {
+ 1and2 {
+ $f.unique configure -state normal
+ $f.return configure -state normal
+ set ed(function,msg) "1 [msgcat::mc {and}] 2"
+ }
+ 1not2 {
+ $f.unique configure -state disabled
+ $f.return configure -state disabled
+ set ed(function,msg) "1 [msgcat::mc {not}] 2"
+ }
+ 2not1 {
+ $f.unique configure -state disabled
+ $f.return configure -state disabled
+ set ed(function,msg) "2 [msgcat::mc {not}] 1"
+ }
+ }
+}
+
+proc CATMatchDialogReturnMenu {f} {
+ global ed
+
+ switch $ed(return) {
+ 1and2 {
+ set ed(return,msg) "1 [msgcat::mc {and}] 2"
+ }
+ 1only {
+ set ed(return,msg) "1 [msgcat::mc {only}]"
+ }
+ 2only {
+ set ed(return,msg) "2 [msgcat::mc {only}]"
+ }
+ }
+}
+
+proc CATMatchDialogCatsMenu {f which cats} {
+ global ed
+
+ set m $f.$which.menu
+
+ menu $m -tearoff 0
+ foreach varname $cats {
+ upvar #0 $varname var
+ global $varname
+
+ $m add radiobutton -variable ed($which) -label $var(title) \
+ -value $varname -command [list set ed($which,msg) $var(title)]
+ }
+}
+
+proc CATMatch {frame varname1 varname2} {
+ global icat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATMatch $frame $varname1 $varname2"
+ }
+
+ upvar #0 $varname1 var1
+ global $varname1
+ global $var1(tbldb)
+ set t1 $var1(tbldb)
+ upvar #0 $t1 T1
+
+ upvar #0 $varname2 var2
+ global $varname2
+ global $var2(tbldb)
+ set t2 $var2(tbldb)
+ upvar #0 $t2 T2
+
+ if {![CATValidDB $var1(tbldb)] || ![CATValidDB $var2(tbldb)]} {
+ return
+ }
+
+ if {$T1(Nrows)==0 || $T2(Nrows)==0} {
+ Warning [msgcat::mc {Match Catalog requires at least 1 row per catalog}]
+ return
+ }
+
+ # cat1
+ set nrows1 [starbase_nrows $var1(tbldb)]
+ set cols1 [starbase_columns $var1(tbldb)]
+ set colx1 [starbase_colnum $var1(tbldb) $var1(colx)]
+ set coly1 [starbase_colnum $var1(tbldb) $var1(coly)]
+
+ set nrows2 [starbase_nrows $var2(tbldb)]
+ set cols2 [starbase_columns $var2(tbldb)]
+ set colx2 [starbase_colnum $var2(tbldb) $var2(colx)]
+ set coly2 [starbase_colnum $var2(tbldb) $var2(coly)]
+
+ global xx1 yy1
+ global xx2 yy2
+ global rr
+ set xx1 {}
+ set yy1 {}
+ set xx2 {}
+ set yy2 {}
+ set rr {}
+
+ for {set ii 1} {$ii <= $nrows1} {incr ii} {
+ lappend xx1 [starbase_get $var1(tbldb) $ii $colx1]
+ lappend yy1 [starbase_get $var1(tbldb) $ii $coly1]
+ }
+ for {set jj 1} {$jj <= $nrows2} {incr jj} {
+ lappend xx2 [starbase_get $var2(tbldb) $jj $colx2]
+ lappend yy2 [starbase_get $var2(tbldb) $jj $coly2]
+ }
+
+ global current
+ $current(frame) match xx1 yy1 $var1(system) $var1(sky) \
+ xx2 yy2 $var2(system) $var2(sky) \
+ $icat(error) $var1(system) $icat(eformat) rr
+
+ switch $icat(function) {
+ 1and2 {
+ if {$icat(unique)} {
+ set aa [lsort -index 0 -integer -unique $rr]
+ set rr [lsort -index 1 -integer -unique $aa]
+ } else {
+ set rr [lsort -index 0 -integer $rr]
+ }
+ }
+ 1not2 {}
+ 2not1 {}
+ }
+
+ if {[llength $rr] == 0} {
+ Info [msgcat::mc {No Items Found}]
+ return
+ }
+
+ switch $icat(function) {
+ 1and2 {
+ switch $icat(return) {
+ 1and2 {CATMatchAnd1and2 $varname1 $varname2 rr}
+ 1only {CATMatchAnd1only $varname1 $varname2 rr}
+ 2only {CATMatchAnd2only $varname1 $varname2 rr}
+ }
+
+ }
+ 1not2 {CATMatchNot $varname1 $varname2 rr}
+ 2not1 {CATMatchNot $varname2 $varname1 rr}
+ }
+}
+
+proc CATMatchAnd1and2 {varname1 varname2 rrname} {
+ upvar $rrname rr
+
+ upvar #0 $varname1 var1
+ global $varname1
+ global $var1(tbldb)
+ set t1 $var1(tbldb)
+ upvar #0 $t1 T1
+
+ upvar #0 $varname2 var2
+ global $varname2
+ global $var2(tbldb)
+ set t2 $var2(tbldb)
+ upvar #0 $t2 T2
+
+ set varname [CATDialog catmatch {} {} {} none]
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ set db $var(catdb)
+ upvar #0 $db T
+
+ ARStatus $varname [msgcat::mc {Loading Catalog}]
+
+ CATOff $varname
+ CATSet $varname {} "$var1(catalog) and $var2(catalog)" \
+ "$var1(title) and $var2(title)"
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(width) {}
+ set var(height) {}
+
+ # required
+ set T(Header) $T1(Header)
+ foreach ll $T2(Header) {
+ # make cols unique
+ lappend T(Header) "2_$ll"
+ }
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(Header) {-}]
+ set T(Ndshs) [expr $T1(Ndshs)+$T2(Ndshs)]
+ set T(H_1) $T(Header)
+ set T(H_2) $T(Dashes)
+ set T(HLines) 2
+ set T(Nrows) 0
+ starbase_colmap T
+
+ # optional
+ if {[info exists ${t1}(DataType)]} {
+ set T(DataType) $T1(DataType)
+ if {[info exists ${t2}(DataType)]} {
+ append T(DataType) " $T2(DataType)"
+ }
+ }
+ if {[info exists ${t1}(Id)]} {
+ set T(Id) $T1(Id)
+ if {[info exists ${t2}(Id)]} {
+ append T(Id) " $T2(Id)"
+ }
+ }
+ if {[info exists ${t1}(ArraySize)]} {
+ set T(ArraySize) $T1(ArraySize)
+ if {[info exists ${t2}(ArraySize)]} {
+ append T(ArraySize) " $T2(ArraySize)"
+ }
+ }
+ if {[info exists ${t1}(Width)]} {
+ set T(Width) $T1(Width)
+ if {[info exists ${t2}(Width)]} {
+ append T(Width) " $T2(Width)"
+ }
+ }
+ if {[info exists ${t1}(Precision)]} {
+ set T(Precision) $T1(Precision)
+ if {[info exists ${t2}(Precision)]} {
+ append T(Precision) " $T2(Precision)"
+ }
+ }
+ if {[info exists ${t1}(Unit)]} {
+ set T(Unit) "$T1(Unit) "
+ if {[info exists ${t2}(Unit)]} {
+ append T(Unit) " $T2(Unit)"
+ }
+ }
+ if {[info exists ${t1}(Ref)]} {
+ set T(Ref) $T1(Ref)
+ if {[info exists ${t2}(Ref)]} {
+ append T(Ref) " $T2(Ref)"
+ }
+ }
+ if {[info exists ${t1}(Ucd)]} {
+ set T(Ucd) $T1(Ucd)
+ if {[info exists ${t2}(Ucd)]} {
+ append T(Ucd) " $T2(Ucd)"
+ }
+ }
+ if {[info exists ${t1}(Description)]} {
+ set T(Description) $T1(Description)
+ if {[info exists ${t2}(Description)]} {
+ append T(Description) " $T2(Description)"
+ }
+ }
+
+ set ll 0
+ foreach {r1 r2} [join $rr] {
+ incr ll
+
+ for {set ii 1} {$ii<=$T1(Ncols)} {incr ii} {
+ set T($ll,$ii) $T1($r1,$ii)
+ }
+ for {set jj 1} {$jj<=$T2(Ncols)} {incr jj} {
+ set T($ll,[expr $ii+$jj-1]) $T2($r2,$jj)
+ }
+
+ incr T(Nrows)
+ }
+
+ ARDone $varname
+ CATLoadDone $varname
+}
+
+proc CATMatchAnd1only {varname1 varname2 rrname} {
+ upvar $rrname rr
+
+ upvar #0 $varname1 var1
+ global $varname1
+ global $var1(tbldb)
+ set t1 $var1(tbldb)
+ upvar #0 $t1 T1
+
+ upvar #0 $varname2 var2
+ global $varname2
+ global $var2(tbldb)
+ set t2 $var2(tbldb)
+ upvar #0 $t2 T2
+
+ set varname [CATDialog catmatch {} {} {} none]
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ set db $var(catdb)
+ upvar #0 $db T
+
+ ARStatus $varname [msgcat::mc {Loading Catalog}]
+
+ CATOff $varname
+ CATSet $varname {} "$var1(catalog) and $var2(catalog)" \
+ "$var1(title) and $var2(title)"
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(width) {}
+ set var(height) {}
+
+ # required
+ set T(Header) $T1(Header)
+ set T(Dashes) $T1(Dashes)
+ set T(Ndshs) $T1(Ndshs)
+ set T(HLines) $T1(HLines)
+ for {set ii 1} {$ii<=$T1(HLines)} {incr ii} {
+ set T(H_$ii) $T1(H_$ii)
+ }
+ set T(Nrows) 0
+ starbase_colmap T
+
+ # optional
+ if {[info exists ${t1}(DataType)]} {
+ set T(DataType) $T1(DataType)
+ }
+ if {[info exists ${t1}(Id)]} {
+ set T(Id) $T1(Id)
+ }
+ if {[info exists ${t1}(ArraySize)]} {
+ set T(ArraySize) $T1(ArraySize)
+ }
+ if {[info exists ${t1}(Width)]} {
+ set T(Width) $T1(Width)
+ }
+ if {[info exists ${t1}(Precision)]} {
+ set T(Precision) $T1(Precision)
+ }
+ if {[info exists ${t1}(Unit)]} {
+ set T(Unit) $T1(Unit)
+ }
+ if {[info exists ${t1}(Ref)]} {
+ set T(Ref) $T1(Ref)
+ }
+ if {[info exists ${t1}(Ucd)]} {
+ set T(Ucd) $T1(Ucd)
+ }
+ if {[info exists ${t1}(Description)]} {
+ set T(Description) $T1(Description)
+ }
+
+ set ll 0
+ foreach {r1 r2} [join $rr] {
+ incr ll
+
+ for {set ii 1} {$ii<=$T1(Ncols)} {incr ii} {
+ set T($ll,$ii) $T1($r1,$ii)
+ }
+
+ incr T(Nrows)
+ }
+
+ ARDone $varname
+ CATLoadDone $varname
+}
+
+proc CATMatchAnd2only {varname1 varname2 rrname} {
+ upvar $rrname rr
+
+ upvar #0 $varname1 var1
+ global $varname1
+ global $var1(tbldb)
+ set t1 $var1(tbldb)
+ upvar #0 $t1 T1
+
+ upvar #0 $varname2 var2
+ global $varname2
+ global $var2(tbldb)
+ set t2 $var2(tbldb)
+ upvar #0 $t2 T2
+
+ set varname [CATDialog catmatch {} {} {} none]
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ set db $var(catdb)
+ upvar #0 $db T
+
+ ARStatus $varname [msgcat::mc {Loading Catalog}]
+
+ CATOff $varname
+ CATSet $varname {} "$var1(catalog) and $var2(catalog)" \
+ "$var1(title) and $var2(title)"
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(width) {}
+ set var(height) {}
+
+ # required
+ set T(Header) $T2(Header)
+ set T(Dashes) $T2(Dashes)
+ set T(Ndshs) $T2(Ndshs)
+ set T(HLines) $T2(HLines)
+ for {set ii 1} {$ii<=$T2(HLines)} {incr ii} {
+ set T(H_$ii) $T2(H_$ii)
+ }
+ set T(Nrows) 0
+ starbase_colmap T
+
+ # optional
+ if {[info exists ${t2}(DataType)]} {
+ set T(DataType) $T2(DataType)
+ }
+ if {[info exists ${t2}(Id)]} {
+ set T(Id) $T2(Id)
+ }
+ if {[info exists ${t2}(ArraySize)]} {
+ set T(ArraySize) $T2(ArraySize)
+ }
+ if {[info exists ${t2}(Width)]} {
+ set T(Width) $T2(Width)
+ }
+ if {[info exists ${t2}(Precision)]} {
+ set T(Precision) $T2(Precision)
+ }
+ if {[info exists ${t2}(Unit)]} {
+ set T(Unit) $T2(Unit)
+ }
+ if {[info exists ${t2}(Ref)]} {
+ set T(Ref) $T2(Ref)
+ }
+ if {[info exists ${t2}(Ucd)]} {
+ set T(Ucd) $T2(Ucd)
+ }
+ if {[info exists ${t2}(Description)]} {
+ set T(Description) $T2(Description)
+ }
+
+ set ll 0
+ foreach {r1 r2} [join $rr] {
+ incr ll
+
+ for {set ii 1} {$ii<=$T2(Ncols)} {incr ii} {
+ set T($ll,$ii) $T2($r2,$ii)
+ }
+
+ incr T(Nrows)
+ }
+
+ ARDone $varname
+ CATLoadDone $varname
+}
+
+proc CATMatchNot {varname1 varname2 rrname} {
+ upvar $rrname rr
+
+ upvar #0 $varname1 var1
+ global $varname1
+ global $var1(tbldb)
+ set t1 $var1(tbldb)
+ upvar #0 $t1 T1
+
+ upvar #0 $varname2 var2
+ global $varname2
+ global $var2(tbldb)
+ set t2 $var2(tbldb)
+ upvar #0 $t2 T2
+
+ set varname [CATDialog catmatch {} {} {} none]
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ set db $var(catdb)
+ upvar #0 $db T
+
+ ARStatus $varname [msgcat::mc {Loading Catalog}]
+
+ CATOff $varname
+ CATSet $varname {} "$var1(catalog) and not $var2(catalog)" \
+ "$var1(title) and not $var2(title)"
+
+ set var(name) {}
+ set var(x) {}
+ set var(y) {}
+ set var(width) {}
+ set var(height) {}
+
+ # required
+ set T(Header) $T1(Header)
+ set T(Dashes) $T1(Dashes)
+ set T(Ndshs) $T1(Ndshs)
+ set T(HLines) $T1(HLines)
+ for {set ii 1} {$ii<=$T1(HLines)} {incr ii} {
+ set T(H_$ii) $T1(H_$ii)
+ }
+ set T(Nrows) 0
+ starbase_colmap T
+
+ # optional
+ if {[info exists ${t1}(DataType)]} {
+ set T(DataType) $T1(DataType)
+ }
+ if {[info exists ${t1}(Id)]} {
+ set T(Id) $T1(Id)
+ }
+ if {[info exists ${t1}(ArraySize)]} {
+ set T(ArraySize) $T1(ArraySize)
+ }
+ if {[info exists ${t1}(Width)]} {
+ set T(Width) $T1(Width)
+ }
+ if {[info exists ${t1}(Precision)]} {
+ set T(Precision) $T1(Precision)
+ }
+ if {[info exists ${t1}(Unit)]} {
+ set T(Unit) $T1(Unit)
+ }
+ if {[info exists ${t1}(Ref)]} {
+ set T(Ref) $T1(Ref)
+ }
+ if {[info exists ${t1}(Ucd)]} {
+ set T(Ucd) $T1(Ucd)
+ }
+ if {[info exists ${t1}(Description)]} {
+ set T(Description) $T1(Description)
+ }
+
+ set ss {}
+ foreach {r1 r2} [join $rr] {
+ lappend ss $r1
+ }
+ set ss [lsort -integer -unique $ss]
+
+ set ll 0
+ for {set jj 1} {$jj<=$T1(Nrows)} {incr jj} {
+ if {[lsearch -integer -sorted $ss $jj] == -1} {
+ incr ll
+ for {set ii 1} {$ii<=$T1(Ncols)} {incr ii} {
+ set T($ll,$ii) $T1($jj,$ii)
+ }
+ incr T(Nrows)
+ }
+ }
+
+ ARDone $varname
+ CATLoadDone $varname
+}
diff --git a/ds9/library/catned.tcl b/ds9/library/catned.tcl
new file mode 100644
index 0000000..71d99c0
--- /dev/null
+++ b/ds9/library/catned.tcl
@@ -0,0 +1,212 @@
+# 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 CATNED {varname} {
+ upvar #0 $varname var
+ global $varname
+ global pcat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATNED $varname"
+ }
+
+ # parser
+ if {$pcat(vot)} {
+ set var(proc,parser) VOTParse
+ } else {
+ set var(proc,reader) CATNEDReader
+ }
+
+ # query
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ switch -- $var(sky) {
+ fk4 -
+ fk5 -
+ icrs {set xx [h2d [Sex2H $var(x)]]}
+ galactic -
+ ecliptic {set xx [Sex2D $var(x)]}
+ }
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ switch -- $var(rformat) {
+ degrees {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ if {$pcat(vot)} {
+ set out "xml_main"
+ } else {
+ set out "ascii_tab"
+ }
+
+ switch -- $var(sky) {
+ fk4 {
+ set sky "Equatorial"
+ set eq "B1950.0"
+ }
+ fk5 -
+ icrs {
+ set sky "Equatorial"
+ set eq "J2000.0"
+ }
+ galactic {
+ set sky "Galactic"
+ set eq {}
+ }
+ ecliptic {
+ set sky "Ecliptic"
+ set eq {}
+ }
+ }
+ switch -- $var(psky) {
+ fk4 {
+ set psky "Equatorial"
+ set peq "B1950.0"
+ }
+ fk5 -
+ icrs {
+ set psky "Equatorial"
+ set peq "J2000.0"
+ }
+ galactic {
+ set psky "Galactic"
+ set peq {}
+ }
+ ecliptic {
+ set psky "Ecliptic"
+ set peq {}
+ }
+ }
+
+ # url
+ set var(query) {}
+ set query [http::formatQuery search_type "Near Position Search" RA $xx DEC $yy SR $rr of $out in_csys $sky in_equinox $eq out_csys $psky out_equinox $peq]
+ set var(url) "http://ned.ipac.caltech.edu/cgi-bin/nph-objsearch?$query"
+
+ if {$pcat(vot)} {
+ CATLoad $varname
+ } else {
+ CATLoadIncr $varname
+ }
+}
+
+proc CATNEDReader {t sock token} {
+ upvar #0 $t T
+ global $t
+
+ set result 0
+
+ if { ![info exists ${t}(state)] } {
+ set T(state) 0
+ }
+
+ switch -- $T(state) {
+ 0 {
+ # init db
+ fconfigure $sock -blocking 1
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) 1
+ }
+
+ 1 {
+ # process header
+ if {[gets $sock line] == -1} {
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) -1
+ return $result
+ }
+
+ set result [string length "$line"]
+
+ # start of data?
+ if {[string range $line 0 2] == {No.}} {
+ # cols
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) $line
+ set T(Header) [split $T(H_$n) "\t"]
+
+ # dashes
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+ set T(Ndshs) [llength $T(Dashes)]
+ starbase_colmap $t
+
+ set T(state) 2
+ }
+ }
+
+ 2 {
+ # process table
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ } else {
+ set result [string length "$line"]
+ set line [string trim $line]
+
+ if {$line != {}} {
+ # ok, save it
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols $t]
+ set c 1
+ foreach val [split $line "\t"] {
+ set T($r,$c) $val
+ incr c
+ }
+ for {} {$c <= $NCols} {incr c} {
+ set T($r,$c) {}
+ }
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+proc CATNEDAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for NED
+
+This research has made use of the NASA/IPAC Extragalactic Database (NED)
+which is operated by the Jet Propulsion Laboratory, California Institute
+of Technology, under contract with the National Aeronautics and Space
+Administration.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 10 insert top $msg
+}
diff --git a/ds9/library/catopt.tcl b/ds9/library/catopt.tcl
new file mode 100644
index 0000000..6b03d74
--- /dev/null
+++ b/ds9/library/catopt.tcl
@@ -0,0 +1,57 @@
+# 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
+
+# sample CATKeyCB
+# Allow the user to define callbacks to be called when
+# the user presses a key with selected regions while in edit mode.
+
+if {0} {
+# add to CATReg
+# callback=key CATKeyCB {${varname}.\${ii}.a}
+
+proc CATKeyCB {tag id} {
+ global icat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATKeyCB $tag $id"
+ }
+
+ set t [split $tag .]
+ set varname [lindex $t 0]
+ set row [lindex $t 1]
+ set key [lindex $t 2]
+
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+
+ if {![info exists ${varname}(top)]} {
+ return
+ }
+
+ if {$icat(key) == $key} {
+ switch -- $key {
+ a {
+ puts stderr "Key: $key $row"
+ return
+
+ # column name 'TooManySrcs'
+ set tcol [starbase_colnum $var(tbldb) {TooManySrcs}]
+
+ # toggle between '0' and '1'
+ set tt [starbase_get $var(tbldb) $row $tcol]
+ if {$tt == {1}} {
+ starbase_set $var(tbldb) $row $tcol {0}
+ } else {
+ starbase_set $var(tbldb) $row $tcol {1}
+ }
+ lappend icat(key,update) [list $varname $row]
+ }
+ }
+ }
+}
+}
diff --git a/ds9/library/catplot.tcl b/ds9/library/catplot.tcl
new file mode 100644
index 0000000..298b7a0
--- /dev/null
+++ b/ds9/library/catplot.tcl
@@ -0,0 +1,216 @@
+# 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 CATPlot {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # do we have a db?
+ if {![CATValidDB $var(tbldb)]} {
+ return
+ }
+
+ if {$var(plot,x) == {}} {
+ set var(plot,x) "\$$var(colx)"
+ }
+ if {$var(plot,y) == {}} {
+ set var(plot,y) "\$$var(coly)"
+ }
+
+ if {[CATPlotDialog $varname]} {
+ if {$var(plot,x) != {} && $var(plot,y) != {}} {
+ CATPlotGenerate $varname
+ }
+ }
+}
+
+proc CATPlotGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(plot,xerr) == {} && $var(plot,yerr) == {}} {
+ set dim xy
+ } elseif {$var(plot,xerr) != {} && $var(plot,yerr) == {}} {
+ set dim xyex
+ } elseif {$var(plot,xerr) == {} && $var(plot,yerr) != {}} {
+ set dim xyey
+ } else {
+ set dim xyexey
+ }
+
+ global $var(tbldb)
+ set nrows [starbase_nrows $var(tbldb)]
+ set cols [starbase_columns $var(tbldb)]
+
+ set rr {}
+ for {set ii 1} {$ii <= $nrows} {incr ii} {
+ foreach col $cols {
+ set val [starbase_get $var(tbldb) $ii \
+ [starbase_colnum $var(tbldb) $col]]
+ # here's a tough one-- what to do if the col is blank
+ # for now, just set it to '0'
+ if {[string trim "$val"] == {}} {
+ set val 0
+ }
+ eval "set \{$col\} \{$val\}"
+ }
+
+ switch $dim {
+ xy {append rr [subst "$var(plot,x), $var(plot,y)\n"]}
+ xyex {append rr [subst "$var(plot,x), $var(plot,y), $var(plot,xerr)\n"]}
+ xyey {append rr [subst "$var(plot,x), $var(plot,y), $var(plot,yerr)\n"]}
+ xyexey {append rr [subst "$var(plot,x), $var(plot,y), $var(plot,xerr), $var(plot,yerr)\n"]}
+ }
+ }
+
+ set xtitle [regsub -all {\$*} $var(plot,x) {}]
+ set ytitle [regsub -all {\$*} $var(plot,y) {}]
+
+ set vvarname plot${varname}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ PlotScatterDialog $vvarname $var(title) {} {} {}
+ set vvar(callback) "CATSelectRows $varname plot"
+ set var(plot) 1
+ set var(plot,var) $vvarname
+ }
+
+ PlotClearData $vvarname
+ PlotDataSet $vvarname $dim $rr
+ PlotTitle $vvarname $var(title) $xtitle $ytitle
+ $vvar(proc,updategraph) $vvarname
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc CATPlotDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+ global ds9
+ global ed2
+
+ set w ".${varname}plot"
+ set mb ".${varname}plotmb"
+
+ set ed2(ok) 0
+ set ed2(x) $var(plot,x)
+ set ed2(xerr) $var(plot,xerr)
+ set ed2(y) $var(plot,y)
+ set ed2(yerr) $var(plot,yerr)
+
+ DialogCreate $w [msgcat::mc {Plot}] ed2(ok)
+
+ $w configure -menu $mb
+ menu $mb
+
+ # file
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command {set ed2(ok) 1}
+ $mb.file add command -label [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+
+ # edit
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+ EditMenu $mb $varname
+
+ # param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.taxis -text {Axis}
+ ttk::label $f.terr -text {Error}
+
+ ttk::label $f.tx -text {X}
+ ttk::entry $f.x -textvariable ed2(x) -width 21
+ ttk::button $f.bx -text [msgcat::mc {Edit}] \
+ -command "CATEditDialog ed2 x $var(catdb)"
+ ttk::entry $f.xerr -textvariable ed2(xerr) -width 21
+ ttk::button $f.bxerr -text [msgcat::mc {Edit}] \
+ -command "CATEditDialog ed2 xerr $var(catdb)"
+ ttk::menubutton $f.mx -text {Cols} -menu $f.mx.menu
+ ttk::menubutton $f.mxerr -text {Cols} -menu $f.mxerr.menu
+
+ CATPlotDialogColsMenu $varname $f.mx x
+ CATPlotDialogColsMenu $varname $f.mxerr xerr
+
+ ttk::label $f.ty -text {Y}
+ ttk::entry $f.y -textvariable ed2(y) -width 21
+ ttk::button $f.by -text [msgcat::mc {Edit}] \
+ -command "CATEditDialog ed2 y $var(catdb)"
+ ttk::entry $f.yerr -textvariable ed2(yerr) -width 21
+ ttk::button $f.byerr -text [msgcat::mc {Edit}] \
+ -command "CATEditDialog ed2 yerr $var(catdb)"
+ ttk::menubutton $f.my -text {Cols} -menu $f.my.menu
+ ttk::menubutton $f.myerr -text {Cols} -menu $f.myerr.menu
+
+ CATPlotDialogColsMenu $varname $f.my y
+ CATPlotDialogColsMenu $varname $f.myerr yerr
+
+ grid x $f.taxis x $f.terr -padx 2 -pady 2 -sticky ew
+ grid $f.tx $f.x $f.bx $f.xerr $f.bxerr -padx 2 -pady 2 -sticky ew
+ grid x $f.mx x $f.mxerr -padx 2 -pady 2 -sticky ew
+ grid $f.ty $f.y $f.by $f.yerr $f.byerr -padx 2 -pady 2 -sticky ew
+ grid x $f.my x $f.myerr -padx 2 -pady 2 -sticky ew
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ pack $w.param -side top -fill both -expand true
+ pack $w.buttons $w.sep -side bottom -fill x
+
+ DialogCenter $w
+ DialogWait $w ed2(ok) $w.buttons.ok
+
+ if {$ed2(ok)} {
+ set var(plot,x) $ed2(x)
+ set var(plot,xerr) $ed2(xerr)
+ set var(plot,y) $ed2(y)
+ set var(plot,yerr) $ed2(yerr)
+ }
+
+ DialogDismiss $w
+ destroy $mb
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
+proc CATPlotDialogColsMenu {varname f ww} {
+ upvar #0 $varname var
+ global $varname
+ global $var(catdb)
+ global ed2
+ global ds9
+
+ set m $f.menu
+
+ menu $m -tearoff 0
+ if {[CATValidDB $var(catdb)]} {
+ set cnt -1
+ foreach col [starbase_columns $var(catdb)] {
+ $m add command -label $col -command "set ed2($ww) \\$$col"
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 0
+ $m entryconfig $col -columnbreak 1
+ }
+ }
+ }
+}
diff --git a/ds9/library/catreg.tcl b/ds9/library/catreg.tcl
new file mode 100644
index 0000000..505e919
--- /dev/null
+++ b/ds9/library/catreg.tcl
@@ -0,0 +1,395 @@
+# 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
+
+# catreg -- convert catalog table into region string
+proc CATReg {varname row interactive resultname} {
+ upvar $resultname result
+
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+ global $var(symdb)
+
+ # init result
+ set result {}
+
+ # How to process each field of a filter
+ # -------------------------------------
+ # condition: subst/expr
+ # shape: constant
+ # color: constant
+ # width: constant
+ # dash: constant
+ # font: constant
+ # fontsize: constant
+ # fontweight: constant
+ # fontslant: constant
+ # text: subst
+ # size1: expr
+ # size2: expr
+ # angle: expr
+
+ # valid cols?
+ if {$var(colx) == {} || $var(coly) == {}} {
+ return
+ }
+ set colx [starbase_colnum $var(tbldb) $var(colx)]
+ set coly [starbase_colnum $var(tbldb) $var(coly)]
+
+ # do we have formats for colx and coly?
+ if {[catch {starbase_hdrget $var(tbldb) UFMT} ff]} {
+ set ff {}
+ global errorInfo
+ set errorInfo {}
+ }
+ set xformat [lindex $ff 0]
+ set yformat [lindex $ff 1]
+
+ # else, do we have T(Units), i.e. votable
+ set db $var(tbldb)
+ upvar #0 $db T
+ if {[info exists T(Unit)]} {
+ set xformat [string trim [lindex $T(Unit) [expr $colx-1]] {"}]
+ set yformat [string trim [lindex $T(Unit) [expr $coly-1]] {"}]
+ }
+
+ # process prologue
+ append result "# Region file format: DS9 version 4.0\n"
+
+ # for speed...
+ # tbldb
+ set nrows [starbase_nrows $var(tbldb)]
+ set cols [starbase_columns $var(tbldb)]
+
+ # system
+ switch $var(psystem) {
+ image -
+ physical -
+ detector -
+ amplifier {set sys $var(psystem)}
+ default {set sys "$var(psystem); $var(psky)"}
+ }
+
+ # symdb
+ set snrows [starbase_nrows $var(symdb)]
+ set sncond [starbase_colnum $var(symdb) condition]
+ set snshape [starbase_colnum $var(symdb) shape]
+ set sncolor [starbase_colnum $var(symdb) color]
+ set snwidth [starbase_colnum $var(symdb) width]
+ set sndash [starbase_colnum $var(symdb) dash]
+ set snfont [starbase_colnum $var(symdb) font]
+ set snfontsize [starbase_colnum $var(symdb) fontsize]
+ set snfontweight [starbase_colnum $var(symdb) fontweight]
+ set snfontslant [starbase_colnum $var(symdb) fontslant]
+ set sntext [starbase_colnum $var(symdb) text]
+ set snsize [starbase_colnum $var(symdb) size]
+ set snsize2 [starbase_colnum $var(symdb) size2]
+ set snunits [starbase_colnum $var(symdb) units]
+ set snangle [starbase_colnum $var(symdb) angle]
+
+ # for each row in the catalog table ...
+ if {[string is integer -strict $row]} {
+ set start $row
+ set end $row
+ } else {
+ set start 1
+ set end $nrows
+ }
+
+ # look for need to eval colnames (only used for conditionals and text
+ set doEval 0
+ for {set jj 1} {$jj <= $snrows} {incr jj} {
+ set cond [starbase_get $var(symdb) $jj $sncond]
+ set text [starbase_get $var(symdb) $jj $sntext]
+ set sz [starbase_get $var(symdb) $jj $snsize]
+ set sz2 [starbase_get $var(symdb) $jj $snsize2]
+ set angle [starbase_get $var(symdb) $jj $snangle]
+ if {$cond!={} || $text!={} || $sz!={} || $sz2!={} || $angle!={}} {
+ set doEval 1
+ }
+ }
+
+ for {set ii $start} {$ii <= $end} {incr ii} {
+ if {$doEval} {
+ # define each colunm variable
+ foreach col $cols {
+ set val [starbase_get $var(tbldb) $ii \
+ [starbase_colnum $var(tbldb) $col]]
+ # here's a tough one-- what to do if the col is blank
+ # for now, just set it to '0'
+ if {[string trim "$val"] == {}} {
+ set val 0
+ }
+ eval "set \{$col\} \{$val\}"
+ }
+ }
+
+ # look through each filter
+ for {set jj 1} {$jj <= $snrows} {incr jj} {
+ # eval condition
+ set cond [starbase_get $var(symdb) $jj $sncond]
+
+ if {$cond != {}} {
+ set found 0
+
+ # subst any column vars
+ if {[catch {subst $cond} cc]} {
+ Error "Unable to evaluate condition $cc"
+ return
+ }
+ # evaluate filter
+ if {[catch {expr $cc} found]} {
+ Error "Unable to evaluate condition $cc"
+ return
+ }
+ } else {
+ set found 1
+ }
+
+ # if not true, goto the next filter
+ if {!$found} {
+ continue
+ }
+
+ # shape
+ set shape [starbase_get $var(symdb) $jj $snshape]
+ if {$shape == {}} {
+ set shape circle
+ }
+
+ # xx
+ set xx [starbase_get $var(tbldb) $ii $colx]
+ switch $xformat {
+ {h:m:s} -
+ {d:m:s} {set xx [uformat $xformat d $xx]}
+ }
+
+ # yy
+ set yy [starbase_get $var(tbldb) $ii $coly]
+ if {$yformat == {d:m:s}} {
+ set yy [uformat $yformat d $yy]
+ }
+
+ # size/angle
+ set szcol {}
+ set sz2col {}
+ set angcol {}
+
+ set units [starbase_get $var(symdb) $jj $snunits]
+ switch -- $units {
+ image {set unitval i}
+ physical {set unitval p}
+ degrees {set unitval d}
+ arcmin {set unitval {'}}
+ arcsec {set unitval {"}}
+ default {set unitval p}
+ }
+
+ switch -- $shape {
+ text -
+ point -
+ {circle point} -
+ {box point} -
+ {diamond point} -
+ {cross point} -
+ {x point} -
+ {arrow point} -
+ {boxcircle point} {set size {}}
+
+ circle {
+ set sz [starbase_get $var(symdb) $jj $snsize]
+
+ set szcolnm [string range $sz 1 end]
+ if {[lsearch -exact $cols $szcolnm] != -1} {
+ set szcol [starbase_colnum $var(tbldb) $szcolnm]
+ }
+
+ if {$sz != {}} {
+ if {[catch {expr $sz} ss]} {
+ Error "Unable to evaluate size $sz"
+ return
+ } else {
+ set sz $ss
+ }
+ } else {
+ set sz 5
+ }
+ set size "${sz}${unitval}"
+ }
+
+ vector {
+ set sz [starbase_get $var(symdb) $jj $snsize]
+
+ set szcolnm [string range $sz 1 end]
+ if {[lsearch -exact $cols $szcolnm] != -1} {
+ set szcol [starbase_colnum $var(tbldb) $szcolnm]
+ }
+
+ if {$sz != {}} {
+ if {[catch {expr $sz} ss]} {
+ Error "Unable to evaluate size $sz"
+ return
+ } else {
+ set sz $ss
+ }
+ } else {
+ set sz 5
+ }
+
+ set angle [starbase_get $var(symdb) $jj $snangle]
+
+ set angcolnm [string range $angle 1 end]
+ if {[lsearch -exact $cols $angcolnm] != -1} {
+ set angcol [starbase_colnum $var(tbldb) $angcolnm]
+ }
+
+ if {$angle != {}} {
+ if {[catch {expr $angle} aa]} {
+ Error "Unable to evaluate angle $angle"
+ return
+ } else {
+ set angle $aa
+ }
+ } else {
+ set angle 0
+ }
+
+ set size "${sz}${unitval} ${angle}"
+ }
+
+ ellipse -
+ box {
+ # size
+ set sz [starbase_get $var(symdb) $jj $snsize]
+
+ set szcolnm [string range $sz 1 end]
+ if {[lsearch -exact $cols $szcolnm] != -1} {
+ set szcol [starbase_colnum $var(tbldb) $szcolnm]
+ }
+
+ if {$sz != {}} {
+ if {[catch {expr $sz} ss]} {
+ Error "Unable to evaluate size $sz"
+ return
+ } else {
+ set sz $ss
+ }
+ } else {
+ set sz 5
+ }
+
+ # size2
+ set sz2 [starbase_get $var(symdb) $jj $snsize2]
+
+ set sz2colnm [string range $sz2 1 end]
+ if {[lsearch -exact $cols $sz2colnm] != -1} {
+ set sz2col [starbase_colnum $var(tbldb) $sz2colnm]
+ }
+
+ if {$sz2 != {}} {
+ if {[catch {expr $sz2} ss]} {
+ Error "Unable to evaluate size $sz2"
+ return
+ } else {
+ set sz2 $ss
+ }
+ } else {
+ set sz2 5
+ }
+
+ # angle
+ set angle [starbase_get $var(symdb) $jj $snangle]
+
+ set angcolnm [string range $angle 1 end]
+ if {[lsearch -exact $cols $angcolnm] != -1} {
+ set angcol [starbase_colnum $var(tbldb) $angcolnm]
+ }
+
+ if {$angle != {}} {
+ if {[catch {expr $angle} aa]} {
+ Error "Unable to evaluate angle $angle"
+ return
+ } else {
+ set angle $aa
+ }
+ } else {
+ set angle 0
+ }
+
+ # put it all together
+ set size "${sz}${unitval} ${sz2}${unitval} ${angle}"
+ }
+ }
+
+ # color
+ set color [starbase_get $var(symdb) $jj $sncolor]
+ if {$color == {}} {
+ set color green
+ }
+
+ # width
+ set width [starbase_get $var(symdb) $jj $snwidth]
+ if {$width == {}} {
+ set width 1
+ }
+
+ # dash
+ set dash [starbase_get $var(symdb) $jj $sndash]
+ if {$dash == {}} {
+ set dash 0
+ }
+
+
+ #font
+ set font [starbase_get $var(symdb) $jj $snfont]
+ if {$font == {}} {
+ set font helvetica
+ }
+ set fontsize [starbase_get $var(symdb) $jj $snfontsize]
+ if {$fontsize == {}} {
+ set fontsize 10
+ }
+ set fontweight [starbase_get $var(symdb) $jj $snfontweight]
+ if {$fontweight == {}} {
+ set fontweight normal
+ }
+ set fontslant [starbase_get $var(symdb) $jj $snfontslant]
+ if {$fontslant == {}} {
+ set fontslant roman
+ }
+
+ # text
+ set text [starbase_get $var(symdb) $jj $sntext]
+ if {$text != {}} {
+ if {[catch {subst $text} tt]} {
+ Error "Unable to evaluate text $text"
+ return
+ } else {
+ set text $tt
+ }
+ }
+ if {$shape == {text} && $text == {}} {
+ set text "$ii"
+ }
+
+ # final substitution and append result
+ # init result for substitutions
+ if {$interactive} {
+ if {$var(edit)} {
+ set template "\${sys};\${shape}(\${xx} \${yy} \${size}) # color=\${color} width=\${width} dash=\${dash} font=\{${font} ${fontsize} ${fontweight} ${fontslant}\} text=\{\${text}\} tag={${varname}} tag={${varname}.\${ii}} select=1 edit=1 move=1 rotate=1 delete=1 highlite=0 callback=select CATHighliteCB {${varname}.\${ii}} callback=unselect CATUnhighliteCB {${varname}.\${ii}} callback=edit CATEditCB {${varname}.\${ii}.\${szcol}.\${sz2col}.\${units}.\${angcol}} callback=move CATMoveCB {${varname}.\${ii}} callback=rotate CATRotateCB {${varname}.\${ii}.\${angcol}} callback=delete CATDeleteCB {${varname}.\${ii}}\n"
+ } else {
+ set template "\${sys};\${shape}(\${xx} \${yy} \${size}) # color=\${color} width=\${width} dash=\${dash} font=\{${font} ${fontsize} ${fontweight} ${fontslant}\} text=\{\${text}\} tag={${varname}} tag={${varname}.\${ii}} select=0 edit=0 move=0 rotate=0 delete=1 highlite=1 callback=delete CATDeleteCB {${varname}.\${ii}} callback=highlite CATHighliteCB {${varname}.\${ii}} callback=unhighlite CATUnhighliteCB {${varname}.\${ii}}\n"
+ }
+ } else {
+ set template "\${sys};\${shape}(\${xx} \${yy} \${size}) # color=\${color} width=\${width} dash=\${dash} text=\{\${text}\} tag=$varname\n"
+ }
+ append result [subst $template]
+
+ # ok, we are done
+ break
+ }
+ }
+}
diff --git a/ds9/library/catsdss.tcl b/ds9/library/catsdss.tcl
new file mode 100644
index 0000000..a2d6769
--- /dev/null
+++ b/ds9/library/catsdss.tcl
@@ -0,0 +1,176 @@
+# 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 CATSDSS {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSDSS $varname"
+ }
+
+ set var(proc,reader) CATSDSSReader
+
+ # coord (degrees)
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ set xx [h2d [Sex2H $var(x)]]
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ # size (arcmin)
+ switch $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcmin {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcsec {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ set query {}
+ append query "ra=$xx&"
+ append query "dec=$yy&"
+ append query "radius=$rr&"
+
+# append query "min_ra=[expr $xx-$ww/2.]&max_ra=[expr $xx+$ww/2.]&"
+# append query "min_dec=[expr $yy-$hh/2.]&max_dec=[expr $yy+$hh/2.]&"
+
+ # output
+ if {$var(allrows)} {
+ append query "entries=all&"
+ } else {
+ append query "topnum=$var(max)&"
+ }
+ append query "format=csv&"
+
+ set var(url) "http://cas.sdss.org/astrodr${var(catalog)}/en/tools/search/x_radial.asp?$query"
+
+ set var(query) {}
+
+ CATLoadIncr $varname
+}
+
+proc CATSDSSReader {t sock token} {
+ upvar #0 $t T
+ global $t
+
+ set result 0
+
+ if { ![info exists ${t}(state)] } {
+ set T(state) 0
+ }
+
+ switch -- $T(state) {
+ 0 {
+ # init db
+ fconfigure $sock -blocking 1
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) 1
+ }
+
+ 1 {
+ # process header
+ if {[gets $sock line] == -1} {
+ return
+ }
+
+ if {[string equal $line "No objects have been found"]} {
+ return
+ }
+
+ # cols
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set result [string length "$line"]
+ set T(H_$n) $line
+ set T(Header) [split $T(H_$n) ","]
+
+ # dashes
+
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+ set T(Ndshs) [llength $T(Dashes)]
+
+ starbase_colmap $t
+ set T(state) 2
+ }
+
+ 2 {
+ # process table
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ } else {
+ set result [string length "$line"]
+ set line [string trim $line]
+ if {$line != {}} {
+ # ok, save it
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols $t]
+ set c 1
+ foreach val [split $line ","] {
+ set T($r,$c) $val
+ incr c
+ }
+ for {} {$c <= $NCols} {incr c} {
+ set T($r,$c) {}
+ }
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+proc CATSDSSAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for SDSS
+
+Funding for the Sloan Digital Sky Survey (SDSS) has been provided
+by the Alfred P. Sloan Foundation, the Participating Institutions,
+the National Aeronautics and Space Administration, the National
+Science Foundation, the U.S. Department of Energy, the Japanese
+Monbukagakusho, and the Max Planck Society. The SDSS Web site is
+http://www.sdss.org/.
+
+The SDSS is managed by the Astrophysical Research Consortium (ARC)
+for the Participating Institutions. The Participating Institutions
+are The University of Chicago, Fermilab, the Institute for
+Advanced Study, the Japan Participation Group, The Johns Hopkins
+University, the Korean Scientist Group, Los Alamos National
+Laboratory, the Max-Planck-Institute for Astronomy (MPIA), the
+Max-Planck-Institute for Astrophysics (MPA), New Mexico State
+University, University of Pittsburgh, University of Portsmouth,
+Princeton University, the United States Naval Observatory, and the
+University of Washington.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 10 insert top $msg
+}
diff --git a/ds9/library/catsimbad.tcl b/ds9/library/catsimbad.tcl
new file mode 100644
index 0000000..2a6085c
--- /dev/null
+++ b/ds9/library/catsimbad.tcl
@@ -0,0 +1,236 @@
+# 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 CATSIMBAD {varname} {
+ upvar #0 $varname var
+ global $varname
+ global pcat
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSIMBAD $varname"
+ }
+
+ # parser
+ if {$pcat(vot)} {
+ set var(proc,parser) CATSIMBADParse
+ } else {
+ set var(proc,reader) CATSIMBADReader
+ }
+
+ # query
+ set qq {}
+
+ if {$pcat(vot)} {
+ append qq "output script=off\n"
+ append qq "output console=off\n"
+ }
+
+ if {$pcat(vot)} {
+ append qq "votable v1 "
+ } else {
+ append qq "format object f1 "
+ }
+
+ switch -- $var(psky) {
+ fk4 {set psky "FK4;1950;1950"}
+ fk5 {set psky "FK5;2000;2000"}
+ icrs {set psky "ICRS"}
+ galactic {set psky "GAL"}
+ ecliptic {set psky "ECL"}
+ }
+
+ if {$pcat(vot)} {
+ append qq "{ coo(d;$psky), main_id, otype(S), pmra, pmdec, plx, z_value, flux(B), flux(V), sp }\n"
+ append qq "votable open v1\n"
+ } else {
+ append qq {"%COO(d;A)\t%COO(d;D)\t%IDLIST(1)\t%OTYPE(S)\t%PM(A)\t%PM(D)\t%PLX(V)\t%RV(Z)\t%FLUXLIST(B;F)\t%FLUXLIST(V;F)\t%SP(S)\n"}
+ append qq "\n"
+ }
+
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ switch -- $var(sky) {
+ fk4 -
+ fk5 -
+ icrs {set xx [h2d [Sex2H $var(x)]]}
+ galactic -
+ ecliptic {set xx [Sex2D $var(x)]}
+ }
+ set yy [Sex2D $var(y)]
+ }
+ }
+ append qq "query coo $xx "
+ if {$yy>0} {
+ append qq "+$yy"
+ } else {
+ append qq "$yy"
+ }
+
+ set ww $var(width)
+ set hh $var(height)
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ append qq " radius=$rr"
+ switch -- $var(rformat) {
+ degrees {append qq "d"}
+ arcmin {append qq "m"}
+ arcsec {append qq "s"}
+ }
+
+ switch -- $var(sky) {
+ fk4 {append qq " frame=FK4 epoch=B1950 equinox=1950"}
+ fk5 {append qq " frame=FK5 epoch=J2000 equinox=2000"}
+ icrs {append qq " frame=ICRS"}
+ galactic {append qq " frame=GAL"}
+ ecliptic {append qq " frame=ECL"}
+ }
+
+ if {$pcat(vot)} {
+ append qq "\nvotable close\n"
+ } else {
+ append qq "\n"
+ }
+
+ # url
+ set var(url) "http://simbad.u-strasbg.fr/simbad/sim-script"
+ set var(query) [http::formatQuery script $qq]
+
+ if {$pcat(vot)} {
+ CATLoad $varname
+ } else {
+ CATLoadIncr $varname
+ }
+}
+
+proc CATSIMBADParse {t token} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ # we can't trust simbad to turn off any error messages
+ variable $token
+ upvar 0 $token state
+
+ set id [string first {<?xml} $state(body)]
+ set ${token}(body) [string range $state(body) $id end]
+
+ VOTParse $t $token
+}
+
+proc CATSIMBADReader {t sock token} {
+ upvar #0 $t T
+ global $t
+
+ set result 0
+
+ if { ![info exists ${t}(state)] } {
+ set T(state) 0
+ }
+
+ switch -- $T(state) {
+ 0 {
+ # init db
+ fconfigure $sock -blocking 1
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) 1
+ }
+
+ 1 {
+ # process header
+ if {[gets $sock line] == -1} {
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) -1
+ return $result
+ }
+
+ set result [string length "$line"]
+
+ # error?
+ if {[string range $line 0 8] == {::error::}} {
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ set T(state) -1
+ return $result
+ }
+
+ # start of data?
+ if {[string range $line 0 7] == {::data::}} {
+ # cols
+ set line "RA\tDEC\tIdentifier\tObject\tPMRA\tPMDEC\tPX\tRV(z)\tB\tV\tSpectralType"
+
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) $line
+ set T(Header) [split $T(H_$n) "\t"]
+
+ # dashes
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+ set T(Ndshs) [llength $T(Dashes)]
+ starbase_colmap $t
+
+ set T(state) 2
+ }
+ }
+
+ 2 {
+ # process table
+ if {[gets $sock line] == -1} {
+ set T(state) 0
+ } else {
+ set result [string length "$line"]
+ set line [string trim $line]
+
+ if {$line != {}} {
+ # ok, save it
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols $t]
+ set c 1
+ foreach val [split $line "\t"] {
+ set T($r,$c) $val
+ incr c
+ }
+ for {} {$c <= $NCols} {incr c} {
+ set T($r,$c) {}
+ }
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+proc CATSIMBADAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for SIMBAD
+
+This research has made use of the SIMBAD database,
+operated at CDS, Strasbourg, France.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 10 insert top $msg
+}
diff --git a/ds9/library/catskybot.tcl b/ds9/library/catskybot.tcl
new file mode 100644
index 0000000..c89f9f0
--- /dev/null
+++ b/ds9/library/catskybot.tcl
@@ -0,0 +1,158 @@
+# 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 CATSkyBot {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSkyBot $varname"
+ }
+
+ CATSkyBotVOT $varname
+}
+
+proc CATSkyBotVOT {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,cat)} {
+ puts stderr "CATSkyBotVOT $varname"
+ }
+
+ set var(proc,parser) VOTParse
+
+ # coord (degrees)
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ switch -- $var(sky) {
+ fk4 -
+ fk5 -
+ icrs {set xx [h2d [Sex2H $var(x)]]}
+ galactic -
+ ecliptic {set xx [Sex2D $var(x)]}
+ }
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ # size (arcmin)
+ switch $var(rformat) {
+ degrees {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ # output
+ if {$var(allcols)} {
+ set type 3
+ } else {
+ set type 2
+ }
+
+ # figure out a epoch (DATE-OBS, then DATE)
+ global current
+ set epoch [string trim [$current(frame) get fits header keyword DATE-OBS]]
+ if {$epoch == {}} {
+ set epoch [string trim [$current(frame) get fits header keyword DATE_OBS]]
+ }
+ if {$epoch == {}} {
+ set epoch [string trim [$current(frame) get fits header keyword DATE]]
+ }
+ if {$epoch == {}} {
+ ARError $varname [msgcat::mc {Unable to determine date of observation}]
+ return
+ }
+
+ # do we have a time? else check UT, UTC-OBS, UTIME, TIME-OBS
+ set ut {}
+ if {[string first {T} $epoch] == -1} {
+ set ut [string trim [$current(frame) get fits header keyword UT]]
+ if {$ut == {}} {
+ set ut [string trim [$current(frame) get fits header keyword UTC-OBS]]
+ }
+ if {$ut == {}} {
+ set ut [string trim [$current(frame) get fits header keyword UTIME]]
+ }
+ if {$ut == {}} {
+ set ut [string trim [$current(frame) get fits header keyword TIME-OBS]]
+ }
+ if {$ut == {}} {
+ set ut [string trim [$current(frame) get fits header keyword TIME_OBS]]
+ }
+
+ if {$ut != {}} {
+ append epoch "T$ut"
+ } else {
+ ARError $varname [msgcat::mc {Unable to determine time of observation}]
+ return
+ }
+ }
+
+ # do we finally have a date with time?
+ set dt [split $epoch {T}]
+ set dd [lindex $dt 0]
+ set tt [lindex $dt 1]
+ if {$tt != {}} {
+ # do we have EXPTIME or EXP_TIME?
+ set exp [string trim [$current(frame) get fits header keyword EXPTIME]]
+ if {$exp == {}} {
+ set exp [string trim [$current(frame) get fits header keyword EXP_TIME]]
+ }
+
+ if {$exp != {} && [string is double $exp]} {
+ # ok, rebuild epoch
+ set ttt [split $tt {:}]
+ set total [expr [lindex $ttt 0]*60.*60. + [lindex $ttt 1]*60. + [lindex $ttt 2] + [expr $exp/2.]]
+ set hh [format "%02d" [expr int($total/60./60.)]]
+ set total [expr $total - $hh*60.*60.]
+ set mm [format "%02d" [expr int($total/60.)]]
+ set ss [format "%02.1f" [expr $total - $mm*60.]]
+ set epoch "${dd}T${hh}:${mm}:${ss}"
+ }
+ }
+
+ # query
+ set var(query) [http::formatQuery EPOCH $epoch RA $xx DEC $yy SR $rr VERB $type -mime votable -loc $var(loc) -filter=0]
+ set var(url) "http://vo.imcce.fr/webservices/skybot/skybotconesearch_query.php"
+
+ CATLoad $varname
+}
+
+proc CATSkyBotAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for SkyBot
+
+Request for Acknowledgment of Use of SkyBot
+
+If SkyBoT was helpful for your research work, the following acknowledgment
+would be appreciated: "This research has made use of IMCCE's SkyBoT VO tool",
+or cite the following article 2006ASPC..351..367B.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 10 insert top $msg
+}
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
+}
diff --git a/ds9/library/catvot.tcl b/ds9/library/catvot.tcl
new file mode 100644
index 0000000..ad040ef
--- /dev/null
+++ b/ds9/library/catvot.tcl
@@ -0,0 +1,70 @@
+# 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
+
+# SAMP
+
+proc CATVOTURL {url catalog title} {
+ if {[string length $url] == 0} {
+ return
+ }
+
+ ParseURL $url r
+ switch -- $r(scheme) {
+ ftp {CATVOTFTP $r(authority) $r(path)}
+ file {CATVOTFile $r(path)}
+ http -
+ default {CATVOTHTTP $url $catalog $title}
+ }
+}
+
+proc CATVOTFTP {host path} {
+ global loadParam
+ global ds9
+ global debug
+
+ set ftp [ftp::Open $host "ftp" "-ds9@" -mode passive]
+ if {$ftp > -1} {
+ set fn [tmpnam [file extension $path]]
+ set ftp::VERBOSE $debug(tcl,ftp)
+ set "ftp::ftp${ftp}(Output)" FTPLog
+ ftp::Type $ftp binary
+ if {[ftp::Get $ftp $path $fn]} {
+ CATVOTFile $fn
+ }
+
+ ftp::Close $ftp
+
+ if {[file exists $fn]} {
+ catch {file delete -force $fn}
+ }
+ }
+}
+
+proc CATVOTHTTP {url catalog title} {
+ global icat
+
+ CATDialog catvot {} $catalog $title none
+
+ set varname [lindex $icat(cats) end]
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}(query) {}
+ set ${varname}(url) $url
+ set ${varname}(proc,parser) VOTParse
+
+ CATLoad $varname
+}
+
+proc CATVOTFile {fn} {
+ global icat
+
+ CATDialog catvot {} {} {} none
+ if {$fn != {}} {
+ CATLoadFn [lindex $icat(cats) end] $fn VOTRead
+ }
+}
+
diff --git a/ds9/library/centroid.tcl b/ds9/library/centroid.tcl
new file mode 100644
index 0000000..254ae83
--- /dev/null
+++ b/ds9/library/centroid.tcl
@@ -0,0 +1,115 @@
+# 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 CentroidDef {} {
+ global centroid
+ global icentroid
+
+ set icentroid(top) .centroid
+ set icentroid(mb) .centroidmb
+}
+
+proc CentroidDialog {} {
+ global centroid
+ global icentroid
+ global ds9
+
+ # see if we already have a window visible
+
+ if {[winfo exists $icentroid(top)]} {
+ raise $icentroid(top)
+ return
+ }
+
+ # create the window
+ set w $icentroid(top)
+ set mb $icentroid(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Centroid Parameters}] CentroidDestroyDialog
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command CentroidApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command CentroidDestroyDialog
+
+ EditMenu $mb icentroid
+
+ UpdateCentroidDialog
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ slider $f.islider 1 100 [msgcat::mc {Iteration}] \
+ marker(centroid,iteration) [list CentroidApplyDialog]
+ slider $f.rslider 0 50 [msgcat::mc {Radius}] \
+ marker(centroid,radius) [list CentroidApplyDialog]
+
+ grid $f.islider -padx 2 -pady 2 -sticky ew
+ grid $f.rslider -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] \
+ -command CentroidApplyDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command CentroidDestroyDialog
+ pack $f.apply $f.close -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
+}
+
+proc CentroidDestroyDialog {} {
+ global icentroid
+
+ if {[winfo exists $icentroid(top)]} {
+ destroy $icentroid(top)
+ destroy $icentroid(mb)
+ }
+}
+
+proc CentroidApplyDialog {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker centroid radius $marker(centroid,radius)
+ $current(frame) marker centroid iteration $marker(centroid,iteration)
+ }
+}
+
+proc UpdateCentroidDialog {} {
+ global centroid
+ global icentroid
+ global current
+ global marker
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateCentroidDialog"
+ }
+
+ if {[winfo exists $icentroid(top)]} {
+ if {$current(frame) != {}} {
+ set marker(centroid,radius) \
+ [$current(frame) get marker centroid radius]
+ set marker(centroid,iteration) \
+ [$current(frame) get marker centroid iteration]
+ }
+ }
+}
+
+proc CentroidBackup {ch which} {
+ puts $ch "$which marker centroid radius [$which get marker centroid radius]"
+ puts $ch "$which marker centroid iteration [$which get marker centroid iteration]"
+}
diff --git a/ds9/library/circle.tcl b/ds9/library/circle.tcl
new file mode 100644
index 0000000..209af01
--- /dev/null
+++ b/ds9/library/circle.tcl
@@ -0,0 +1,108 @@
+# 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 CircleDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ # procs
+ set var(proc,apply) CircleApply
+ set var(proc,close) CircleClose
+ set var(proc,coordCB) CircleCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisHistogramDialog $varname
+ MarkerAnalysisPlot3dDialog $varname
+
+ # init
+ CircleEditCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback edit CircleEditCB $varname
+
+ set f $var(top).param
+
+ # Radius
+ ttk::label $f.tradius -text [msgcat::mc {Radius}]
+ ttk::entry $f.radius -textvariable ${varname}(radius) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list CircleEditCB $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+
+ grid $f.tradius $f.radius $f.uradius -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc CircleClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback edit CircleEditCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc CircleApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) circle radius $var(radius) \
+ $var(dcoord) $var(dformat)
+
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc CircleCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "CircleCoordCB"
+ }
+
+ MarkerAnalysisStatsSystem $varname
+ MarkerAnalysisPlot3dSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+}
+
+proc CircleEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "CircleEditCB"
+ }
+
+ set var(radius) [$var(frame) get marker $var(id) circle radius \
+ $var(dcoord) $var(dformat)]
+}
diff --git a/ds9/library/colorbar.tcl b/ds9/library/colorbar.tcl
new file mode 100644
index 0000000..c7c3602
--- /dev/null
+++ b/ds9/library/colorbar.tcl
@@ -0,0 +1,1449 @@
+# 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 ColorbarDef {} {
+ global colorbar
+ global icolorbar
+ global pcolorbar
+
+ global ds9
+
+ set icolorbar(top) .clrbar
+ set icolorbar(mb) .clrbarmb
+
+ set icolorbar(vertical,width) 75
+ set icolorbar(horizontal,height) 45
+ set icolorbar(num) 1024
+ set icolorbar(start) $ds9(menu,start)
+ set icolorbar(end) 0
+ set icolorbar(count) 0
+
+ set icolorbar(h5) 0
+ set icolorbar(h5,fn) [list h5_autumn.sao h5_bluered.sao h5_bone.sao h5_cool.sao h5_copper.sao h5_dkbluered.sao h5_gray.sao h5_green.sao h5_hot.sao h5_hsv.sao h5_jet.sao h5_pink.sao h5_spring.sao h5_summer.sao h5_winter.sao h5_yarg.sao h5_yellow.sao
+]
+
+ set icolorbar(matplotlib) 0
+ set icolorbar(matplotlib,fn) [list viridis.lut]
+
+ set icolorbar(cubehelix) 0
+ set icolorbar(cubehelix,fn) [list ch05m151008.sao ch05m151010.sao ch05m151012.sao ch05m151410.sao ch05p151010.sao ch20m151010.sao - cubehelix0.sao cubehelix1.sao]
+
+ set icolorbar(gist) 0
+ set icolorbar(gist,fn) [list gist_earth.sao gist_heat.sao gist_rainbow.sao gist_yarg.sao gist_gray.sao gist_ncar.sao gist_stern.sao]
+
+ set icolorbar(topo) 0
+ set icolorbar(topo,fn) [list tpglarf.sao tpglhcf.sao tpglhwf.sao tpglpof.sao tpglarm.sao tpglhcm.sao tpglhwm.sao tpglpom.sao]
+
+ set icolorbar(user) 0
+ set icolorbar(user,fn) {}
+
+ set colorbar(lock) 0
+ set colorbar(size) 20
+ set colorbar(ticks) 11
+ set colorbar(map) grey
+ set colorbar(invert) 0
+ set colorbar(numerics) 1
+ set colorbar(space) 0
+ set colorbar(orientation) horizontal
+ set colorbar(tag) red
+ set colorbar(font) helvetica
+ set colorbar(font,size) 9
+ set colorbar(font,weight) normal
+ set colorbar(font,slant) roman
+
+ array set pcolorbar [array get colorbar]
+}
+
+proc CreateColorbar {} {
+ global icolorbar
+
+ global ds9
+ global canvas
+ global view
+
+ $ds9(canvas) create colorbar$ds9(visual)$ds9(depth) \
+ -colors 2048 \
+ -tag colorbar \
+ -anchor nw \
+ -helvetica $ds9(helvetica) \
+ -courier $ds9(courier) \
+ -times $ds9(times)
+
+ $ds9(canvas) bind colorbar <Motion> [list ColorbarMotion %x %y]
+ $ds9(canvas) bind colorbar <Enter> [list ColorbarEnter %x %y]
+ $ds9(canvas) bind colorbar <Leave> [list ColorbarLeave]
+
+ $ds9(canvas) bind colorbar <Button-1> [list ColorbarButton1 %x %y]
+ $ds9(canvas) bind colorbar <B1-Motion> [list ColorbarMotion1 %x %y]
+ $ds9(canvas) bind colorbar <ButtonRelease-1> [list ColorbarRelease1 %x %y]
+ $ds9(canvas) bind colorbar <Double-1> [list ColorbarDouble1 %x %y]
+ $ds9(canvas) bind colorbar <Double-ButtonRelease-1> \
+ [list ColorbarDoubleRelease1 %x %y]
+
+ $ds9(canvas) bind colorbar <Key> [list ColorbarKey %K %A %x %y]
+ $ds9(canvas) bind colorbar <KeyRelease> \
+ [list ColorbarKeyRelease %K %A %x %y]
+
+ $ds9(canvas) create colorbarrgb$ds9(visual)$ds9(depth) \
+ -colors 2048 \
+ -tag colorbarrgb \
+ -anchor nw \
+ -helvetica $ds9(helvetica) \
+ -courier $ds9(courier) \
+ -times $ds9(times)
+
+ $ds9(canvas) bind colorbarrgb <Motion> [list ColorbarMotion %x %y]
+ $ds9(canvas) bind colorbarrgb <Enter> [list ColorbarEnter %x %y]
+ $ds9(canvas) bind colorbarrgb <Leave> [list ColorbarLeave]
+
+ LayoutColorbar
+}
+
+proc InitColorbar {} {
+ global colorbar
+
+ global current
+
+ set current(colorbar) colorbar
+
+ $current(colorbar) map "{$colorbar(map)}"
+ $current(colorbar) invert $colorbar(invert)
+}
+
+proc ResetColormap {} {
+ global colorbar
+
+ global current
+ global rgb
+
+ $current(colorbar) reset
+ if {$current(frame) != {} } {
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap [$current(colorbar) get colormap]]
+ set colorbar(invert) [$current(colorbar) get invert]
+ }
+ LockColorCurrent
+ UpdateColorDialog
+}
+
+proc LoadColormap {} {
+ LoadColormapFile [OpenFileDialog colorbarfbox]
+}
+
+# used by backup
+proc LoadColormapFile {filename} {
+ global colorbar
+ global icolorbar
+
+ global current
+ global ds9
+
+ if {$filename != {}} {
+ colorbar load "\{$filename\}"
+ set id [colorbar get id]
+ set colorbar(map) [colorbar get name]
+
+ $ds9(mb).color.user add radiobutton \
+ -label "$colorbar(map)" \
+ -variable colorbar(map) \
+ -command [list ChangeColormapID $id]
+
+ if {[winfo exists $icolorbar(top)]} {
+ $icolorbar(mb).colormap.user add radiobutton \
+ -label "$colorbar(map)" \
+ -variable colorbar(map) \
+ -command [list ChangeColormapID $id]
+ }
+ incr icolorbar(count)
+
+ ChangeColormapID $id
+ }
+}
+
+proc SaveColormap {} {
+ FileLast colorbarfbox [colorbar get file name]
+ SaveColormapFile [SaveFileDialog colorbarfbox]
+}
+
+proc SaveColormapFile {filename} {
+ if {$filename != {}} {
+ colorbar save "\{$filename\}"
+ }
+}
+
+proc LoadContrastBias {} {
+ global dcolorbar
+
+ set filename [OpenFileDialog contrastbiasfbox]
+ if {$filename != {}} {
+ if {![catch {set ch [open $filename r]}]} {
+ set ll [gets $ch]
+ close $ch
+ set dcolorbar(contrast) [lindex $ll 0]
+ set dcolorbar(bias) [lindex $ll 1]
+ ApplyColormap
+ }
+ }
+}
+
+proc SaveContrastBias {} {
+ global dcolorbar
+
+ set filename [SaveFileDialog contrastbiasfbox]
+ if {$filename != {}} {
+ if {![catch {set ch [open $filename w]}]} {
+ puts $ch "$dcolorbar(contrast) $dcolorbar(bias)"
+ close $ch
+ }
+ }
+}
+
+proc ColorbarEnter {x y} {
+ global current
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarEnter"
+ }
+
+ # check to see if this event was generated while processing other events
+ if {$ds9(b1) || $ds9(sb1) || $ds9(cb1) ||
+ $ds9(csb1) || $ds9(b2) || $ds9(b3)} {
+ return
+ }
+
+ $ds9(canvas) focus $current(colorbar)
+
+ switch -- $current(colorbar) {
+ colorbar {UpdateFrameInfoBox base}
+ colorbarrgb {UpdateFrameInfoBox rgb}
+ }
+}
+
+proc ColorbarLeave {} {
+ global current
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarLeave"
+ }
+
+ # check to see if this event was generated while processing other events
+ if {$ds9(b1) || $ds9(sb1) || $ds9(cb1) ||
+ $ds9(csb1) || $ds9(b2) || $ds9(b3)} {
+ return
+ }
+
+ $ds9(canvas) focus {}
+ ClearInfoBoxCoords
+}
+
+proc ColorbarMotion {x y} {
+ global current
+ global infobox
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarMotion $x $y"
+ }
+
+ switch -- $current(colorbar) {
+ colorbar {
+ set infobox(value) [$current(colorbar) get value $x $y]
+ }
+ colorbarrgb {
+ set vv [$current(colorbar) get value $x $y]
+ switch -- $current(rgb) {
+ red {set infobox(value,red) $vv}
+ green {set infobox(value,green) $vv}
+ blue {set infobox(value,blue) $vv}
+ }
+ }
+ }
+}
+
+proc ColorbarKey {K A xx yy} {
+ global current
+ global ds9
+
+ # MacOSX and Ubuntu returns bogus values in xx,yy
+ # calculate our own values
+ set xx [expr {[winfo pointerx $ds9(canvas)] - [winfo rootx $ds9(canvas)]}]
+ set yy [expr {[winfo pointery $ds9(canvas)] - [winfo rooty $ds9(canvas)]}]
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarKey $K $A $xx $yy"
+ }
+
+ switch -- $current(mode) {
+ colorbar {
+ switch -- $K {
+ Delete -
+ BackSpace {
+ $current(colorbar) tag delete $xx $yy
+ if {$current(frame) != {}} {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+ }
+ }
+ }
+ }
+}
+
+proc ColorbarKeyRelease {K A xx yy} {
+ global current
+ global ds9
+
+ # MacOSX and Ubuntu returns bogus values in xx,yy
+ # calculate our own values
+ set xx [expr {[winfo pointerx $ds9(canvas)] - [winfo rootx $ds9(canvas)]}]
+ set yy [expr {[winfo pointery $ds9(canvas)] - [winfo rooty $ds9(canvas)]}]
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarKeyRelease $K $A $xx $yy"
+ }
+}
+
+proc ColorbarButton1 {x y} {
+ global icolorbar
+ global colorbar
+ global ds9
+ global current
+ global icursor
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarButton1"
+ }
+
+ # let others know that the mouse is down
+ set ds9(b1) 1
+
+ # turn off blinking cursor
+ if {$icursor(timer)} {
+ catch {after cancel $icursor(id)}
+ set icursor(id) 0
+ }
+
+ # are we on a tag? else create
+ switch -- $current(mode) {
+ colorbar {$current(colorbar) tag edit begin $x $y $colorbar(tag)}
+ }
+}
+
+proc ColorbarMotion1 {x y} {
+ global icolorbar
+ global current
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarMotion1"
+ }
+
+ # abort if we are here by accident (such as a double click)
+ if {($ds9(b1) == 0) && ($ds9(sb1) == 0) &&
+ ($ds9(cb1) == 0) && ($ds9(csb1) == 0)} {
+ return
+ }
+
+ switch -- $current(mode) {
+ colorbar {
+ $current(colorbar) tag edit motion $x $y
+ if {$current(frame) != {}} {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+ }
+ }
+}
+
+proc ColorbarRelease1 {x y} {
+ global icolorbar
+ global current
+ global icursor
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarRelease1"
+ }
+
+ # abort if we are here by accident (such as a double click)
+ if {($ds9(b1) == 0) && ($ds9(sb1) == 0) &&
+ ($ds9(cb1) == 0) && ($ds9(csb1) == 0)} {
+ return
+ }
+
+ # and turn on blinking cursor if needed
+ if {$icursor(timer)} {
+ CursorTimer
+ }
+
+ switch -- $current(mode) {
+ colorbar {
+ $current(colorbar) tag edit end $x $y
+ if {$current(frame) != {}} {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+ }
+ }
+
+ # let others know that the mouse is up
+ set ds9(b1) 0
+ set ds9(sb1) 0
+ set ds9(cb1) 0
+ set ds9(csb1) 0
+}
+
+proc ColorbarDouble1 {x y} {
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarDouble1"
+ }
+
+ switch -- $current(mode) {
+ colorbar {ColorTagDialog $x $y}
+ }
+}
+
+proc ColorbarDoubleRelease1 {x y} {
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ColorbarDoubleRelease1"
+ }
+}
+
+proc ColorbarButton3 {x y} {
+ global icolorbar
+
+ global current
+ global rgb
+ global icursor
+
+ # turn off blinking cursor
+ if {$icursor(timer)} {
+ catch {after cancel $icursor(id)}
+ set icursor(id) 0
+ }
+
+ if {$current(frame) != {}} {
+ # we need to hold the current frame, since we may be blinking
+ set icolorbar(frame) $current(frame)
+ $icolorbar(frame) colormap begin
+ }
+}
+
+proc ColorbarMotion3 {x y} {
+ global icolorbar
+
+ global current
+ global canvas
+
+ # X sets bias
+ set bias [expr double($x)/$canvas(width)]
+
+ # Y sets contrast
+ set contrast [expr double($y)/$canvas(height) * 10]
+
+ RGBEvalLockColorbar [list $current(colorbar) adjust $contrast $bias]
+ if {$icolorbar(frame) != {}} {
+ # only update the current colorbar frame
+ $icolorbar(frame) colormap motion [$current(colorbar) get colormap]
+ }
+ UpdateColorDialog
+}
+
+proc ColorbarRelease3 {x y} {
+ global icolorbar
+
+ global current
+ global rgb
+ global icursor
+
+ # and turn on blinking cursor if needed
+ if {$icursor(timer)} {
+ CursorTimer
+ }
+
+ # only update the current colorbar frame
+ if {$icolorbar(frame) != {}} {
+ $icolorbar(frame) colormap end
+ set icolorbar(frame) {}
+ }
+ LockColorCurrent
+ UpdateColorDialog
+}
+
+proc ChangeColormapID {id} {
+ global colorbar
+
+ global current
+
+ colorbar map $id
+ if {$current(frame) != {} } {
+ $current(frame) colormap [colorbar get colormap]
+ set colorbar(map) [colorbar get name]
+ set colorbar(invert) [colorbar get invert]
+ }
+ LockColorCurrent
+ UpdateColorDialog
+}
+
+proc MatchColorCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchColor $current(frame)
+ }
+}
+
+proc MatchColor {which} {
+ global ds9
+ global current
+ global colorbar
+
+ set tt [$which get type]
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ switch -- [$ff get type] {
+ base -
+ 3d {
+ if {$tt != {rgb}} {
+ $ff colormap [colorbar get colormap]
+ }
+ }
+ rgb {
+ if {$tt == {rgb}} {
+ $ff colormap [colorbarrgb get colormap]
+ }
+ }
+ }
+ }
+ }
+}
+
+proc LockColorCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockColor $current(frame)
+ }
+}
+
+proc LockColor {which} {
+ global colorbar
+
+ if {$colorbar(lock)} {
+ MatchColor $which
+ }
+}
+
+proc InvertColorbar {} {
+ global colorbar
+
+ global current
+
+ $current(colorbar) invert $colorbar(invert)
+ if {$current(frame) != {} } {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+ LockColorCurrent
+ UpdateColorDialog
+}
+
+proc UpdateColormapLevel {} {
+ global icolorbar
+
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateColormapLevel"
+ }
+
+ if {$current(frame) != {}} {
+ $current(colorbar) colormap level \
+ [$current(frame) get colormap level $icolorbar(num)]
+ } else {
+ $current(colorbar) colormap level
+ }
+}
+
+proc UpdateColormapLevelMosaic {which x y sys} {
+ global icolorbar
+
+ global current
+ global current
+ global scale
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateColormapLevelMosaic"
+ }
+
+ if {$current(frame) == {}} {
+ $current(colorbar) colormap level
+ return
+ }
+
+ if {($current(frame) == $which) &&
+ ($scale(scope) == "local") &&
+ [$which has fits mosaic]} {
+
+ set ext [$which get fits ext $sys $x $y]
+
+ if {$current(ext) != $ext} {
+ $current(colorbar) colormap level \
+ [$current(frame) get colormap level $icolorbar(num) $sys $x $y]
+ }
+
+ set current(ext) $ext
+ } else {
+ set current(ext) {}
+ }
+}
+
+proc ColorFrameBackup {ch which} {
+ puts $ch "$which colorbar tag \"\{[$which get colorbar tag]\}\""
+ puts $ch "colorbar tag \"\{[$which get colorbar tag]\}\""
+}
+
+proc ColorbarSizeDialog {} {
+ global colorbar
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ if {[EntryDialog [msgcat::mc {Colorbar}] [msgcat::mc {Size}] 10 colorbar(size)]} {
+ UpdateView
+ }
+ }
+ aqua {
+ # we have a race condition here. the main window needs focus
+ # back from the dialog before UpdateView is run, otherwise,
+ # our pretty blue buttons are not activated
+ if {[EntryDialog [msgcat::mc {Colorbar}] [msgcat::mc {Size}] 10 colorbar(size)]} {
+ after 100 UpdateView
+ }
+ }
+ }
+}
+
+proc TicksDialog {} {
+ global colorbar
+
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ if {[EntryDialog [msgcat::mc {Colorbar}] [msgcat::mc {Number of Ticks}] 10 colorbar(ticks)]} {
+ UpdateView
+ }
+ }
+ aqua {
+ # we have a race condition here. the main window needs focus
+ # back from the dialog before UpdateView is run, otherwise,
+ # our pretty blue buttons are not activated
+ if {[EntryDialog [msgcat::mc {Colorbar}] [msgcat::mc {Number of Ticks}] 10 colorbar(ticks)]} {
+ after 100 UpdateView
+ }
+ }
+ }
+}
+
+proc OpenColorTag {} {
+ LoadColorTag [OpenFileDialog colortagfbox]
+}
+
+proc LoadColorTag {fn} {
+ global current
+
+ if {$fn != {}} {
+ $current(colorbar) tag load "\{$fn\}"
+ if {$current(frame) != {}} {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+ }
+}
+
+proc SaveColorTag {} {
+ global current
+
+ set fn [SaveFileDialog colortagfbox]
+ if {$fn != {}} {
+ $current(colorbar) tag save "\{$fn\}"
+ }
+}
+
+proc DeleteColorTag {} {
+ global current
+
+ $current(colorbar) tag delete
+ if {$current(frame) != {}} {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+}
+
+proc ColorTagDialog {x y} {
+ global ds9
+ global current
+ global colorbar
+ global ed2
+
+ set w {.ctagd}
+
+ set rr [$current(colorbar) get tag $x $y]
+
+ set ed2(ok) 0
+ set ed2(id) [lindex $rr 0]
+ set ed2(start) [lindex $rr 1]
+ set ed2(stop) [lindex $rr 2]
+ set ed2(color) [lindex $rr 3]
+
+ DialogCreate $w [msgcat::mc {Color}] ed2(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.tstart -text [msgcat::mc {Start}]
+ ttk::entry $f.start -textvariable ed2(start) -width 10
+ ttk::label $f.tstop -text [msgcat::mc {Stop}]
+ ttk::entry $f.stop -textvariable ed2(stop) -width 10
+ ttk::label $f.tcolor -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color ed2 color {}
+
+ grid $f.tstart $f.start -padx 2 -pady 2 -sticky w
+ grid $f.tstop $f.stop -padx 2 -pady 2 -sticky w
+ grid $f.tcolor $f.color -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ $current(colorbar) tag $ed2(id) $ed2(start) $ed2(stop) $ed2(color)
+ if {$current(frame) != {}} {
+ $current(frame) colormap [$current(colorbar) get colormap]
+ }
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
+proc ColormapDialog {} {
+ global colorbar
+ global icolorbar
+ global dcolorbar
+
+ global ds9
+
+ # see if we already have a window visible
+
+ if {[winfo exists $icolorbar(top)]} {
+ raise $icolorbar(top)
+ return
+ }
+
+ # create the window
+ set w $icolorbar(top)
+ set mb $icolorbar(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Colormap Parameters}] ColormapDestroyDialog
+
+ $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 {Colormap}] -menu $mb.colormap
+ $mb add cascade -label [msgcat::mc {Color}] -menu $mb.color
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command ApplyColormap
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load Colormap}]..." \
+ -command LoadColormap
+ $mb.file add command -label "[msgcat::mc {Save Colormap}]..." \
+ -command SaveColormap
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Download Colormap}]..." \
+ -command {HV cpt CPT-CITY http://soliton.vm.bytemark.co.uk/pub/cpt-city}
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load Contrast/Bias}]..."\
+ -command LoadContrastBias
+ $mb.file add command -label "[msgcat::mc {Save Contrast/Bias}]..." \
+ -command SaveContrastBias
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load Color Tags}]..."\
+ -command OpenColorTag
+ $mb.file add command -label "[msgcat::mc {Save Color Tags}]..." \
+ -command SaveColorTag
+ $mb.file add command -label "[msgcat::mc {Delete Color Tags}]..." \
+ -command DeleteColorTag
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command ColormapDestroyDialog
+
+ EditMenu $mb icolorbar
+
+ ColorMenu $mb.color colorbar tag {}
+
+ menu $mb.colormap
+ menu $mb.colormap.h5
+ menu $mb.colormap.matplotlib
+ menu $mb.colormap.cubehelix
+ menu $mb.colormap.gist
+ menu $mb.colormap.topo
+ menu $mb.colormap.user
+
+ set id [colorbar list id]
+
+ ColormapCreateMenu id $mb.colormap \
+ 0 $icolorbar(end)
+ ColormapCreateMenu id $mb.colormap.h5 \
+ $icolorbar(h5) $icolorbar(matplotlib)
+ ColormapCreateMenu id $mb.colormap.matplotlib \
+ $icolorbar(matplotlib) $icolorbar(cubehelix)
+ ColormapCreateMenu id $mb.colormap.cubehelix \
+ $icolorbar(cubehelix) $icolorbar(gist)
+ ColormapCreateMenu id $mb.colormap.gist \
+ $icolorbar(gist) $icolorbar(topo)
+ ColormapCreateMenu id $mb.colormap.topo \
+ $icolorbar(topo) $icolorbar(user)
+ ColormapCreateMenu id $mb.colormap.user \
+ $icolorbar(user) $icolorbar(count)
+
+ $mb.colormap add separator
+ $mb.colormap add cascade -label [msgcat::mc {h5utils}] \
+ -menu $mb.colormap.h5
+ $mb.colormap add cascade -label [msgcat::mc {Matplotlib}] \
+ -menu $mb.colormap.matplotlib
+ $mb.colormap add cascade -label [msgcat::mc {Cubehelix}] \
+ -menu $mb.colormap.cubehelix
+ $mb.colormap add cascade -label [msgcat::mc {Gist}] \
+ -menu $mb.colormap.gist
+ $mb.colormap add cascade -label [msgcat::mc {Topographic}] \
+ -menu $mb.colormap.topo
+ $mb.colormap add cascade -label [msgcat::mc {User}] \
+ -menu $mb.colormap.user
+ $mb.colormap add separator
+ $mb.colormap add checkbutton \
+ -label [msgcat::mc {Invert Colormap}] \
+ -variable colorbar(invert) -command InvertColorbar
+ $mb.colormap add command -label [msgcat::mc {Reset Colormap}] \
+ -command ResetColormap
+
+ UpdateColorDialog
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ slider $f.cslider 0. 10. [msgcat::mc {Contrast}] \
+ dcolorbar(contrast) [list AdjustColormap]
+ slider $f.bslider 0. 1. [msgcat::mc {Bias}] \
+ dcolorbar(bias) [list AdjustColormap]
+
+ grid $f.cslider -padx 2 -pady 2 -sticky ew
+ grid $f.bslider -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ bind $f.cslider.slider <Button-1> BeginAdjustColormap
+ bind $f.cslider.slider <ButtonRelease-1> EndAdjustColormap
+ bind $f.bslider.slider <Button-1> BeginAdjustColormap
+ bind $f.bslider.slider <ButtonRelease-1> EndAdjustColormap
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] \
+ -command ApplyColormap
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command ColormapDestroyDialog
+ pack $f.apply $f.close -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
+}
+
+proc ColormapCreateMenu {varname which start stop} {
+ upvar $varname var
+
+ for {set ii $start} {$ii<$stop} {incr ii} {
+ set jj [lindex $var $ii]
+ set name [colorbar get name $jj]
+ $which add radiobutton \
+ -label [msgcat::mc $name] \
+ -variable colorbar(map) -value $name \
+ -command "ChangeColormapID $jj"
+ }
+}
+
+proc ColormapDestroyDialog {} {
+ global icolorbar
+ global dcolorbar
+
+ if {[winfo exists $icolorbar(top)]} {
+ destroy $icolorbar(top)
+ destroy $icolorbar(mb)
+ }
+
+ unset dcolorbar
+}
+
+proc ApplyColormap {} {
+ global dcolorbar
+
+ global current
+ global rgb
+
+ RGBEvalLockColorbar [list $current(colorbar) adjust $dcolorbar(contrast) $dcolorbar(bias)]
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap [$current(colorbar) get colormap]]
+ LockColorCurrent
+ }
+}
+
+proc BeginAdjustColormap {} {
+ global icolorbar
+
+ global current
+ global rgb
+
+ set icolorbar(adjustok) 1
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap begin]
+ }
+}
+
+proc AdjustColormap {} {
+ global icolorbar
+ global dcolorbar
+
+ global current
+ global rgb
+
+ if {[info exists icolorbar(adjustok)]} {
+ RGBEvalLockColorbar [list $current(colorbar) adjust $dcolorbar(contrast) $dcolorbar(bias)]
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap motion [$current(colorbar) get colormap]]
+ }
+ }
+}
+
+proc EndAdjustColormap {} {
+ global icolorbar
+
+ global current
+ global rgb
+
+ if {[info exists icolorbar(adjustok)]} {
+ unset icolorbar(adjustok)
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap end]
+ LockColorCurrent
+ }
+ }
+}
+
+proc UpdateColorDialog {} {
+ global icolorbar
+ global dcolorbar
+
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateColorDialog"
+ }
+
+ if {[winfo exists $icolorbar(top)]} {
+ set dcolorbar(contrast) [$current(colorbar) get contrast]
+ set dcolorbar(bias) [$current(colorbar) get bias]
+ set end [expr $icolorbar(end)+$icolorbar(start)]
+
+ if {$current(frame) != {}} {
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ $icolorbar(mb).file entryconfig \
+ "[msgcat::mc {Load Colormap}]..." -state normal
+ $icolorbar(mb).file entryconfig \
+ "[msgcat::mc {Save Colormap}]..." -state normal
+ for {set ii $icolorbar(start)} {$ii<$end} {incr ii} {
+ $icolorbar(mb).colormap entryconfig $ii -state normal
+ }
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {h5utils}] -state normal
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Matplotlib}] -state normal
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Cubehelix}] -state normal
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Gist}] -state normal
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Topographic}] -state normal
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {User}] -state normal
+ }
+ rgb {
+ $icolorbar(mb).file entryconfig \
+ "[msgcat::mc {Load Colormap}]..." -state disabled
+ $icolorbar(mb).file entryconfig \
+ "[msgcat::mc {Save Colormap}]..." -state disabled
+ for {set ii $icolorbar(start)} {$ii<$end} {incr ii} {
+ $icolorbar(mb).colormap entryconfig $ii -state disabled
+ }
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {h5utils}] -state disabled
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Matplotlib}] -state disabled
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Cubehelix}] -state disabled
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Gist}] -state disabled
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {Topographic}] -state disabled
+ $icolorbar(mb).colormap entryconfig \
+ [msgcat::mc {User}] -state disabled
+ }
+ }
+ } else {
+ $icolorbar(mb).file entryconfig \
+ "[msgcat::mc {Load Colormap}]..." -state normal
+ $icolorbar(mb).file entryconfig \
+ "[msgcat::mc {Save Colormap}]..." -state normal
+ for {set ii $icolorbar(start)} {$ii<$end} {incr ii} {
+ $icolorbar(mb).colormap entryconfig $ii -state normal
+ }
+ $icolorbar(mb).colormap entryconfig [msgcat::mc {h5utils}] \
+ -state normal
+ $icolorbar(mb).colormap entryconfig [msgcat::mc {Matplotlib}] \
+ -state normal
+ $icolorbar(mb).colormap entryconfig [msgcat::mc {Cubehelix}] \
+ -state normal
+ $icolorbar(mb).colormap entryconfig [msgcat::mc {Gist}] \
+ -state normal
+ $icolorbar(mb).colormap entryconfig [msgcat::mc {Topographic}] \
+ -state normal
+ $icolorbar(mb).colormap entryconfig [msgcat::mc {User}] \
+ -state normal
+ }
+ }
+}
+
+proc LayoutColorbar {} {
+ global colorbar
+ global icolorbar
+
+ global ds9
+ global canvas
+
+ colorbar configure \
+ -size $colorbar(size) \
+ -ticks $colorbar(ticks) \
+ -numerics $colorbar(numerics) \
+ -space $colorbar(space) \
+ -font $colorbar(font) \
+ -fontsize $colorbar(font,size) \
+ -fontweight $colorbar(font,weight) \
+ -fontslant $colorbar(font,slant) \
+
+ colorbarrgb configure \
+ -size $colorbar(size) \
+ -ticks $colorbar(ticks) \
+ -numerics $colorbar(numerics) \
+ -space $colorbar(space) \
+ -font $colorbar(font) \
+ -fontsize $colorbar(font,size) \
+ -fontweight $colorbar(font,weight) \
+ -fontslant $colorbar(font,slant) \
+
+ switch -- $colorbar(orientation) {
+ horizontal {
+ set xx 0
+ set yy [expr $canvas(height) + $canvas(gap)]
+
+ colorbar configure -x $xx -y $yy \
+ -width $canvas(width) \
+ -height $icolorbar(horizontal,height) \
+ -orientation 0
+
+ colorbarrgb configure -x $xx -y $yy \
+ -width $canvas(width) \
+ -height $icolorbar(horizontal,height) \
+ -orientation 0
+ }
+ vertical {
+ set xx [expr $canvas(width) + $canvas(gap)]
+ set yy 0
+
+ colorbar configure -x $xx -y $yy \
+ -width $icolorbar(vertical,width) \
+ -height $canvas(height) \
+ -orientation 1
+
+ colorbarrgb configure -x $xx -y $yy \
+ -width $icolorbar(vertical,width) \
+ -height $canvas(height) \
+ -orientation 1
+ }
+ }
+}
+
+proc ColorbarBackup {ch which} {
+ global colorbar
+
+ puts $ch "$which configure -size $colorbar(size)"
+ puts $ch "$which configure -ticks $colorbar(ticks)"
+ puts $ch "$which configure -numerics $colorbar(numerics)"
+ puts $ch "$which configure -space $colorbar(space)"
+ switch $colorbar(orientation) {
+ horizontal {puts $ch "$which configure -orientation 0"}
+ vertical {puts $ch "$which configure -orientation 1"}
+ }
+ puts $ch "$which configure -font $colorbar(font)"
+ puts $ch "$which configure -fontsize $colorbar(font,size)"
+ puts $ch "$which configure -fontweight $colorbar(font,weight)"
+ puts $ch "$which configure -fontslant $colorbar(font,slant)"
+
+ puts $ch "$which colorbar [$which get colorbar]"
+ puts $ch "$which tag \"\{[$which get tag]\}\""
+}
+
+proc ColormapFrameBackup {ch which} {
+ switch -- [$which get type] {
+ base -
+ 3d {
+ puts $ch "set sav \[colorbar get colorbar\]"
+ puts $ch "colorbar colorbar [$which get colorbar]"
+ puts $ch "$which colormap \[colorbar get colormap\]"
+ puts $ch "colorbar colorbar \$sav"
+ }
+ rgb {
+ puts $ch "set sav \[colorbarrgb get colorbar\]"
+ puts $ch "colorbarrgb colorbar [$which get colorbar]"
+ puts $ch "$which colormap \[colorbarrgb get colormap\]"
+ puts $ch "colorbarrgb colorbar \$sav"
+ }
+ }
+}
+
+proc ColorbarBackupCmaps {ch dir} {
+ global icolorbar
+
+ set rdir "./[lindex [file split $dir] end]"
+
+ # delete old cmaps
+ foreach ff [glob -directory $dir -nocomplain "*.sao"] {
+ catch {file delete -force $ff}
+ }
+ foreach ff [glob -directory $dir -nocomplain "*.lut"] {
+ catch {file delete -force $ff}
+ }
+
+ # save any loaded cmaps
+ set id [colorbar list id]
+ if {$icolorbar(user)<[llength $id]} {
+ for {set ii $icolorbar(user)} {$ii<[llength $id]} {incr ii} {
+ set which [lindex $id $ii]
+ set nn [lindex [file split [colorbar get file name $which]] end]
+ colorbar save $which \"[file join $dir $nn]\"
+ puts $ch "LoadColormapFile \"[file join $rdir $nn]\""
+ }
+ }
+}
+
+# Process Cmds
+
+proc ProcessCmapCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global colorbar
+ global current
+
+ global ds9
+ global current
+ global rgb
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {ColormapDialog}
+ close {ColormapDestroyDialog}
+ match {
+ # backward compatibility
+ MatchColorCurrent
+ }
+ lock {
+ # backward compatibility
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set colorbar(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set colorbar(lock) 1
+ incr i -1
+ }
+ LockColorCurrent
+ }
+ load -
+ file {
+ incr i
+ set fn [lindex $var $i]
+ LoadColormapFile $fn
+ FileLast colormapfbox $fn
+ }
+ save {
+ incr i
+ set fn [lindex $var $i]
+ SaveColormapFile $fn
+ FileLast colormapfbox $fn
+ }
+ invert {
+ incr i
+ set colorbar(invert) [FromYesNo [lindex $var $i]]
+ InvertColorbar
+ }
+ tag {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch $item {
+ load {incr i; LoadColorTag [lindex $var $i]}
+ save {incr i; $current(colorbar) tag save [lindex $var $i]}
+ delete {DeleteColorTag}
+ }
+ }
+ value {
+ incr i
+ set c [lindex $var $i]
+ incr i
+ set b [lindex $var $i]
+ if {$current(frame) != {}} {
+ RGBEvalLockColorbar [list $current(colorbar) adjust $c $b]
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap begin]
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap motion [$current(colorbar) get colormap]]
+ RGBEvalLockCurrent rgb(lock,colorbar) [list $current(frame) colormap end]
+ }
+ LockColorCurrent
+ UpdateColorDialog
+ }
+ default {
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ set cmap [lindex $var $i]
+ # common variants on spellings
+ switch -- [string tolower $cmap] {
+ gray {set cmap grey}
+ }
+
+ set id [colorbar list id]
+ set found 0
+ foreach ii $id {
+ set title [colorbar get name $ii]
+ if {[string equal -nocase $title $cmap]} {
+ set colorbar(map) $title
+ colorbar map "{$colorbar(map)}"
+ $current(frame) colormap [colorbar get colormap]
+ set colorbar(invert) [colorbar get invert]
+
+ set found 1
+ break
+ }
+ }
+ if {!$found} {
+ Error "[msgcat::mc {Unknown Colormap}] $cmap"
+ }
+ }
+ rgb {}
+ }
+ LockColorCurrent
+ UpdateColorDialog
+ }
+ }
+}
+
+proc ProcessSendCmapCmd {proc id param} {
+ global colorbar
+ global current
+
+ switch -- [string tolower $param] {
+ file {$proc $id "[$current(colorbar) get file name]\n"}
+ invert {$proc $id [ToYesNo $colorbar(invert)]}
+ value {$proc $id "[$current(colorbar) get contrast] [$current(colorbar) get bias]\n"}
+ lock {$proc $id [ToYesNo $colorbar(lock)]}
+ {} {$proc $id "[$current(colorbar) get name]\n"}
+ }
+}
+
+proc ProcessColorbarCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global colorbar
+ global view
+
+ set item [string tolower [lindex $var $i]]
+
+ switch -- $item {
+ match {
+ # backward compatibility
+ MatchColorCurrent
+ }
+ lock {
+ # backward compatibility
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set colorbar(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set colorbar(lock) 1
+ incr i -1
+ }
+ LockColorCurrent
+ }
+ numerics {
+ incr i
+ set yesno [string tolower [lindex $var $i]]
+ set colorbar(numerics) [FromYesNo $yesno]
+ UpdateView
+ }
+ space {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ value {set item 1}
+ default {set item 0}
+ }
+ set colorbar(space) $item
+ UpdateView
+ }
+ font {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ set colorbar(font) $item
+ UpdateView
+ }
+ fontsize {
+ incr i
+ set item [lindex $var $i]
+ set colorbar(font,size) $item
+ UpdateView
+ }
+ fontweight {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ set colorbar(font,weight) $item
+ UpdateView
+ }
+ fontslant {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ set colorbar(font,slant) $item
+ UpdateView
+ }
+ fontstyle {
+ # backward compatibility
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch $item {
+ normal {
+ set colorbar(font,weight) normal
+ set colorbar(font,slant) roman
+ }
+ bold {
+ set colorbar(font,weight) bold
+ set colorbar(font,slant) roman
+ }
+ italic {
+ set colorbar(font,weight) normal
+ set colorbar(font,slant) italic
+ }
+ }
+ UpdateView
+ }
+ orientation {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ set colorbar(orientation) $item
+ UpdateView
+ }
+ vertical -
+ horizontal {
+ set colorbar(orientation) $item
+ UpdateView
+ }
+ size {
+ incr i
+ set item [lindex $var $i]
+ set colorbar(size) $item
+ UpdateView
+ }
+ ticks {
+ incr i
+ set item [lindex $var $i]
+ set colorbar(ticks) $item
+ UpdateView
+ }
+ default {
+ set yesno [string tolower [lindex $var $i]]
+ set view(colorbar) [FromYesNo $yesno]
+ UpdateView
+ }
+ }
+}
+
+proc ProcessSendColorbarCmd {proc id param} {
+ global colorbar
+ global view
+
+ switch -- [string tolower [lindex $param 0]] {
+ lock {
+ #backward compatibility
+ $proc $id [ToYesNo $colorbar(lock)]
+ }
+ orientation {$proc $id "$colorbar(orientation)\n"}
+ numerics {$proc $id [ToYesNo $colorbar(numerics)]}
+ space {
+ if {$colorbar(space)} {
+ $proc $id "value\n"
+ } else {
+ $proc $id "distance\n"
+ }
+ }
+ font {$proc $id "$colorbar(font)\n"}
+ fontsize {$proc $id "$colorbar(font,size)\n"}
+ fontstyle -
+ fontweight {$proc $id "$colorbar(font,weight)\n"}
+ fontslant {$proc $id "$colorbar(font,slant)\n"}
+ size {$proc $id "$colorbar(size)\n"}
+ ticks {$proc $id "$colorbar(ticks)\n"}
+ default {$proc $id [ToYesNo $view(colorbar)]}
+ }
+}
diff --git a/ds9/library/comm.tcl b/ds9/library/comm.tcl
new file mode 100644
index 0000000..7fdd0d8
--- /dev/null
+++ b/ds9/library/comm.tcl
@@ -0,0 +1,386 @@
+# 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
+
+# used to access ProcessSend*Cmd via tcl
+proc CommReturn {id rr} {
+ return "$id $rr"
+}
+
+proc CommSet {fn paramlist {safemode 0}} {
+ global debug
+ if {$debug(tcl,hv) || $debug(tcl,samp)} {
+ puts stderr "CommSet:$fn:$paramlist:$safemode"
+ }
+
+ set cmd [lindex $paramlist 0]
+ set param [lrange $paramlist 1 end]
+ set len 0
+
+ set i 0
+
+ catch {
+ switch -- $cmd {
+ 2mass {Process2MASSCmd param i}
+ 3d {Process3DCmd param i}
+ about {}
+ align {ProcessAlignCmd param i}
+ analysis {ProcessAnalysisCmd param i {} $fn}
+ array {ProcessArrayCmd param i {} $fn}
+ bg -
+ background {ProcessBgCmd param i}
+ backup {ProcessBackupCmd param i}
+ blink {ProcessBlinkCmd param i}
+ bin {ProcessBinCmd param i}
+ block {ProcessBlockCmd param i}
+ cat -
+ catalog {ProcessCatalogCmd param i}
+ cd {ProcessCDCmd param i}
+ cmap {ProcessCmapCmd param i}
+ colorbar {ProcessColorbarCmd param i}
+ console {ProcessConsoleCmd param i}
+ contours -
+ contour {ProcessContourCmd param i}
+ crop {ProcessCropCmd param i}
+ crosshair {ProcessCrosshairCmd param i}
+ cursor {ProcessCursorCmd param i}
+ data {}
+ datacube -
+ cube {ProcessCubeCmd param i}
+ dss -
+ dsssao {ProcessSAOCmd param i}
+ dsseso {ProcessESOCmd param i}
+ dssstsci {ProcessSTSCICmd param i}
+ envi {ProcessENVICmd param i {} $fn}
+ export {ProcessExportCmd param i}
+ file {ProcessFileCmd param i {} {} {}}
+ fits {ProcessFitsCmd param i {} $fn}
+ frame {ProcessFrameCmd param i}
+ gif {ProcessGIFCmd param i {} $fn}
+ grid {ProcessGridCmd param i}
+ header {ProcessHeaderCmd param i}
+ height {ProcessHeightCmd param i}
+ iconify {ProcessIconifyCmd param i}
+ iexam -
+ imexam {}
+ iis {ProcessIISCmd param i}
+ irafalign {
+ # backward compatibility
+ ProcessIRAFAlignCmd param i
+ }
+ jpg -
+ jpeg {ProcessJPEGCmd param i {} $fn}
+ lock {ProcessLockCmd param i}
+ lower {ProcessLowerCmd param i}
+ magnifier {ProcessMagnifierCmd param i}
+ mask {ProcessMaskCmd param i}
+ match {ProcessMatchCmd param i}
+ mecube {ProcessMECubeCmd param i {} $fn}
+ minmax {ProcessMinMaxCmd param i}
+ mode {ProcessModeCmd param i}
+ mosaic {ProcessMosaicCmd param i {} $fn}
+ mosaicimage {ProcessMosaicImageCmd param i {} $fn}
+ mosaicwcs {
+ # backward compatibility
+ ProcessMosaicWCSCmd param i {} $fn
+ }
+ mosaiciraf {
+ # backward compatibility
+ ProcessMosaicIRAFCmd param i {} $fn
+ }
+ mosaicimagewcs {
+ # backward compatibility
+ ProcessMosaicImageWCSCmd param i {} $fn
+ }
+ mosaicimageiraf {
+ # backward compatibility
+ ProcessMosaicImageIRAFCmd param i {} $fn
+ }
+ mosaicimagewfpc2 {
+ # backward compatibility
+ ProcessMosaicImageWFPC2Cmd param i {} $fn
+ }
+ savempeg -
+ movie {ProcessMovieCmd param i}
+ memf -
+ multiframe {ProcessMultiFrameCmd param i {} $fn}
+ nameserver {ProcessNRESCmd param i}
+ nan {ProcessNanCmd param i}
+ nrrd {ProcessNRRDCmd param i {} $fn}
+ nvss {ProcessNVSSCmd param i}
+ orient {ProcessOrientCmd param i}
+ {page setup} -
+ pagesetup {ProcessPageSetupCmd param i}
+ pspagesetup {ProcessPSPageSetupCmd param i}
+ pan {ProcessPanCmd param i}
+ pixeltable {ProcessPixelTableCmd param i}
+ plot {ProcessPlotCmd param i {} $fn}
+ png {ProcessPNGCmd param i {} $fn}
+ prefs {ProcessPrefsCmd param i}
+ preserve {ProcessPreserveCmd param i}
+ print {
+ if {$safemode} {
+ Error [msgcat::mc {Command not allowed}]
+ } else {
+ ProcessPrintCmd param i
+ }
+ }
+ psprint {
+ if {$safemode} {
+ Error [msgcat::mc {Command not allowed}]
+ } else {
+ ProcessPSPrintCmd param i
+ }
+ }
+ exit -
+ quit {ProcessQuitCmd param i}
+ raise {ProcessRaiseCmd param i}
+ restore {ProcessRestoreCmd param i}
+ region -
+ regions {ProcessRegionsCmd param i {} $fn}
+ rgb {ProcessRGBCmd param i}
+ rgbarray {ProcessRGBArrayCmd param i {} $fn}
+ rgbcube {ProcessRGBCubeCmd param i {} $fn}
+ rgbimage {ProcessRGBImageCmd param i {} $fn}
+ rotate {ProcessRotateCmd param i}
+ samp {ProcessSAMPCmd param i}
+ save -
+ savefits {ProcessSaveCmd param i}
+ saveimage {ProcessSaveImageCmd param i}
+ scale {ProcessScaleCmd param i}
+ sfits {
+ # backward compatibility
+ ProcessSFitsCmd param i {} $fn
+ }
+ sia {ProcessSIACmd param i}
+ single {ProcessSingleCmd param i}
+ shm {ProcessShmCmd param i 0}
+ skyview {ProcessSkyViewCmd param i}
+ sleep {ProcessSleepCmd param i}
+ smosaic {
+ # backward compatibility
+ ProcessSMosaicCmd param i {} $fn
+ }
+ smosaicwcs {
+ # backward compatibility
+ ProcessSMosaicWCSCmd param i {} $fn
+ }
+ smosaiciraf {
+ # backward compatibility
+ ProcessSMosaicIRAFCmd param i {} $fn
+ }
+ smooth {ProcessSmoothCmd param i}
+ source {
+ if {$safemode} {
+ Error [msgcat::mc {Command not allowed}]
+ } else {
+ ProcessSourceCmd param i
+ }
+ }
+ srgbcube {ProcessSRGBCubeCmd param i {} $fn}
+ tcl {
+ if {$safemode} {
+ Error [msgcat::mc {Command not allowed}]
+ } else {
+ ProcessTclCmd param i {} $fn
+ }
+ }
+ theme {
+ # backward compatibility
+ ProcessThemeCmd param i
+ }
+ threads {ProcessThreadsCmd param i}
+ tif -
+ tiff {ProcessTIFFCmd param i {} $fn}
+ tile {ProcessTileCmd param i}
+ update {ProcessUpdateCmd param i}
+ url {ProcessURLFitsCmd param i}
+ version {}
+ view {ProcessViewCmd param i}
+ vla -
+ first {ProcessVLACmd param i}
+ vlss {ProcessVLSSCmd param i}
+ vo {ProcessVOCmd param i}
+ wcs {ProcessWCSCmd param i {} $fn}
+ web {ProcessWebCmd param i}
+ width {ProcessWidthCmd param i}
+ zoom {ProcessZoomCmd param i}
+ zscale {ProcessZScaleCmd param i}
+ default {Error "[msgcat::mc {Unknown command}]: $cmd"}
+ }
+ }
+}
+
+proc CommGet {proc id paramlist fn} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "CommGet:$proc:$id:$paramlist:$fn"
+ }
+
+ set cmd [lindex $paramlist 0]
+ set param [lrange $paramlist 1 end]
+
+ catch {
+ switch -- $cmd {
+ 2mass {ProcessSend2MASSCmd $proc $id $param}
+ 3d {ProcessSend3DCmd $proc $id $param}
+ about {ProcessSendAboutCmd $proc $id $param {} $fn}
+ align {ProcessSendAlignCmd $proc $id $param}
+ analysis {ProcessSendAnalysisCmd $proc $id $param {} $fn}
+ array {ProcessSendArrayCmd $proc $id $param {} $fn}
+ bg -
+ background {ProcessSendBgCmd $proc $id $param}
+ blink {ProcessSendBlinkCmd $proc $id $param}
+ bin {ProcessSendBinCmd $proc $id $param}
+ block {ProcessSendBlockCmd $proc $id $param}
+ cat -
+ catalog {ProcessSendCatalogCmd $proc $id $param {} $fn}
+ cd {ProcessSendCDCmd $proc $id $param}
+ cmap {ProcessSendCmapCmd $proc $id $param}
+ colorbar {ProcessSendColorbarCmd $proc $id $param}
+ console {}
+ contours -
+ contour {ProcessSendContourCmd $proc $id $param {} $fn}
+ crop {ProcessSendCropCmd $proc $id $param}
+ crosshair {ProcessSendCrosshairCmd $proc $id $param}
+ cursor {}
+ data {ProcessSendDataCmd $proc $id $param {} $fn}
+ datacube -
+ cube {ProcessSendCubeCmd $proc $id $param}
+ dss -
+ dsssao {ProcessSendSAOCmd $proc $id $param}
+ dsseso {ProcessSendESOCmd $proc $id $param}
+ dssstsci {ProcessSendSTSCICmd $proc $id $param}
+ envi {}
+ exit {}
+ export {}
+ file {ProcessSendFileCmd $proc $id $param}
+ fits {ProcessSendFitsCmd $proc $id $param {} $fn}
+ frame {ProcessSendFrameCmd $proc $id $param}
+ gif {ProcessSendGIFCmd $proc $id $param {} $fn}
+ grid {ProcessSendGridCmd $proc $id $param}
+ header {}
+ height {ProcessSendHeightCmd $proc $id $param}
+ iconify {ProcessSendIconifyCmd $proc $id $param}
+ iexam -
+ imexam {ProcessSendIExamCmd $proc $id $param}
+ iis {ProcessSendIISCmd $proc $id $param}
+ irafalign {
+ # backward compatibility
+ ProcessSendIRAFAlignCmd $proc $id $param
+ }
+ jpg -
+ jpeg {ProcessSendJPEGCmd $proc $id $param {} $fn}
+ lock {ProcessSendLockCmd $proc $id $param}
+ lower {}
+ magnifier {ProcessSendMagnifierCmd $proc $id $param}
+ mask {ProcessSendMaskCmd $proc $id $param}
+ match {}
+ mecube {ProcessSendMECubeCmd $proc $id $param {} $fn}
+ minmax {ProcessSendMinMaxCmd $proc $id $param}
+ mode {ProcessSendModeCmd $proc $id $param}
+ mosaic {ProcessSendMosaicCmd $proc $id $param {} $fn}
+ mosaicimage {ProcessSendMosaicImageCmd $proc $id $param {} $fn}
+ mosaicwcs {
+ # backward compatibility
+ ProcessSendMosaicWCSCmd $proc $id $param {} $fn
+ }
+ mosaiciraf {
+ # backward compatibility
+ }
+ mosaicimagewcs {
+ # backward compatibility
+ ProcessSendMosaicImageWCSCmd $proc $id $param {} $fn
+ }
+ mosaicimageiraf {
+ # backward compatibility
+ }
+ mosaicimagewfpc2 {
+ # backward compatibility
+ }
+ savempeg -
+ movie {}
+ memf -
+ multiframe {}
+ nameserver {ProcessSendNRESCmd $proc $id $param}
+ nan {ProcessSendNanCmd $proc $id $param}
+ nrrd {ProcessSendNRRDCmd $proc $id $param {} $fn}
+ nvss {ProcessSendNVSSCmd $proc $id $param}
+ orient {ProcessSendOrientCmd $proc $id $param}
+ {page setup} -
+ pagesetup {ProcessSendPageSetupCmd $proc $id $param}
+ pan {ProcessSendPanCmd $proc $id $param}
+ pixeltable {ProcessSendPixelTableCmd $proc $id $param {} $fn}
+ plot {ProcessSendPlotCmd $proc $id $param}
+ png {ProcessSendPNGCmd $proc $id $param {} $fn}
+ prefs {ProcessSendPrefsCmd $proc $id $param}
+ preserve {ProcessSendPreserveCmd $proc $id $param}
+ pspagesetup {ProcessSendPSPageSetupCmd $proc $id $param}
+ print {ProcessSendPrintCmd $proc $id $param}
+ psprint {ProcessSendPSPrintCmd $proc $id $param}
+ exit -
+ quit {}
+ raise {}
+ region -
+ regions {ProcessSendRegionsCmd $proc $id $param {} $fn}
+ rgb {ProcessSendRGBCmd $proc $id $param}
+ rgbarray {ProcessSendRGBArrayCmd $proc $id $param {} $fn}
+ rgbcube {ProcessSendRGBCubeCmd $proc $id $param {} $fn}
+ rgbimage {ProcessSendRGBImageCmd $proc $id $param {} $fn}
+ rotate {ProcessSendRotateCmd $proc $id $param}
+ samp {}
+ save -
+ savefits {}
+ saveimage {}
+ scale {ProcessSendScaleCmd $proc $id $param}
+ sfits {
+ # backward compatibility
+ }
+ single {ProcessSendSingleCmd $proc $id $param}
+ shm {ProcessSendShmCmd $proc $id $param}
+ skyview {ProcessSendSkyViewCmd $proc $id $param}
+ smosaic {
+ # backward compatibility
+ }
+ smosaiciraf {
+ # backward compatibility
+ }
+ smosaicwcs {
+ # backward compatibility
+ }
+ smooth {ProcessSendSmoothCmd $proc $id $param}
+ source {}
+ srgbcube {}
+ tcl {}
+ theme {
+ # backward compatibility
+ ProcessSendThemeCmd $proc $id $param
+ }
+ threads {ProcessSendThreadsCmd $proc $id $param}
+ tif -
+ tiff {ProcessSendTIFFCmd $proc $id $param {} $fn}
+ tile {ProcessSendTileCmd $proc $id $param}
+ update {}
+ url {}
+ version {ProcessSendVersionCmd $proc $id $param}
+ view {ProcessSendViewCmd $proc $id $param}
+ vla -
+ first {ProcessSendVLACmd $proc $id $param}
+ vlss {ProcessSendVLSSCmd $proc $id $param}
+ vo {ProcessSendVOCmd $proc $id $param}
+ wcs {ProcessSendWCSCmd $proc $id $param}
+ web {ProcessSendWebCmd $proc $id $param}
+ width {ProcessSendWidthCmd $proc $id $param}
+ zscale {ProcessSendZScaleCmd $proc $id $param}
+ zoom {ProcessSendZoomCmd $proc $id $param}
+ default {
+ Error "[msgcat::mc {Unknown command}]: $cmd"
+ $proc $id {}
+ }
+ }
+ }
+}
+
+
diff --git a/ds9/library/command.tcl b/ds9/library/command.tcl
new file mode 100644
index 0000000..50f8151
--- /dev/null
+++ b/ds9/library/command.tcl
@@ -0,0 +1,918 @@
+# 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 BadVisualError {} {
+ global ds9
+
+ Error [msgcat::mc {Sorry, DS9 requires a Truecolor8, Truecolor16, Truecolor24 visual be available}]
+ exit
+}
+
+proc ProcessCommandLineFirst {} {
+ global argc
+ global argv
+ global icolorbar
+ global ds9
+ global pds9
+
+ set i 0
+ while {$i < $argc} {
+ set item [lindex $argv $i]
+
+ switch -- $item {
+ -help {
+ puts "For more information, use --help"
+ QuitDS9
+ }
+ -debug {incr i; ProcessDebugTclCmd argv i}
+ -private {
+ # backward compatibility
+ }
+ -title {
+ incr i
+ set ds9(title) [lindex $argv $i]
+ set t "SAOImage $ds9(title)"
+ wm title $ds9(top) "$t"
+ wm iconname $ds9(top) "$t"
+ }
+ -language {
+ incr i
+ set pds9(language) [lindex $argv $i]
+ set pds9(language,name) [LanguageToName $pds9(language)]
+ }
+ -msg {
+ incr i
+ set pds9(language,dir) [lindex $argv $i]
+ }
+ -xpa {incr i; ProcessXPAFirstCmd argv i}
+ }
+ incr i
+ }
+}
+
+proc ProcessCommandLine {} {
+ global argc
+ global argv
+
+ ProcessCommand $argv $argc
+}
+
+proc ds9Cmd {argv} {
+ ProcessCommand $argv [llength $argv]
+}
+
+proc ProcessCommand {argv argc} {
+ global ds9
+ global pds9
+ global help
+ global current
+ global contour
+ global colorbar
+ global debug
+ global wcs
+ global view
+ global grid
+ global bin
+ global scale
+ global minmax
+ global zscale
+ global iis
+ global file
+
+ set file(type) fits
+ set file(mode) {}
+ set file(layer) {}
+ set file(mosaic) wcs
+
+ set load 0
+ set noopts 0
+ set i 0
+
+ # Note: -help is processed previously for fv (temporary)
+ set item {}
+
+ while {$i < $argc} {
+ set item [lindex $argv $i]
+ switch -- $item {
+ -- {set noopts 1}
+ -? -
+ -help -
+ --help {HelpCommand}
+
+ -version {
+ ProcessSendVersionCmd puts stdout {}
+ QuitDS9
+ }
+
+ -2mass {incr i; Process2MASSCmd argv i}
+ -3d -
+ -3D {incr i; Process3DCmd argv i}
+ -about {ProcessSendAboutCmd puts stdout {} {} {}}
+ -align {incr i; ProcessAlignCmd argv i}
+ -analysis {incr i; ProcessAnalysisCmd argv i {} {}}
+ -array {set file(type) array}
+ -asinh {set scale(type) asinh; ChangeScale}
+ -bg -
+ -background {incr i; ProcessBgCmd argv i}
+ -backup {incr i; ProcessBackupCmd argv i}
+ -bin {incr i; ProcessBinCmd argv i}
+ -block {incr i; ProcessBlockCmd argv i}
+ -blink {incr i; ProcessBlinkCmd argv i}
+ -blue {set current(rgb) blue; RGBChannel}
+ -cat -
+ -catalog {incr i; ProcessCatalogCmd argv i}
+ -cd {incr i; ProcessCDCmd argv i}
+ -cmap {incr i; ProcessCmapCmd argv i}
+ -colorbar {incr i; ProcessColorbarCmd argv i}
+ -console {ProcessConsoleCmd argv i}
+ -contours -
+ -contour {incr i; ProcessContourCmd argv i}
+ -nocontour {set contour(view) 0; ContourUpdate}
+ -crop {incr i; ProcessCropCmd argv i}
+ -crosshair {incr i; ProcessCrosshairCmd argv i}
+ -cursor {incr i; ProcessCursorCmd argv i}
+ -datacube -
+ -cube {incr i; ProcessCubeCmd argv i}
+ -debug {incr i; ProcessDebugCmd argv i}
+ -dss -
+ -dsssao {incr i; ProcessSAOCmd argv i}
+ -dsseso {incr i; ProcessESOCmd argv i}
+ -dssstsci {incr i; ProcessSTSCICmd argv i}
+ -envi {set file(type) envi}
+ -export {incr i; ProcessExportCmd argv i}
+ -exit -
+ -quit {ProcessQuitCmd argv i}
+ -frame {incr i; ProcessFrameCmd argv i}
+ -fifo {
+ incr i
+ set fifo [lindex $argv $i]
+ if {$fifo!="none"} {
+ set iis(ififo) ${fifo}i
+ set iis(ofifo) ${fifo}o
+ } else {
+ set iis(ififo) none
+ set iis(ofifo) none
+ }
+ }
+ -fifo_only {
+ set iis(port) 0
+ set iis(unix) none
+ }
+ -file -
+ -fits {set file(type) fits; CommandFitsCmd argv i}
+ -geometry {
+ # already processed
+ }
+ -gif {set file(type) gif}
+ -green {set current(rgb) green; RGBChannel}
+ -grid {incr i; ProcessGridCmd argv i}
+ -nogrid {set grid(view) 0; GridUpdateCurrent}
+ -header {incr i; ProcessHeaderCmd argv i}
+ -height {incr i; ProcessHeightCmd argv i}
+ -histequ {set scale(type) histequ; ChangeScale}
+ -horzgraph {
+ # backward compatibility
+ set view(graph,horz) 1
+ UpdateView
+ }
+ -nohorzgraph {
+ # backward compatibility
+ set view(graph,horz) 0
+ UpdateView
+ }
+ -iconify {incr i; ProcessIconifyCmd argv i}
+ -iis {incr i; ProcessIISCmd argv i}
+ -info {
+ # backward compatibility
+ set view(info) 1
+ UpdateView
+ }
+ -noinfo {
+ # backward compatibility
+ set view(info) 0
+ UpdateView
+ }
+ -invert {set colorbar(invert) 1; InvertColorbar}
+ -jpg -
+ -jpeg {set file(type) jpeg}
+ -language {
+ # already processed
+ incr i
+ }
+ -lock {incr i; ProcessLockCmd argv i}
+ -linear {set scale(type) linear; ChangeScale}
+ -log {set scale(type) log; ChangeScale}
+ -lower {ProcessLowerCmd argv i}
+ -magnifier {incr i; ProcessMagnifierCmd argv i}
+ -nomagnifier {
+ # backward compatibility
+ set view(magnifier) 0
+ UpdateView
+ }
+ -mask {incr i; set file(layer) [ProcessMaskCmd argv i]}
+ -nomask {set file(layer) {}}
+ -match {incr i; ProcessMatchCmd argv i}
+ -mecube {set file(type) mecube}
+ -memf -
+ -multiframe {set file(type) multiframe}
+ -minmax {incr i; ProcessMinMaxCmd argv i}
+ -minmaxmode {
+ # backward compatibility
+ incr i
+ set minmax(mode) [lindex $argv $i]
+ }
+ -minmaxsample {
+ # backward compatibility
+ incr i
+ set minmax(sample) [lindex $argv $i]
+ }
+ -mode {incr i; ProcessModeCmd argv i}
+
+ -mosaic {
+ set file(type) mosaic
+ CommandMosaicCmd argv i
+ }
+ -mosaicimage {
+ set file(type) mosaicimage
+ CommandMosaicImageCmd argv i
+ }
+
+ -mosaicimageiraf {
+ # backward compatibility
+ set file(type) mosaicimage
+ set file(mosaic) iraf
+ }
+ -mosaicimagewcs {
+ # backward compatibility
+ set file(type) mosaicimage
+ set file(mosaic) wcs
+ }
+ -mosaicimagewfpc2 {
+ # backward compatibility
+ set file(type) mosaicimage
+ set file(mosaic) wfpc2
+ }
+
+ -mosaiciraf {
+ # backward compatibility
+ set file(type) mosaic
+ set file(mosaic) iraf
+ }
+ -mosaicwcs {
+ # backward compatibility
+ set file(type) mosaic
+ set file(mosaic) wcs
+ }
+ -savempeg -
+ -movie {incr i; ProcessMovieCmd argv i}
+
+ -msg {
+ # already processed
+ incr i
+ }
+ -nameserver {incr i; ProcessNRESCmd argv i}
+ -nan {incr i; ProcessNanCmd argv i}
+ -nrrd {set file(type) nrrd}
+ -nvss {incr i; ProcessNVSSCmd argv i}
+ -orient {incr i; ProcessOrientCmd argv i}
+ -pagesetup {incr i; ProcessPageSetupCmd argv i}
+ -pspagesetup {incr i; ProcessPSPageSetupCmd argv i}
+ -pan {incr i; ProcessPanCmd argv i}
+ -panner {
+ # backward compatibility
+ set view(panner) 1
+ UpdateView
+ }
+ -nopanner {
+ # backward compatibility
+ set view(panner) 0
+ UpdateView
+ }
+ -photo {
+ # backward compatibility
+ set file(type) tiff
+ }
+ -pixeltable {incr i; ProcessPixelTableCmd argv i}
+ -nopixeltable {PixelTableDestroyDialog}
+ -plot {incr i; ProcessPlotCmd argv i {} {}}
+ -png {set file(type) png}
+ -port {incr i; set iis(port) [lindex $argv $i]}
+ -inet_only -
+ -port_only {
+ set iis(ififo) none
+ set iis(ofifo) none
+ set iis(unix) none
+ }
+ -pow {set scale(type) pow; ChangeScale}
+ -prefs {incr i; ProcessPrefsCmd argv i}
+ -preserve {incr i; ProcessPreserveCmd argv i}
+ -print {incr i; ProcessPrintCmd argv i}
+ -psprint {incr i; ProcessPSPrintCmd argv i}
+ -private {
+ #already processed
+ }
+ -raise {ProcessRaiseCmd argv i}
+ -red {set current(rgb) red; RGBChannel}
+ -region -
+ -regions -
+ -regionfile {incr i; ProcessRegionsCmd argv i {} {}}
+ -restore {incr i; ProcessRestoreCmd argv i}
+ -rgb {incr i; ProcessRGBCmd argv i}
+ -rgbcube {set file(type) rgbcube}
+ -srgbcube {
+ # backward compatibility
+ set file(type) srgbcube
+ }
+ -rgbimage {set file(type) rgbimage}
+ -rgbarray {set file(type) rgbarray}
+ -rotate {incr i; ProcessRotateCmd argv i}
+ -samp {incr i; ProcessSAMPCmd argv i}
+ -savefits -
+ -save {incr i; ProcessSaveCmd argv i}
+ -saveimage {incr i; ProcessSaveImageCmd argv i}
+ -scale -
+ -ztrans {incr i; ProcessScaleCmd argv i}
+ -scalelims -
+ -scalelimits {
+ #backward compatibility
+ incr i
+ set scale(min) [lindex $argv $i]
+ incr i
+ set scale(max) [lindex $argv $i]
+ ChangeScaleLimit
+ }
+ -scalemode {
+ #backward compatibility
+ incr i
+ set scale(mode) [string tolower [lindex $argv $i]]
+ ChangeScaleMode
+ }
+ -scalescope {
+ #backward compatibility
+ incr i
+ set scale(scope) [string tolower [lindex $argv $i]]
+ ChangeScaleScope
+ }
+ -sfits {
+ # backward compatibility
+ set file(type) sfits
+ CommandSFitsCmd argv i
+ }
+ -sia {incr i; ProcessSIACmd argv i}
+ -shm {incr i; ProcessShmCmd argv i 1}
+ -single {ProcessSingleCmd argv i}
+ -sinh {set scale(type) sinh; ChangeScale}
+ -skyview {incr i; ProcessSkyViewCmd argv i}
+ -sleep {incr i; ProcessSleepCmd argv i}
+ -slice {set file(mode) slice}
+ -noslice {set file(mode) {}}
+ -smooth {incr i; ProcessSmoothCmd argv i}
+ -smosaic {
+ # backward compatibility
+ set file(type) smosaic
+ CommandMosaicCmd argv i
+ }
+ -smosaiciraf {
+ # backward compatibility
+ set file(type) smosaic
+ set file(mosaic) iraf
+ }
+ -smosaicwcs {
+ # backward compatibility
+ set file(type) smosaic
+ set file(mosaic) wcs
+ }
+ -squared {set scale(type) squared; ChangeScale}
+ -sqrt {set scale(type) sqrt; ChangeScale}
+ -source {incr i; ProcessSourceCmd argv i}
+ -tcl {incr i; ; ProcessTclCmd argv i {} {}}
+ -theme {
+ # backward compatibility
+ incr i; ProcessThemeCmd argv i
+ }
+ -threads {incr i; ProcessThreadsCmd argv i}
+ -tif -
+ -tiff {set file(type) tiff}
+ -tile {incr i; ProcessTileCmd argv i}
+ -title {
+ #already processed
+ incr i
+ }
+ -unix {incr i; set iis(unix) [lindex $argv $i]}
+ -unix_only {
+ set iis(ififo) none
+ set iis(ofifo) none
+ set iis(port) 0
+ }
+ -url {set file(type) url}
+ -update {incr i; ProcessUpdateCmd argv i}
+ -vertgraph {
+ #backward compatibility
+ set view(graph,vert) 1
+ UpdateView
+ }
+ -novertgraph {
+ #backward compatibility
+ set view(graph,vert) 0
+ UpdateView
+ }
+ -view {incr i; ProcessViewCmd argv i}
+ -visual {
+ #already processed
+ }
+ -vla -
+ -first {incr i; ProcessVLACmd argv i}
+ -vlss {incr i; ProcessVLSSCmd argv i}
+ -vo {incr i; ProcessVOCmd argv i}
+ -wcs {incr i; ProcessWCSCmd argv i {} {}}
+ -wcsformat {
+ #backward compatibility
+ incr i
+ set wcs(format,) [lindex $argv $i]
+ }
+ -web {incr i; ProcessWebCmd argv i}
+ -width {incr i; ProcessWidthCmd argv i}
+ -xpa {incr i; ProcessXPACmd argv i}
+ -z1 {
+ #backward compatibility
+ incr i
+ set scale(min) [lindex $argv $i]
+ ChangeScaleLimit
+ }
+ -z2 {
+ #backward compatibility
+ incr i
+ set scale(max) [lindex $argv $i]
+ ChangeScaleLimit
+ }
+ -zscale {incr i; ProcessZScaleCmd argv i}
+ -zmax {set scale(mode) zmax; ChangeScaleMode}
+ -zoom {incr i; ProcessZoomCmd argv i}
+
+ default {
+ # allow abc, -, and -[foo] but not -abc
+ if {!$noopts && [regexp -- {^-[a-zA-Z]+} $item]} {
+ puts stderr "[msgcat::mc {Unknown command}]: $item"
+ puts stderr "[msgcat::mc {For more information, use --help}]"
+ return
+ }
+
+ if {$load == 0} {
+ StartLoad
+ incr load
+ }
+
+ switch $ds9(wm) {
+ x11 -
+ aqua {CommandLineLoad $item argv i}
+ win32 {
+ # if win32 and envoked via DOS shell
+ # we must expand wildcards ourselves
+ if {[catch {glob $item} fns]} {
+ # cygwin/double click/DOS Shell no wildcards
+ CommandLineLoad $item argv i
+ } else {
+ # DOS Shell with wildcards
+ foreach fn $fns {
+ CommandLineLoad $fn argv i
+ }
+ }
+ }
+ }
+
+ FinishLoadPre
+ }
+ }
+ incr i
+ }
+
+ if {$load != 0} {
+ FinishLoadPost
+ }
+}
+
+proc CommandLineLoad {item argvname iname} {
+ upvar $argvname argv
+ upvar $iname i
+
+ global file
+ global current
+
+ if {$current(frame) != {}} {
+ switch -- [$current(frame) get type] {
+ base {CommandLineLoadBase $item $argvname $iname}
+ rgb {CommandLineLoadRGB $item $argvname $iname}
+ 3d {CommandLineLoad3D $item $argvname $iname}
+ }
+ } else {
+ CommandLineLoadBase $item $argvname $iname
+ }
+
+ SetFileLast $file(type) $item
+}
+
+proc CommandLineLoadBase {item argvname iname} {
+ upvar 2 $argvname argv
+ upvar 2 $iname i
+
+ global file
+ global ds9
+
+ switch -- $file(type) {
+ fits {
+ # under windows, a double click on a
+ # data file comes here
+ MultiLoad $file(layer) $file(mode)
+ LoadFitsFile $item $file(layer) $file(mode)
+ }
+ url {
+ MultiLoad $file(layer) $file(mode)
+ LoadURLFits $item $file(layer) $file(mode)
+ }
+
+
+ rgbimage {
+ CreateRGBFrame
+ LoadRGBImageFile $item
+ }
+ rgbcube {
+ CreateRGBFrame
+ LoadRGBCubeFile $item
+ }
+
+ mecube {
+ MultiLoad
+ LoadMECubeFile $item
+ }
+ multiframe {
+ MultiLoad
+ LoadMultiFrameFile $item
+ }
+
+ mosaicimage {
+ MultiLoad $file(layer)
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicImageIRAFFile $item $file(layer)}
+ wfpc2 {LoadMosaicImageWFPC2File $item}
+ default {LoadMosaicImageWCSFile $item $file(layer) $file(mosaic)}
+ }
+ }
+ mosaic {
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicIRAFFile $item $file(layer)}
+ default {LoadMosaicWCSFile $item $file(layer) $file(mosaic)}
+ }
+ }
+
+ sfits {
+ #backward compatibility
+ incr i
+ MultiLoad $file(layer) $file(mode)
+ LoadSFitsFile $item [lindex $argv $i] $file(layer) $file(mode)
+ }
+ srgbcube {
+ #backward compatibility
+ CreateRGBFrame
+ incr i
+ LoadSRGBCubeFile $item [lindex $argv $i]
+ }
+ smosaic {
+ #backward compatibility
+ incr i
+ switch -- $file(mosaic) {
+ iraf {LoadSMosaicIRAFFile $item [lindex $argv $i] $file(layer)}
+ default {LoadSMosaicWCSFile $item [lindex $argv $i] $file(layer) $file(mosaic)}
+ }
+ }
+
+ array {
+ MultiLoad $file(layer)
+ ImportArrayFile $item $file(layer)
+ }
+ rgbarray {
+ CreateRGBFrame
+ ImportRGBArrayFile $item
+ }
+ nrrd {
+ MultiLoad $file(layer)
+ ImportNRRDFile $item $file(layer)
+ }
+ envi {
+ MultiLoad
+ set fn $item
+ set fn2 [lindex $argv [expr $i+1]]
+ if {$fn2 == {} || [string range $fn2 0 0] == {-}} {
+ set fn2 [FindENVIDataFile $fn]
+ } else {
+ incr i
+ }
+ ImportENVIFile $fn $fn2
+ }
+ gif -
+ tiff -
+ jpeg -
+ png {
+ MultiLoad {} $file(mode)
+ ImportPhotoFile $item $file(mode)
+ }
+ }
+}
+
+proc CommandLineLoadRGB {item argvname iname} {
+ upvar 2 $argvname argv
+ upvar 2 $iname i
+
+ global file
+
+ switch -- $file(type) {
+ fits {LoadFitsFile $item {} $file(mode)}
+ url {LoadURLFits $item {} $file(mode)}
+
+ rgbimage {
+ MultiLoadRGB
+ LoadRGBImageFile $item
+ }
+ rgbcube {
+ MultiLoadRGB
+ LoadRGBCubeFile $item
+ }
+
+ mecube {LoadMECubeFile $item}
+ multiframe {
+ # not supported
+ }
+
+ mosaicimage {
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicImageIRAFFile $item {}}
+ wfpc2 {LoadMosaicImageWFPC2File $item}
+ default {LoadMosaicImageWCSFile $item {} $file(mosaic)}
+ }
+ }
+ mosaic {
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicIRAFFile $item {}}
+ default {LoadMosaicWCSFile $item {} $file(mosaic)}
+ }
+ }
+
+ sfits {
+ #backward compatibility
+ incr i
+ LoadSFitsFile $item [lindex $argv $i] {} $file(mode)
+ }
+ srgbcube {
+ #backward compatibility
+ MultiLoadRGB
+ incr i
+ LoadSRGBCubeFile $item [lindex $argv $i]
+ }
+ smosaic {
+ #backward compatibility
+ incr i
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicIRAFSFitsFile $item [lindex $argv $i] {}}
+ default {LoadMosaicWCSSFitsFile $item [lindex $argv $i] {} $file(mosaic)}
+ }
+ }
+
+ array {ImportArrayFile $item {}}
+ rgbarray {
+ MultiLoadRGB
+ ImportRGBArrayFile $item
+ }
+ nrrd {ImportNRRDFile $item {}}
+ envi {}
+ gif -
+ tiff -
+ jpeg -
+ png {
+ MultiLoadRGB
+ ImportPhotoFile $item $file(mode)
+ }
+
+ }
+}
+
+proc CommandLineLoad3D {item argvname iname} {
+ upvar 2 $argvname argv
+ upvar 2 $iname i
+
+ global file
+
+ switch -- $file(type) {
+ fits {
+ MultiLoad {} $file(mode)
+ LoadFitsFile $item {} $file(mode)
+ }
+ url {
+ MultiLoad {} $file(mode)
+ LoadURLFits $item {} $file(mode)
+ }
+
+ rgbimage {
+ CreateRGBFrame
+ LoadRGBImageFile $item
+ }
+ rgbcube {
+ CreateRGBFrame
+ LoadRGBCubeFile $item
+ }
+
+ mecube {
+ MultiLoad
+ LoadMECubeFile $item
+ }
+ multiframe {
+ MultiLoad
+ LoadMultiFrameFile $item
+ }
+
+ mosaicimage {
+ MultiLoad
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicImageIRAFFile $item {}}
+ wfpc2 {LoadMosaicImageWFPC2File $item}
+ default {LoadMosaicImageWCSFile $item {} $file(mosaic)}
+ }
+ }
+ mosaic {
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicIRAFFile $item {}}
+ default {LoadMosaicWCSFile $item {} $file(mosaic)}
+ }
+ }
+
+ sfits {
+ #backward compatibility
+ incr i
+ MultiLoad {} $file(mode)
+ LoadSFitsFile $item [lindex $argv $i] {} $file(mode)
+ }
+ srgbcube {
+ #backward compatibility
+ CreateRGBFrame
+ incr i
+ LoadSRGBCubeFile $item [lindex $argv $i]
+ }
+ smosaic {
+ #backward compatibility
+ incr i
+ switch -- $file(mosaic) {
+ iraf {LoadMosaicIRAFSFitsFile $item [lindex $argv $i] {}}
+ default {LoadMosaicWCSSFitsFile $item [lindex $argv $i] {} $file(mosaic)}
+ }
+ }
+
+ array {
+ MultiLoad
+ ImportArrayFile $item {}
+ }
+ rgbarray {
+ CreateRGBFrame
+ ImportRGBArrayFile $item
+ }
+ nrrd {
+ MultiLoad
+ ImportNRRDFile $item {}
+ }
+ envi {
+ set fn $item
+ set fn2 [lindex $argv [expr $i+1]]
+ if {$fn2 == {} || [string range $fn2 0 0] == {-}} {
+ set fn2 [FindENVIDataFile $fn]
+ } else {
+ incr i
+ }
+ ImportENVIFile $fn $fn2
+ }
+ gif -
+ tiff -
+ jpeg -
+ png {
+ MultiLoad {} $file(mode)
+ ImportPhotoFile $item $file(mode)
+ }
+ }
+}
+
+proc CommandFitsCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global file
+
+ set item [string tolower [lindex $var [expr $i+1]]]
+ switch -- $item {
+ mosaicimage -
+ mosaic {
+ set file(type) $item
+ incr i
+
+ set item [string tolower [lindex $var [expr $i+1]]]
+ switch -- $item {
+ wfpc2 {incr i; set file(mosaic) wfpc2}
+ default {CommandMosaicType $item $iname}
+ }
+ }
+ mecube -
+ multiframe -
+ rgbcube -
+ rgbimage {
+ set file(type) $item
+ incr i
+ }
+ }
+}
+
+proc CommandSFitsCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global file
+
+ set item [string tolower [lindex $var [expr $i+1]]]
+ switch -- $item {
+ mosaic {
+ set file(type) smosaic
+ incr i
+
+ set item [string tolower [lindex $var [expr $i+1]]]
+ switch -- $item {
+ wfpc2 {incr i; set file(mosaic) wfpc2}
+ default {CommandMosaicType $item $iname}
+ }
+ }
+ rgbcube {
+ set file(type) srgbcube
+ incr i
+ }
+ }
+}
+
+proc CommandMosaicImageCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global file
+
+ set item [string tolower [lindex $var [expr $i+1]]]
+ switch -- $item {
+ wfpc2 {incr i; set file(mosaic) wfpc2}
+ default {CommandMosaicType $item $iname}
+ }
+}
+
+proc CommandMosaicCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global file
+
+ set item [string tolower [lindex $var [expr $i+1]]]
+ CommandMosaicType $item $iname
+}
+
+proc CommandMosaicType {sys iname} {
+ upvar 2 $iname i
+
+ global file
+
+ switch $sys {
+ iraf -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {
+ incr i
+ set file(mosaic) $sys
+ }
+ default {set file(mosaic) wcs}
+ }
+}
diff --git a/ds9/library/compass.tcl b/ds9/library/compass.tcl
new file mode 100644
index 0000000..11dc5ab
--- /dev/null
+++ b/ds9/library/compass.tcl
@@ -0,0 +1,99 @@
+# 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 CompassDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set arrows [$var(frame) get marker $var(id) compass arrow]
+ set var(narrow) [lindex $arrows 0]
+ set var(earrow) [lindex $arrows 1]
+
+ set labels [$var(frame) get marker $var(id) compass label]
+ set var(north) [lindex $labels 0]
+ set var(east) [lindex $labels 1]
+
+ set s [$var(frame) get marker $var(id) compass system]
+ set var(system) [lindex $s 0]
+ set var(sky) [lindex $s 1]
+ set var(skyformat) degrees
+
+ # procs
+ set var(which) compass
+ set var(proc,apply) CompassApply
+ set var(proc,close) CompassClose
+ set var(proc,coordCB) CompassCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ set f $var(top).param
+
+ # Labels
+ ttk::label $f.ntitle -text [msgcat::mc {North}]
+ ttk::entry $f.north -textvariable ${varname}(north) -width 13
+ ttk::checkbutton $f.narrow -variable ${varname}(narrow) \
+ -text [msgcat::mc {Arrow}] -command "CompassArrow $varname"
+ ttk::label $f.etitle -text [msgcat::mc {East}]
+ ttk::entry $f.east -textvariable ${varname}(east) -width 13
+ ttk::checkbutton $f.earrow -variable ${varname}(earrow) \
+ -text [msgcat::mc {Arrow}] -command "CompassArrow $varname"
+
+ grid $f.ntitle $f.north $f.narrow -padx 2 -pady 2 -sticky w
+ grid $f.etitle $f.east $f.earrow -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc CompassClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseCenterClose $varname
+}
+
+proc CompassApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) compass label "\{$var(north)\}" "\{$var(east)\}"
+
+ MarkerBaseCenterApply $varname
+}
+
+proc CompassArrow {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) compass arrow $var(narrow) $var(earrow)
+}
+
+# callbacks
+
+proc CompassCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "CompassCoordCB"
+ }
+
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+
+ $var(frame) marker $var(id) compass system $var(system) $var(sky)
+}
+
+
+
diff --git a/ds9/library/composite.tcl b/ds9/library/composite.tcl
new file mode 100644
index 0000000..7b3153f
--- /dev/null
+++ b/ds9/library/composite.tcl
@@ -0,0 +1,136 @@
+# 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 CompositeDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set var(global) [$var(frame) get marker $var(id) composite global]
+
+ # procs
+ set var(proc,apply) CompositeApply
+ set var(proc,close) CompositeClose
+ set var(proc,coordCB) CompositeCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # init
+ MarkerBaseCenterRotateCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback rotate CompositeRotateCB $varname
+
+ set f $var(top).param
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+ ttk::label $f.tcomp -text [msgcat::mc {Angle Complement}]
+ ttk::label $f.comp -textvariable ${varname}(comp) -width 13 -anchor w
+ ttk::label $f.ucomp -text [msgcat::mc {Degrees}]
+
+ # Global
+ ttk::label $f.tglobal -text [msgcat::mc {Global Properties}]
+ ttk::checkbutton $f.global -variable ${varname}(global) \
+ -command "CompositeGlobal $varname"
+
+ grid $f.tangle $f.angle x $f.uangle -padx 2 -pady 2 -sticky w
+ grid $f.tcomp $f.comp x $f.ucomp -padx 2 -pady 2 -sticky w
+ grid $f.tglobal $f.global -padx 2 -pady 2 -sticky w
+
+ CompositeCompAngle $varname
+}
+
+# actions
+
+proc CompositeClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback rotate CompositeRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc CompositeApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ CompositeRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+proc CompositeRotate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) angle $var(angle) $var(system) $var(sky)
+
+ CompositeCompAngle $varname
+}
+
+proc CompositeCompAngle {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set comp [expr 360-$var(angle)]
+
+ if {[::math::fuzzy::tge $comp 360]} {
+ set comp [expr $comp - 360]
+ }
+ if {[::math::fuzzy::tlt $comp 0]} {
+ set comp [expr $comp + 360]
+ }
+
+ set var(comp) $comp
+}
+
+proc CompositeGlobal {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) composite global $var(global)
+}
+
+# callbacks
+
+proc CompositeCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "CompositeCoordCB"
+ }
+
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+proc CompositeRotateCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "CompositeRotateCB"
+ }
+
+ set var(angle) [$var(frame) get marker $var(id) angle \
+ $var(system) $var(sky)]
+
+ CompositeCompAngle $varname
+}
diff --git a/ds9/library/contour.tcl b/ds9/library/contour.tcl
new file mode 100644
index 0000000..774ddb0
--- /dev/null
+++ b/ds9/library/contour.tcl
@@ -0,0 +1,1418 @@
+# 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 ContourDef {} {
+ global contour
+ global icontour
+ global pcontour
+
+ set icontour(top) .ct
+ set icontour(mb) .ctmb
+
+ set contour(view) 0
+ set contour(copy) {}
+
+ set contour(color) green
+ set contour(width) 1
+ set contour(dash) 0
+
+ set contour(method) block
+ set contour(smooth) 4
+ set contour(numlevel) 5
+
+ set contour(scale) linear
+ set contour(mode) minmax
+ set contour(log) 1000
+ set contour(min) {}
+ set contour(max) {}
+
+ # used for command line options
+ # example % ds9 -contour log foo.fits -zscale -contour
+ # .. contour scale is log, not zscale
+ set contour(init,scale) 0
+ set contour(init,mode) 0
+ set contour(init,limits) 0
+
+ set pcontour(view) $contour(view)
+ set pcontour(method) $contour(method)
+ set pcontour(color) $contour(color)
+ set pcontour(width) $contour(width)
+ set pcontour(dash) $contour(dash)
+ set pcontour(smooth) $contour(smooth)
+ set pcontour(numlevel) $contour(numlevel)
+}
+
+proc ContourUpdate {} {
+ global contour
+ global icontour
+ global dcontour
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {!$contour(view)} {
+ $current(frame) contour delete
+ return
+ }
+
+ ContourCheckParams
+ if {[winfo exists $icontour(top)]} {
+ set levels [$dcontour(txt) get 1.0 end]
+ # remove endl and trim
+ regsub -all "\n" $levels " " levels
+ set levels [string trimright $levels " "]
+
+ if {$levels == {}} {
+ ContourGenerateDialog
+ set levels [$dcontour(txt) get 1.0 end]
+ # remove endl and trim
+ regsub -all "\n" $levels " " levels
+ set levels [string trimright $levels " "]
+ }
+
+ if {$levels != {} && [ContourCheckMinMax]} {
+ $current(frame) contour create \
+ $contour(color) $contour(width) $contour(dash) \
+ $contour(method) $contour(numlevel) $contour(smooth) \
+ $contour(scale) $contour(log) $contour(mode) \
+ $contour(min) $contour(max) \
+ "\"$levels\""
+ }
+ } else {
+ set contour(scale) [$current(frame) get colorscale]
+ set contour(log) [$current(frame) get colorscale log]
+ set contour(mode) [$current(frame) get clip mode]
+ set limits [$current(frame) get clip $contour(mode)]
+ set contour(min) [lindex $limits 0]
+ set contour(max) [lindex $limits 1]
+
+ if {[ContourCheckMinMax]} {
+ $current(frame) contour create \
+ $contour(color) $contour(width) $contour(dash) \
+ $contour(method) $contour(numlevel) $contour(smooth) \
+ $contour(scale) $contour(log) $contour(mode) \
+ $contour(min) $contour(max) \
+ "{}"
+ }
+ }
+}
+
+proc ContourCheckParams {} {
+ global contour
+
+ if {$contour(smooth) < 1} {
+ set contour(smooth) 1
+ }
+ if {$contour(numlevel) < 1} {
+ set contour(numlevel) 1
+ }
+}
+
+proc ContourCheckMinMax {} {
+ global contour
+
+ if {$contour(min) != {} &&
+ $contour(max) != {} &&
+ !($contour(min) eq "nan") &&
+ !($contour(max) eq "nan") &&
+ [string is double $contour(min)] &&
+ [string is double $contour(max)]
+ } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc ContourDialog {} {
+ global contour
+ global icontour
+ global dcontour
+ global current
+ global ds9
+
+ # see if we already have a ctr window visible
+ if {[winfo exists $icontour(top)]} {
+ raise $icontour(top)
+ return
+ }
+
+ # create the contour window
+ set w $icontour(top)
+ set mb $icontour(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Contour Parameters}] ContourDestroyDialog
+
+ # local variables
+ $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 {Color}] -menu $mb.color
+ $mb add cascade -label [msgcat::mc {Width}] -menu $mb.width
+ $mb add cascade -label [msgcat::mc {Scale}] -menu $mb.scale
+ $mb add cascade -label [msgcat::mc {Limits}] -menu $mb.limit
+ $mb add cascade -label [msgcat::mc {Method}] -menu $mb.method
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command ContourApplyDialog
+ $mb.file add command -label [msgcat::mc {Generate}] \
+ -command ContourGenerateDialog
+ $mb.file add command -label [msgcat::mc {Clear}] \
+ -command ContourOffDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Copy Contours}] \
+ -command ContourCCopyDialog
+ $mb.file add command -label "[msgcat::mc {Paste Contours}]..." \
+ -command ContourCPasteDialog
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load Contours}]..." \
+ -command ContourLoadDialog
+ $mb.file add command -label "[msgcat::mc {Save Contours}]..." \
+ -command ContourSaveDialog
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load Contour Levels}]..." \
+ -command ContourLoadLevels
+ $mb.file add command -label "[msgcat::mc {Save Contour Levels}]..." \
+ -command ContourSaveLevels
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Convert to Polygons}] \
+ -command Contour2Polygons
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command ContourDestroyDialog
+
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -command ContourCutDialog -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command ContourCopyDialog -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -command ContourPasteDialog -accelerator "${ds9(ctrl)}V"
+
+ ColorMenu $mb.color contour color {}
+ WidthDashMenu $mb.width contour width dash {} {}
+
+ menu $mb.scale
+ $mb.scale add radiobutton -label [msgcat::mc {Linear}] \
+ -variable contour(scale) -value linear
+ $mb.scale add radiobutton -label [msgcat::mc {Log}] \
+ -variable contour(scale) -value log
+ $mb.scale add radiobutton -label [msgcat::mc {Power}] \
+ -variable contour(scale) -value pow
+ $mb.scale add radiobutton -label [msgcat::mc {Square Root}] \
+ -variable contour(scale) -value sqrt
+ $mb.scale add radiobutton -label [msgcat::mc {Squared}] \
+ -variable contour(scale) -value squared
+ $mb.scale add radiobutton -label {ASINH} \
+ -variable contour(scale) -value asinh
+ $mb.scale add radiobutton -label {SINH} \
+ -variable contour(scale) -value sinh
+ $mb.scale add radiobutton \
+ -label [msgcat::mc {Histogram Equalization}] \
+ -variable contour(scale) -value histequ
+ $mb.scale add separator
+ $mb.scale add command -label "[msgcat::mc {Log Exponent}]..." \
+ -command ContourLogDialog
+
+ menu $mb.limit
+ $mb.limit add radiobutton -label [msgcat::mc {Min Max}] \
+ -variable contour(mode) -value minmax -command ContourModeDialog
+ $mb.limit add separator
+ $mb.limit add radiobutton -label {99.5%} \
+ -variable contour(mode) -value 99.5 -command ContourModeDialog
+ $mb.limit add radiobutton -label {99%} \
+ -variable contour(mode) -value 99 -command ContourModeDialog
+ $mb.limit add radiobutton -label {98%} \
+ -variable contour(mode) -value 98 -command ContourModeDialog
+ $mb.limit add radiobutton -label {95%} \
+ -variable contour(mode) -value 95 -command ContourModeDialog
+ $mb.limit add radiobutton -label {90%} \
+ -variable contour(mode) -value 90 -command ContourModeDialog
+ $mb.limit add separator
+ $mb.limit add radiobutton -label {ZScale} \
+ -variable contour(mode) -value zscale -command ContourModeDialog
+ $mb.limit add radiobutton -label {ZMax} \
+ -variable contour(mode) -value zmax -command ContourModeDialog
+ $mb.limit add radiobutton -label [msgcat::mc {User}] \
+ -variable contour(mode) -value user -command ContourModeDialog
+
+ menu $mb.method
+ $mb.method add radiobutton -label [msgcat::mc {Block}] \
+ -variable contour(method) -value block
+ $mb.method add radiobutton -label [msgcat::mc {Smooth}] \
+ -variable contour(method) -value smooth
+
+ # Param
+ set f [ttk::labelframe $w.param -text [msgcat::mc {Contour}] -padding 2]
+
+ slider $f.nslider 0 50 [msgcat::mc {Levels}] contour(numlevel) {}
+ slider $f.rslider 0 32 [msgcat::mc {Smoothness}] contour(smooth) {}
+
+ ttk::label $f.title -text [msgcat::mc {Limits}]
+ ttk::label $f.ltitle -text [msgcat::mc {Low}]
+ ttk::entry $f.low -textvariable contour(min) -width 10
+ ttk::label $f.htitle -text [msgcat::mc {High}]
+ ttk::entry $f.high -textvariable contour(max) -width 10
+
+ grid $f.nslider -columnspan 6 -padx 2 -pady 2
+ grid $f.rslider -columnspan 6 -padx 2 -pady 2
+ grid $f.title $f.ltitle $f.low $f.htitle $f.high -padx 2 -pady 2
+
+ # Levels
+ set f [ttk::labelframe $w.levels -text [msgcat::mc {Levels}] -padding 2]
+
+ set dcontour(txt) [text $f.text \
+ -wrap none \
+ -width 15 \
+ -height 10 \
+ -font [font actual TkDefaultFont] \
+ -yscrollcommand [list $f.yscroll set] \
+ ]
+ ttk::scrollbar $f.yscroll -command [list $dcontour(txt) yview] \
+ -orient vertical
+
+ grid $f.text $f.yscroll -sticky 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 ContourApplyDialog
+ ttk::button $f.generate -text [msgcat::mc {Generate}] \
+ -command ContourGenerateDialog
+ ttk::button $f.clear -text [msgcat::mc {Clear}] \
+ -command ContourOffDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command ContourDestroyDialog
+ pack $f.apply $f.generate $f.clear $f.close \
+ -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ grid $w.param $w.levels -sticky news
+ grid $w.buttons - -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid columnconfigure $w 1 -weight 1
+
+ UpdateContourDialog
+}
+
+proc ContourApplyDialog {} {
+ global contour
+
+ set contour(view) 1
+ ContourUpdate
+}
+
+proc ContourDestroyDialog {} {
+ global contour
+ global icontour
+ global dcontour
+
+ if {[winfo exists $icontour(top)]} {
+ destroy $icontour(top)
+ destroy $icontour(mb)
+ }
+
+ unset dcontour
+}
+
+proc ContourGenerateDialog {} {
+ global contour
+ global dcontour
+ global current
+
+ ContourCheckParams
+
+ $dcontour(txt) delete 1.0 end
+ if {$current(frame) != {}} {
+ if {([$current(frame) has fits]) && [ContourCheckMinMax]} {
+ set ll [$current(frame) get colorscale level $contour(numlevel) \
+ $contour(min) $contour(max) \
+ $contour(scale) $contour(log)]
+ regsub -all " " "$ll" "\n" ll
+ $dcontour(txt) insert end "$ll"
+ }
+ }
+}
+
+proc ContourOffDialog {} {
+ global contour
+ global current
+
+ set contour(view) 0
+ if {$current(frame) != {}} {
+ $current(frame) contour delete
+ $current(frame) contour delete aux
+ }
+ UpdateContourScale
+ UpdateContourDialog
+}
+
+proc ContourCutDialog {} {
+ global icontour
+ global dcontour
+
+ if {[winfo exists $icontour(top)]} {
+ set w [focus -displayof $icontour(top)]
+ if {$w == $dcontour(txt)} {
+ tk_textCut $w
+ } else {
+ EntryCut $icontour(top)
+ }
+ }
+}
+
+proc ContourCopyDialog {} {
+ global icontour
+ global dcontour
+
+ if {[winfo exists $icontour(top)]} {
+ set w [focus -displayof $icontour(top)]
+ if {$w == $dcontour(txt)} {
+ tk_textCopy $w
+ } else {
+ EntryCopy $icontour(top)
+ }
+ }
+}
+
+proc ContourPasteDialog {} {
+ global icontour
+ global dcontour
+
+ if {[winfo exists $icontour(top)]} {
+ set w [focus -displayof $icontour(top)]
+ if {$w == $dcontour(txt)} {
+ tk_textPaste $w
+ } else {
+ EntryPaste $icontour(top)
+ }
+ }
+}
+
+proc ContourCCopyDialog {} {
+ global contour
+ global current
+
+ set contour(copy) $current(frame)
+ UpdateContourDialog
+}
+
+proc ContourCPasteDialog {} {
+ global ds9
+ global current
+ global contour
+ global ed
+
+ if {$current(frame) == {} || $contour(copy) == {}} {
+ return
+ }
+
+ set w {.ctld}
+
+ set ed(ok) 0
+ set ed(system) wcs
+ set ed(sky) fk5
+ set ed(color) green
+ set ed(width) 1
+ set ed(dash) 0
+ set ed(frame) $current(frame)
+ set ed(original) 0
+
+ SetCoordSystem ed system sky {}
+ AdjustCoordSystem ed system
+
+ DialogCreate $w [msgcat::mc {Contour Paste}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param1]
+
+ ttk::checkbutton $f.original -text [msgcat::mc {Use Original Color/Width}] -variable ed(original)
+ grid $f.original -padx 2 -pady 2 -sticky w
+
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.coordtitle -text [msgcat::mc {Coordinate System}]
+
+ CoordMenuButton $f.coordbutton ed system 1 {} {} {}
+ CoordMenuEnable $f.coordbutton.menu ed system 1 {} {}
+
+ ttk::label $f.colortitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.colorbutton ed color {}
+
+ ttk::label $f.widthtitle -text [msgcat::mc {Width}]
+ ttk::menubutton $f.widthbutton -textvariable ed(width) \
+ -menu $f.widthbutton.menu
+ WidthDashMenu $f.widthbutton.menu ed width dash {} {}
+
+ grid $f.coordtitle $f.coordbutton -padx 2 -pady 2 -sticky w
+ grid $f.colortitle $f.colorbutton -padx 2 -pady 2 -sticky w
+ grid $f.widthtitle $f.widthbutton -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ ttk::separator $w.sep2 -orient horizontal
+ pack $w.buttons $w.sep -side bottom -fill x
+# pack $w.param1 $w.sep2 $w.param2 -side top -fill both -expand true
+ pack $w.param -side top -fill both -expand true
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set ed(color) [string tolower $ed(color)]
+
+ if {$current(frame) == $contour(copy)} {
+ set ed(system) physical
+ }
+
+ set cc [$contour(copy) get contour $ed(system) fk5]
+ if {$ed(original)} {
+ $current(frame) contour paste cc
+ } else {
+ $current(frame) contour paste cc $ed(color) $ed(width) $ed(dash)
+ }
+ UpdateContourDialog
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc ContourModeDialog {} {
+ global current
+ global contour
+
+ if {$current(frame) != {}} {
+ set limits [$current(frame) get clip $contour(mode)]
+ set contour(min) [lindex $limits 0]
+ set contour(max) [lindex $limits 1]
+ }
+}
+
+proc ContourLoadLevels {} {
+ set fn [OpenFileDialog contourlevlfbox]
+
+ ContourLoadLevelsNow $fn
+}
+
+proc ContourLoadLevelsNow {fn} {
+ global dcontour
+
+ if {$fn == {}} {
+ return
+ }
+
+ $dcontour(txt) delete 1.0 end
+ set ch [open $fn r]
+ if {[file extension $fn] == {.lev}} {
+ $dcontour(txt) insert end [read $ch]
+ } else {
+ ContourLoadLevelsNew $ch
+ }
+ close $ch
+}
+
+proc ContourLoadLevelsNew {ch} {
+ global dcontour
+
+ while {[gets $ch line] != -1} {
+ set aa [split $line {= }]
+ regsub -all {[{}]} $aa {} aa
+ regsub -all { +} $aa { } aa
+ set aa [string trim $aa]
+
+ if {![string compare -nocase [lindex $aa 0] {level}]} {
+ set value [string trim [lindex $aa 1]]
+ if {[string is double $value]} {
+ $dcontour(txt) insert end "$value\n"
+ }
+ }
+ }
+}
+
+proc ContourSaveLevels {} {
+ set fn [SaveFileDialog contourlevsfbox]
+ ContourSaveLevelsNow $fn
+}
+
+proc ContourSaveLevelsNow {fn} {
+ global dcontour
+
+ if {$fn == {}} {
+ return
+ }
+
+ set id [open $fn w]
+ puts -nonewline $id "[$dcontour(txt) get 1.0 end]"
+ close $id
+}
+
+proc ContourSaveDialog {} {
+ global ds9
+ global current
+ global contour
+ global ed
+ global wcs
+
+ set fn [SaveFileDialog contoursfbox]
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ set w {.ctld}
+
+ set ed(ok) 0
+ set ed(system) wcs
+ set ed(sky) fk5
+ set ed(skyformat) degrees
+ set ed(frame) $current(frame)
+
+ SetCoordSystem ed system sky {}
+ AdjustCoordSystem ed system
+
+ DialogCreate $w [msgcat::mc {Contour Save}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.coordtitle -text [msgcat::mc {Coordinate System}]
+
+ CoordMenuButton $f.coordbutton ed system 1 sky skyformat {}
+ CoordMenuEnable $f.coordbutton.menu ed system 1 sky skyformat
+ grid $f.coordtitle $f.coordbutton -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ switch -- $ed(system) {
+ image -
+ physical -
+ detector -
+ amplifier {}
+ default {
+ if {![$current(frame) has wcs $ed(system)]} {
+ Error "[msgcat::mc {Invalid WCS}] $ed(system)"
+ return $ed(ok)
+ }
+ }
+ }
+
+ $current(frame) contour save "\{$fn\}" $ed(system) $ed(sky)
+ UpdateContourDialog
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc ContourLoadDialog {} {
+ global ds9
+ global current
+ global contour
+ global ed
+
+ set fn [OpenFileDialog contourlfbox]
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ set w {.ctld}
+
+ set ed(ok) 0
+ set ed(color) green
+ set ed(width) 1
+ set ed(dash) 0
+ set ed(frame) $current(frame)
+ set ed(original) 0
+ if {[file extension $fn] == {.con}} {
+ ContourLoadOldDialog $fn
+ } else {
+ ContourLoadNewDialog $fn
+ }
+}
+
+proc ContourLoadOldDialog {fn} {
+ global ds9
+ global current
+ global contour
+ global ed
+
+ set w {.ctld}
+
+ set ed(ok) 0
+ set ed(system) wcs
+ set ed(sky) fk5
+ set ed(color) green
+ set ed(width) 1
+ set ed(dash) 0
+ set ed(frame) $current(frame)
+
+ SetCoordSystem ed system sky {}
+ AdjustCoordSystem ed system
+
+ DialogCreate $w [msgcat::mc {Contour Paste}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.coordtitle -text [msgcat::mc {Coordinate System}]
+
+ CoordMenuButton $f.coordbutton ed system 1 {} {} {}
+ CoordMenuEnable $f.coordbutton.menu ed system 1 {} {}
+
+ ttk::label $f.colortitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.colorbutton ed color {}
+
+ ttk::label $f.widthtitle -text [msgcat::mc {Width}]
+ ttk::menubutton $f.widthbutton -textvariable ed(width) \
+ -menu $f.widthbutton.menu
+ WidthDashMenu $f.widthbutton.menu ed width dash {} {}
+
+ grid $f.coordtitle $f.coordbutton -padx 2 -pady 2 -sticky w
+ grid $f.colortitle $f.colorbutton -padx 2 -pady 2 -sticky w
+ grid $f.widthtitle $f.widthbutton -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set ed(color) [string tolower $ed(color)]
+ $current(frame) contour load $ed(color) $ed(width) $ed(dash) \
+ "\{$fn\}" $ed(system) $ed(sky)
+ UpdateContourDialog
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc ContourLoadNewDialog {fn} {
+ global ds9
+ global current
+ global contour
+ global ed
+
+ set w {.ctld}
+
+ set ed(ok) 0
+ set ed(color) green
+ set ed(width) 1
+ set ed(dash) 0
+ set ed(frame) $current(frame)
+ set ed(original) 0
+
+ DialogCreate $w [msgcat::mc {Contour Paste}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param1]
+
+ ttk::checkbutton $f.original -text [msgcat::mc {Use Original Color/Width}] \
+ -variable ed(original)
+
+ grid $f.original -padx 2 -pady 2 -sticky w
+
+ set f [ttk::frame $w.param2]
+
+ ttk::label $f.colortitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.colorbutton ed color {}
+
+ ttk::label $f.widthtitle -text [msgcat::mc {Width}]
+ ttk::menubutton $f.widthbutton -textvariable ed(width) \
+ -menu $f.widthbutton.menu
+ WidthDashMenu $f.widthbutton.menu ed width dash {} {}
+
+ grid $f.colortitle $f.colorbutton -padx 2 -pady 2 -sticky w
+ grid $f.widthtitle $f.widthbutton -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ ttk::separator $w.sep2 -orient horizontal
+ pack $w.buttons $w.sep -side bottom -fill x
+ pack $w.param1 $w.sep2 $w.param2 -side top -fill both -expand true
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set ed(color) [string tolower $ed(color)]
+
+ if {$ed(original)} {
+ $current(frame) contour load "\{$fn\}"
+ } else {
+ $current(frame) contour load "\{$fn\}" \
+ $ed(color) $ed(width) $ed(dash)
+ }
+ UpdateContourDialog
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc Contour2Polygons {} {
+ global current
+ global contour
+
+ if {$current(frame) != {}} {
+ $current(frame) contour create polygon
+ $current(frame) contour delete
+ }
+}
+
+proc UpdateContourMenu {} {
+ global contour
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateContourMenu"
+ }
+
+ if {($current(frame) == {})} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ set contour(view) [$current(frame) has contour]
+
+ if {[$current(frame) has contour]} {
+ set contour(color) [$current(frame) get contour color]
+ set contour(width) [$current(frame) get contour width]
+ set contour(dash) [$current(frame) get contour dash]
+ set contour(method) [$current(frame) get contour method]
+ set contour(smooth) [$current(frame) get contour smooth]
+ set contour(numlevel) [$current(frame) get contour number level]
+ }
+
+ UpdateContourScale
+}
+
+proc UpdateContourScale {} {
+ global contour
+ global current
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateContourScale"
+ }
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {[$current(frame) has contour]} {
+ set contour(scale) [$current(frame) get contour colorscale]
+ set contour(mode) [$current(frame) get contour clip mode]
+ set contour(log) [$current(frame) get contour colorscale log]
+ set limits [$current(frame) get contour clip]
+ set contour(min) [lindex $limits 0]
+ set contour(max) [lindex $limits 1]
+ } else {
+ if {!($ds9(init) && $contour(init,scale))} {
+ set contour(scale) [$current(frame) get colorscale]
+ set contour(log) [$current(frame) get colorscale log]
+ }
+ if {!($ds9(init) && $contour(init,mode))} {
+ set contour(mode) [$current(frame) get clip mode]
+ }
+ if {!($ds9(init) && $contour(init,limits))} {
+ set limits [$current(frame) get clip $contour(mode)]
+ set contour(min) [lindex $limits 0]
+ set contour(max) [lindex $limits 1]
+ }
+ }
+}
+
+proc UpdateContourDialog {} {
+ global contour
+ global icontour
+ global dcontour
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateContourDialog"
+ }
+
+ if {![winfo exists $icontour(top)]} {
+ return
+ }
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {[$current(frame) has contour]} {
+ set levels [$current(frame) get contour level]
+ regsub -all "\n" "$levels" " " levels
+ set levels [join $levels "\n"]
+ if {$levels != {}} {
+ $dcontour(txt) delete 1.0 end
+ $dcontour(txt) insert end $levels
+ } else {
+ ContourGenerateDialog
+ }
+ } else {
+ ContourGenerateDialog
+ }
+}
+
+proc ContourLogDialog {} {
+ global contour
+
+ EntryDialog [msgcat::mc {Scale}] [msgcat::mc {Log Exponent}] 10 contour(log)
+}
+
+proc ContourBackup {ch which fdir rdir} {
+ switch [$which get type] {
+ base -
+ 3d {ContourBackupBase $ch $which $fdir $rdir}
+ rgb {ContourBackupRGB $ch $which $fdir $rdir}
+ }
+}
+
+proc ContourBackupBase {ch which fdir rdir} {
+ if {[$which has contour]} {
+ set color [$which get contour color]
+ set width [$which get contour width]
+ set dash [$which get contour dash]
+ set method [$which get contour method]
+ set numlevel [$which get contour number level]
+ set smooth [$which get contour smooth]
+ set scale [$which get contour colorscale]
+ set log [$which get contour colorscale log]
+ set mode [$which get contour clip mode]
+ set limits [$which get contour clip]
+ set levels [$which get contour level]
+
+ puts $ch "$which contour create $color $width $dash $method $numlevel $smooth $scale $log $mode $limits \{\"$levels\"\}"
+ }
+
+ # delete old contours
+ foreach ff [glob -directory $fdir -nocomplain "aux*.ctr"] {
+ catch {file delete -force $ff}
+ }
+
+ if {[$which has contour aux]} {
+ set fn $fdir/aux.ctr
+ set rfn $rdir/aux.ctr
+ $which contour save aux \"$fn\" physical fk5
+ puts $ch "$which contour load \{\"$rfn\"\}"
+ }
+}
+
+proc ContourBackupRGB {ch which fdir rdir} {
+ set sav [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ puts $ch "$which rgb channel $cc"
+ ContourBackupBase $ch $which $fdir $rdir
+ }
+ $which rgb channel $sav
+ puts $ch "$which rgb channel $sav"
+}
+
+proc PrefsDialogContour {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Contours}]
+ lappend dprefs(tabs) [ttk::frame $w.contour]
+
+ set f [ttk::labelframe $w.contour.param -text [msgcat::mc {Contours}]]
+
+ ttk::label $f.mtitle -text [msgcat::mc {Method}]
+ ttk::menubutton $f.method -textvariable pcontour(method) \
+ -menu $f.method.menu
+
+ global pcontour
+ ttk::label $f.ctitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color pcontour color {}
+
+ ttk::label $f.wtitle -text [msgcat::mc {Width}]
+ ttk::menubutton $f.width -textvariable pcontour(width) -menu $f.width.menu
+ WidthDashMenu $f.width.menu pcontour width dash {} {}
+
+ grid $f.mtitle $f.method -padx 2 -pady 2 -sticky w
+ grid $f.ctitle $f.color -padx 2 -pady 2 -sticky w
+ grid $f.wtitle $f.width -padx 2 -pady 2 -sticky w
+
+ set m $f.method.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {Block}] \
+ -variable pcontour(method) -value block
+ $m add radiobutton -label [msgcat::mc {Smooth}] \
+ -variable pcontour(method) -value smooth
+
+ pack $f -side top -fill both -expand true
+}
+
+proc ProcessContourCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global contour
+ global current
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {ContourDialog}
+ close {ContourDestroyDialog}
+ clear {ContourOffDialog}
+ load {
+ incr i
+ set fn [lindex $var $i]
+
+ # backward compatibility
+ incr i
+ set sys [lindex $var $i]
+ incr i
+ set sky [lindex $var $i]
+ incr i
+ set color [lindex $var $i]
+ incr i
+ set width [lindex $var $i]
+ incr i
+ set dash [lindex $var $i]
+ incr i [ProcessContourFix sys sky color width dash]
+
+ if {$fn != {}} {
+ if {[file extension $fn] == {.con}} {
+ $current(frame) contour load $color $width $dash "\{$fn\}" $sys $sky
+ } else {
+ $current(frame) contour load "\{$fn\}" $color $width $dash
+ }
+ }
+ FileLast contourlfbox $fn
+ UpdateContourDialog
+ }
+ save {
+ incr i
+ set fn [lindex $var $i]
+ incr i
+ set sys [lindex $var $i]
+ incr i
+ set sky [lindex $var $i]
+
+ # Backward compatibility
+ incr i
+ set color {}
+ incr i
+ set width {}
+ incr i
+ set dash {}
+ incr i [ProcessContourFix sys sky color width dash]
+
+ if {$fn != {}} {
+ $current(frame) contour save "\{$fn\}" $sys $sky
+ }
+ FileLast contoursfbox $fn
+ }
+ convert {Contour2Polygons}
+ loadlevels {
+ ContourDialog
+ incr i
+ ContourLoadLevelsNow [lindex $var $i]
+ ContourUpdate
+ }
+ savelevels {
+ ContourDialog
+ incr i
+ ContourSaveLevelsNow [lindex $var $i]
+ }
+
+ copy {ContourCCopyDialog}
+ paste {
+ incr i
+ set sys [lindex $var $i]
+ incr i
+ set sky [lindex $var $i]
+ incr i
+ # backward compatibility
+ set color [lindex $var $i]
+ incr i
+ set width [lindex $var $i]
+ incr i
+ set dash [lindex $var $i]
+ incr i [ProcessContourFix sys sky color width dash]
+
+ if {$current(frame) != {} && $contour(copy) != {}} {
+ set cc [$contour(copy) get contour $sys $sky]
+ $current(frame) contour paste cc $color $width $dash
+ }
+ }
+
+ color {
+ ContourDialog
+
+ incr i
+ set contour(color) [lindex $var $i]
+ ContourUpdate
+ }
+ width {
+ ContourDialog
+
+ incr i
+ set contour(width) [lindex $var $i]
+ ContourUpdate
+ }
+ dash {
+ ContourDialog
+
+ incr i
+ set contour(dash) [FromYesNo [lindex $var $i]]
+ ContourUpdate
+ }
+
+ smooth {
+ ContourDialog
+
+ incr i
+ set contour(smooth) [lindex $var $i]
+ ContourGenerateDialog
+ ContourUpdate
+ }
+ method {
+ ContourDialog
+
+ incr i
+ set contour(method) [lindex $var $i]
+ ContourGenerateDialog
+ ContourUpdate
+ }
+
+ nlevels {
+ ContourDialog
+
+ incr i
+ set contour(numlevel) [lindex $var $i]
+ ContourGenerateDialog
+ ContourUpdate
+ }
+ scale {
+ set contour(init,scale) 1
+ ContourDialog
+
+ incr i
+ set contour(scale) [string tolower [lindex $var $i]]
+ ContourGenerateDialog
+ ContourUpdate
+ }
+ log {
+ set contour(init,scale) 1
+ ContourDialog
+
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ exp {
+ incr i
+ set contour(log) [string tolower [lindex $var $i]]
+ }
+ default {
+ incr i -1
+ set contour(log) [string tolower [lindex $var $i]]
+ }
+ }
+ ContourGenerateDialog
+ ContourUpdate
+ }
+ mode {
+ set contour(init,mode) 1
+ ContourDialog
+
+ incr i
+ set contour(mode) [lindex $var $i]
+ ContourModeDialog
+ ContourGenerateDialog
+ ContourUpdate
+ }
+ limits {
+ set contour(init,limits) 1
+ ContourDialog
+
+ incr i
+ set contour(min) [lindex $var $i]
+ incr i
+ set contour(max) [lindex $var $i]
+ ContourGenerateDialog
+ ContourUpdate
+ }
+
+ levels {
+ ContourDialog
+
+ global dcontour
+ $dcontour(txt) delete 1.0 end
+ incr i
+ $dcontour(txt) insert end [lindex $var $i]
+ ContourUpdate
+ }
+
+ generate {
+ ContourDialog
+
+ ContourGenerateDialog
+ ContourUpdate
+ }
+
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ set contour(view) [FromYesNo [lindex $var $i]]
+ ContourUpdate
+ }
+
+ default {
+ set contour(view) 1
+ ContourUpdate
+ incr i -1
+ }
+ }
+}
+
+proc ProcessContourFix {sysname skyname colorname widthname dashname} {
+ upvar $sysname sys
+ upvar $skyname sky
+ upvar $colorname color
+ upvar $widthname width
+ upvar $dashname dash
+
+ global current
+
+ set rr 0
+
+ # sys
+ switch -- $sys {
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {}
+ default {
+ set dash $width
+ set width $color
+ set color $sky
+ set sky $sys
+ if {[$current(frame) has wcs wcs]} {
+ set sys wcs
+ } else {
+ set sys physical
+ }
+ incr rr -1
+ }
+ }
+
+ # sky
+ switch -- $sky {
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {}
+ default {
+ set dash $width
+ set width $color
+ set color $sky
+ set sky fk5
+ incr rr -1
+ }
+ }
+
+ # color
+ if {[string range $color 0 0] == {-} || $color == {}} {
+ set color {}
+ set width {}
+ set dash {}
+ return -3
+ }
+ switch -- $color {
+ white -
+ black -
+ red -
+ green -
+ blue -
+ cyan -
+ magenta -
+ yellow {}
+ default {
+ if {[string range $color 0 0] != "#"} {
+ set dash $width
+ set width $color
+ set color green
+ incr rr -1
+ }
+ }
+ }
+
+ # width
+ if {![string is integer $width]} {
+ set dash $width
+ set width 1
+ incr rr -1
+ }
+
+ # dash
+ switch -- $dash {
+ yes -
+ no -
+ on -
+ off -
+ true -
+ false -
+ 0 -
+ 1 {set dash [FromYesNo $dash]}
+ default {
+ set dash 0
+ incr rr -1
+ }
+ }
+
+ return $rr
+}
+
+proc ProcessSendContourCmd {proc id param sock fn} {
+ global contour
+
+ switch -- [lindex $param 0] {
+ {} {$proc $id [ToYesNo $contour(view)]}
+ color {$proc $id "$contour(color)\n"}
+ width {$proc $id "$contour(width)\n"}
+ dash {$proc $id [ToYesNo $contour(dash)]}
+ smooth {$proc $id "$contour(smooth)\n"}
+ method {$proc $id "$contour(method)\n"}
+ nlevels {$proc $id "$contour(numlevel)\n"}
+ scale {$proc $id "$contour(scale)\n"}
+ log -
+ {log exp} {$proc $id "$contour(log)\n"}
+ mode {$proc $id "$contour(mode)\n"}
+ limits {$proc $id "$contour(min) $contour(max)\n"}
+ levels {
+ global dcontour
+ ContourDialog
+ $proc $id "[$dcontour(txt) get 1.0 end]"
+ }
+ default {
+ global current
+ if {$current(frame) != {}} {
+ ProcessSend $proc $id $sock $fn {.ctr} \
+ [$current(frame) get contour [lindex $param 0] [lindex $param 1]]
+ }
+ }
+ }
+}
diff --git a/ds9/library/convert.tcl b/ds9/library/convert.tcl
new file mode 100644
index 0000000..83884ed
--- /dev/null
+++ b/ds9/library/convert.tcl
@@ -0,0 +1,215 @@
+# 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
+
+set M_PI 3.14159265358979323846
+
+# hours to degrees
+proc h2d {h} {
+ return [expr ($h + 0.0) * 15.0]
+}
+
+# degrees to hours
+proc d2h {d} {
+ return [expr ($d + 0.0) / 15.0]
+}
+
+# degrees to radians -- returns 0 <= r < PI
+proc d2r {d} {
+ global M_PI
+ while {[::math::fuzzy::tge $d 360.0]} {
+ set d [expr $d - 360.0]
+ }
+ return [expr ($d + 0.0) * ($M_PI / 360.0)]
+}
+
+# radians to degrees -- returns 0 <= d < PI
+proc r2d {r} {
+ global M_PI
+ while {[::math::fuzzy::tge $r $M_PI]} {
+ set r [expr $r - $M_PI]
+ }
+ return [expr ($r + 0.0) * (360.0 / $M_PI)]
+}
+
+#
+# strtod -- convert string to double
+#
+# Supports sexagesimal values:
+# 12:30:45.6 12h30m45.6s 12d30m45.6s "12 30 45.6"
+
+# Supports 12.5d (degrees) 12.5r (radians)
+#
+# A hidden global _strtod returns the number of arguments in the input.
+# if this value is 3 or 4, then hms or dms was input. This can be used
+# to determine that hms was input for ra so that you can convert hours
+# to degrees.
+#
+#
+set _strtod 0
+proc strtod {d} {
+ global _strtod
+
+ set d [string trim $d]
+ set d [string trimleft $d 0]
+ if { $d == {} } {
+ set d 0
+ }
+
+ if { [string first - $d] >= 0 } {
+ set sign "-"
+ regsub -all -- "-" $d {} d
+ } elseif { [string first + $d] >= 0 } {
+ set sign {}
+ regsub -all -- {\+} $d {} d
+ } else {
+ set sign {}
+ }
+
+ regsub -all {[ \t]*[hms][ \t]*} $d ":" d
+ set arglist [split $d ": "]
+
+ set _strtod 0
+ foreach arg $arglist {
+ set args($_strtod) [string trimleft $arg 0]
+ if { $args($_strtod) == {} } {
+ set args($_strtod) 0
+ }
+ incr _strtod
+ }
+
+ switch $_strtod {
+ 2 {
+ error "ERROR: strtod h:m:s|d:m:s|d"
+ }
+ 3 {
+ set d [expr double($args(0)) + 0.0];
+ set m [expr double($args(1)) + 0.0];
+ set s [expr double($args(2)) + 0.0];
+ }
+ 4 {
+ set d [expr double($args(0)) + 0.0];
+ set m [expr double($args(1)) + 0.0];
+ set s [expr double($args(2)) + 0.0];
+ }
+ default {
+ set c [string range $d end end]
+ if { $c == "r" } {
+ set d [string trimright $d r]
+ set d [r2d $d]
+ } elseif { $c == "d" } {
+ set d [string trimright $d d]
+ }
+ set m 0
+ set s 0
+ }
+ }
+ set val [expr $d + ($m / 60.0) + ($s / 3600.0)]
+ # we don't want this. it rounds off to a precision of 6, which can
+ # cause problems with h:m:s to degree convertions
+ # set val [format "%s%g" $sign $val]
+ set val "$sign$val"
+ return $val
+}
+
+#
+# _uformat -- primative unit format converter to convert a float to a string
+# output format can be:
+# # or : (output in sexagesimal) or d (output in decimal)
+#
+proc _uformat {oformat value} {
+
+ if { $value < 0.0 } {
+ set sign "-"
+ set d [expr -$value]
+ } else {
+ set sign {}
+ set d $value
+ }
+ switch $oformat {
+ {#} {
+ set m [expr ($d - (int($d))) * 60]
+ if { $m < 0 } {
+ set m 0.0
+ }
+ set s [expr ($m - (int($m))) * 60]
+ if { $s < 0 } {
+ set s 0.0
+ }
+ return [format "%s%d %d %.3f" \
+ $sign [expr int($d)] [expr int($m)] $s]
+ }
+ : {
+ set m [expr ($d - (int($d))) * 60]
+ if { $m < 0 } {
+ set m 0.0
+ }
+ set s [expr ($m - (int($m))) * 60]
+ if { $s < 0 } {
+ set s 0.0
+ }
+ return [format "%s%d:%d:%.3f" \
+ $sign [expr int($d)] [expr int($m)] $s]
+ }
+ d {
+ return [format "%s%f" $sign $d]
+ }
+ }
+}
+
+#
+# uformat -- unit format converter
+#
+# uformat input_format output_format value
+#
+# where input format can be:
+# h (hours) d (degrees) m (minutes) s (seconds)
+# and output format can be the same, with a suffix of:
+# # or : (output in sexagesimal) or d (output in decimal)
+#
+proc uformat {iformat oformat value} {
+ set itype [string index $iformat 0]
+ set otype [string index $oformat 0]
+ set oform [string index $oformat 1]
+ if { $oform == {} } {
+ set oform d
+ }
+ set value [strtod $value]
+
+ switch $itype {
+ h {
+ switch $otype {
+ h {return [_uformat $oform $value]}
+ d {return [_uformat $oform [h2d $value]]}
+ m {return [_uformat $oform [h2d $value]*60]}
+ s {return [_uformat $oform [h2d $value]*60*60]}
+ }
+ }
+ d {
+ switch $otype {
+ h {return [_uformat $oform [d2h $value]]}
+ d {return [_uformat $oform $value]}
+ m {return [_uformat $oform [expr $value*60]]}
+ s {return [_uformat $oform [expr $value*60*60]]}
+ }
+ }
+ m {
+ switch $otype {
+ h {return [_uformat $oform [d2h $value/60]]}
+ d {return [_uformat $oform [expr $value/60]]}
+ m {return [_uformat $oform $value]}
+ s {return [_uformat $oform [expr $value*60]]}
+ }
+ }
+ s {
+ switch $otype {
+ h {return [_uformat $oform [h2d $value/60/60]]}
+ d {return [_uformat $oform [expr $value/60/60]]}
+ m {return [_uformat $oform [expr $value/60]]}
+ s {return [_uformat $oform $value]}
+ }
+ }
+ }
+}
diff --git a/ds9/library/coord.tcl b/ds9/library/coord.tcl
new file mode 100644
index 0000000..3419721
--- /dev/null
+++ b/ds9/library/coord.tcl
@@ -0,0 +1,204 @@
+# 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 CoordDef {} {
+ global pcoord
+
+ # prefs only
+ set pcoord(filename) 0
+ set pcoord(value) 1
+ set pcoord(image) 1
+ set pcoord(physical) 0
+ set pcoord(amplifier) 0
+ set pcoord(detector) 0
+ set pcoord(wcs) 1
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set "pcoord(wcs$l)" 0
+ }
+}
+
+proc SetCoordSystem {varname system sky skyformat} {
+ upvar #0 $varname var
+ global $varname
+
+ global current
+ switch $var(system) {
+ image -
+ physical -
+ detector -
+ amplifier {}
+ default {
+ if {$current(frame) != {}} {
+ set rr [$current(frame) get wcs]
+ set var($system) [lindex $rr 0]
+ if {$sky != {}} {
+ set var($sky) [lindex $rr 1]
+ }
+ if {$skyformat != {}} {
+ set var($skyformat) [lindex $rr 2]
+ }
+ }
+ }
+ }
+}
+
+proc AdjustCoordSystem {varname system} {
+ upvar #0 $varname var
+ global $varname
+
+ global current
+ switch -- $var($system) {
+ image -
+ physical -
+ amplifier -
+ detector {}
+ wcs {
+ if {$current(frame) != {}} {
+ if {![$current(frame) has wcs $var($system)]} {
+ set ${varname}($system) physical
+ }
+ }
+ }
+ default {
+ if {$current(frame) != {}} {
+ if {![$current(frame) has wcs $var($system)]} {
+ if {[$current(frame) has wcs wcs]} {
+ set ${varname}($system) wcs
+ } else {
+ set ${varname}($system) physical
+ }
+ }
+ }
+ }
+ }
+}
+
+proc AdjustCoordSystem3d {varname system} {
+ upvar #0 $varname var
+ global $varname
+
+ global current
+ switch -- $var($system) {
+ image {}
+ wcs {
+ if {$current(frame) != {}} {
+ if {![$current(frame) has wcs 3d $var($system)]} {
+ set ${varname}($system) image
+ }
+ }
+ }
+ default {
+ if {$current(frame) != {}} {
+ if {![$current(frame) has wcs 3d $var($system)]} {
+ if {[$current(frame) has wcs wcs]} {
+ set ${varname}($system) wcs
+ } else {
+ set ${varname}($system) image
+ }
+ }
+ }
+ }
+ }
+}
+
+proc DisplayCoordDialog {which x y} {
+ global pcoord
+ global wcs
+
+ set r {}
+
+ if {$pcoord(filename)} {
+ append r "[$which get fits file name full]"
+ }
+
+ foreach l {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ if {"$pcoord(wcs$l)" && [$which has wcs "wcs$l"]} {
+ set cd "[$which get coordinates $x $y wcs$l $wcs(sky) $wcs(skyformat)]"
+
+ if {[$which has wcs equatorial "wcs$l"]} {
+ append r " [lindex $cd 0] [lindex $cd 1] $wcs(sky)"
+ } else {
+ set name [$which get wcs name "wcs$l"]
+ if {$name != {}} {
+ append r " [lindex $cd 0] [lindex $cd 1] $name"
+ } else {
+ append r " [lindex $cd 0] [lindex $cd 1] [lindex $cd 3]"
+ }
+ }
+ }
+ }
+
+ if {$pcoord(detector) && [$which has detector]} {
+ append r " [$which get coordinates $x $y detector] detector"
+ }
+
+ if {$pcoord(amplifier) && [$which has amplifier]} {
+ append r " [$which get coordinates $x $y amplifier] amplifier"
+ }
+
+ if {$pcoord(physical) && [$which has physical]} {
+ append r " [$which get coordinates $x $y physical] physical"
+ }
+
+ if {$pcoord(image)} {
+ append r " [$which get coordinates $x $y image]"
+ }
+
+ if {$pcoord(value)} {
+ append r " [$which get value canvas $x $y]"
+ }
+
+ append r " \n"
+
+ SimpleTextDialog coordtxt [msgcat::mc {Coordinates}] \
+ 80 20 append bottom "$r"
+}
+
+proc PrefsDialogCoord {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Print Coordinates}]
+ lappend dprefs(tabs) [ttk::frame $w.coord]
+
+ # Print
+ set f [ttk::labelframe $w.coord.print -text [msgcat::mc {Print}]]
+
+ ttk::checkbutton $f.filename -text [msgcat::mc {Filename}] \
+ -variable pcoord(filename)
+ ttk::checkbutton $f.value -text [msgcat::mc {Value}] \
+ -variable pcoord(value)
+ ttk::checkbutton $f.wcs -text [msgcat::mc {WCS}] -variable pcoord(wcs)
+ ttk::menubutton $f.mwcs -text [msgcat::mc {Multiple WCS}] -menu $f.mwcs.menu
+
+ ttk::checkbutton $f.image -text [msgcat::mc {Image}] \
+ -variable pcoord(image)
+ ttk::checkbutton $f.physical -text [msgcat::mc {Physical}] \
+ -variable pcoord(physical)
+ ttk::checkbutton $f.amplifier -text [msgcat::mc {Amplifier}] \
+ -variable pcoord(amplifier)
+ ttk::checkbutton $f.detector -text [msgcat::mc {Detector}] \
+ -variable pcoord(detector)
+
+ set m $f.mwcs.menu
+ menu $m
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $m add checkbutton -label "[msgcat::mc {WCS}] $l" \
+ -variable "pcoord(wcs$l)"
+ }
+
+ grid $f.filename -padx 2 -pady 2 -sticky w
+ grid $f.value -padx 2 -pady 2 -sticky w
+ grid $f.wcs $f.mwcs -padx 2 -pady 2 -sticky w
+ grid $f.image -padx 2 -pady 2 -sticky w
+ grid $f.physical -padx 2 -pady 2 -sticky w
+ grid $f.amplifier -padx 2 -pady 2 -sticky w
+ grid $f.detector -padx 2 -pady 2 -sticky w
+
+ pack $w.coord.print -side top -fill both -expand true
+}
+
diff --git a/ds9/library/cpanda.tcl b/ds9/library/cpanda.tcl
new file mode 100644
index 0000000..02b1c1d
--- /dev/null
+++ b/ds9/library/cpanda.tcl
@@ -0,0 +1,132 @@
+# 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 PandaDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(which) panda
+ set var(proc,apply) PandaApply
+ set var(proc,close) PandaClose
+ set var(proc,generate) PandaGenerate
+ set var(proc,coordCB) PandaCoordCB
+ set var(proc,editCB) PandaEditCB
+ set var(proc,distCB) PandaDistCB
+
+ # base panda dialog
+ MarkerBasePandaDialog $varname
+
+ set f $var(top).param
+
+ # Radius
+ ttk::label $f.tinner -text [msgcat::mc {Inner}]
+ ttk::label $f.touter -text [msgcat::mc {Outer}]
+ ttk::label $f.tradius -text [msgcat::mc {Radius}]
+ ttk::entry $f.inner -textvariable ${varname}(inner) -width 13
+ ttk::entry $f.outer -textvariable ${varname}(outer) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list $var(proc,distCB) $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+
+ # Annuli
+ ttk::label $f.tannuli -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable ${varname}(annuli) -width 13
+
+ grid x $f.tinner $f.touter -padx 2 -pady 2 -sticky w
+ grid $f.tradius $f.inner $f.outer $f.uradius -padx 2 -pady 2 -sticky w
+ grid $f.tannuli $f.annuli -padx 2 -pady 2 -sticky w
+
+ # init - do this last
+ PandaDistCB $varname
+}
+
+# actions
+
+proc PandaClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBasePandaClose $varname
+}
+
+proc PandaApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBasePandaApply $varname
+}
+
+proc PandaGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseAnnulusGenerateCircle $varname
+ MarkerBasePandaGenerateAngles $varname
+}
+
+# callbacks
+
+proc PandaCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "PandaCoordCB"
+ }
+
+ MarkerBasePandaCoordCB $varname
+}
+
+proc PandaEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "PandaEditCB"
+ }
+
+ set t [$var(frame) get marker $var(id) panda radius \
+ $var(dcoord) $var(dformat)]
+
+ set last [expr [llength $t]-1]
+ set var(inner) [lindex $t 0]
+ set var(outer) [lindex $t $last]
+ set var(annuli) $last
+
+ $var(annulitxt) delete 1.0 end
+ $var(annulitxt) insert end "$t"
+
+ set a [$var(frame) get marker $var(id) panda angle $var(system) $var(sky)]
+
+ set last [expr [llength $a]-1]
+ set var(ang1) [lindex $a 0]
+ set var(ang2) [lindex $a $last]
+ set var(angnum) $last
+
+ $var(angtxt) delete 1.0 end
+ $var(angtxt) insert end "$a"
+}
+
+proc PandaDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "PandaDistCB"
+ }
+
+ MarkerBasePandaDistCB $varname
+}
diff --git a/ds9/library/crop.tcl b/ds9/library/crop.tcl
new file mode 100644
index 0000000..a4982d3
--- /dev/null
+++ b/ds9/library/crop.tcl
@@ -0,0 +1,467 @@
+# 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 CropDef {} {
+ global crop
+ global icrop
+
+ set icrop(top) .cr
+ set icrop(mb) .crmb
+
+ set crop(lock) none
+
+ set crop(system) wcs
+ set crop(sky) fk5
+ set crop(skyformat) degrees
+ set crop(dcoord) wcs
+ set crop(dformat) degrees
+ set crop(rcoord) wcs
+}
+
+proc CropReset {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) crop
+ UpdateCrop $current(frame)
+ }
+}
+
+proc CropButton {which x y} {
+ global rgb
+ RGBEvalLock rgb(lock,crop) $which [list $which crop begin $x $y]
+}
+
+proc CropMotion {which x y} {
+ $which crop motion $x $y
+}
+
+proc CropRelease {which x y} {
+ global rgb
+
+ RGBEvalLock rgb(lock,crop) $which [list $which crop end $x $y]
+ UpdateCrop $which
+}
+
+proc Crop3dButton {which x y zz} {
+ $which crop 3d begin $x $y $zz
+}
+
+proc Crop3dMotion {which x y zz} {
+ $which crop 3d motion $x $y $zz
+}
+
+proc Crop3dRelease {which x y zz} {
+ $which crop 3d end $x $y $zz
+ UpdateCrop $which
+}
+
+proc UpdateCrop {which} {
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateCrop"
+ }
+
+ LockCrop $which
+ UpdateCropDialog
+ UpdateCubeDialog
+ UpdateContourScale
+ UpdateContourDialog
+ UpdateScaleDialog
+ GridUpdateZoom
+ UpdateGraphXAxis $which
+ UpdateGraphYAxis $which
+ UpdateInfoBoxBase
+ UpdateMain
+}
+
+proc CropDialog {} {
+ global crop
+ global icrop
+ global dcrop
+ global ds9
+ global current
+
+ # see if we already have a window visible
+ if {[winfo exists $icrop(top)]} {
+ raise $icrop(top)
+ return
+ }
+
+ # create the window
+ set w $icrop(top)
+ set mb $icrop(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Crop Parameters}] \
+ CropDestroyDialog
+
+ # for CoordMenuButton
+ set crop(frame) $current(frame)
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command CropApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Reset}] -command CropReset
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command CropDestroyDialog
+
+ EditMenu $mb icrop
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.title -text [msgcat::mc {Center}]
+ ttk::entry $f.x -textvariable dcrop(x) -width 14
+ ttk::entry $f.y -textvariable dcrop(y) -width 14
+ set dcrop(cb) $f.center
+ CoordMenuButton $dcrop(cb) crop system 1 sky skyformat UpdateCropDialog
+
+ ttk::label $f.stitle -text [msgcat::mc {Size}]
+ ttk::entry $f.w -textvariable dcrop(w) -width 14
+ ttk::entry $f.h -textvariable dcrop(h) -width 14
+ set dcrop(db) $f.size
+ DistMenuButton $dcrop(db) crop dcoord 1 dformat UpdateCropDialog
+
+ ttk::label $f.rtitle -text [msgcat::mc {3D}]
+ ttk::entry $f.from -textvariable dcrop(zmin) -width 14
+ ttk::entry $f.to -textvariable dcrop(zmax) -width 14
+ set dcrop(rb) $f.range
+ CoordMenuButton $dcrop(rb) crop rcoord 2 {} {} UpdateCropDialog
+
+ grid $f.title $f.x $f.y $dcrop(cb) -padx 2 -pady 2
+ grid $f.stitle $f.w $f.h $dcrop(db) -padx 2 -pady 2
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command CropApplyDialog
+ ttk::button $f.reset -text [msgcat::mc {Reset}] -command CropReset
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command CropDestroyDialog
+ pack $f.apply $f.reset $f.close -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
+
+ $w.param.x select range 0 end
+
+ UpdateCropDialog
+}
+
+proc CropApplyDialog {} {
+ global crop
+ global icrop
+ global dcrop
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) crop center $dcrop(x) $dcrop(y) \
+ $crop(system) $crop(sky) \
+ $dcrop(w) $dcrop(h) $crop(dcoord) $crop(dformat)
+
+ if {[$current(frame) has fits cube]} {
+ $current(frame) crop 3d $dcrop(zmin) $dcrop(zmax) $crop(rcoord)
+ }
+ UpdateCrop $current(frame)
+ }
+}
+
+proc CropDestroyDialog {} {
+ global icrop
+ global dcrop
+
+ if {[winfo exists $icrop(top)]} {
+ destroy $icrop(top)
+ destroy $icrop(mb)
+ }
+
+ unset dcrop
+}
+
+proc UpdateCropMenu {} {
+ # can be changed by wcs
+ SetCoordSystem crop system sky skyformat
+}
+
+proc UpdateCropDialog {} {
+ global crop
+ global icrop
+ global dcrop
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateCropDialog"
+ }
+
+ if {![winfo exists $icrop(top)]} {
+ return
+ }
+
+ set w $icrop(top)
+
+ if {$current(frame) != {}} {
+ set crop(frame) $current(frame)
+
+ if {[$current(frame) has fits]} {
+ # now make sure we have the coord systems
+ AdjustCoordSystem crop system
+ CoordMenuEnable $dcrop(cb).menu crop system 1 sky skyformat
+ CoordMenuButtonCmd crop system sky {}
+
+ AdjustCoordSystem crop dcoord
+ DistMenuEnable $dcrop(db).menu crop dcoord 1 dformat
+ DistMenuButtonCmd crop dcoord dformat {}
+
+ AdjustCoordSystem3d crop rcoord
+ CoordMenuEnable $dcrop(rb).menu crop rcoord 2 {} {}
+ CoordMenuButtonCmd crop rcoord {} {}
+
+ set rr [$current(frame) get crop center \
+ $crop(system) $crop(sky) $crop(skyformat) \
+ $crop(dcoord) $crop(dformat)]
+ set dcrop(x) [lindex $rr 0]
+ set dcrop(y) [lindex $rr 1]
+ set dcrop(w) [lindex $rr 2]
+ set dcrop(h) [lindex $rr 3]
+
+ if {[$current(frame) has fits cube]} {
+ set ss [$current(frame) get crop 3d $crop(rcoord)]
+ set dcrop(zmin) [lindex $ss 0]
+ set dcrop(zmax) [lindex $ss 1]
+
+ grid $w.param.rtitle $w.param.from $w.param.to $dcrop(rb) \
+ -padx 2 -pady 2
+ } else {
+ set dcrop(zmin) {}
+ set dcrop(zmax) {}
+
+ grid forget $w.param.rtitle $w.param.from $w.param.to $dcrop(rb)
+ }
+
+ return
+ }
+ }
+
+ grid forget $w.param.rtitle $w.param.from $w.param.to $dcrop(rb)
+
+ CoordMenuReset $dcrop(cb).menu crop system 1 sky skyformat
+ DistMenuReset $dcrop(db).menu crop dcoord 1 dformat
+ CoordMenuReset $dcrop(rb).menu crop rcoord 2 {} {}
+
+ set dcrop(x) {}
+ set dcrop(y) {}
+ set dcrop(w) {}
+ set dcrop(h) {}
+ set dcrop(zmin) {}
+ set dcrop(zmax) {}
+}
+
+proc MatchCropCurrent {sys} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchCrop $current(frame) $sys
+ }
+}
+
+proc MatchCrop {which sys} {
+ global ds9
+ global rgb
+
+ # make sure matrices have been updated
+ RealizeDS9
+
+ set tt [$which has crop]
+ set datasec [$which get datasec]
+
+ if {$tt} {
+ switch -- $sys {
+ image -
+ physical -
+ amplifier -
+ detector {
+ set rr [$which get crop center $sys fk5 degrees $sys degrees]
+ set r(x) [lindex $rr 0]
+ set r(y) [lindex $rr 1]
+ set r(w) [lindex $rr 2]
+ set r(h) [lindex $rr 3]
+ set qq [$which get crop 3d image]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,crop) $ff [list $ff datasec $datasec]
+ RGBEvalLock rgb(lock,crop) $ff [list $ff crop center $r(x) $r(y) $sys fk5 $r(w) $r(h) $sys degrees]
+ RGBEvalLock rgb(lock,crop) $ff [list $ff crop 3d $qq image]
+ }
+ }
+ }
+ wcs {
+ set ss [lindex [$which get wcs] 0]
+ if {[$which has wcs $ss]} {
+ set rr [$which get crop center $ss fk5 degrees $ss degrees]
+ set r(x) [lindex $rr 0]
+ set r(y) [lindex $rr 1]
+ set r(w) [lindex $rr 2]
+ set r(h) [lindex $rr 3]
+ set qq [$which get crop 3d $ss]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ if {[$ff has wcs $ss]} {
+ RGBEvalLock rgb(lock,crop) $ff [list $ff crop center $r(x) $r(y) $ss fk5 $r(w) $r(h) $ss degrees]
+ RGBEvalLock rgb(lock,crop) $ff [list $ff crop 3d $qq $ss]
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,crop) $ff [list $ff crop]
+ RGBEvalLock rgb(lock,crop) $ff [list $ff crop 3d]
+ }
+ }
+ }
+}
+
+proc LockCropCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockCrop $current(frame)
+ }
+}
+
+proc LockCrop {which} {
+ global crop
+
+ switch -- $crop(lock) {
+ none {}
+ default {MatchCrop $which $crop(lock)}
+ }
+}
+
+proc CropBackup {ch which} {
+ switch [$which get type] {
+ base -
+ 3d {CropBackupBase $ch $which}
+ rgb {CropBackupRGB $ch $which}
+ }
+}
+
+proc CropBackupBase {ch which} {
+ if {[$which has crop]} {
+ if {[$which has fits]} {
+ set rr [$which get crop physical fk5 degrees]
+ puts $ch "$which crop $rr physical fk5"
+
+ if {[$which has fits cube]} {
+ set ss [$which get crop 3d image]
+ puts $ch "$which crop 3d $ss image"
+ }
+ }
+ }
+}
+
+proc CropBackupRGB {ch which} {
+ set sav [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ puts $ch "$which rgb channel $cc"
+ CropBackupBase $ch $which
+ }
+ $which rgb channel $sav
+ puts $ch "$which rgb channel $sav"
+}
+
+# Process Cmds
+
+proc ProcessCropCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ global crop
+ global current
+ switch -- [string tolower [lindex $var $i]] {
+ match {
+ incr i
+ MatchCropCurrent [lindex $var $i]
+ }
+ lock {
+ incr i
+ set crop(lock) [lindex $var $i]
+ LockCropCurrent
+ }
+ open {CropDialog}
+ close {CropDestroyDialog}
+ reset {CropReset}
+ 3d {
+ incr i 1
+ set zmin [lindex $var [expr $i+0]]
+ set zmax [lindex $var [expr $i+1]]
+ set sys [lindex $var [expr $i+2]]
+
+ incr i 1
+ incr i [FixSpecSystem sys physical]
+
+ $current(frame) crop 3d $zmin $zmax $sys
+ }
+ default {
+ set x [lindex $var [expr $i+0]]
+ set y [lindex $var [expr $i+1]]
+ set w [lindex $var [expr $i+2]]
+ set h [lindex $var [expr $i+3]]
+ set sys [lindex $var [expr $i+4]]
+ set sky [lindex $var [expr $i+5]]
+ set dformat [lindex $var [expr $i+6]]
+
+ incr i 3
+ incr i [FixSpec sys sky dformat physical fk5 degrees]
+
+ $current(frame) crop center $x $y $sys $sky $w $h $sys $dformat
+ }
+ }
+}
+
+proc ProcessSendCropCmd {proc id param} {
+ global crop
+ global current
+
+ switch -- [string tolower [lindex $param 0]] {
+ lock {$proc $id "$crop(lock)\n"}
+ 3d {
+ set sys [lindex $param 1]
+ FixSpecSystem sys physical
+
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get crop 3d $sys]\n"
+ }
+ }
+ default {
+ set sys [lindex $param 0]
+ set sky [lindex $param 1]
+ set format [lindex $param 2]
+ set dformat [lindex $param 3]
+ FixSpec sys sky format physical fk5 degrees
+
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get crop center $sys $sky $format $sys $dformat]\n"
+ }
+ }
+ }
+}
diff --git a/ds9/library/crosshair.tcl b/ds9/library/crosshair.tcl
new file mode 100644
index 0000000..512e461
--- /dev/null
+++ b/ds9/library/crosshair.tcl
@@ -0,0 +1,310 @@
+# 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 CrosshairDef {} {
+ global crosshair
+ global icrosshair
+
+ set icrosshair(top) .ch
+ set icrosshair(mb) .chmb
+
+ set crosshair(lock) none
+
+ # set via wcs()
+ set crosshair(system) wcs
+ set crosshair(sky) fk5
+ set crosshair(skyformat) degrees
+}
+
+proc CrosshairButton {which x y} {
+ global ds9
+ global crosshair
+
+ $which crosshair canvas $x $y
+ UpdateCrosshairDialog
+ LockCrosshair $which
+}
+
+proc CrosshairArrowKey {which x y} {
+ global ds9
+ global crosshair
+
+ $which crosshair warp $x $y
+ UpdateCrosshairDialog
+ LockCrosshair $which
+
+ set coord [$which get crosshair canvas]
+ set X [lindex $coord 0]
+ set Y [lindex $coord 1]
+
+ UpdateColormapLevelMosaic $which $X $Y canvas
+ UpdateInfoBox $which $X $Y canvas
+ UpdatePixelTableDialog $which $X $Y canvas
+ UpdateGraph $which $X $Y canvas
+}
+
+proc CrosshairTo {x y sys sky} {
+ global crosshair
+ global current
+ global ds9
+
+ set current(mode) crosshair
+ ChangeMode
+
+ if {$current(frame) != {}} {
+ $current(frame) crosshair $sys $sky $x $y
+ set coord [$current(frame) get crosshair canvas]
+ UpdateColormapLevelMosaic $current(frame) \
+ [lindex $coord 0] [lindex $coord 1] canvas
+ UpdateInfoBox $current(frame) \
+ [lindex $coord 0] [lindex $coord 1] canvas
+
+ if {$crosshair(lock) != "none"} {
+ set coord [$current(frame) get crosshair $crosshair(lock)]
+ foreach f $ds9(frames) {
+ if {$f != $current(frame) && [$f has system $crosshair(lock)]} {
+ $f crosshair $crosshair(lock) $coord
+ }
+ }
+ }
+ }
+}
+
+proc MatchCrosshairCurrent {sys} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchCrosshair $current(frame) $sys
+ }
+}
+
+proc MatchCrosshair {which sys} {
+ global crosshair
+ global ds9
+ global current
+
+ if {$current(mode) != {crosshair}} {
+ return
+ }
+
+ switch -- $sys {
+ image -
+ physical -
+ amplifier -
+ detector {
+ set coord [$which get crosshair $sys]
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ $ff crosshair $sys $coord
+ }
+ }
+ }
+ wcs {
+ set ss [lindex [$which get wcs] 0]
+ if {[$which has wcs $ss]} {
+ set coord [$which get crosshair $ss]
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ if {[$ff has wcs $ss]} {
+ $ff crosshair $ss $coord
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+proc LockCrosshairCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockCrosshair $current(frame)
+ }
+}
+
+proc LockCrosshair {which} {
+ global crosshair
+
+ switch -- $crosshair(lock) {
+ none {}
+ default {MatchCrosshair $which $crosshair(lock)}
+ }
+}
+
+proc CrosshairDialog {} {
+ global crosshair
+ global icrosshair
+ global dcrosshair
+ global current
+
+ # see if we already have a window visible
+ if {[winfo exists $icrosshair(top)]} {
+ raise $icrosshair(top)
+ return
+ }
+
+ # create the window
+ set w $icrosshair(top)
+ set mb $icrosshair(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Crosshair Parameters}] \
+ CrosshairDestroyDialog
+
+ # for CoordMenuButton
+ set crosshair(frame) $current(frame)
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command CrosshairApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command CrosshairDestroyDialog
+
+ EditMenu $mb icrosshair
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.title -text [msgcat::mc {Crosshair}]
+ ttk::entry $f.x -textvariable dcrosshair(x) -width 14
+ ttk::entry $f.y -textvariable dcrosshair(y) -width 14
+ set dcrosshair(cb) $f.system
+ CoordMenuButton $dcrosshair(cb) crosshair system 1 sky skyformat \
+ UpdateCrosshairDialog
+
+ grid $f.title $f.x $f.y $f.system -padx 2 -pady 2
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] \
+ -command CrosshairApplyDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command CrosshairDestroyDialog
+ pack $f.apply $f.close -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
+
+ $w.param.x select range 0 end
+
+ UpdateCrosshairDialog
+}
+
+proc CrosshairApplyDialog {} {
+ global crosshair
+ global dcrosshair
+
+ CrosshairTo $dcrosshair(x) $dcrosshair(y) $crosshair(system) $crosshair(sky)
+}
+
+proc CrosshairDestroyDialog {} {
+ global icrosshair
+ global dcrosshair
+
+ if {[winfo exists $icrosshair(top)]} {
+ destroy $icrosshair(top)
+ destroy $icrosshair(mb)
+ }
+
+ unset dcrosshair
+}
+
+proc UpdateCrosshairDialog {} {
+ global crosshair
+ global icrosshair
+ global dcrosshair
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateCrosshairDialog"
+ }
+
+ if {![winfo exists $icrosshair(top)]} {
+ return
+ }
+
+ if {$current(frame) != {}} {
+ set crosshair(frame) $current(frame)
+ if {[$current(frame) has fits]} {
+ # now make sure we have the coord systems
+ AdjustCoordSystem crosshair system
+ CoordMenuEnable $dcrosshair(cb).menu crosshair system 1 sky skyformat
+ CoordMenuButtonCmd crosshair system sky {}
+ } else {
+ CoordMenuReset $dcrosshair(cb).menu crosshair system 1 sky skyformat
+ }
+ }
+
+ if {$current(frame) != {}} {
+ set coord [$current(frame) get crosshair $crosshair(system) \
+ $crosshair(sky) $crosshair(skyformat)]
+ set dcrosshair(x) [lindex $coord 0]
+ set dcrosshair(y) [lindex $coord 1]
+ } else {
+ set dcrosshair(x) {}
+ set dcrosshair(y) {}
+ }
+}
+
+proc ProcessCrosshairCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ match {
+ incr i
+ MatchCrosshairCurrent [lindex $var $i]
+ }
+ lock {
+ incr i
+ set crosshair(lock) [lindex $var $i]
+ LockCrosshairCurrent
+ }
+ default {
+ set x [lindex $var [expr $i+0]]
+ set y [lindex $var [expr $i+1]]
+ set sys [lindex $var [expr $i+2]]
+ set sky [lindex $var [expr $i+3]]
+ set format {}
+
+ incr i 1
+ incr i [FixSpec sys sky format physical fk5 degrees]
+
+ CrosshairTo $x $y $sys $sky
+ UpdateCrosshairDialog
+ }
+ }
+}
+
+proc ProcessSendCrosshairCmd {proc id param} {
+ global crosshair
+ global current
+
+ switch -- [string tolower $param] {
+ lock {$proc $id "$crosshair(lock)\n"}
+ default {
+ set sys [lindex $param 0]
+ set sky [lindex $param 1]
+ set format [lindex $param 2]
+ FixSpec sys sky format physical fk5 degrees
+
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get crosshair $sys $sky $format]\n"
+ }
+ }
+ }
+}
+
diff --git a/ds9/library/cube.tcl b/ds9/library/cube.tcl
new file mode 100644
index 0000000..68ecf25
--- /dev/null
+++ b/ds9/library/cube.tcl
@@ -0,0 +1,843 @@
+# 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 CubeDef {} {
+ global icube
+ global cube
+
+ set icube(top) .cube
+ set icube(mb) .cubemb
+ set icube(id) 0
+
+ set cube(lock) none
+ set cube(lock,axes) 0
+# needs work, at high values, but cropped, causes problems
+# set cube(format) {%.5g}
+# axes cnt starts at 0
+ set cube(axis) 2
+ set cube(system) wcs
+ set cube(axes) 123
+}
+
+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
+
+ 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)]
+
+ UpdateCube
+}
+
+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
+
+ 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"
+ } else {
+ set dcube(image,$cube(axis)) 1
+ set dcube(wcs,$cube(axis)) 1
+ }
+ UpdateCube
+ }
+}
+
+proc UpdateCube {} {
+ global current
+
+ LockCubeCurrent
+ UpdateScaleDialog
+ UpdateContourScale
+ UpdateContourDialog
+ UpdateGraphYAxis $current(frame)
+ UpdateInfoBoxBase
+ 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
+ $mb add cascade -label [msgcat::mc {Axes Order}] -menu $mb.axes
+
+ 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
+
+ menu $mb.axes
+ $mb.axes add radiobutton -label {1 2 3} -variable cube(axes) \
+ -value 123 -command CubeAxes
+ $mb.axes add radiobutton -label {1 3 2} -variable cube(axes) \
+ -value 132 -command CubeAxes
+ $mb.axes add radiobutton -label {2 1 3} -variable cube(axes) \
+ -value 213 -command CubeAxes
+ $mb.axes add radiobutton -label {2 3 1} -variable cube(axes) \
+ -value 231 -command CubeAxes
+ $mb.axes add radiobutton -label {3 1 2} -variable cube(axes) \
+ -value 312 -command CubeAxes
+ $mb.axes add radiobutton -label {3 2 1} -variable cube(axes) \
+ -value 321 -command CubeAxes
+
+ # 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 5 -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 {} {
+ global cube
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateCubeMenu"
+ }
+
+ if {$current(frame) != {}} {
+ set cube(axes) [$current(frame) get cube axes]
+ }
+
+ # 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
+ }
+
+ if {$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 {} {}
+ }
+ }
+
+ # get number of axes
+ if {$current(frame) != {}} {
+ set naxes [$current(frame) get fits naxes]
+ } else {
+ set naxes 2
+ }
+
+ # set from/to
+ set depth 1
+ if {$naxes == 2} {
+ set dcube(from,2) 1
+ set dcube(to,2) 1
+ } else {
+ for {set ii 2} {$ii<$naxes} {incr ii} {
+ set dcube(from,$ii) 1
+ set dcube(to,$ii) 1
+
+ if {$ii==2} {
+ # 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 depth [$current(frame) get fits depth $ii]
+ 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)
+ }
+
+ # show it
+ if {$naxes <= 3} {
+ # special chase, no checkbox
+ 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 {
+ 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
+ if {$naxes == 2} {
+ SliderMinMax $dcube(sslice,2) $dcube(from,2) $dcube(to,2) 4
+ set dcube(vcoord) $cube(system)
+ } else {
+ for {set ii 2} {$ii<$naxes} {incr ii} {
+ set dcube(vcoord) $cube(system)
+ switch $cube(system) {
+ image {
+ set dcube(from,$ii) [expr int($dcube(from,$ii))]
+ set dcube(to,$ii) [expr int($dcube(to,$ii))]
+ }
+ default {
+ 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 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) > [expr $naxes-1]} {
+ set cube(axis) [expr $naxes-1]
+ if {$cube(axis) < 2} {
+ set cube(axis) 2
+ }
+ }
+
+ # we must do this after the scale has been configured
+ if {$naxes == 2} {
+ set dcube(image,2) 1
+ set dcube(wcs,2) 1
+ } else {
+ for {set ii 2} {$ii<$naxes} {incr ii} {
+ 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
+
+ set axes [$which get cube axes]
+ puts $ch "$which cube axes $axes"
+
+ 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"
+}
+
+proc MatchAxesCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchAxes $current(frame)
+ }
+}
+
+proc MatchAxes {which} {
+ global cube
+ global ds9
+ global rgb
+ global grid
+
+ set axes [$which get cube axes]
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,axes) $ff "$ff cube axes $axes"
+
+ # grid
+ if {[$ff has grid]} {
+ array set ogrid [array get grid]
+ array set grid [$ff get grid var]
+
+ GridUpdate $ff
+
+ array set grid [array get ogrid]
+ }
+ }
+ }
+}
+
+proc LockAxesCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockAxes $current(frame)
+ }
+}
+
+proc LockAxes {which} {
+ global cube
+
+ if {$cube(lock,axes)} {
+ MatchAxes $which
+ }
+}
+
+proc CubeAxes {} {
+ global cube
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,axes) \
+ "$current(frame) cube axes $cube(axes)"
+ ResetWatchCursor
+
+ LockAxesCurrent
+ UpdateHeaderDialog
+ UpdateWCS
+ UpdateDS9
+ UpdateMain
+ }
+}
+
+# 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
+ }
+ }
+ }
+ axes -
+ order {
+ incr i;
+ switch -- [string tolower [lindex $var $i]] {
+ lock {
+ incr i;
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set cube(lock,axes) [FromYesNo [lindex $var $i]]
+ } else {
+ set cube(lock,axes) 1
+ incr i -1
+ }
+ LockAxesCurrent
+ }
+ default {
+ set cube(axes) [lindex $var $i]
+ CubeAxes
+ }
+ }
+ }
+ 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"}
+ axes -
+ order {
+ switch -- [string tolower [lindex $param 1]] {
+ lock {$proc $id [ToYesNo $cube(lock,axes)]}
+ default {$proc $id "$cube(axes)\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"
+ }
+ }
+ }
+}
diff --git a/ds9/library/debug.tcl b/ds9/library/debug.tcl
new file mode 100644
index 0000000..32188dc
--- /dev/null
+++ b/ds9/library/debug.tcl
@@ -0,0 +1,285 @@
+# 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 DebugDef {} {
+ global debug
+
+ set debug(tcl,events) 0
+ set debug(tcl,update) 0
+ set debug(tcl,idletasks) 0
+ set debug(tcl,layout) 0
+ set debug(tcl,info) 0
+ set debug(tcl,marker) 0
+ set debug(tcl,hv) 0
+ set debug(tcl,cat) 0
+ set debug(tcl,sia) 0
+ set debug(tcl,ime) 0
+ set debug(tcl,samp) 0
+ set debug(tcl,grid) 0
+ set debug(tcl,restore) 0
+ set debug(tcl,http) 0
+ set debug(tcl,ftp) 0
+ set debug(tcl,xpa) 0
+ set debug(tcl,image) 0
+
+ set debug(tksao,ast) 0
+ set debug(tksao,mosaic) 0
+ set debug(tksao,parser) 0
+ set debug(tksao,perf) 0
+ set debug(tksao,wcs) 0
+ set debug(tksao,bin) 0
+ set debug(tksao,block) 0
+ set debug(tksao,compress) 0
+ set debug(tksao,gz) 0
+ set debug(tksao,rgb) 0
+ set debug(tksao,crop) 0
+
+ set debug(iis) 0
+}
+
+proc Debug {which varname} {
+ upvar $varname var
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) debug $which $var
+ }
+}
+
+proc DebugMenu {} {
+ global ds9
+ global debug
+
+ if {[winfo exists $ds9(mb).debug]} {
+ return
+ }
+
+ $ds9(mb) add cascade -label {Debug} -menu $ds9(mb).debug
+
+ menu $ds9(mb).debug
+ $ds9(mb).debug add cascade -label {Tcl} -menu $ds9(mb).debug.tcl
+ $ds9(mb).debug add cascade -label {TKSAO} -menu $ds9(mb).debug.tksao
+ $ds9(mb).debug add cascade -label {IIS} -menu $ds9(mb).debug.iis
+
+ menu $ds9(mb).debug.tcl
+ $ds9(mb).debug.tcl add checkbutton -label {Events} \
+ -variable debug(tcl,events)
+ $ds9(mb).debug.tcl add checkbutton -label {Update} \
+ -variable debug(tcl,update)
+ $ds9(mb).debug.tcl add checkbutton -label {Idletasks} \
+ -variable debug(tcl,idletasks)
+ $ds9(mb).debug.tcl add checkbutton -label {Layout} \
+ -variable debug(tcl,layout)
+ $ds9(mb).debug.tcl add checkbutton -label {Info} \
+ -variable debug(tcl,info)
+ $ds9(mb).debug.tcl add checkbutton -label {Marker} \
+ -variable debug(tcl,marker)
+ $ds9(mb).debug.tcl add checkbutton -label {HV} \
+ -variable debug(tcl,hv)
+ $ds9(mb).debug.tcl add checkbutton -label {Catalog} \
+ -variable debug(tcl,cat)
+ $ds9(mb).debug.tcl add checkbutton -label {SIA} \
+ -variable debug(tcl,sia)
+ $ds9(mb).debug.tcl add checkbutton -label {IME} \
+ -variable debug(tcl,ime)
+ $ds9(mb).debug.tcl add checkbutton -label {SAMP} \
+ -variable debug(tcl,samp)
+ $ds9(mb).debug.tcl add checkbutton -label {Grid} \
+ -variable debug(tcl,grid)
+ $ds9(mb).debug.tcl add checkbutton -label {Restore} \
+ -variable debug(tcl,restore)
+ $ds9(mb).debug.tcl add checkbutton -label {HTTP} \
+ -variable debug(tcl,http)
+ $ds9(mb).debug.tcl add checkbutton -label {FTP} \
+ -variable debug(tcl,ftp)
+ $ds9(mb).debug.tcl add checkbutton -label {XPA} \
+ -variable debug(tcl,xpa)
+ $ds9(mb).debug.tcl add checkbutton -label {IMAGE} \
+ -variable debug(tcl,image)
+
+ menu $ds9(mb).debug.tksao
+ $ds9(mb).debug.tksao add checkbutton -label {AST} \
+ -variable debug(tksao,ast) \
+ -command "Debug ast debug(tksao,ast)"
+ $ds9(mb).debug.tksao add checkbutton -label {Mosaic} \
+ -variable debug(tksao,mosaic) \
+ -command "Debug mosaic debug(tksao,mosaic)"
+ $ds9(mb).debug.tksao add checkbutton -label {Parser} \
+ -variable debug(tksao,parser) \
+ -command "Debug parser debug(tksao,parser)"
+ $ds9(mb).debug.tksao add checkbutton -label {Perf} \
+ -variable debug(tksao,perf) \
+ -command "Debug perf debug(tksao,perf)"
+ $ds9(mb).debug.tksao add checkbutton -label {WCS} \
+ -variable debug(tksao,wcs) \
+ -command "Debug wcs debug(tksao,wcs)"
+ $ds9(mb).debug.tksao add checkbutton -label {Bin} \
+ -variable debug(tksao,bin) \
+ -command "Debug bin debug(tksao,bin)"
+ $ds9(mb).debug.tksao add checkbutton -label {Block} \
+ -variable debug(tksao,block) \
+ -command "Debug block debug(tksao,block)"
+ $ds9(mb).debug.tksao add checkbutton -label {Compress} \
+ -variable debug(tksao,compress) \
+ -command "Debug compress debug(tksao,compress)"
+ $ds9(mb).debug.tksao add checkbutton -label {GZ} \
+ -variable debug(tksao,gz) \
+ -command "Debug gz debug(tksao,gz)"
+ $ds9(mb).debug.tksao add checkbutton -label {RGB} \
+ -variable debug(tksao,rgb) \
+ -command "Debug rgb debug(tksao,rgb)"
+ $ds9(mb).debug.tksao add checkbutton -label {Crop} \
+ -variable debug(tksao,crop) \
+ -command "Debug crop debug(tksao,crop)"
+
+ menu $ds9(mb).debug.iis
+ $ds9(mb).debug.iis add checkbutton -label {IIS} \
+ -variable debug(iis) -command IISDebug
+}
+
+proc DumpURL {varname} {
+ upvar $varname r
+
+ puts stderr "r(scheme)=$r(scheme)"
+ puts stderr "r(authority)=$r(authority)"
+ puts stderr "r(path)=$r(path)"
+ puts stderr "r(query)=$r(query)"
+ puts stderr "r(fragment)=$r(fragment)"
+}
+
+proc DumpCallStack {} {
+ for {set x [expr [info level]-1]} {$x>0} {incr x -1} {
+ puts stderr "$x: [info level $x]"
+ }
+}
+
+proc DumpArray {varname} {
+ upvar $varname var
+ global $varname
+ foreach f [array names $varname] {
+ puts stderr "${varname}($f) = $var($f)"
+ }
+}
+
+# Process Cmds
+
+proc ProcessDebugTclCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # default debug dialog
+ if {[info proc bgerror] != {}} {
+ rename bgerror {}
+ }
+
+ global debug
+ switch -- [string tolower [lindex $var $i]] {
+ events {set debug(tcl,events) 1}
+ update {set debug(tcl,update) 1}
+ idletasks {set debug(tcl,idletasks) 1}
+ layout {set debug(tcl,layout) 1}
+ info {set debug(tcl,info) 1}
+ marker {set debug(tcl,marker) 1}
+ hv {set debug(tcl,hv) 1}
+ cat {set debug(tcl,cat) 1}
+ sia {set debug(tcl,sia) 1}
+ ime {set debug(tcl,ime) 1}
+ samp {set debug(tcl,samp) 1}
+ grid {set debug(tcl,grid) 1}
+ restore {set debug(tcl,restore) 1}
+ http {set debug(tcl,http) 1}
+ ftp {set debug(tcl,ftp) 1}
+ xpa {set debug(tcl,xpa) 1}
+ image {
+ set debug(tcl,hv) 1
+ set debug(tcl,http) 1
+ set debug(tcl,image) 1
+ }
+ }
+}
+
+proc ProcessDebugCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ DebugMenu
+
+ global debug
+ switch -- [string tolower [lindex $var $i]] {
+ ast {
+ set debug(tksao,ast) 1
+ Debug ast debug(tksao,ast)
+ }
+ mosaic {
+ set debug(tksao,mosaic) 1
+ Debug mosaic debug(tksao,mosaic)
+ }
+ parser {
+ set debug(tksao,parser) 1
+ Debug parser debug(tksao,parser)
+ }
+ perf {
+ set debug(tksao,perf) 1
+ Debug perf debug(tksao,perf)
+ }
+ wcs {
+ set debug(tksao,wcs) 1
+ Debug wcs debug(tksao,wcs)
+ }
+ bin {
+ set debug(tksao,bin) 1
+ Debug bin debug(tksao,bin)
+ }
+ block {
+ set debug(tksao,block) 1
+ Debug block debug(tksao,block)
+ }
+ compress {
+ set debug(tksao,compress) 1
+ Debug compress debug(tksao,compress)
+ }
+ gz {
+ set debug(tksao,gz) 1
+ Debug gz debug(tksao,gz)
+ }
+ iis {
+ set debug(iis) 1
+ IISDebug
+ }
+ rgb {
+ set debug(tksao,rgb) 1
+ Debug rgb debug(tksao,rgb)
+ }
+ crop {
+ set debug(tksao,crop) 1
+ Debug crop debug(tksao,crop)
+ }
+
+ events -
+ update -
+ idletasks -
+ layout -
+ info -
+ marker -
+ watch -
+ hv -
+ cat -
+ sia -
+ ime -
+ samp -
+ grid -
+ restore -
+ http -
+ ftp -
+ xpa -
+ image {}
+
+ default {
+ incr ${iname} -1
+ }
+ }
+}
+
diff --git a/ds9/library/dialog.tcl b/ds9/library/dialog.tcl
new file mode 100644
index 0000000..1936fd2
--- /dev/null
+++ b/ds9/library/dialog.tcl
@@ -0,0 +1,585 @@
+# 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 DialogCreate {top title varname} {
+ global ds9
+
+ eval {toplevel $top}
+ switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ ::tk::unsupported::MacWindowStyle style $top document "closeBox fullZoom collapseBox resizable"
+ }
+ }
+
+ wm title $top "$title"
+ wm iconname $top "$title"
+
+ upvar #0 varname var
+ wm protocol $top WM_DELETE_WINDOW "set $varname 1"
+}
+
+proc DialogCenter {w} {
+ global ds9
+ ::tk::PlaceWindow $w widget $ds9(top)
+}
+
+proc DialogWait {top varname {focus {}}} {
+ upvar $varname var
+
+ if {[string length $focus] == 0} {
+ set focus $top
+ }
+ set old [focus -displayof $top]
+ focus $focus
+ catch {tkwait visibility $top}
+ catch {grab $top}
+ tkwait variable $varname
+ catch {grab release $top}
+ focus $old
+
+ # reset errorInfo
+ global errorInfo
+ set errorInfo {}
+}
+
+proc DialogDismiss {w} {
+ destroy $w
+}
+
+# Simple List Box
+
+proc SLBDialog {varname title width} {
+ upvar $varname var
+ global ed
+
+ set w {.slb}
+
+ set ed(ok) 0
+
+ DialogCreate $w $title ed(ok)
+
+ # Lists
+ set f [ttk::frame $w.ed]
+
+ ttk::scrollbar $f.scroll -command "$f.box yview"
+ set ed(listbox) [listbox $f.box \
+ -yscroll "$f.scroll set" \
+ -setgrid 1 \
+ -selectmode single]
+ grid $f.box $f.scroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] \
+ -command {set ed(ok) 1}
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] \
+ -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -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.ed -side top -fill both -expand true
+
+ # init
+ for {set i 1} {$i <= $var(count)} {incr i} {
+ $w.ed.box insert end $var($i,item)
+ }
+ $w.ed.box selection set 0
+
+ bind $w <Double-1> {set ed(ok) 1}
+ bind $w <Return> {set ed(ok) 1}
+
+ bind $w <Up> "SLBArrow $ed(listbox) -1"
+ bind $w <Down> "SLBArrow $ed(listbox) 1"
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+
+ if {$ed(ok)} {
+ set i [expr [$ed(listbox) curselection]+1]
+ if {$i > 0 && $i <= $var(count)} {
+ set var(item) $var($i,item)
+ set var(value) $var($i,value)
+ }
+ }
+
+ DialogDismiss $w
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc SLBArrow {lb dir} {
+ set which [$lb curselection]
+ if {$which == {}} {
+ set which 0
+ }
+ set end [$lb index end]
+
+ $lb selection clear 0 end
+ incr which $dir
+ if {$which < 0} {
+ set which 0
+ }
+ if {$which >= $end} {
+ set which [expr $end -1]
+ }
+ $lb selection set $which
+}
+
+# Entry Dialog
+
+proc EntryDialog {title message size varname} {
+ upvar $varname var
+ global ds9
+ global ed
+
+ set w {.entry}
+ set mb {.entrymb}
+
+ set ed(top) $w
+ set ed(ok) 0
+ set ed(text) $var
+
+ DialogCreate $w $title ed(ok)
+
+ $w configure -menu $mb
+ menu $mb
+
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+ EditMenu $mb ed
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.title -text $message
+ ttk::entry $f.txt -textvariable ed(text) -width $size
+ if {$size < 30} {
+ grid $f.title $f.txt -padx 2 -pady 2
+ } else {
+ grid $f.title -padx 2 -pady 2 -sticky w
+ grid $f.txt -padx 2 -pady 2
+ }
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ $w.param.txt select range 0 end
+ DialogWait $w ed(ok) $w.param.txt
+
+ if {$ed(ok)} {
+ set var $ed(text)
+ }
+
+ DialogDismiss $w
+ destroy $mb
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+# Entry Cut/Copy/Paste
+
+proc EntryCut {top} {
+ set w [focus -displayof $top]
+
+ if {![catch {set data [string range [$w get] [$w index sel.first] [expr {[$w index sel.last] - 1}]]}]} {
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
+ $w delete sel.first sel.last
+ }
+}
+
+proc EntryCopy {top} {
+ set w [focus -displayof $top]
+
+ if {![catch {set data [string range [$w get] [$w index sel.first] [expr {[$w index sel.last] - 1}]]}]} {
+ clipboard clear -displayof $w
+ clipboard append -displayof $w $data
+ }
+}
+
+proc EntryPaste {top} {
+ set w [focus -displayof $top]
+
+ catch {$w delete sel.first sel.last}
+ if {![catch {$w insert insert [GetSelection $w]}]} {
+ tk::EntrySeeInsert $w
+ }
+}
+
+proc GetSelection {w} {
+ if {
+ ![catch {selection get -displayof $w -type UTF8_STRING} txt] ||
+ ![catch {selection get -displayof $w} txt] ||
+ ![catch {selection get -displayof $w -selection CLIPBOARD} txt]
+ } {
+ return $txt
+ }
+}
+
+# Simple Text Dialog
+
+proc SimpleTextDef {} {
+ global istxt
+
+ set istxt(dialogs) {}
+}
+
+proc SimpleTextDialog {varname title width height action pos txt
+ {destroyCB {}} {destroyParam {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global istxt
+ global ds9
+ global pds9
+
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ } else {
+ # create window
+ Toplevel $var(top) $var(mb) 7 $title "SimpleTextDestroy $varname"
+
+ lappend istxt(dialogs) $varname
+
+ set var(search) {}
+ set var(destroyCB) $destroyCB
+ set var(destroyParam) $destroyParam
+ set var(font) $pds9(text,font)
+ set var(font,size) $pds9(text,font,size)
+ set var(font,weight) $pds9(text,font,weight)
+ set var(font,slant) $pds9(text,font,slant)
+
+ $var(mb) add cascade -label [msgcat::mc {File}] -menu $var(mb).file
+ menu $var(mb).file
+ $var(mb).file add command -label "[msgcat::mc {Save}]..." \
+ -command "SimpleTextSave $varname"
+ switch $ds9(wm) {
+ x11 -
+ aqua -
+ win32 {
+ $var(mb).file add separator
+ $var(mb).file add command -label "[msgcat::mc {Print}]..." \
+ -command "SimpleTextPrint $varname"
+ }
+ }
+ $var(mb).file add separator
+ $var(mb).file add command -label [msgcat::mc {Close}] \
+ -command "SimpleTextDestroy $varname"
+
+ $var(mb) add cascade -label [msgcat::mc {Edit}] -menu $var(mb).edit
+ menu $var(mb).edit
+ $var(mb).edit add command -label [msgcat::mc {Cut}] \
+ -command "SimpleTextCut $varname" -accelerator "${ds9(ctrl)}X"
+ $var(mb).edit add command -label [msgcat::mc {Copy}] \
+ -command "SimpleTextCopy $varname" -accelerator "${ds9(ctrl)}C"
+ $var(mb).edit add command -label [msgcat::mc {Paste}] \
+ -state disabled -accelerator "${ds9(ctrl)}V"
+ $var(mb).edit add command -label [msgcat::mc {Clear}] \
+ -command "SimpleTextClear $varname"
+ $var(mb).edit add separator
+ $var(mb).edit add command -label [msgcat::mc {Select All}] \
+ -command "SimpleTextSelectAll $varname"
+ $var(mb).edit add command -label [msgcat::mc {Select None}] \
+ -command "SimpleTextSelectNone $varname"
+ $var(mb).edit add separator
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $var(mb).edit add command -label "[msgcat::mc {Find}]..." \
+ -command "SimpleTextFind $varname" \
+ -accelerator "${ds9(ctrl)}F"
+ }
+ aqua {
+ # Known bug in Tk, can't have dialogs invoked by accelerator
+ $var(mb).edit add command -label "[msgcat::mc {Find}]..." \
+ -command "SimpleTextFind $varname"
+ }
+ }
+ $var(mb).edit add command -label [msgcat::mc {Find Next}] \
+ -command "SimpleTextFindNext $varname" -accelerator "${ds9(ctrl)}G"
+
+ $var(mb) add cascade -label [msgcat::mc {Font}] -menu $var(mb).font
+ FontMenu $var(mb).font $varname font font,size font,weight font,slant \
+ [list SimpleTextFont $varname]
+
+ # create the text and scroll widgets
+
+ set var(text) [text $var(top).text -height $height -width $width \
+ -wrap none \
+ -yscrollcommand [list $var(top).yscroll set] \
+ -xscrollcommand [list $var(top).xscroll set] \
+ ]
+
+ ttk::scrollbar $var(top).yscroll -command [list $var(text) yview] \
+ -orient vertical
+ ttk::scrollbar $var(top).xscroll -command [list $var(text) xview] \
+ -orient horizontal
+
+ grid $var(text) $var(top).yscroll -sticky news
+ grid $var(top).xscroll -stick news
+ grid rowconfigure $var(top) 0 -weight 1
+ grid columnconfigure $var(top) 0 -weight 1
+
+ # Bindings
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ bind $var(top) <<Find>> [list SimpleTextFind $varname]
+ }
+ aqua {
+ # Known bug in Tk, can't have dialogs invoked by accelerator
+ }
+ }
+ bind $var(top) <<FindNext>> [list SimpleTextFindNext $varname]
+
+ # some window managers need a hint
+ raise $var(top)
+ }
+
+ $var(text) configure -state normal
+ if {$action != {append}} {
+ $var(text) delete 1.0 end
+ }
+ $var(text) insert end "$txt"
+ switch -- $pos {
+ top {$var(text) see 1.0}
+ bottom {$var(text) see end}
+ }
+
+ SimpleTextFont $varname
+}
+
+proc SimpleTextDestroy {varname} {
+ global istxt
+
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(destroyCB) != {}} {
+ eval $var(destroyCB) $var(destroyParam)
+ }
+
+ if {[winfo exists $var(top)]} {
+ destroy $var(top)
+ destroy $var(mb)
+ }
+
+ set ii [lsearch $istxt(dialogs) $varname]
+ if {$ii>=0} {
+ set istxt(dialogs) [lreplace $istxt(dialogs) $ii $ii]
+ }
+
+ unset $varname
+}
+
+proc SimpleTextFont {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ $var(text) configure -font \
+ "{$ds9($var(font))} $var(font,size) $var(font,weight) $var(font,slant)"
+}
+
+proc SimpleTextUpdateFont {} {
+ global istxt
+ global pds9
+
+ foreach varname $istxt(dialogs) {
+ upvar #0 $varname var
+ global $varname
+
+ set var(font) $pds9(text,font)
+ set var(font,size) $pds9(text,font,size)
+ set var(font,weight) $pds9(text,font,weight)
+ set var(font,slant) $pds9(text,font,slant)
+
+ SimpleTextFont $varname
+ }
+}
+
+proc SimpleTextCut {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ tk_textCut $var(text)
+}
+
+proc SimpleTextCopy {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ tk_textCopy $var(text)
+}
+
+proc SimpleTextClear {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(text) configure -state normal
+ $var(text) delete 1.0 end
+ $var(text) configure -state disabled
+}
+
+proc SimpleTextSelectAll {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(text) tag add sel 1.0 end
+}
+
+proc SimpleTextSelectNone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(text) tag remove sel 1.0 end
+}
+
+proc SimpleTextFind {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(text) tag remove sel 1.0 end
+ set result "$var(search)"
+ if {[EntryDialog [msgcat::mc {Search}] [msgcat::mc {Enter Search Expression}] 40 result]} {
+ set var(search) "$result"
+ set start [$var(text) search -nocase -count cnt \
+ -regexp -- $result 1.0 end]
+ if {$start != {}} {
+ $var(text) tag add sel $start "$start + $cnt chars"
+ $var(text) see $start
+ } else {
+ Error "$var(search) [msgcat::mc {Not Found}]"
+ }
+ }
+}
+
+proc SimpleTextFindNext {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(search) != {}} {
+ if {[$var(text) tag ranges sel] != {}} {
+ set ss {sel.last}
+ } else {
+ set ss {1.0}
+ }
+
+ set start [$var(text) search -nocase -count cnt \
+ -regexp -- $var(search) $ss end]
+ if {$start != {}} {
+ $var(text) tag remove sel 1.0 end
+ $var(text) tag add sel $start "$start + $cnt chars"
+ $var(text) see $start
+ } else {
+ # wrap
+ set start [$var(text) search -nocase -count cnt \
+ -regexp -- $var(search) 1.0 end]
+ if {$start != {}} {
+ $var(text) tag remove sel 1.0 end
+ $var(text) tag add sel $start "$start + $cnt chars"
+ $var(text) see $start
+ } else {
+ Error "$var(search) [msgcat::mc {Not Found}]"
+ }
+ }
+ }
+}
+
+proc SimpleTextPrint {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ aqua -
+ win32 {SimpleTextPSPrint $varname}
+ wwin32 {win32 pm print text [$var(text) get 1.0 end]}
+ }
+}
+
+proc SimpleTextPSPrint {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[PRPrintDialog]} {
+ if {[catch {SimpleTextPostScript $varname} printError]} {
+ Error "[msgcat::mc {An error has occurred while printing}] $printError"
+ }
+ }
+}
+
+proc SimpleTextPostScript {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ps
+
+ if {$ps(dest) == "file"} {
+ set ch [open "| cat > $ps(filename,txt)" w]
+ } else {
+ set ch [open "| $ps(cmd)" w]
+ }
+
+ puts -nonewline $ch [$var(text) get 1.0 end]
+ close $ch
+}
+
+proc SimpleTextPageSetup {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ aqua -
+ win32 {}
+ wwin32 {win32 pm pagesetup}
+ }
+}
+
+proc SimpleTextSave {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set filename [SaveFileDialog textfbox]
+ if {$filename != {}} {
+ if {[catch {set ch [open "| cat > \"$filename\"" w]}]} {
+ Error [msgcat::mc {An error has occurred while saving}]
+ return
+ }
+ puts -nonewline $ch [$var(text) get 1.0 end]
+ close $ch
+ }
+}
+
diff --git a/ds9/library/ds9.tcl b/ds9/library/ds9.tcl
new file mode 100755
index 0000000..f1405df
--- /dev/null
+++ b/ds9/library/ds9.tcl
@@ -0,0 +1,603 @@
+# Copyright (C) 1999-2016
+# Smithsonian Astrophysical Observatory, Cambridge, MA, USA
+# For conditions of distribution and use, see copyright notice in "copyright"
+
+proc DS9Def {} {
+ global ds9
+ global pds9
+
+ set ds9(title) "$ds9(app)"
+ # for beta version, MUST have space
+ set ds9(version) {7.5 rc2}
+
+ set ds9(top) .
+ set ds9(mb) .mb
+
+ set ds9(visual) {}
+ set ds9(depth) 8
+ set ds9(FTY_MAXAXES) 10
+ set ds9(threads) [GetNumCores]
+
+ set ds9(helvetica) [font configure TkDefaultFont -family]
+ set ds9(courier) [font configure TkFixedFont -family]
+ switch $ds9(wm) {
+ x11 {
+ set ds9(times) serif
+
+ # These look better if normal weight
+ font configure TkCaptionFont -weight normal
+ font configure TkHeadingFont -weight normal
+ }
+ aqua {set ds9(times) times}
+ win32 {set ds9(times) times}
+ }
+
+ set ds9(main) {}
+ set ds9(image) {}
+ set ds9(canvas) {}
+ set ds9(panel) {}
+ set ds9(info) {}
+ set ds9(panner) {}
+ set ds9(magnifier) {}
+ set ds9(buttons) {}
+ set ds9(graph,sp) {}
+ set ds9(graph,horz) {}
+ set ds9(graph,vert) {}
+
+ set ds9(frames) {}
+ set ds9(active) {}
+ set ds9(active,num) 0
+ set ds9(lock) 0
+ set ds9(next) {}
+ set ds9(next,num) 1
+ set ds9(last) {}
+
+ set ds9(event,opendoc) {}
+ set ds9(event,printdoc) {}
+
+ set ds9(tmpdir) {}
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {set ds9(menu,start) 1}
+ aqua {set ds9(menu,start) 0}
+ }
+ set ds9(menu,size,frame,goto) [expr $ds9(menu,start)+0]
+ set ds9(menu,size,frame,active) [expr $ds9(menu,start)+3]
+ set ds9(menu,size,analysis) [expr $ds9(menu,start)+35]
+ set ds9(menu,size,wrap) 20
+
+ set ds9(display) single
+ set ds9(bg) white
+
+ set ds9(array,x) 512
+ set ds9(array,y) 512
+ set ds9(array,bitpix) -32
+ set ds9(array,skip) 0
+ set ds9(array,arch) bigendian
+
+ set ds9(row) -1
+ set ds9(freeze) 0
+
+ set ds9(b1) 0
+ set ds9(b2) 0
+ set ds9(b3) 0
+
+ set ds9(sb1) 0
+ set ds9(sb2) 0
+ set ds9(sb3) 0
+
+ set ds9(cb1) 0
+ set ds9(cb2) 0
+ set ds9(cb3) 0
+
+ set ds9(csb1) 0
+ set ds9(csb2) 0
+ set ds9(csb3) 0
+
+ set ds9(modifier) 0
+
+ set ds9(ext,file) ".$ds9(app).fil"
+ set ds9(ext,alt) ".$ds9(app).file"
+
+ set ds9(msg) {}
+ set ds9(msg,level) info
+ set ds9(msg,src) {}
+ set ds9(msg,timeout) 1000
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ set ds9(ctrl) "Control-"
+ set ds9(shiftctrl) "Shift-Control-"
+ }
+ aqua {
+ set ds9(ctrl) "Command-"
+ set ds9(shiftctrl) "Shift-Command-"
+ }
+ }
+
+ # prefs only
+ InitDefaultFont
+ InitDefaultTextFont
+
+ set pds9(backup) 1
+ set pds9(automarker) 1
+ set pds9(xpa) 1
+ set pds9(samp) 1
+ set pds9(confirm) 1
+ set pds9(bg) white
+ set pds9(nan) white
+ set pds9(iraf) 1
+ switch $ds9(wm) {
+ x11 {set pds9(dialog) motif}
+ aqua -
+ win32 {set pds9(dialog) native}
+ }
+ set pds9(dialog,center) 0
+ set pds9(dialog,all) 0
+ set pds9(language) locale
+ set pds9(language,name) [LanguageToName $pds9(language)]
+ set pds9(language,dir) {}
+}
+
+# if we have a problem at this point, dump simple message and exit
+if {[catch {tk windowingsystem} ds9(wm)]} {
+ puts stderr "Unable to initialize window system."
+ exit
+}
+
+# who are we?
+set ds9(app) [file tail [info nameofexecutable]]
+
+# Themes are now hardcoded
+switch $ds9(wm) {
+ x11 {
+ # set bg for non ttk widgets
+ set bg [ttk::style lookup "." -background]
+
+ # standard widgets
+ option add {*Text.Background} $bg
+ option add {*Listbox.Background} $bg
+ option add {*PlotBackground} $bg
+
+ # ttk widgets
+ ttk::style configure TLabel -borderwidth 2 -padding 1
+ ttk::style configure TEntry -fieldbackground $bg -padding 1
+ }
+ aqua {
+ # set bg for non ttk widgets
+ set bg [ttk::style lookup "." -background]
+
+ # standard widgets
+ option add {*PlotBackground} $bg
+ }
+ win32 {ttk::style theme use xpnative}
+}
+
+switch $ds9(wm) {
+ x11 {
+ # set to absolute path so that if -cd command is used,
+ # so we can still find our files
+ set ds9(root) [file normalize [file join [pwd] zvfsmntpt]]
+
+ if {![namespace exists msgcat]} {
+ source $ds9(root)/tcl8/8.5/msgcat-1.5.2.tm
+ }
+ if {![namespace exists http]} {
+ source $ds9(root)/tcl8/8.6/http-2.8.9.tm
+ source $ds9(root)/library/htp.tcl
+ }
+
+ source $ds9(root)/tk8.6/tearoff.tcl
+ source $ds9(root)/tk8.6/comdlg.tcl
+ source $ds9(root)/tk8.6/focus.tcl
+ source $ds9(root)/tk8.6/mkpsenc.tcl
+ source $ds9(root)/tk8.6/msgbox.tcl
+ source $ds9(root)/tk8.6/optMenu.tcl
+ source $ds9(root)/tk8.6/unsupported.tcl
+
+ source $ds9(root)/tcllib/base64/base64.tcl
+ source $ds9(root)/tcllib/log/log.tcl
+ source $ds9(root)/tcllib/ftp/ftp.tcl
+ source $ds9(root)/tcllib/textutil/repeat.tcl
+ source $ds9(root)/tcllib/textutil/tabify.tcl
+ source $ds9(root)/tcllib/math/fuzzy.tcl
+
+ source $ds9(root)/tkcon/tkcon.tcl
+ source $ds9(root)/tkblt/graph.tcl
+
+ source $ds9(root)/library/source.tcl
+
+ # fix ::tk and msgcat
+ rename ::tk::msgcat::mc {}
+ rename ::tk::msgcat::mcmax {}
+
+ namespace import ::msgcat::mc
+ namespace import ::msgcat::mcmax
+ ::msgcat::mcload [file join $::tk_library msgs]
+
+ # fix ::tk::dialog::file
+ set ::tk::dialog::file::showHiddenVar 0
+ set ::tk::dialog::file::showHiddenBtn 1
+ }
+ aqua {
+ # set to absolute path
+ set ds9(root) [file normalize [file dirname [file dirname $argv0]]]
+ set bb [file dirname [file dirname $ds9(root)]]
+ set auto_path [list $ds9(root) $bb/Tcl.framework/Resources $bb/Tcl.framework/Resources/Scripts $bb/Tk.framework/Resources $bb/Tk.framework/Resources/Scripts $bb/Tk.framework/Resources/Scripts/ttk]
+
+ package require msgcat
+ package require http
+ source $ds9(root)/library/htp.tcl
+
+ package require base64
+ package require log
+ package require ftp
+ package require textutil
+ package require math
+
+ package require tkcon
+ package require Tkblt
+
+ package require DS9
+
+ proc ::tk::mac::ShowPreferences {} {
+ PrefsDialog
+ }
+
+ proc ::tk::mac::ReopenApplication {} {
+ if {[wm state .] eq "withdrawn"} {
+ wm state . normal
+ } else {
+ wm deiconify .
+ }
+ raise .
+ }
+
+ proc ::tk::mac::OpenDocument {args} {
+ global ds9
+
+ set ds9(event,opendoc) $args
+ if {!$ds9(init)} {
+ MacOSXOpenDocEvent 1
+ }
+ }
+
+ proc ::tk::mac::PrintDocument {args} {
+ global ds9
+
+ set ds9(event,printdoc) $args
+ if {!$ds9(init)} {
+ MacOSXPrintDocEvent 0
+ }
+ }
+
+ proc ::tk::mac::Quit {args} {
+ QuitDS9
+ }
+
+ proc ::tk::mac::ShowHelp {args} {
+ HelpRef
+ }
+ }
+ win32 {
+ set ds9(root) [file dirname [file dirname $argv0]]
+ set auto_path [list $ds9(root) $ds9(root)/tcl8.6 $ds9(root)/tk8.6 $ds9(root)/tk8.6/ttk]
+
+ package require msgcat
+ package require http
+ source $ds9(root)/library/htp.tcl
+
+ package require base64
+ package require log
+ package require ftp
+ package require textutil
+ package require math
+
+ package require tkcon
+ package require Tkblt
+
+ package require DS9
+
+ proc checkdns {a b {c {}}} {
+ return 0
+ }
+ }
+}
+
+# Define Variables
+DS9Def
+2MASSDef
+3DDef
+AnalysisDef
+BinDef
+BlinkDef
+BlockDef
+ButtonsDef
+CanvasDef
+CATDef
+CATSymDef
+CATCDSSrchDef
+CentroidDef
+ColorbarDef
+ContourDef
+CoordDef
+CrosshairDef
+CubeDef
+CurrentDef
+CursorDef
+DebugDef
+ESODef
+ExamineDef
+ExportDef
+GraphDef
+GridDef
+GroupDef
+HelpDef
+HTTPDef
+HVDef
+IExamDef
+IISDef
+IMEDef
+MagnifierDef
+MarkerDef
+MaskDef
+MinMaxDef
+MovieDef
+NRESDef
+NVSSDef
+PannerDef
+PanZoomDef
+CropDef
+PixelDef
+PlotDef
+PrefsDef
+PSDef
+RGBDef
+SAMPDef
+SAODef
+SaveDef
+SaveImageDef
+ScaleDef
+SIADef
+SimpleTextDef
+SkyViewDef
+SmoothDef
+STSCIDef
+TemplateDef
+TileDef
+ViewDef
+VLADef
+VLSSDef
+VODef
+WCSDef
+ZScaleDef
+
+# let's start
+set ds9(init) 1
+
+# set up signal trap
+# not supported under windows
+switch $tcl_platform(platform) {
+ unix {signal add SIGINT QuitDS9}
+ windows {}
+}
+
+# environment vars
+# we don't want to see any error messages if xpa is not available
+if { [info exists env(XPA_VERBOSITY)] == 0 } {
+ set env(XPA_VERBOSITY) 0
+}
+# set filter ptype to contained (default is process)
+set env(FILTER_PTYPE) c
+# set filter error proc so it will not kill ds9
+set env(GERROR) 0
+
+# Events
+event add <<Open>> <${ds9(ctrl)}o>
+event add <<Save>> <${ds9(ctrl)}s>
+event add <<PageSetup>> <${ds9(ctrl)}P>
+event add <<Print>> <${ds9(ctrl)}p>
+event add <<SelectAll>> <${ds9(ctrl)}a>
+event add <<Find>> <${ds9(ctrl)}f>
+event add <<FindNext>> <${ds9(ctrl)}g>
+
+# Init Temporary Dir before prefs
+InitTempDir
+
+# Init the filter compiler
+InitFilterCompiler
+
+# Load any preferences here, before we do any real work
+LoadPrefs
+
+# set fonts
+SetDefaultFont false
+SetDefaultTextFont false
+
+switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ ::tk::unsupported::MacWindowStyle style $ds9(top) document "closeBox fullZoom collapseBox resizable"
+ # we need to map the top window so we can get the proper truecolor masks
+ update idletasks
+ }
+}
+
+# We want to withdraw the window til everything is ready to go
+wm withdraw $ds9(top)
+
+wm title $ds9(top) "SAOImage $ds9(title)"
+wm iconname $ds9(top) "SAOImage $ds9(title)"
+wm protocol $ds9(top) WM_DELETE_WINDOW QuitDS9
+
+# we need to set certain variables before anything else
+# such as color, title, language
+ProcessCommandLineFirst
+
+# initialize language
+switch $pds9(language) {
+ locale {
+ switch $ds9(wm) {
+ x11 {
+ foreach ee {LC_MESSAGES LC_ALL LANG} {
+ if {[info exists env($ee)]} {
+ set ll [string tolower [string range $env($ee) 0 1]]
+ if {[SetLanguage $ll]} {
+ break
+ }
+ }
+ }
+ }
+ aqua {
+ foreach ll [MacOSXGetLocale] {
+ if {[SetLanguage $ll]} {
+ break
+ }
+ }
+ }
+ win32 {}
+ }
+ }
+ default {SetLanguage $pds9(language)}
+}
+
+# set the visual
+set ds9(visual) [winfo visual .]
+set ds9(depth) [winfo depth .]
+
+switch $ds9(wm) {
+ x11 {
+ if {$ds9(depth)==15} {
+ set ds9(depth) 16
+ }
+ if {$ds9(depth)==32} {
+ set ds9(depth) 24
+ }
+ }
+ aqua {
+ if {$ds9(depth)==15} {
+ set ds9(depth) 16
+ }
+ }
+ win32 {
+ if {$ds9(depth)==32} {
+ set ds9(depth) 24
+ }
+ }
+}
+
+switch -- $ds9(visual)$ds9(depth) {
+ truecolor8 {}
+ truecolor16 {}
+ truecolor24 {}
+ default {BadVisualError}
+}
+
+# create our main frame
+set ds9(main) [ttk::frame ${ds9(top)}ds9]
+pack $ds9(main) -fill both -expand true
+
+# Create image canvas
+CreateCanvas
+
+# Create Colorbar-- Create this first, so in case of a private colormap,
+# gui colors will be allocated in the new colormap, not the default colormap
+CreateColorbar
+
+# Create other parts of the display
+CreateMenuBar
+CreateInfoPanel
+CreatePanner
+CreateMagnifier
+CreateButtons
+CreateGraphs
+
+# Make sure that the wm knows when to swap in the colormap (if needed)
+wm colormapwindows . "$ds9(main) $ds9(canvas)"
+
+# Initialize the display
+InitColorbar
+InitPanner
+InitDialogBox
+
+# Set our current state of things
+ChangeMode
+
+# force a update, then layout
+update
+ConfigureView
+
+# our first frame
+CreateFrame
+
+# do this last so we don't get an ConfigureView event
+InitCanvas
+
+# ok, ready to show the window
+wm deiconify $ds9(top)
+update
+
+# Init external File Formats
+# we want this before processing the command line
+InitExternalFile
+
+# Init analysis file formats
+InitAnalysisFile
+
+# Configure HTTP
+ConfigHTTP
+
+# SAMP
+InitSAMP
+
+# XPA
+# don't start xpa for windows
+switch $ds9(wm) {
+ x11 -
+ aqua {InitXPA}
+ win32 {}
+}
+
+# and process any command line items
+# we want to see something before any fits files are loaded
+ProcessCommandLine
+
+# Initialize IIS
+# after command line options to set port/fifo/unix...
+catch {IISInit}
+
+# any os events received?
+switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ MacOSXOpenDocEvent 0
+ MacOSXPrintDocEvent 1
+ }
+}
+
+# Load any initalization tcl code
+SourceInitFileDir {.ini}
+
+# do we have the correct prefs file?
+CheckPrefs
+
+# kludge for aqua. We need to trigger the trap to update buttons vars
+switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ set current(display) $current(display)
+ set colorbar(map) $colorbar(map)
+ }
+}
+
+# start error monitor
+after $ds9(msg,timeout) [list ErrorTimer]
+
+# ok, we're done
+set ds9(init) 0
+
diff --git a/ds9/library/ellipse.tcl b/ds9/library/ellipse.tcl
new file mode 100644
index 0000000..de25b7e
--- /dev/null
+++ b/ds9/library/ellipse.tcl
@@ -0,0 +1,126 @@
+# 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 EllipseDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ # procs
+ set var(proc,apply) EllipseApply
+ set var(proc,close) EllipseClose
+ set var(proc,coordCB) EllipseCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisHistogramDialog $varname
+ MarkerAnalysisPlot3dDialog $varname
+
+ # init
+ EllipseEditCB $varname
+ MarkerBaseCenterRotateCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback edit EllipseEditCB $varname
+ $var(frame) marker $var(id) callback rotate \
+ MarkerBaseCenterRotateCB $varname
+
+ set f $var(top).param
+
+ # Radius
+ ttk::label $f.tradius -text Radius
+ ttk::entry $f.radius1 -textvariable ${varname}(radius1) -width 13
+ ttk::entry $f.radius2 -textvariable ${varname}(radius2) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list EllipseEditCB $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid $f.tradius $f.radius1 $f.radius2 $f.uradius -padx 2 -pady 2 -sticky w
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc EllipseClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback edit EllipseEditCB
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc EllipseApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(radius1) != {} &&
+ $var(radius2) !={}} {
+ $var(frame) marker $var(id) ellipse radius \
+ $var(radius1) $var(radius2) $var(dcoord) $var(dformat)
+ }
+
+ MarkerBaseCenterRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc EllipseCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "EllipseCoordCB"
+ }
+
+ MarkerAnalysisStatsSystem $varname
+ MarkerAnalysisPlot3dSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+proc EllipseEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "EllipseEditCB"
+ }
+
+ set r [$var(frame) get marker $var(id) ellipse radius \
+ $var(dcoord) $var(dformat)]
+ set var(radius1) [lindex $r 0]
+ set var(radius2) [lindex $r 1]
+}
diff --git a/ds9/library/ellipseannulus.tcl b/ds9/library/ellipseannulus.tcl
new file mode 100644
index 0000000..b550a86
--- /dev/null
+++ b/ds9/library/ellipseannulus.tcl
@@ -0,0 +1,28 @@
+# 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 EllipseAnnulusDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(which) ellipseannulus
+ set var(proc,apply) MarkerBaseAnnulusRectApply
+ set var(proc,close) MarkerBaseAnnulusRectClose
+ set var(proc,generate) MarkerBaseAnnulusGenerateEllipse
+ set var(proc,coordCB) MarkerBaseAnnulusRectCoordCB
+ set var(proc,editCB) MarkerBaseAnnulusRectEditCB
+ set var(proc,distCB) MarkerBaseAnnulusRectDistCB
+
+ # base
+ MarkerBaseAnnulusRectDialog $varname radius Major Minor
+}
diff --git a/ds9/library/envi.tcl b/ds9/library/envi.tcl
new file mode 100644
index 0000000..a510c51
--- /dev/null
+++ b/ds9/library/envi.tcl
@@ -0,0 +1,96 @@
+# 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 ImportENVIFile {hdr fn} {
+ global loadParam
+
+ set loadParam(file,type) envi
+ set loadParam(file,mode) {}
+ set loadParam(load,type) smmap
+ set loadParam(file,name) $fn
+ set loadParam(file,header) $hdr
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc ExportENVIFile {hdr fn opt} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save envi file "\{$hdr\}" "\{$fn\}" $opt
+}
+
+proc ProcessENVICmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {0} {
+ # not supported
+ } else {
+ set fn [lindex $var $i]
+ set fn2 [lindex $var [expr $i+1]]
+ if {$fn2 == {}} {
+ set fn2 [FindENVIDataFile $fn]
+ }
+ ImportENVIFile $fn $fn2
+ }
+ } else {
+ # comm
+ if {0} {
+ # not supported
+ } else {
+ set fn [lindex $var $i]
+ set fn2 [lindex $var [expr $i+1]]
+ if {$fn2 == {}} {
+ set fn2 [FindENVIDataFile $fn]
+ }
+ ImportENVIFile $fn $fn2
+ }
+ }
+ FinishLoad
+}
+
+proc FindENVIDataFile {fn} {
+ set rn [file rootname $fn]
+ foreach ff {{bil} {bip} {bsq} {raw} {cube}} {
+ set fn2 "$rn.$ff"
+ if {[file exists $fn2]} {
+ return $fn2
+ }
+ }
+ return {}
+}
diff --git a/ds9/library/epanda.tcl b/ds9/library/epanda.tcl
new file mode 100644
index 0000000..93072d0
--- /dev/null
+++ b/ds9/library/epanda.tcl
@@ -0,0 +1,38 @@
+# 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 EpandaDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(which) epanda
+ set var(proc,apply) MarkerBasePandaRectApply
+ set var(proc,close) MarkerBasePandaRectClose
+ set var(proc,generate) EpandaGenerate
+ set var(proc,coordCB) MarkerBasePandaRectCoordCB
+ set var(proc,editCB) MarkerBasePandaRectEditCB
+ set var(proc,distCB) MarkerBasePandaRectDistCB
+
+ # base panda rect dialog
+ MarkerBasePandaRectDialog $varname
+}
+
+# actions
+
+proc EpandaGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseAnnulusGenerateEllipse $varname
+ MarkerBasePandaGenerateAngles $varname
+}
diff --git a/ds9/library/error.tcl b/ds9/library/error.tcl
new file mode 100644
index 0000000..b1f570d
--- /dev/null
+++ b/ds9/library/error.tcl
@@ -0,0 +1,73 @@
+# 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
+
+# capture general errors
+# this only captures gui errors, not xpa errors
+proc bgerror {err} {
+ tk_messageBox -type ok -icon error \
+ -message "[msgcat::mc {An internal error has been detected}] $err"
+}
+
+# force capture xpa/samp/hv/interactive errors
+proc InitError {which} {
+ global ds9
+ set ds9(msg) {}
+ set ds9(msg,level) info
+ set ds9(msg,src) $which
+
+ global errorInfo
+ set errorInfo {}
+}
+
+proc Info {message} {
+ ProcessMessage info $message
+}
+
+proc Warning {message} {
+ ProcessMessage warning $message
+}
+
+# used by backup
+proc Error {message} {
+ ProcessMessage error $message
+}
+
+proc ProcessMessage {level message} {
+ global ds9
+ global pds9
+
+ set ds9(msg,level) $level
+ switch -- $ds9(msg,src) {
+ xpa -
+ hv -
+ samp {set ds9(msg) $message}
+ default {
+ if {$pds9(confirm)} {
+ tk_messageBox -message $message -type ok -icon $level
+ }
+ }
+ }
+}
+
+# here is where errors from within the canvas widgets
+# will try to get our attention.
+# XPA, HV, and SAMP will have already seen any problems
+proc ErrorTimer {} {
+ global ds9
+ global pds9
+
+ if {$ds9(msg) != {}} {
+ if {$pds9(confirm)} {
+ tk_messageBox -message $ds9(msg) -type ok -icon $ds9(msg,level)
+ }
+ InitError tcl
+ }
+
+ # set again
+ after $ds9(msg,timeout) ErrorTimer
+}
+
+
diff --git a/ds9/library/eso.tcl b/ds9/library/eso.tcl
new file mode 100644
index 0000000..8b314bf
--- /dev/null
+++ b/ds9/library/eso.tcl
@@ -0,0 +1,170 @@
+# 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 ESODef {} {
+ global eso
+ global ieso
+
+ set ieso(top) .eso
+ set ieso(mb) .esomb
+
+ set eso(sky) fk5
+ set eso(rformat) arcmin
+ set eso(width) 15
+ set eso(height) 15
+ set eso(mode) new
+ set eso(save) 0
+ set eso(survey) {DSS1}
+}
+
+proc ESODialog {} {
+ global eso
+ global ieso
+ global wcs
+
+ if {[winfo exists $ieso(top)]} {
+ raise $ieso(top)
+ return
+ }
+
+ set varname deso
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $ieso(top)
+ set var(mb) $ieso(mb)
+ set var(sky) $eso(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $eso(rformat)
+ set var(width) $eso(width)
+ set var(height) $eso(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(survey) $eso(survey)
+ set var(mode) $eso(mode)
+ set var(save) $eso(save)
+
+ set w $var(top)
+ IMGSVRInit $varname "ESO-DSS [msgcat::mc {Server}]" \
+ ESOExec ESOAck ARDone ARError
+
+ $var(mb) add cascade -label Survey -menu $var(mb).survey
+ menu $var(mb).survey
+ # these must be Caps, the server will not accept lower case
+ $var(mb).survey add radiobutton -label {DSS1} \
+ -variable ${varname}(survey) -value DSS1
+ $var(mb).survey add radiobutton -label {DSS2-red} \
+ -variable ${varname}(survey) -value DSS2-red
+ $var(mb).survey add radiobutton -label {DSS2-blue} \
+ -variable ${varname}(survey) -value DSS2-blue
+ $var(mb).survey add radiobutton -label {DSS2-infrared} \
+ -variable ${varname}(survey) -value DSS2-infrared
+
+ IMGSVRUpdate $varname
+}
+
+proc ESOExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set mime "application/x-fits"
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set mime "display/gz-fits"
+ set var(fn) [tmpnam {.fits.gz}]
+ }
+
+ # size - convert to arcmin
+ switch -- $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcmin {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcsec {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ }
+ if {$ww>60} {
+ set ww 60
+ }
+ if {$hh>60} {
+ set hh 60
+ }
+
+ # query
+ set query [http::formatQuery ra $var(x) dec $var(y) equinox J2000 x $ww y $hh mime-type $mime Sky-Survey $var(survey)]
+ # Load image
+ # we can't use -query because eso needs a GET not a POST
+ set var(query) {}
+ set url "http://archive.eso.org/dss/dss?$query"
+ IMGSVRGetURL $varname $url
+}
+
+proc ESOAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the ESO
+
+The Digitized Sky Surveys were produced at the Space Telescope Science
+Institute under U.S. Government grant NAG W-2166. The images of these
+surveys are based on photographic data obtained using the Oschin
+Schmidt Telescope on Palomar Mountain and the UK Schmidt Telescope.
+The plates were processed into the present compressed digital form
+with the permission of these institutions.
+
+The National Geographic Society - Palomar Observatory Sky Atlas
+(POSS-I) was made by the California Institute of Technology with
+grants from the National Geographic Society.
+
+The Second Palomar Observatory Sky Survey (POSS-II) was made by the
+California Institute of Technology with funds from the National
+Science Foundation, the National Geographic Society, the Sloan
+Foundation, the Samuel Oschin Foundation, and the Eastman Kodak
+Corporation.
+
+The Oschin Schmidt Telescope is operated by the California Institute
+of Technology and Palomar Observatory.
+
+The UK Schmidt Telescope was operated by the Royal Observatory
+Edinburgh, with funding from the UK Science and Engineering Research
+Council (later the UK Particle Physics and Astronomy Research Council),
+until 1988 June, and thereafter by the Anglo-Australian
+Observatory. The blue plates of the southern Sky Atlas and its
+Equatorial Extension (together known as the SERC-J), as well as the
+Equatorial Red (ER), and the Second Epoch [red] Survey (SES) were all
+taken with the UK Schmidt.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc ProcessESOCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ ESODialog
+ IMGSVRProcessCmd $varname $iname deso
+}
+
+proc ProcessSendESOCmd {proc id param} {
+ ESODialog
+ IMGSVRProcessSendCmd $proc $id $param deso
+}
diff --git a/ds9/library/examine.tcl b/ds9/library/examine.tcl
new file mode 100644
index 0000000..5cc82dc
--- /dev/null
+++ b/ds9/library/examine.tcl
@@ -0,0 +1,319 @@
+# 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 ExamineDef {} {
+ global pexamine
+
+ # prefs only
+ set pexamine(mode) new
+ set pexamine(zoom) 4
+}
+
+proc ExamineButton {which x y} {
+ if {![$which has fits]} {
+ return
+ }
+
+ switch -- [$which get type] {
+ base {ExamineButtonBase $which $x $y}
+ rgb {ExamineButtonRGB $which $x $y}
+ 3d {ExamineButton3D $which $x $y}
+ }
+}
+
+proc ExamineButtonBase {which x y} {
+ global current
+ global ds9
+ global pexamine
+
+ # this code will not handle mosaics.
+
+ # current coord
+ set coord [$which get coordinates $x $y physical]
+
+ # find filename/slice
+ set fn [$which get fits file name full canvas $x $y]
+ for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
+ set slice($ii) [$which get fits slice $ii]
+ }
+
+ # so the new frame will have all of the parent frame when created
+ set ds9(next) $which
+ GotoFrame
+
+ # create frame if needed
+ switch -- $pexamine(mode) {
+ new {CreateFrame}
+ one {
+ if {[info exists pexamine(one)]} {
+ if {$which == $pexamine(one)} {
+ # do nothing, we clicked in the examine frame
+ return
+ }
+ DeleteSingleFrame $pexamine(one)
+ CreateFrame
+ set pexamine(one) $current(frame)
+ } else {
+ CreateFrame
+ set pexamine(one) $current(frame)
+ }
+ }
+ }
+
+ # go to tile mode in case
+ set current(display) tile
+ DisplayMode
+
+ # load data
+ LoadFitsFile $fn {} {}
+
+ RealizeDS9
+
+ # set slice
+ for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
+ $current(frame) update fits slice $ii $slice($ii)
+ }
+
+ # zoom to about
+ if {[$current(frame) has fits bin]} {
+ set bf "[$current(frame) get bin factor]"
+ set bx [expr [lindex $bf 0]/$pexamine(zoom)]
+ set by [expr [lindex $bf 1]/$pexamine(zoom)]
+ $current(frame) bin factor to $bx $by about \
+ [lindex $coord 0] [lindex $coord 1]
+ } else {
+ $current(frame) zoom $pexamine(zoom) $pexamine(zoom) \
+ about physical [lindex $coord 0] [lindex $coord 1]
+ }
+
+ # back to original frame
+ set ds9(next) $which
+ GotoFrame
+
+ # update any dialogs
+ UpdateDS9
+}
+
+proc ExamineButtonRGB {which x y} {
+ global current
+ global ds9
+ global pexamine
+
+ # this code is far from perfect. It assumes data is loaded into the red
+ # and it is the keychannel. Furthermore, it assumes either images or bin
+ # tables are loaded into each channel, but not both.
+ # this code will not handle mosaics.
+
+ # save current channel
+ set channel [$which get rgb channel]
+
+ # current coord
+ $which rgb channel red
+ set coord [$which get coordinates $x $y physical]
+
+ # find filename/slice
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ set fn($cc) [$which get fits file name full canvas $x $y]
+
+ for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
+ set slice($cc,$ii) [$which get fits slice $ii]
+ }
+ }
+
+ # so the new frame will have all of the parent frame when created
+ set ds9(next) $which
+ GotoFrame
+
+ # create frame if needed
+ switch -- $pexamine(mode) {
+ new {CreateRGBFrame}
+ one {
+ if {[info exists pexamine(one)]} {
+ if {$which == $pexamine(one)} {
+ # do nothing, we clicked in the examine frame
+ return
+ }
+ DeleteSingleFrame $pexamine(one)
+ CreateRGBFrame
+ set pexamine(one) $current(frame)
+ } else {
+ CreateRGBFrame
+ set pexamine(one) $current(frame)
+ }
+ }
+ }
+
+ # go to tile mode in case
+ set current(display) tile
+ DisplayMode
+
+ # load data
+ foreach cc {red green blue} {
+ $current(frame) rgb channel $cc
+
+ if {$fn($cc) != {}} {
+ LoadFitsFile $fn($cc) {} {}
+ }
+ }
+
+ RealizeDS9
+
+ # set slice
+ foreach cc {red green blue} {
+ $current(frame) rgb channel $cc
+ for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
+ $current(frame) update fits slice $ii $slice($cc,$ii)
+ }
+ }
+
+ # zoom to about
+ $current(frame) rgb channel red
+ if {[$current(frame) has fits bin]} {
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ $current(frame) rgb channel $cc
+
+ set bf "[$current(frame) get bin factor]"
+ set bx [expr [lindex $bf 0]/$pexamine(zoom)]
+ set by [expr [lindex $bf 1]/$pexamine(zoom)]
+ $current(frame) bin factor to $bx $by about \
+ [lindex $coord 0] [lindex $coord 1]
+ }
+ } else {
+ $current(frame) zoom $pexamine(zoom) $pexamine(zoom) \
+ about image [lindex $coord 0] [lindex $coord 1]
+ }
+
+ # set channel
+ $current(frame) rgb channel $channel
+
+ # back to original frame
+ set ds9(next) $which
+ GotoFrame
+ $current(frame) rgb channel $channel
+
+ # update any dialogs
+ UpdateDS9
+}
+
+proc ExamineButton3D {which x y} {
+ global current
+ global ds9
+ global pexamine
+
+ # this code will not handle mosaics.
+
+ # current coord
+ set coord [$which get coordinates $x $y physical]
+
+ # find filename/slice
+ set fn [$which get fits file name full canvas $x $y]
+ for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
+ set slice($ii) [$which get fits slice $ii]
+ }
+
+ # and 3d info
+ set rr [$current(frame) get 3d view]
+ set az [lindex $rr 0]
+ set el [lindex $rr 1]
+ set method [$current(frame) get 3d method]
+
+ # so the new frame will have all of the parent frame when created
+ set ds9(next) $which
+ GotoFrame
+
+ # create frame if needed
+ switch -- $pexamine(mode) {
+ new {Create3DFrame}
+ one {
+ if {[info exists pexamine(one)]} {
+ if {$which == $pexamine(one)} {
+ # do nothing, we clicked in the examine frame
+ return
+ }
+ DeleteSingleFrame $pexamine(one)
+ Create3DFrame
+ set pexamine(one) $current(frame)
+ } else {
+ Create3DFrame
+ set pexamine(one) $current(frame)
+ }
+ }
+ }
+
+ # go to tile mode in case
+ set current(display) tile
+ DisplayMode
+
+ # load data
+ LoadFitsFile $fn {} {}
+
+ RealizeDS9
+
+ # set slice
+ for {set ii 2} {$ii<$ds9(FTY_MAXAXES)} {incr ii} {
+ $current(frame) update fits slice $ii $slice($ii)
+ }
+
+ # zoom to about
+ if {[$current(frame) has fits bin]} {
+ set bf "[$current(frame) get bin factor]"
+ set bx [expr [lindex $bf 0]/$pexamine(zoom)]
+ set by [expr [lindex $bf 1]/$pexamine(zoom)]
+ $current(frame) bin factor to $bx $by about \
+ [lindex $coord 0] [lindex $coord 1]
+ } else {
+ $current(frame) zoom $pexamine(zoom) $pexamine(zoom) \
+ about physical [lindex $coord 0] [lindex $coord 1]
+ }
+
+ # set 3d
+ $current(frame) 3d view $az $el
+ $current(frame) 3d method $method
+
+ # back to original frame
+ set ds9(next) $which
+ GotoFrame
+
+ # update any dialogs
+ UpdateDS9
+}
+
+# Prefs
+
+proc PrefsDialogExamine {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Examine}]
+ lappend dprefs(tabs) [ttk::frame $w.examine]
+
+ # Examine
+ set f [ttk::labelframe $w.examine.mode -text [msgcat::mc {Mode}]]
+
+ ttk::radiobutton $f.new -text [msgcat::mc {New Frame each Time}] \
+ -variable pexamine(mode) -value new
+ ttk::radiobutton $f.one -text [msgcat::mc {Examine Frame}] \
+ -variable pexamine(mode) -value one
+
+ grid $f.new -padx 2 -pady 2 -sticky w
+ grid $f.one -padx 2 -pady 2 -sticky w
+
+ set f [ttk::labelframe $w.examine.mag -text [msgcat::mc {Magnification}]]
+
+ ttk::radiobutton $f.x1 -text {1x} -variable pexamine(zoom) -value 1
+ ttk::radiobutton $f.x2 -text {2x} -variable pexamine(zoom) -value 2
+ ttk::radiobutton $f.x4 -text {4x} -variable pexamine(zoom) -value 4
+ ttk::radiobutton $f.x8 -text {8x} -variable pexamine(zoom) -value 8
+ ttk::radiobutton $f.x16 -text {16x} -variable pexamine(zoom) -value 16
+
+ grid $f.x1 $f.x2 $f.x4 $f.x8 $f.x16 -padx 2 -pady 2 -sticky w
+
+ pack $w.examine.mode $w.examine.mag -side top -fill both -expand true
+}
+
diff --git a/ds9/library/export.tcl b/ds9/library/export.tcl
new file mode 100644
index 0000000..f9b0cc4
--- /dev/null
+++ b/ds9/library/export.tcl
@@ -0,0 +1,398 @@
+# 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 ExportDef {} {
+ global export
+
+ set export(array,endian) native
+ set export(nrrd,endian) native
+ set export(envi,endian) native
+ set export(jpeg,quality) 75
+ set export(tiff,compress) none
+}
+
+proc Export {fn format fn2} {
+ global export
+
+ switch $format {
+ array {ExportArrayFile $fn $export(array,endian)}
+ rgbarray {ExportRGBArrayFile $fn $export(array,endian)}
+ nrrd {ExportNRRDFile $fn $export(nrrd,endian)}
+ envi {ExportENVIFile $fn $fn2 $export(envi,endian)}
+ gif {ExportPhotoFile $fn $format {}}
+ tiff {ExportPhotoFile $fn $format $export(tiff,compress)}
+ jpeg {ExportPhotoFile $fn $format $export(jpeg,quality)}
+ png {ExportPhotoFile $fn $format {}}
+ }
+}
+
+# Process Cmds
+
+proc ProcessExportCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ set format {}
+ set fn [lindex $var $i]
+ set fn2 {}
+ if {$fn == {}} {
+ return
+ }
+
+ switch -- $fn {
+ array -
+ rgbarray -
+ nrrd -
+ envi -
+ gif -
+ tiff -
+ jpeg -
+ png {
+ set format $fn
+ set fn {}
+ incr i
+ }
+ jpg {
+ set format jpeg
+ set fn {}
+ incr i
+ }
+ tif {
+ set format tiff
+ set fn {}
+ incr i
+ }
+ }
+
+ # one last time
+ if {$fn == {}} {
+ set fn [lindex $var $i]
+ if {$fn == {}} {
+ return
+ }
+ }
+
+ if {$format == {}} {
+ set format [ExtToFormat $fn]
+ }
+
+ global export
+ set param [string tolower [lindex $var [expr $i+1]]]
+ switch $format {
+ array -
+ rgbarray {
+ switch $param {
+ native -
+ big -
+ bigendian -
+ little -
+ littleendian {
+ set export(array,endian) $param
+ incr i
+ }
+ }
+ }
+ nrrd {
+ switch $param {
+ native -
+ big -
+ bigendian -
+ little -
+ littleendian {
+ set export(nrrd,endian) $param
+ incr i
+ }
+ }
+ }
+ envi {
+ switch $param {
+ {} {set fn2 "[file rootname $fn].bsq"}
+ native -
+ big -
+ bigendian -
+ little -
+ littleendian {
+ set fn2 "[file rootname $fn].bsq"
+ set export(envi,endian) $param
+ incr i
+ }
+ default {
+ if {[string range $param 0 0] == {-}} {
+ set fn2 "[file rootname $fn].bsq"
+ } else {
+ set fn2 $param
+ incr i
+ set param [string tolower [lindex $var [expr $i+1]]]
+ switch $param {
+ native -
+ big -
+ bigendian -
+ little -
+ littleendian {
+ set export(envi,endian) $param
+ incr i
+ }
+ }
+ }
+ }
+ }
+ }
+ gif {}
+ jpeg {
+ if {$param != {} && [string is integer $param]} {
+ set export(jpeg,quality) $param
+ incr i
+ }
+ }
+ tiff {
+ switch $param {
+ none -
+ jpeg -
+ packbits -
+ deflate {
+ set export(tiff,compress) $param
+ incr i
+ }
+ }
+ }
+ png {}
+ }
+
+ global arrayfbox
+ global rgbarrayfbox
+ global giffbox
+ global jpegfbox
+ global tifffbox
+ global pngfbox
+ global nrrdfbox
+ global envifbox
+ global envi2fbox
+ switch -- $format {
+ array {FileLast arrayfbox $fn}
+ rgbarray {FileLast rgbarrayfbox $fn}
+ nrrd {FileLast nrrdfbox $fn}
+ envi {
+ FileLast envifbox $fn
+ FileLast envi2fbox $fn2
+ }
+ gif {FileLast giffbox $fn}
+ jpeg {FileLast jpegfbox $fn}
+ tiff {FileLast tifffbox $fn}
+ png {FileLast pngfbox $fn}
+ }
+ Export $fn $format $fn2
+}
+
+# Support
+
+proc ExportDialog {format} {
+ global export
+ global arrayfbox
+ global rgbarrayfbox
+ global nrrdfbox
+ global envifbox
+ global envi2fbox
+ global giffbox
+ global jpegfbox
+ global tifffbox
+ global pngfbox
+
+ switch -- $format {
+ array {set fn [SaveFileDialog arrayfbox]}
+ rgbarray {set fn [SaveFileDialog rgbarrayfbox]}
+ nrrd {set fn [SaveFileDialog nrrdfbox]}
+ envi {set fn [SaveFileDialog envifbox]}
+ gif {set fn [SaveFileDialog giffbox]}
+ jpeg {set fn [SaveFileDialog jpegfbox]}
+ tiff {set fn [SaveFileDialog tifffbox]}
+ png {set fn [SaveFileDialog pngfbox]}
+ }
+ set fn2 {}
+
+ if {$fn != {}} {
+ set ok 1
+ switch -- $format {
+ array {set ok [ArrayExportDialog export(array,endian)]}
+ rgbarray {}
+ nrrd {set ok [ArrayExportDialog export(nrrd,endian)]}
+ envi {
+ set fn2 "[file rootname $fn].bsq"
+ SetFileLast envi2 $fn2
+# set fn2 [SaveFileDialog envi2fbox]
+# if {$fn2 == {}} {
+# set ok 0
+# }
+ if {$ok} {
+ set ok [ArrayExportDialog export(envi,endian)]
+ }
+ }
+ gif {}
+ jpeg {set ok [JPEGExportDialog export(jpeg,quality)]}
+ tiff {set ok [TIFFExportDialog export(tiff,compress)]}
+ png {}
+ }
+
+ if {$ok} {
+ Export $fn $format $fn2
+ }
+ }
+}
+
+proc ArrayExportDialog {varname} {
+ upvar $varname var
+ global ed2
+
+ set w {.arr}
+
+ set ed2(ok) 0
+ set ed2(arch) $var
+
+ DialogCreate $w [msgcat::mc {Export Array}] ed2(ok)
+
+ # Arch
+ set f [ttk::labelframe $w.arch -text [msgcat::mc {Architecture}] -padding 2]
+ ttk::radiobutton $f.native -text {Native} -variable ed2(arch) \
+ -value native
+ ttk::radiobutton $f.big -text {Big-Endian} -variable ed2(arch) \
+ -value big
+ ttk::radiobutton $f.little -text {Little-Endian} -variable ed2(arch) \
+ -value little
+ grid $f.native -padx 2 -pady 2 -sticky w
+ grid $f.big -padx 2 -pady 2 -sticky w
+ grid $f.little -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # Fini
+ grid $w.arch -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ set var $ed2(arch)
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
+proc TIFFExportDialog {varname} {
+ upvar $varname var
+ global ed2
+
+ set w {.savetiff}
+
+ set ed2(ok) 0
+ set ed2(compress) $var
+
+ DialogCreate $w {TIFF} ed2(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.title -text [msgcat::mc {Compression}]
+ ttk::radiobutton $f.none -text [msgcat::mc {None}] \
+ -variable ed2(compress) -value none
+ ttk::radiobutton $f.jpeg -text {JPEG} \
+ -variable ed2(compress) -value jpeg
+ ttk::radiobutton $f.packbits -text {Packbits} \
+ -variable ed2(compress) -value packbits
+ ttk::radiobutton $f.deflate -text {Deflate} \
+ -variable ed2(compress) -value deflate
+ grid $f.title -padx 2 -pady 2 -sticky w
+ grid $f.none -padx 2 -pady 2 -sticky w
+ grid $f.jpeg -padx 2 -pady 2 -sticky w
+ grid $f.packbits -padx 2 -pady 2 -sticky w
+ grid $f.deflate -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ set var $ed2(compress)
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
+proc JPEGExportDialog {varname} {
+ upvar $varname var
+ global ed2
+
+ set w {.savejpeg}
+
+ set ed2(ok) 0
+ set ed2(quality) $var
+
+ DialogCreate $w {JPEG} ed2(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ slider $f.squality 0 100 [msgcat::mc {JPEG Quality Factor}] \
+ ed2(quality) {}
+
+ grid $f.squality -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ set var $ed2(quality)
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
diff --git a/ds9/library/external.tcl b/ds9/library/external.tcl
new file mode 100644
index 0000000..49f5dfa
--- /dev/null
+++ b/ds9/library/external.tcl
@@ -0,0 +1,61 @@
+# 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 InitExternalFile {} {
+ global ds9
+
+ if {[file exists "./$ds9(ext,file)"]} {
+ ProcessExternalFile "./$ds9(ext,file)"
+ } elseif {[file exists "./$ds9(ext,alt)"]} {
+ ProcessExternalFile "./$ds9(ext,alt)"
+ } elseif {[file exists "~/$ds9(ext,file)"]} {
+ ProcessExternalFile "~/$ds9(ext,file)"
+ } elseif {[file exists "~/$ds9(ext,alt)"]} {
+ ProcessExternalFile "~/$ds9(ext,alt)"
+ }
+}
+
+proc ProcessExternalFile {fn} {
+ global extFits
+
+ set status 1
+ if {[file exists "$fn"]} {
+ set id [open $fn r]
+ while {[gets $id line] >= 0} {
+ # empty line
+ if {[string length $line] == 0} continue
+ # comments
+ if {[string range $line 0 0] == "\#"} continue
+ # else
+ switch -- $status {
+ 1 {
+ # eat the line
+ set template {}
+ set status 2
+ }
+ 2 {
+ set template "$line"
+ set status 3
+ }
+ 3 {
+ # eat the line
+ set status 4
+ }
+ 4 {
+ if {"$template" != {} && "$line" != {}} {
+ foreach t $template {
+ set extFits($t) "$line"
+ }
+ }
+
+ set status 1
+ }
+ }
+ }
+ close $id
+ }
+}
+
diff --git a/ds9/library/file.tcl b/ds9/library/file.tcl
new file mode 100644
index 0000000..f9acff7
--- /dev/null
+++ b/ds9/library/file.tcl
@@ -0,0 +1,307 @@
+# 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
+
+# backward compatibility
+proc ProcessFileCmd {varname iname sock ch fn} {
+ upvar $varname var
+ upvar $iname i
+
+ set vvar $var
+ set ii $i
+
+ set zero $i
+ set one [expr $i+1]
+ set two [expr $i+2]
+ set three [expr $i+3]
+
+ switch -- [string tolower [lindex $var $zero]] {
+ new {
+ switch -- [string tolower [lindex $var $one]] {
+ slice {ProcessFitsCmd vvar ii $sock $fn}
+ fits {
+ set vvar [lreplace $var $one $one]
+ ProcessFitsCmd vvar ii $sock $fn
+ }
+ sfits {
+ set vvar [lreplace $var $one $one]
+ ProcessSFitsCmd vvar ii $sock $fn
+ }
+
+ rgbimage {
+ set vvar [lreplace $var $one $one]
+ ProcessRGBImageCmd vvar ii $sock $fn
+ }
+ rgbcube {
+ set vvar [lreplace $var $one $one]
+ ProcessRGBCubeCmd vvar ii $sock $fn
+ }
+ srgbcube {
+ set vvar [lreplace $var $one $one]
+ ProcessSRGBCubeCmd vvar ii $sock $fn
+ }
+
+ mecube {
+ set vvar [lreplace $var $one $one]
+ ProcessMECubeCmd vvar ii $sock $fn
+ }
+ memf -
+ multiframe {
+ set vvar [lreplace $var $one $one]
+ ProcessMultiFrameCmd vvar ii $sock $fn
+ }
+
+ mosaicimage {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageCmd vvar ii $sock $fn
+ }
+ mosaicimagewcs {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageWCSCmd vvar ii $sock $fn
+ }
+ mosaicimageiraf {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ }
+ mosaicimagewfpc2 {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ }
+
+ mosaic {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicCmd vvar ii $sock $fn
+ }
+ mosaicwcs {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicWCSCmd vvar ii $sock $fn
+ }
+ mosaiciraf {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ }
+
+ smosaic {
+ set vvar [lreplace $var $one $one]
+ ProcessSMosaicCmd vvar ii $sock $fn
+ }
+ smosaicwcs {
+ set vvar [lreplace $var $one $one]
+ ProcessSMosaicWCSCmd vvar ii $sock $fn
+ }
+ smosaiciraf {
+ set vvar [lreplace $var $one $one]
+ ProcessSMosaicIRAFCmd vvar ii $sock $fn
+ }
+
+ url {
+ set vvar [lreplace $var $one $one]
+ ProcessURLFitsCmd vvar ii
+ }
+
+ array {
+ set vvar [lreplace $var $one $one]
+ ProcessArrayCmd vvar ii $sock $fn
+ }
+ rgbarray {
+ set vvar [lreplace $var $one $one]
+ ProcessRGBArrayCmd vvar ii $sock $fn
+ }
+ photo {
+ set vvar [lreplace $var $one $one]
+ ProcessTIFFCmd vvar ii $ch $fn
+ }
+ default {ProcessFitsCmd vvar ii $sock $fn}
+ }
+ }
+ mask {
+ switch -- [string tolower [lindex $var $one]] {
+ fits {
+ set vvar [lreplace $var $one $one]
+ ProcessFitsCmd vvar ii $sock $fn
+ }
+ sfits {
+ set vvar [lreplace $var $one $one]
+ ProcessSFitsCmd vvar ii $sock $fn
+ }
+ mosaicimage {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageCmd vvar ii $sock $fn
+ }
+ mosaicimagewcs {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageWCSCmd vvar ii $sock $fn
+ }
+ mosaicimageiraf {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ }
+ mosaicimagewfpc2 {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ }
+ mosaic {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicCmd vvar ii $sock $fn
+ }
+ mosaicwcs {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicWCSCmd vvar ii $sock $fn
+ }
+ mosaiciraf {
+ set vvar [lreplace $var $one $one]
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ }
+ smosaic {
+ set vvar [lreplace $var $one $one]
+ ProcessSMosaicCmd vvar ii $sock $fn
+ }
+ smosaicwcs {
+ set vvar [lreplace $var $one $one]
+ ProcessSMosaicWCSCmd vvar ii $sock $fn
+ }
+ smosaiciraf {
+ set vvar [lreplace $var $one $one]
+ ProcessSMosaicIRAFCmd vvar ii $sock $fn
+ }
+ array {
+ set vvar [lreplace $var $one $one]
+ ProcessArrayCmd vvar ii $sock $fn
+ }
+ default {ProcessFitsCmd vvar ii $sock $fn}
+ }
+ }
+ slice {ProcessFitsCmd vvar ii $sock $fn}
+
+ fits {
+ set vvar [lreplace $var $zero $zero]
+ ProcessFitsCmd vvar ii $sock $fn
+ }
+ sfits {
+ set vvar [lreplace $var $zero $zero]
+ ProcessSFitsCmd vvar ii $sock $fn
+ }
+
+ rgbimage {
+ set vvar [lreplace $var $zero $zero]
+ ProcessRGBImageCmd vvar ii $sock $fn
+ }
+ rgbcube {
+ set vvar [lreplace $var $zero $zero]
+ ProcessRGBCubeCmd vvar ii $sock $fn
+ }
+ srgbcube {
+ set vvar [lreplace $var $zero $zero]
+ ProcessSRGBCubeCmd vvar ii $sock $fn
+ }
+
+ mecube {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMECubeCmd vvar ii $sock $fn
+ }
+ memf -
+ multiframe {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMultiFrameCmd vvar ii $sock $fn
+ }
+
+ mosaicimage {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicImageCmd vvar ii $sock $fn
+ }
+ mosaicimagewcs {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicImageWCSCmd vvar ii $sock $fn
+ }
+ mosaicimageiraf {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ }
+ mosaicimagewfpc2 {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ }
+
+ mosaic {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicCmd vvar ii $sock $fn
+ }
+ mosaicwcs {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicWCSCmd vvar ii $sock $fn
+ }
+ mosaiciraf {
+ set vvar [lreplace $var $zero $zero]
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ }
+
+ smosaic {
+ set vvar [lreplace $var $zero $zero]
+ ProcessSMosaicCmd vvar ii $sock $fn
+ }
+ smosaicwcs {
+ set vvar [lreplace $var $zero $zero]
+ ProcessSMosaicWCSCmd vvar ii $sock $fn
+ }
+ smosaiciraf {
+ set vvar [lreplace $var $zero $zero]
+ ProcessSMosaicIRAFCmd vvar ii $sock $fn
+ }
+
+ url {
+ set vvar [lreplace $var $zero $zero]
+ ProcessURLFitsCmd vvar ii
+ }
+
+ array {
+ set vvar [lreplace $var $zero $zero]
+ ProcessArrayCmd vvar ii $sock $fn
+ }
+ rgbarray {
+ set vvar [lreplace $var $zero $zero]
+ ProcessRGBArrayCmd vvar ii $sock $fn
+ }
+ photo {
+ set vvar [lreplace $var $zero $zero]
+ ProcessTIFFCmd vvar ii $ch $fn
+ }
+
+ save {
+ set which image
+ set fn {}
+ switch -- [string tolower [lindex $var $one]] {
+ resample {
+ set which resample
+ switch -- [string tolower [lindex $var $two]] {
+ gz {
+ # ignore
+ set fn [lindex $var $three]
+ }
+ default {set fn [lindex $var $two]}
+ }
+ }
+ gz {
+ # ignore
+ set fn [lindex $var $two]
+ }
+ default {set fn [lindex $var $one]}
+ }
+
+ SaveFitsFile $which $fn
+ }
+
+ default {ProcessFitsCmd vvar ii $sock $fn}
+ }
+}
+
+proc ProcessSendFileCmd {proc id param} {
+ global current
+
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get fits file name full]\n"
+ }
+}
+
+
diff --git a/ds9/library/fits.tcl b/ds9/library/fits.tcl
new file mode 100644
index 0000000..f5f00de
--- /dev/null
+++ b/ds9/library/fits.tcl
@@ -0,0 +1,408 @@
+# 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 LoadFitsFile {fn layer mode} {
+ global loadParam
+ global current
+ global pds9
+ global marker
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+ set loadParam(load,layer) $layer
+
+ ConvertFitsFile
+ # save load type, since ProcessLoad will clear loadParam
+ if {$loadParam(load,type) == "mmapincr"} {
+ set mmap 1
+ } else {
+ set mmap 0
+ }
+ ProcessLoad
+
+ # now autoload markers
+ if {$pds9(automarker) && $mmap} {
+ # now, load fits[REGION] if present
+ set id [string first "\[" $fn]
+ if {$id > 0} {
+ set base [string range $fn 0 [expr $id-1]]
+ } else {
+ set base $fn
+ }
+
+ set reg "${base}\[REGION\]"
+ if {[$current(frame) fitsy has ext "\"$reg\""]} {
+ RealizeDS9
+ catch {
+ $current(frame) marker load fits "\"$reg\"" $marker(color) $marker(dashlist) $marker(width) "\{$marker(font) $marker(font,size) $marker(font,weight) $marker(font,slant)\}"
+ }
+ }
+ }
+}
+
+proc LoadFitsAlloc {path fn layer mode} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc LoadFitsSocket {sock fn layer mode} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc SaveFitsFile {which fn} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits $which file "\{$fn\}"
+}
+
+proc SaveFitsSocket {which sock} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits $which socket $sock
+}
+
+proc ProcessFitsCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ if {[ProcessFitsBackwardCmd $varname $iname $sock $fn]} {
+ return
+ }
+
+ global loadParam
+ global current
+
+ set layer {}
+ set mode {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ set mode slice
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadFitsSocket $sock $param $layer $mode]} {
+ InitError xpa
+ LoadFitsFile $param $layer $mode
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadFitsAlloc $fn $param $layer $mode
+ } else {
+ LoadFitsFile $param $layer $mode
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendFitsCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set which image
+
+ switch -- [string tolower [lindex $param 0]] {
+ width {
+ $proc $id "[$current(frame) get fits width]\n"
+ return
+ }
+ height {
+ $proc $id "[$current(frame) get fits height]\n"
+ return
+ }
+ depth {
+ $proc $id "[$current(frame) get fits depth 2]\n"
+ return
+ }
+ bitpix {
+ $proc $id "[$current(frame) get fits bitpix]\n"
+ return
+ }
+ size {
+ set sys [lindex $param 1]
+ set sky [lindex $param 2]
+ set format [lindex $param 3]
+ if {$sys == {} && $sky == {} && $format == {}} {
+ $proc $id "[$current(frame) get fits size]\n"
+ } else {
+ FixSpec sys sky format image fk5 degrees
+ $proc $id "[$current(frame) get fits size $sys $sky $format]\n"
+ }
+ return
+ }
+ header {
+ switch -- [llength $param] {
+ 1 {ProcessSend $proc $id {} $fn {.txt} "[$current(frame) get fits header 1]\n"}
+ 2 {ProcessSend $proc $id {} $fn {.txt} "[$current(frame) get fits header [lindex $param 1]]\n"}
+ 3 {
+ set key [lindex $param 2]
+ set key [string trim $key \']
+ set key [string trim $key \{]
+ set key [string trim $key \}]
+ $proc $id "[string trim [$current(frame) get fits header keyword \{$key\}]]\n"
+ }
+ 4 {
+ set key [lindex $param 3]
+ set key [string trim $key \']
+ set key [string trim $key \{]
+ set key [string trim $key \}]
+ $proc $id "[string trim [$current(frame) get fits header [lindex $param 1] keyword \{$key\}]]\n"
+ }
+ }
+ return
+ }
+ type {
+ if {[$current(frame) has fits bin]} {
+ $proc $id "table\n"
+ } else {
+ $proc $id "image\n"
+ }
+ return
+ }
+ table {set which table}
+ image {}
+ slice {set which slice}
+ resample {set which resample}
+ }
+
+ if {$sock != {}} {
+ # xpa
+ SaveFitsSocket $which $sock
+ } elseif {$fn != {}} {
+ # comm
+ SaveFitsFile $which $fn
+ $proc $id {} $fn
+ }
+}
+
+# backward compatibility
+proc ProcessFitsBackwardCmd {varname iname sock fn} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ set vvar $var
+ set ii $i
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ switch -- [string tolower [lindex $var [expr $i+1]]] {
+ rgbimage {
+ set vvar [lreplace $var 1 1]
+ ProcessRGBImageCmd vvar ii $sock $fn
+ return 1
+ }
+ rgbcube {
+ set vvar [lreplace $var 1 1]
+ ProcessRGBCubeCmd vvar ii $sock $fn
+ return 1
+ }
+
+ datacube -
+ mecube -
+ medatacube {
+ set vvar [lreplace $var 1 1]
+ ProcessMECubeCmd vvar ii $sock $fn
+ return 1
+ }
+
+ mosaicimage {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimagewcs {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageWCSCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimageiraf {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimagewfpc2 {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ return 1
+ }
+
+ mosaic {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicwcs {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicWCSCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaiciraf {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ return 1
+ }
+ }
+ }
+
+ mask {
+ switch -- [string tolower [lindex $var [expr $i+1]]] {
+ mosaicimage {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimagewcs {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageWCSCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimageiraf {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimagewfpc2 {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ return 1
+ }
+
+ mosaic {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicwcs {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicWCSCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaiciraf {
+ set vvar [lreplace $var 1 1]
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ return 1
+ }
+ }
+ }
+
+ datacube -
+ mecube -
+ medatacube {
+ set vvar [lreplace $var 0 0]
+ ProcessMECubeCmd vvar ii $sock $fn
+ return 1
+ }
+ memf -
+ multiframe {
+ set vvar [lreplace $var 0 0]
+ ProcessMultiFrameCmd vvar ii $sock $fn
+ return 1
+ }
+
+ rgbimage {
+ set vvar [lreplace $var 0 0]
+ ProcessRGBImageCmd vvar ii $sock $fn
+ return 1
+ }
+ rgbcube {
+ set vvar [lreplace $var 0 0]
+ ProcessRGBCubeCmd vvar ii $sock $fn
+ return 1
+ }
+
+ mosaicimage {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicImageCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimagewcs {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicImageWCSCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimageiraf {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicimagewfpc2 {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ return 1
+ }
+
+ mosaic {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaicwcs {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicWCSCmd vvar ii $sock $fn
+ return 1
+ }
+ mosaiciraf {
+ set vvar [lreplace $var 0 0]
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ return 1
+ }
+ }
+
+ return 0
+}
+
diff --git a/ds9/library/frame.tcl b/ds9/library/frame.tcl
new file mode 100644
index 0000000..8c13c87
--- /dev/null
+++ b/ds9/library/frame.tcl
@@ -0,0 +1,2667 @@
+# 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
+
+# Public Procedures
+
+proc CreateFrame {} {
+ CreateNamedFrame base
+}
+
+proc CreateRGBFrame {} {
+ CreateNamedFrame rgb
+ RGBDialog
+}
+
+proc Create3DFrame {} {
+ CreateNamedFrame 3d
+ 3DDialog
+}
+
+proc CreateNamedFrame {type} {
+ global ds9
+
+ # find the first open slot
+ set num $ds9(next,num)
+ while {1} {
+ set which "Frame$num"
+ if {[lsearch $ds9(frames) $which]==-1} {
+ CreateNameNumberFrame $which $type
+ set ds9(next,num) [expr $num+1]
+ return
+ }
+ incr num
+ }
+}
+
+proc CreateGotoFrame {num type} {
+ global ds9
+ global active
+
+ set which "Frame$num"
+ if {[lsearch $ds9(frames) $which]==-1} {
+ CreateNameNumberFrame $which $type
+ set ds9(next,num) [expr $num+1]
+ } else {
+ if {$active($which)==0} {
+ set active($which) 1
+ UpdateActiveFrames
+ }
+ set ds9(next) $which
+ GotoFrame
+ }
+}
+
+# used by backup
+proc CreateNameNumberFrame {which type} {
+ global ds9
+ global pds9
+ global active
+ global current
+ global ipanner
+ global ppanner
+ global imagnifier
+ global pmagnifier
+ global bin
+ global wcs
+ global colorbar
+ global scale
+ global minmax
+ global zscale
+ global marker
+ global pmarker
+ global centroid
+ global panzoom
+ global block
+ global smooth
+ global pthreed
+ global threed
+ global cube
+
+ set ds9(next) $which
+
+ # update frame lists
+ lappend ds9(frames) $ds9(next)
+ lappend ds9(active) $ds9(next)
+ set ds9(active,num) [llength $ds9(active)]
+ set active($ds9(next)) 1
+
+ # and create the frame
+ switch -- $type {
+ base {
+ $ds9(canvas) create frame$ds9(visual)$ds9(depth) \
+ -command $ds9(next)
+ $ds9(next) colormap [colorbar get colormap]
+ }
+ rgb {
+ $ds9(canvas) create framergb$ds9(visual)$ds9(depth) \
+ -command $ds9(next)
+ $ds9(next) colormap [colorbarrgb get colormap]
+ }
+ 3d {
+ $ds9(canvas) create frame3d$ds9(visual)$ds9(depth) \
+ -command $ds9(next)
+ $ds9(next) colormap [colorbar get colormap]
+ }
+ }
+
+ $ds9(next) configure -x 0 -y 0 \
+ -anchor nw \
+ -tag $ds9(next) \
+ -helvetica $ds9(helvetica) \
+ -courier $ds9(courier) \
+ -times $ds9(times)
+
+ $ds9(next) threads $ds9(threads)
+
+ $ds9(next) panner 'panner' $ipanner(size) $ipanner(size)
+ $ds9(next) magnifier 'magnifier' $imagnifier(size) $imagnifier(size)
+ $ds9(next) magnifier zoom $pmagnifier(zoom)
+ $ds9(next) magnifier graphics $pmagnifier(region)
+ $ds9(next) magnifier cursor $pmagnifier(cursor)
+
+ $ds9(next) zoom to $current(zoom)
+ $ds9(next) rotate to $current(rotate)
+ $ds9(next) orient $current(orient)
+ $ds9(next) wcs align $current(align)
+
+ $ds9(next) pan preserve $panzoom(preserve)
+
+ # set so prefs (pwcs) will work
+ # may cause other problems, but can't remember why
+ $ds9(next) wcs $wcs(system) $wcs(sky) $wcs(skyformat)
+
+ $ds9(next) datasec $scale(datasec)
+
+ $ds9(next) bg color $pds9(bg)
+ $ds9(next) nan color $pds9(nan)
+ $ds9(next) iraf align $pds9(iraf)
+
+ $ds9(next) marker epsilon $pmarker(epsilon)
+ $ds9(next) marker show $marker(show)
+ $ds9(next) marker show text $marker(show,text)
+ $ds9(next) marker centroid auto $marker(centroid,auto)
+ $ds9(next) marker centroid radius $marker(centroid,radius)
+ $ds9(next) marker centroid iteration $marker(centroid,iteration)
+ $ds9(next) marker preserve $marker(preserve)
+
+ # Frame type items
+ switch -- [$ds9(next) get type] {
+ base -
+ rgb {}
+ 3d {
+ $ds9(next) 3d method $pthreed(method)
+ $ds9(next) 3d background $pthreed(background)
+ $ds9(next) 3d border $pthreed(border)
+ $ds9(next) 3d border color $pthreed(border,color)
+ $ds9(next) 3d compass $pthreed(compass)
+ $ds9(next) 3d compass color $pthreed(compass,color)
+ $ds9(next) 3d highlite $pthreed(highlite)
+ $ds9(next) 3d highlite color $pthreed(highlite,color)
+ }
+ }
+
+ # channel dependent items
+ switch -- [$ds9(next) get type] {
+ base -
+ 3d {
+ $ds9(next) colorscale $scale(type)
+ $ds9(next) colorscale log $scale(log)
+
+ $ds9(next) clip scope $scale(scope)
+ $ds9(next) clip mode $scale(mode)
+ $ds9(next) clip minmax $minmax(sample) $minmax(mode)
+ $ds9(next) clip user $scale(min) $scale(max)
+ $ds9(next) clip zscale \
+ $zscale(contrast) $zscale(sample) $zscale(line)
+
+ $ds9(next) datasec $scale(datasec)
+
+ $ds9(next) bin function $bin(function)
+ $ds9(next) bin factor to $bin(factor)
+ $ds9(next) bin depth $bin(depth)
+ $ds9(next) bin buffer size $bin(buffersize)
+
+ $ds9(next) block to $block(factor)
+
+ $ds9(next) cube axes $cube(axes)
+
+ if {$smooth(view)} {
+ $ds9(next) smooth $smooth(function) $smooth(radius)
+ }
+ }
+ rgb {
+ foreach c {red green blue} {
+ $ds9(next) rgb channel $c
+
+ $ds9(next) colorscale $scale(type)
+ $ds9(next) colorscale log $scale(log)
+
+ $ds9(next) clip scope $scale(scope)
+ $ds9(next) clip mode $scale(mode)
+ $ds9(next) clip minmax $minmax(sample) $minmax(mode)
+ $ds9(next) clip user $scale(min) $scale(max)
+ $ds9(next) clip zscale \
+ $zscale(contrast) $zscale(sample) $zscale(line)
+
+ $ds9(next) datasec $scale(datasec)
+
+ $ds9(next) bin function $bin(function)
+ $ds9(next) bin factor to $bin(factor)
+ $ds9(next) bin depth $bin(depth)
+ $ds9(next) bin buffer size $bin(buffersize)
+
+ $ds9(next) block to $block(factor)
+
+ $ds9(next) cube axes $cube(axes)
+
+ if {$smooth(view)} {
+ $ds9(next) smooth $smooth(function) $smooth(radius)
+ }
+ }
+ $ds9(next) rgb channel red
+ }
+ }
+
+ switch $current(mode) {
+ crosshair -
+ analysis {
+ $ds9(next) crosshair on
+ }
+ }
+
+ UpdateFrameMenuItems
+ UpdateDS9Static
+
+ if {$current(frame) != {}} {
+ $current(frame) colorbar tag "\{[$current(colorbar) get tag]\}"
+ }
+ set current(frame) $ds9(next)
+ set ds9(next) {}
+ DisplayMode
+}
+
+proc DeleteAllFramesMenu {} {
+ global pds9
+
+ if {$pds9(confirm)} {
+ if {[tk_messageBox -type okcancel -icon question -message [msgcat::mc {Delete All Frames?}]] != {ok}} {
+ return
+ }
+ }
+ DeleteAllFrames
+}
+
+proc DeleteCurrentFrame {} {
+ global current
+
+ if {$current(frame) != {}} {
+ DeleteSingleFrame $current(frame)
+ }
+}
+
+proc DeleteAllFrames {} {
+ global ds9
+
+ foreach ff $ds9(frames) {
+ DeleteFrame $ff
+ }
+
+ set ds9(next,num) 1
+
+ UpdateFrameMenuItems
+ UpdateActiveFrames
+ UpdateDS9Static
+
+ ClearInfoBox
+ PixelTableClearDialog
+ ClearGraphData
+}
+
+proc DeleteSingleFrame {which} {
+ DeleteFrame $which
+
+ UpdateFrameMenuItems
+ UpdateActiveFrames
+ UpdateDS9Static
+
+ PixelTableClearDialog
+ ClearGraphData
+}
+
+proc DeleteFrame {which} {
+ global ds9
+ global active
+ global current
+ global contour
+ global marker
+
+ # clear any loaded images
+ ClearFrame $which
+
+ # contour copy
+ if {$contour(copy) == $which} {
+ set contour(copy) {}
+ }
+ # marker copy
+ if {$marker(copy) == $which} {
+ set marker(copy) {}
+ }
+
+ # delete canvas widget
+ $ds9(canvas) delete $which
+
+ # setup for next frame
+ set ii [lsearch $ds9(active) $which]
+ if {$ii>0} {
+ set ds9(next) [lindex $ds9(active) [expr $ii-1]]
+ set ds9(active) [lreplace $ds9(active) $ii $ii]
+ set ds9(active,num) [llength $ds9(active)]
+ unset active($which)
+ } else {
+ set ds9(next) {}
+ }
+
+ # delete it from the frame list
+ set ii [lsearch $ds9(frames) $which]
+ set ds9(frames) [lreplace $ds9(frames) $ii $ii]
+}
+
+proc UpdateCurrentFrame {} {
+ global current
+
+ UpdateFrame $current(frame)
+}
+
+proc UpdateAllFrame {} {
+ global ds9
+
+ foreach f $ds9(frames) {
+ UpdateFrame $f
+ }
+}
+
+proc UpdateFrame {which} {
+ if {$which != {}} {
+ $which update
+ }
+}
+
+# Event Processing
+
+proc BindEventsFrame {which} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "BindEventsFrame $which"
+ }
+
+ $ds9(canvas) bind $which <Motion> [list MotionFrame $which %x %y]
+ $ds9(canvas) bind $which <Shift-Motion> \
+ [list ShiftMotionFrame $which %x %y]
+ $ds9(canvas) bind $which <Control-Motion> \
+ [list ControlMotionFrame $which %x %y]
+
+ $ds9(canvas) bind $which <Enter> [list EnterFrame $which %x %y]
+ $ds9(canvas) bind $which <Leave> [list LeaveFrame $which]
+
+ $ds9(canvas) bind $which <Button-1> [list Button1Frame $which %x %y]
+ $ds9(canvas) bind $which <Shift-Button-1> \
+ [list ShiftButton1Frame $which %x %y]
+ $ds9(canvas) bind $which <Control-Button-1> \
+ [list ControlButton1Frame $which %x %y]
+ $ds9(canvas) bind $which <Control-Shift-Button-1> \
+ [list ControlShiftButton1Frame $which %x %y]
+ $ds9(canvas) bind $which <B1-Motion> [list Motion1Frame $which %x %y]
+ $ds9(canvas) bind $which <ButtonRelease-1> \
+ [list Release1Frame $which %x %y]
+
+ $ds9(canvas) bind $which <Double-1> [list Double1Frame $which %x %y]
+ $ds9(canvas) bind $which <Double-ButtonRelease-1> \
+ [list DoubleRelease1Frame $which %x %y]
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(canvas) bind $which <Button-2> \
+ [list Button2Frame $which %x %y]
+ $ds9(canvas) bind $which <Shift-Button-2> \
+ [list ShiftButton2Frame $which %x %y]
+ $ds9(canvas) bind $which <B2-Motion> \
+ [list Motion2Frame $which %x %y]
+ $ds9(canvas) bind $which <ButtonRelease-2> \
+ [list Release2Frame $which %x %y]
+ }
+ aqua {
+ # swap button-2 and button-3 on the mighty mouse
+ $ds9(canvas) bind $which <Button-3> \
+ [list Button2Frame $which %x %y]
+ $ds9(canvas) bind $which <Shift-Button-3> \
+ [list ShiftButton2Frame $which %x %y]
+ $ds9(canvas) bind $which <B3-Motion> \
+ [list Motion2Frame $which %x %y]
+ $ds9(canvas) bind $which <ButtonRelease-3> \
+ [list Release2Frame $which %x %y]
+
+ # x11 option key emulation
+ $ds9(canvas) bind $which <Option-Button-1> \
+ [list Button2Frame $which %x %y]
+ $ds9(canvas) bind $which <Option-B1-Motion> \
+ [list Motion2Frame $which %x %y]
+ $ds9(canvas) bind $which <Option-ButtonRelease-1> \
+ [list Release2Frame $which %x %y]
+
+ # x11 command key emulation
+ # we need this to eat the Button-1 events
+ # so it passes to the canvas
+ $ds9(canvas) bind $which <Command-Button-1> {set foo bar}
+ $ds9(canvas) bind $which <Command-B1-Motion> {set foo bar}
+ $ds9(canvas) bind $which <Command-ButtonRelease-1> {set foo bar}
+ }
+ }
+
+ switch $ds9(wm) {
+ x11 {
+ $ds9(canvas) bind $which <Button-4> \
+ [list Button4Frame $which %x %y]
+ $ds9(canvas) bind $which <Button-5> \
+ [list Button5Frame $which %x %y]
+ }
+ aqua -
+ win32 {}
+ }
+
+ BindEventsFrameKey $which
+}
+
+proc BindEventsFrameKey {which} {
+ global ds9
+ global ianalysis
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "BindEventsFrameKey $which"
+ }
+
+ $ds9(canvas) bind $which <Key> [list KeyFrame $which %K %A %x %y]
+ $ds9(canvas) bind $which <KeyRelease> \
+ [list KeyReleaseFrame $which %K %A %x %y]
+
+ for {set i 0} {$i<$ianalysis(bind,count)} {incr i} {
+ $ds9(canvas) bind $which "$ianalysis(bind,$i,item)" \
+ [list AnalysisTask $i bind $which %x %y]
+ }
+}
+
+proc UnBindEventsFrame {which} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "UnBindEventsFrame $which"
+ }
+
+ $ds9(canvas) bind $which <Button-4> {}
+ $ds9(canvas) bind $which <Button-5> {}
+
+ $ds9(canvas) bind $which <Motion> {}
+ $ds9(canvas) bind $which <Shift-Motion> {}
+ $ds9(canvas) bind $which <Control-Motion> {}
+
+ $ds9(canvas) bind $which <Enter> {}
+ $ds9(canvas) bind $which <Leave> {}
+
+ $ds9(canvas) bind $which <Button-1> {}
+ $ds9(canvas) bind $which <Shift-Button-1> {}
+ $ds9(canvas) bind $which <Control-Button-1> {}
+ $ds9(canvas) bind $which <Control-Shift-Button-1> {}
+ $ds9(canvas) bind $which <B1-Motion> {}
+ $ds9(canvas) bind $which <ButtonRelease-1> {}
+
+ $ds9(canvas) bind $which <Double-1> {}
+ $ds9(canvas) bind $which <Double-ButtonRelease-1> {}
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(canvas) bind $which <Button-2> {}
+ $ds9(canvas) bind $which <Shift-Button-2> {}
+ $ds9(canvas) bind $which <B2-Motion> {}
+ $ds9(canvas) bind $which <ButtonRelease-2> {}
+ }
+ aqua {
+ $ds9(canvas) bind $which <Command-Button-1> {}
+ $ds9(canvas) bind $which <Command-B1-Motion> {}
+ $ds9(canvas) bind $which <Command-ButtonRelease-1> {}
+
+ $ds9(canvas) bind $which <Button-3> {}
+ $ds9(canvas) bind $which <Shift-Button-3> {}
+ $ds9(canvas) bind $which <B3-Motion> {}
+ $ds9(canvas) bind $which <ButtonRelease-3> {}
+
+ $ds9(canvas) bind $which <Option-Button-1> {}
+ $ds9(canvas) bind $which <Option-B1-Motion> {}
+ $ds9(canvas) bind $which <Option-ButtonRelease-1> {}
+ }
+ }
+
+ switch $ds9(wm) {
+ x11 {
+ $ds9(canvas) bind $which <Button-4> {}
+ $ds9(canvas) bind $which <Button-5> {}
+ }
+ aqua -
+ win32 {}
+ }
+
+ UnBindEventsFrameKey $which
+}
+
+proc UnBindEventsFrameKey {which} {
+ global ds9
+ global ianalysis
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "UnBindEventsFrameKey $which"
+ }
+
+ $ds9(canvas) bind $which <Key> {}
+ $ds9(canvas) bind $which <KeyRelease> {}
+
+ for {set i 0} {$i<$ianalysis(bind,count)} {incr i} {
+ $ds9(canvas) bind $which "$ianalysis(bind,$i,item)" {}
+ }
+}
+
+proc EnterFrame {which x y} {
+ global ds9
+ global current
+ global view
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "EnterFrame $which"
+ }
+
+ # check to see if this event was generated while processing other events
+ if {$ds9(b1) || $ds9(sb1) || $ds9(cb1) ||
+ $ds9(csb1) || $ds9(b2) || $ds9(b3)} {
+ return
+ }
+
+ $ds9(canvas) focus $which
+
+ switch -- $current(mode) {
+ crosshair -
+ analysis {
+ set coord [$which get crosshair canvas]
+ set x [lindex $coord 0]
+ set y [lindex $coord 1]
+ }
+ none -
+ pointer -
+ region -
+ catalog -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ colorbar -
+ examine -
+ iexam {}
+ }
+
+ EnterInfoBox $which
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateGraphXAxis $which
+ UpdateGraphYAxis $which
+ UpdateMagnifier $which $x $y
+
+ if {$view(magnifier)} {
+ # don't turn on the magnifier until we've finished the init process
+ # this a real problem with 3d frames
+ if {!$ds9(init)} {
+ $which magnifier on
+ }
+ }
+
+ UpdateEditMenu
+}
+
+proc LeaveFrame {which} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "LeaveFrame $which"
+ }
+
+ # check to see if this event was generated while processing other events
+ if {$ds9(b1) || $ds9(sb1) || $ds9(cb1) ||
+ $ds9(csb1) || $ds9(b2) || $ds9(b3)} {
+ return
+ }
+
+ $ds9(canvas) focus {}
+
+ switch -- $current(mode) {
+ crosshair -
+ analysis {}
+
+ none -
+ pointer -
+ region -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ catalog -
+ examine -
+ iexam {
+ LeaveInfoBox
+ PixelTableClearDialog
+ ClearGraphData
+ }
+ }
+
+ $which magnifier off
+ magnifier clear
+}
+
+proc MotionFrame {which x y} {
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "MotionFrame $which"
+ }
+
+ DoMotion $which $x $y sizing fleur
+}
+
+proc ShiftMotionFrame {which x y} {
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ShiftMotionFrame $which"
+ }
+
+ DoMotion $which $x $y exchange fleur
+}
+
+proc ControlMotionFrame {which x y} {
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ControlMotionFrame $which"
+ }
+
+ DoMotion $which $x $y sizing draped_box
+}
+
+proc DoMotion {which x y cursor1 cursor2} {
+ global ds9
+ global current
+
+ # if button 3 is down, ignore this event, we are doing something already
+
+ if {$ds9(b3) || $ds9(b2)} {
+ return
+ }
+
+ switch -- $current(mode) {
+ pointer -
+ region -
+ catalog -
+ analysis {
+ if {$which == $current(frame)} {
+ MarkerCursor $which $x $y $cursor1 $cursor2
+ }
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ }
+ none -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ examine -
+ iexam {
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ }
+ crosshair {}
+ }
+
+ UpdateMagnifier $which $x $y
+}
+
+proc Button1Frame {which x y} {
+ global ds9
+ global current
+ global imarker
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Button1Frame $which"
+ }
+
+ # let others know that the mouse is down
+ set ds9(b1) 1
+
+ switch -- $current(mode) {
+ none {
+ if {$which == $current(frame)} {
+ } else {
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ set ds9(next) $which
+ GotoFrame
+ }
+ UpdateMagnifier $which $x $y
+ }
+ pointer -
+ region {
+ if {$which == $current(frame)} {
+ MarkerButton $which $x $y
+ } else {
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ set ds9(next) $which
+ GotoFrame
+ }
+ UpdateMagnifier $which $x $y
+ }
+ crosshair {
+ CrosshairButton $which $x $y
+
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateMagnifier $which $x $y
+ }
+ colorbar {
+ ColorbarButton3 $x $y
+ }
+ pan {
+ PanButton $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ zoom {
+ ZoomButton $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ rotate {RotateButton $which $x $y}
+ crop {
+ CropButton $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ catalog {
+ if {$which == $current(frame)} {
+ CATButton $which $x $y
+ } else {
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ set ds9(next) $which
+ GotoFrame
+ }
+ UpdateMagnifier $which $x $y
+ }
+ analysis {
+ IMEButton $which $x $y
+
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateMagnifier $which $x $y
+ }
+ examine {ExamineButton $which $x $y}
+ iexam {IExamButton $which $x $y}
+ }
+}
+
+proc ShiftButton1Frame {which x y} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ShiftButton1Frame $which"
+ }
+
+ # let others know that the mouse is down
+ set ds9(sb1) 1
+
+ switch -- $current(mode) {
+ none {}
+ pointer -
+ region {
+ if {$which == $current(frame)} {
+ MarkerShift $which $x $y
+ }
+ UpdateMagnifier $which $x $y
+ }
+ crosshair {}
+ colorbar {}
+ pan {}
+ zoom {ZoomShift $which}
+ rotate -
+ crop {
+ Crop3dButton $which $x $y 0
+ UpdateMagnifier $which $x $y
+ }
+ catalog {
+ if {$which == $current(frame)} {
+ CATShift $which $x $y
+ }
+ UpdateMagnifier $which $x $y
+ }
+ analysis {
+ IMEShift $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ examine -
+ iexam {}
+ }
+}
+
+proc ControlButton1Frame {which x y} {
+ global ds9
+ global current
+ global imarker
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ControlButton1Frame $which"
+ }
+
+ # let others know that the mouse is down
+
+ set ds9(cb1) 1
+
+ switch -- $current(mode) {
+ none {}
+ pointer -
+ region -
+ catalog {
+ if {$which == $current(frame)} {
+ MarkerControl $which $x $y
+ } else {
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+ }
+ UpdateMagnifier $which $x $y
+ }
+ crosshair -
+ colorbar -
+ pan -
+ zoom -
+ rotate {}
+ crop {
+ Crop3dButton $which $x $y 1
+ UpdateMagnifier $which $x $y
+ }
+ analysis {}
+ examine -
+ iexam {}
+ }
+}
+
+proc ControlShiftButton1Frame {which x y} {
+ global ds9
+ global current
+ global imarker
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ControlShiftButton1Frame $which"
+ }
+
+ # let others know that the mouse is down
+
+ set ds9(csb1) 1
+
+ switch -- $current(mode) {
+ none {}
+ pointer -
+ region -
+ catalog {
+ if {$which == $current(frame)} {
+ MarkerControlShift $which $x $y
+ } else {
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+ }
+ UpdateMagnifier $which $x $y
+ }
+ crosshair -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ analysis {}
+ examine -
+ iexam {}
+ }
+}
+
+proc Motion1Frame {which x y} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Motion1Frame $which $x $y $ds9(b1) $ds9(sb1) $ds9(cb1)"
+ }
+
+ # abort if we are here by accident (such as a double click)
+ if {($ds9(b1) == 0) && ($ds9(sb1) == 0) &&
+ ($ds9(cb1) == 0) && ($ds9(csb1) == 0)} {
+ return
+ }
+
+ switch -- $current(mode) {
+ none {UpdateMagnifier $which $x $y}
+ pointer -
+ region {
+ if {$which == $current(frame)} {
+ MarkerMotion $which $x $y
+ }
+
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateMagnifier $which $x $y
+ }
+ crosshair {
+ if {$ds9(b1)} {
+ CrosshairButton $which $x $y
+
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateMagnifier $which $x $y
+ }
+ }
+ colorbar {
+ if {$ds9(b1)} {
+ ColorbarMotion3 $x $y
+ }
+ }
+ pan {
+ if {$ds9(b1)} {
+ PanMotion $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ }
+ zoom {UpdateMagnifier $which $x $y}
+ rotate {
+ if {$ds9(b1)} {
+ RotateMotion $which $x $y
+ }
+ }
+ crop {
+ if {$ds9(b1)} {
+ CropMotion $which $x $y
+ }
+ if {$ds9(sb1)} {
+ Crop3dMotion $which $x $y 0
+ }
+ if {$ds9(cb1)} {
+ Crop3dMotion $which $x $y 1
+ }
+
+ UpdateMagnifier $which $x $y
+ }
+ catalog {
+ if {$which == $current(frame)} {
+ CATMotion $which $x $y
+ }
+
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateMagnifier $which $x $y
+ }
+ analysis {
+ IMEMotion $which $x $y
+
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ UpdateMagnifier $which $x $y
+ }
+ examine -
+ iexam {}
+ }
+}
+
+proc Release1Frame {which x y} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Release1Frame $which"
+ }
+
+ # abort if we are here by accident (such as a double click)
+ if {($ds9(b1) == 0) && ($ds9(sb1) == 0) &&
+ ($ds9(cb1) == 0) && ($ds9(csb1) == 0)} {
+ return
+ }
+
+ switch -- $current(mode) {
+ pointer -
+ region {
+ if {$which == $current(frame)} {
+ MarkerRelease $which $x $y
+ }
+ }
+ crosshair {
+ if {$ds9(b1)} {
+ CrosshairButton $which $x $y
+
+ UpdateColormapLevelMosaic $which $x $y canvas
+ UpdateInfoBox $which $x $y canvas
+ UpdatePixelTableDialog $which $x $y canvas
+ UpdateGraph $which $x $y canvas
+ }
+ }
+ colorbar {
+ if {$ds9(b1)} {
+ ColorbarRelease3 $x $y
+ }
+ }
+ pan {
+ if {$ds9(b1)} {
+ PanRelease $which $x $y
+ }
+ }
+ zoom {}
+ rotate {
+ if {$ds9(b1)} {
+ RotateRelease $which $x $y
+ }
+ }
+ crop {
+ if {$ds9(b1)} {
+ CropRelease $which $x $y
+ }
+ if {$ds9(sb1)} {
+ Crop3dRelease $which $x $y 0
+ }
+ if {$ds9(cb1)} {
+ Crop3dRelease $which $x $y 1
+ }
+ }
+ catalog {
+ if {$which == $current(frame)} {
+ CATRelease $which $x $y
+ }
+ }
+ none {}
+ analysis {
+ IMERelease $which $x $y
+ }
+ examine -
+ iexam {}
+ }
+
+ # let others know that the mouse is up
+ set ds9(b1) 0
+ set ds9(sb1) 0
+ set ds9(cb1) 0
+ set ds9(csb1) 0
+
+ UpdateEditMenu
+ UpdateMagnifier $which $x $y
+}
+
+proc Double1Frame {which x y} {
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Double1Frame $which"
+ }
+
+ switch -- $current(mode) {
+ pointer -
+ region {
+ if {$which == $current(frame)} {
+ MarkerDouble $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ }
+ none -
+ crosshair -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ catalog {}
+ analysis {
+ IMEDouble $which $x $y
+ UpdateMagnifier $which $x $y
+ }
+ examine -
+ iexam {}
+ }
+}
+
+proc DoubleRelease1Frame {which x y} {
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "DoubleRelease1Frame $which"
+ }
+
+ switch -- $current(mode) {
+ none -
+ pointer -
+ region -
+ crosshair -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ catalog -
+ analysis -
+ examine -
+ iexam {}
+ }
+
+ UpdateEditMenu
+ UpdateMagnifier $which $x $y
+}
+
+proc Button2Frame {which x y} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Button2Frame"
+ }
+
+ set ds9(b2) 1
+ PanButton $which $x $y
+}
+
+proc ShiftButton2Frame {which x y} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "ShiftButton2Frame $which"
+ }
+
+ set ds9(sb2) 1
+}
+
+proc Motion2Frame {which x y} {
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Motion2Frame $which"
+ }
+
+ PanMotion $which $x $y
+}
+
+proc Release2Frame {which x y} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Release2Frame $which"
+ }
+
+ PanRelease $which $x $y
+
+ # let others know that the mouse is up
+
+ set ds9(b2) 0
+ set ds9(sb2) 0
+}
+
+proc Button4Frame {which x y} {
+ global ppanzoom
+ global pbin
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Button4Frame $which $x $y"
+ }
+
+ if {[$which has fits bin]} {
+ if {$pbin(wheel)} {
+ set zz $pbin(wheel,factor)
+ BinFrame $which $zz $zz
+ return
+ }
+ }
+
+ if {$ppanzoom(wheel)} {
+ set zz [expr 1./$ppanzoom(wheel,factor)]
+ ZoomFrame $which $zz $zz
+ }
+}
+
+proc Button5Frame {which x y} {
+ global ppanzoom
+ global pbin
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Button5Frame $which $x $y"
+ }
+
+ if {[$which has fits bin]} {
+ if {$pbin(wheel)} {
+ set zz [expr 1./$pbin(wheel,factor)]
+ BinFrame $which $zz $zz
+ return
+ }
+ }
+
+ if {$ppanzoom(wheel)} {
+ set zz $ppanzoom(wheel,factor)
+ ZoomFrame $which $zz $zz
+ }
+}
+
+# used by aqua and win32
+proc MouseWheelFrame {X Y dd} {
+ global ds9
+ global view
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "MouseWheel $X $Y $dd"
+ }
+
+ # macosx returns main window coords in X,Y
+ switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ switch $view(layout) {
+ horizontal {
+ set aa [winfo height $ds9(main)]
+ set bb [winfo height $ds9(image)]
+ set Y [expr $Y-$aa+$bb]
+ }
+ vertical {
+ set aa [winfo width $ds9(main)]
+ set bb [winfo width $ds9(image)]
+ set X [expr $X-$aa+$bb]
+ }
+ }
+
+ }
+ }
+
+ set id [$ds9(canvas) find closest $X $Y]
+ set which [lindex [$ds9(canvas) gettags $id] 0]
+ if {[string equal -length 5 {Frame} $which]} {
+ set orig [$ds9(canvas) coords $which]
+ set x [expr $X-int([lindex $orig 0])]
+ set y [expr $Y-int([lindex $orig 1])]
+
+ if {$dd>0} {
+ Button5Frame $which $x $y
+ } else {
+ Button4Frame $which $x $y
+ }
+ }
+}
+
+proc KeyFrame {which K A xx yy} {
+ global ds9
+ global current
+
+ # MacOSX and Ubuntu returns bogus values in xx,yy
+ # calculate our own values
+ set xx [expr {[winfo pointerx $ds9(canvas)] - [winfo rootx $ds9(canvas)]}]
+ set yy [expr {[winfo pointery $ds9(canvas)] - [winfo rooty $ds9(canvas)]}]
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "KeyFrame $which $K $A $xx $yy"
+ }
+
+ if {$K == {Control_R} ||
+ $K == {Control_L} ||
+ $K == {Meta_R} ||
+ $K == {Meta_L} ||
+ $K == {Alt_R} ||
+ $K == {Alt_L} ||
+ $K == {Super_R} ||
+ $K == {Super_L} ||
+ $K == {??}} {
+ set ds9(modifier) 1
+ return
+ }
+
+ # modal bindings
+ switch -- $current(mode) {
+ none {
+ switch -- $K {
+ c {
+ if {!$ds9(modifier)} {
+ DisplayCoordDialog $which $xx $yy
+ }
+ }
+
+ plus {CubeNext}
+ minus {CubePrev}
+
+ Up -
+ k {$which warp 0 -1}
+ Down -
+ j {$which warp 0 1}
+ Left -
+ h {$which warp -1 0}
+ Right -
+ l {$which warp 1 0}
+ }
+ }
+ pointer -
+ region {
+ switch -- $K {
+ c {
+ if {!$ds9(modifier)} {
+ DisplayCoordDialog $which $xx $yy
+ }
+ }
+
+ plus {CubeNext}
+ minus {CubePrev}
+
+ Delete -
+ BackSpace {MarkerDeleteKey $which $xx $yy}
+
+ Up -
+ k {MarkerArrowKey $which 0 -1}
+ Down -
+ j {MarkerArrowKey $which 0 1}
+ Left -
+ h {MarkerArrowKey $which -1 0}
+ Right -
+ l {MarkerArrowKey $which 1 0}
+
+ i {$which marker property include 1 $xx $yy}
+ e {$which marker property include 0 $xx $yy}
+ s {$which marker property source 1 $xx $yy}
+ b {$which marker property source 0 $xx $yy}
+ g {GroupCreate}
+ G {GroupCreateSilent}
+ }
+ }
+ crosshair {
+ switch -- $K {
+ c {
+ if {!$ds9(modifier)} {
+ DisplayCoordDialog $which $xx $yy
+ }
+ }
+
+ plus {CubeNext}
+ minus {CubePrev}
+
+ Up -
+ k {CrosshairArrowKey $which 0 -1}
+ Down -
+ j {CrosshairArrowKey $which 0 1}
+ Left -
+ h {CrosshairArrowKey $which -1 0}
+ Right -
+ l {CrosshairArrowKey $which 1 0}
+ }
+ }
+ pan {
+ switch -- $K {
+ Up -
+ k {Pan 0 1 canvas}
+ Down -
+ j {Pan 0 -1 canvas}
+ Left -
+ h {Pan 1 0 canvas}
+ Right -
+ l {Pan -1 0 canvas}
+ }
+ UpdateMagnifier $which $xx $yy
+ }
+ catalog {
+ switch -- $K {
+ Up -
+ k {MarkerArrowKey $which 0 -1}
+ Down -
+ j {MarkerArrowKey $which 0 1}
+ Left -
+ h {MarkerArrowKey $which -1 0}
+ Right -
+ l {MarkerArrowKey $which 1 0}
+ }
+ CATKey $which $K
+ }
+ analysis {
+ switch -- $K {
+ plus {CubeNext}
+ minus {CubePrev}
+
+ Up {IMEArrowKey $which 0 -1}
+ Down {IMEArrowKey $which 0 1}
+ Left {IMEArrowKey $which -1 0}
+ Right {IMEArrowKey $which 1 0}
+
+ default {IMEKey $which $K $xx $yy}
+ }
+ }
+ iexam {IExamKey $which $K $xx $yy}
+ colorbar -
+ zoom -
+ rotate -
+ crop -
+ examine {}
+ }
+
+ UpdateEditMenu
+}
+
+proc KeyReleaseFrame {which K A xx yy} {
+ global ds9
+
+ # MacOSX and Ubuntu returns bogus values in xx,yy
+ # calculate our own values
+ set xx [expr {[winfo pointerx $ds9(canvas)] - [winfo rootx $ds9(canvas)]}]
+ set yy [expr {[winfo pointery $ds9(canvas)] - [winfo rooty $ds9(canvas)]}]
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "KeyReleaseFrame $which $K $A $xx $yy"
+ }
+
+ if {$K == {Control_R} ||
+ $K == {Control_L} ||
+ $K == {Meta_R} ||
+ $K == {Meta_L} ||
+ $K == {Alt_R} ||
+ $K == {Alt_L} ||
+ $K == {Super_R} ||
+ $K == {Super_L}} {
+ set ds9(modifier) 0
+ }
+}
+
+# Other Public Routines
+
+proc CopyFrame {} {
+ global current
+
+ switch -- $current(mode) {
+ pointer -
+ region {MarkerCopy}
+ }
+}
+
+proc CutFrame {} {
+ global current
+
+ switch -- $current(mode) {
+ pointer -
+ region {MarkerCut}
+ }
+}
+
+proc PasteFrame {} {
+ global current
+
+ switch -- $current(mode) {
+ pointer -
+ region {MarkerPaste}
+ }
+}
+
+proc UndoFrame {} {
+ global current
+
+ switch -- $current(mode) {
+ pointer -
+ region {MarkerUndo}
+ }
+}
+
+proc FirstFrame {} {
+ global ds9
+ set ds9(next) [lindex $ds9(active) 0]
+ GotoFrame
+}
+
+proc PrevFrame {} {
+ global ds9
+ global current
+
+ set ii [lsearch $ds9(active) $current(frame)]
+ if {$ii>0} {
+ set ds9(next) [lindex $ds9(active) [expr $ii-1]]
+ } else {
+ set ds9(next) [lindex $ds9(active) [expr $ds9(active,num)-1]]
+ }
+ GotoFrame
+}
+
+proc NextFrame {} {
+ global ds9
+ global current
+
+ set ii [lsearch $ds9(active) $current(frame)]
+ if {$ii < [expr $ds9(active,num)-1]} {
+ set ds9(next) [lindex $ds9(active) [expr $ii+1]]
+ } else {
+ set ds9(next) [lindex $ds9(active) 0]
+ }
+ GotoFrame
+}
+
+proc LastFrame {} {
+ global ds9
+
+ set ds9(next) [lindex $ds9(active) [expr $ds9(active,num)-1]]
+ GotoFrame
+}
+
+proc MoveFirstFrame {} {
+ global ds9
+ global current
+
+ set i [lsearch $ds9(frames) $current(frame)]
+ set ds9(frames) [lreplace $ds9(frames) $i $i]
+ set ds9(frames) [linsert $ds9(frames) 0 $current(frame)]
+
+ UpdateFrameMenuItems
+ UpdateActiveFrames
+}
+
+proc MovePrevFrame {} {
+ global ds9
+ global current
+
+ set i [lsearch $ds9(frames) $current(frame)]
+ set ds9(frames) [lreplace $ds9(frames) $i $i]
+ if {$i>0} {
+ set ds9(frames) [linsert $ds9(frames) [expr $i-1] $current(frame)]
+ } else {
+ set ds9(frames) [linsert $ds9(frames) end $current(frame)]
+ }
+
+ UpdateFrameMenuItems
+ UpdateActiveFrames
+}
+
+proc MoveNextFrame {} {
+ global ds9
+ global current
+
+ set i [lsearch $ds9(frames) $current(frame)]
+ set ds9(frames) [lreplace $ds9(frames) $i $i]
+ set last [llength $ds9(frames)]
+ if {$i<$last} {
+ set ds9(frames) [linsert $ds9(frames) [expr $i+1] $current(frame)]
+ } else {
+ set ds9(frames) [linsert $ds9(frames) 0 $current(frame)]
+ }
+
+ UpdateFrameMenuItems
+ UpdateActiveFrames
+}
+
+proc MoveLastFrame {} {
+ global ds9
+ global current
+
+ set i [lsearch $ds9(frames) $current(frame)]
+ set ds9(frames) [lreplace $ds9(frames) $i $i]
+ set ds9(frames) [linsert $ds9(frames) end $current(frame)]
+
+ UpdateFrameMenuItems
+ UpdateActiveFrames
+}
+
+proc UpdateActiveFrames {} {
+ global ds9
+ global active
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateActiveFrames"
+ }
+
+ # reset active list
+ set ds9(active) {}
+ set ds9(active,num) 0
+
+ foreach f $ds9(frames) {
+ if {$active($f)} {
+ lappend ds9(active) $f
+ $ds9(mb).frame.goto entryconfig \
+ "[msgcat::mc {Frame}] [string range $f 5 end]" -state normal
+ } else {
+ $ds9(mb).frame.goto entryconfig \
+ "[msgcat::mc {Frame}] [string range $f 5 end]" -state disabled
+ }
+
+ }
+ set ds9(active,num) [llength $ds9(active)]
+
+ # New layout if needed
+ if {$ds9(active,num) > 0} {
+ if {[lsearch $ds9(active) $current(frame)] == -1} {
+ if {$ds9(next) != {}} {
+ set current(frame) $ds9(next)
+ } else {
+ set current(frame) [lindex $ds9(active) 0]
+ set ds9(next) $current(frame)
+ }
+ }
+ }
+
+ DisplayMode
+}
+
+proc ActiveFrameAll {} {
+ global ds9
+ global active
+
+ foreach f $ds9(frames) {
+ set active($f) 1
+ }
+ UpdateActiveFrames
+}
+
+proc ActiveFrameNone {} {
+ global ds9
+ global active
+
+ foreach f $ds9(frames) {
+ set active($f) 0
+ }
+ UpdateActiveFrames
+}
+
+proc GotoFrame {} {
+ global ds9
+ global current
+ global active
+
+ if {$current(frame) != {} && $current(frame) != $ds9(next)} {
+ $current(frame) highlite off
+ $current(frame) panner off
+
+ switch -- $ds9(display) {
+ blink -
+ single {
+ $current(frame) hide
+ UnBindEventsFrame $current(frame)
+ }
+ tile {}
+ }
+ }
+
+ if {$current(frame) != $ds9(next)} {
+ if {$current(frame) != {}} {
+ $current(frame) colorbar tag "\{[$current(colorbar) get tag]\}"
+ }
+ set current(frame) $ds9(next)
+ set ds9(next) {}
+ FrameToFront
+ }
+}
+
+proc DisplayMode {} {
+ global ds9
+ global current
+ global tile
+ global blink
+ global iblink
+
+ switch -- $current(display) {
+ single {set ds9(display) $current(display)}
+ tile {
+ if {$ds9(active,num) > 1} {
+ set ds9(display) $current(display)
+ } else {
+ switch -- $tile(grid,mode) {
+ automatic {set ds9(display) single}
+ manual {set ds9(display) $current(display)}
+ }
+ }
+ }
+ blink {
+ if {$ds9(active,num) > 1} {
+ set ds9(display) $current(display)
+ } else {
+ set ds9(display) single
+ }
+ }
+ }
+
+ switch -- $ds9(display) {
+ single -
+ tile {
+ # turn off blink if on
+ if {$iblink(id)>0} {
+ after cancel $iblink(id)
+ set iblink(id) 0
+ set iblink(index) -1
+ }
+
+ LayoutFrames
+ }
+ blink {
+ # ignore if we are already blinking
+ if {$iblink(id)==0} {
+ LayoutFrames
+ BlinkTimer
+ }
+ }
+ }
+}
+
+proc BlinkTimer {} {
+ global blink
+ global iblink
+ global ds9
+
+ if {$ds9(active,num) > 0} {
+ incr iblink(index)
+ if {$iblink(index) >= $ds9(active,num)} {
+ set iblink(index) 0
+ }
+ set ds9(next) [lindex $ds9(active) $iblink(index)]
+ GotoFrame
+ }
+
+ set iblink(id) [after $blink(interval) BlinkTimer]
+}
+
+proc ResetCurrentFrame {} {
+ global current
+
+ ResetFrame $current(frame)
+}
+
+proc ResetAllFrame {} {
+ global ds9
+
+ foreach f $ds9(frames) {
+ ResetFrame $f
+ }
+}
+
+proc ResetFrame {which} {
+ if {$which != {}} {
+ if {[$which has iis]} {
+ IISCursorModeCmd 0
+ }
+
+ $which reset
+
+ RefreshInfoBox $which
+ PixelTableClearDialog
+ ClearGraphData
+
+ LockFrame $which
+ UpdatePanZoomDialog
+ UpdateCrosshairDialog
+ UpdateCropDialog
+ GridUpdateZoom
+ UpdateZoomMenu
+ UpdateScaleMenu
+ UpdateScaleDialog
+ UpdateGraphXAxis $which
+ UpdateGraphYAxis $which
+
+ SAMPSendCoordPointAtSkyCmd $which
+ }
+}
+
+proc ClearCurrentFrame {} {
+ global current
+
+ ClearFrame $current(frame)
+
+ ClearInfoBox
+ PixelTableClearDialog
+ ClearGraphData
+
+ UpdateDS9
+}
+
+proc ClearAllFrame {} {
+ global ds9
+
+ foreach f $ds9(frames) {
+ ClearFrame $f
+ }
+
+ ClearInfoBox
+ PixelTableClearDialog
+ ClearGraphData
+
+ UpdateDS9
+}
+
+proc ClearFrame {which} {
+ if {$which == {}} {
+ return
+ }
+
+ DestroyHeader $which
+ $which clear
+
+ # delete saved loadParams
+ foreach cc {{} red green blue} {
+ set varname $which$cc
+ global $varname
+ if {[info exists $varname]} {
+ unset $varname
+ }
+ }
+}
+
+# Private Procedures
+
+proc FrameToFront {} {
+ global ds9
+ global current
+ global view
+ global colorbar
+ global blink
+
+ set which $current(frame)
+
+ # process proper colorbar
+ switch -- [$which get type] {
+ base -
+ 3d {
+ if {$view(colorbar)} {
+ colorbar show
+ } else {
+ colorbar hide
+ }
+ colorbarrgb hide
+ set current(colorbar) colorbar
+
+ colorbar colorbar [$which get colorbar]
+ colorbar tag "\{[$which get colorbar tag]\}"
+ set colorbar(map) [colorbar get name]
+
+ $ds9(canvas) raise colorbar colorbarrgb
+ }
+ rgb {
+ colorbar hide
+ if {$view(colorbar)} {
+ colorbarrgb show
+ } else {
+ colorbarrgb hide
+ }
+ set current(colorbar) colorbarrgb
+
+ colorbarrgb colorbar [$which get colorbar]
+ colorbarrgb rgb channel [$which get rgb channel]
+
+ $ds9(canvas) raise colorbarrgb colorbar
+ }
+ }
+ set colorbar(invert) [$current(colorbar) get invert]
+
+ $ds9(canvas) raise $which
+
+ $which show
+ switch -- $ds9(display) {
+ single -
+ blink {
+ if {!$ds9(freeze)} {
+ BindEventsFrame $which
+ }
+ }
+ tile {$which highlite on}
+ }
+
+ if {$view(panner)} {
+ $which panner on
+ }
+
+ UpdateDS9
+}
+
+proc TileDialog {} {
+ global tile
+ global itile
+ global dtile
+ global ds9
+
+ # see if we already have a window visible
+ if {[winfo exists $itile(top)]} {
+ raise $itile(top)
+ return
+ }
+
+ # create window
+ set w $itile(top)
+ set mb $itile(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Tile Parameters}] TileDestroyDialog
+
+ set dtile(mode) $tile(grid,mode)
+ set dtile(dir) $tile(grid,dir)
+ set dtile(row) $tile(grid,row)
+ set dtile(col) $tile(grid,col)
+ set dtile(gap) $tile(grid,gap)
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command TileApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command TileDestroyDialog
+
+ EditMenu $mb itile
+
+ # Grid
+ set f [ttk::labelframe $w.grid -text [msgcat::mc {Grid}] -padding 2]
+ ttk::radiobutton $f.auto -text [msgcat::mc {Automatic}] \
+ -variable dtile(mode) -value automatic
+ ttk::radiobutton $f.manual -text [msgcat::mc {Manual}] \
+ -variable dtile(mode) -value manual
+ grid $f.auto $f.manual -padx 2 -pady 2 -sticky w
+
+ # Grid Direction
+ set f [ttk::labelframe $w.dir -text [msgcat::mc {Direction}] -padding 2]
+ ttk::radiobutton $f.x -text [msgcat::mc {X}] \
+ -variable dtile(dir) -value x
+ ttk::radiobutton $f.y -text [msgcat::mc {Y}] \
+ -variable dtile(dir) -value y
+ grid $f.x $f.y -padx 2 -pady 2 -sticky w
+
+ # Layout
+ set f [ttk::labelframe $w.layout -text [msgcat::mc {Layout}] -padding 2]
+ ttk::label $f.tcol -text [msgcat::mc {Columns}]
+ ttk::label $f.trow -text [msgcat::mc {Rows}]
+ ttk::entry $f.col -textvariable dtile(col) -width 6
+ ttk::label $f.tx -text {x}
+ ttk::entry $f.row -textvariable dtile(row) -width 6
+ grid $f.tcol x $f.trow -padx 2 -pady 2 -sticky w
+ grid $f.col $f.tx $f.row -padx 2 -pady 2 -sticky w
+
+ # Gap
+ set f [ttk::labelframe $w.gap -text [msgcat::mc {Gap}] -padding 2]
+ ttk::entry $f.gap -textvariable dtile(gap) -width 6
+ ttk::label $f.ugap -text [msgcat::mc {Pixels}]
+ grid $f.gap - $f.ugap -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command TileApplyDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command TileDestroyDialog
+ pack $f.apply $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ grid $w.grid -sticky news
+ grid $w.dir -sticky news
+ grid $w.layout -sticky news
+ grid $w.gap -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid rowconfigure $w 2 -weight 1
+ grid rowconfigure $w 3 -weight 1
+ grid columnconfigure $w 0 -weight 1
+}
+
+proc TileDestroyDialog {} {
+ global itile
+ global dtile
+
+ if {[winfo exists $itile(top)]} {
+ destroy $itile(top)
+ destroy $itile(mb)
+ }
+
+ unset dtile
+}
+
+proc TileApplyDialog {} {
+ global tile
+ global dtile
+
+ set tile(mode) grid
+ set tile(grid,mode) $dtile(mode)
+ set tile(grid,dir) $dtile(dir)
+ set tile(grid,row) $dtile(row)
+ set tile(grid,col) $dtile(col)
+ set tile(grid,gap) $dtile(gap)
+
+ DisplayMode
+}
+
+# Process Cmds
+
+proc ProcessFrameCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+ global active
+ global panzoom
+
+ catch {
+ switch -- [string tolower [lindex $var $i]] {
+ match {
+ incr i
+ MatchFrameCurrent [lindex $var $i]
+ }
+ lock {
+ incr i
+ set panzoom(lock) [lindex $var $i]
+ LockFrameCurrent
+ }
+ center {
+ incr i
+ switch -- [lindex $var $i] {
+ all {CenterAllFrame}
+ {} {CenterCurrentFrame; incr i -1}
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ CenterFrame $f
+ } else {
+ CenterCurrentFrame; incr i -1
+ }
+ }
+ }
+ }
+ clear {
+ incr i
+ switch -- [lindex $var $i] {
+ all {ClearAllFrame}
+ {} {ClearCurrentFrame; incr i -1}
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ ClearFrame $f
+ } else {
+ ClearCurrentFrame; incr i -1
+ }
+ }
+ }
+ }
+ delete {
+ incr i
+ switch -- [lindex $var $i] {
+ all {DeleteAllFrames}
+ {} {DeleteCurrentFrame; incr i -1}
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ DeleteSingleFrame $f
+ } else {
+ DeleteCurrentFrame; incr i -1
+ }
+ }
+ }
+ }
+ new {
+ incr i
+ switch -- [lindex $var $i] {
+ rgb {CreateRGBFrame}
+ 3d {Create3DFrame}
+ default {CreateFrame; incr i -1}
+ }
+ }
+ reset {
+ incr i
+ switch -- [lindex $var $i] {
+ all {ResetAllFrame}
+ {} {ResetCurrentFrame; incr i -1}
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ ResetFrame $f
+ } else {
+ ResetCurrentFrame; incr i -1
+ }
+ }
+ }
+ }
+ refresh {
+ incr i
+ switch -- [lindex $var $i] {
+ all {UpdateAllFrame}
+ {} {UpdateCurrentFrame; incr i -1}
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ UpdateFrame $f
+ } else {
+ UpdateCurrentFrame; incr i -1
+ }
+ }
+ }
+ }
+ hide {
+ incr i
+ switch -- [lindex $var $i] {
+ all {ActiveFrameNone}
+ {} {
+ set active($current(frame)) 0
+ UpdateActiveFrames
+ incr i -1
+ }
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ set active($f) 0
+ UpdateActiveFrames
+ } else {
+ set active($current(frame)) 0
+ UpdateActiveFrames
+ incr i -1
+ }
+ }
+ }
+ }
+ show {
+ incr i
+ switch -- [lindex $var $i] {
+ all {ActiveFrameAll}
+ default {
+ if {[string is integer [lindex $var $i]]} {
+ set f "Frame[lindex $var $i]"
+ set active($f) 1
+ UpdateActiveFrames
+ } else {
+ incr i -1
+ }
+ }
+ }
+ }
+ move {
+ incr i
+ switch -- [lindex $var $i] {
+ first {MoveFirstFrame}
+ back {MovePrevFrame}
+ forward {MoveNextFrame}
+ last {MoveLastFrame}
+ }
+ }
+ first {FirstFrame}
+ prev {PrevFrame}
+ next {NextFrame}
+ last {LastFrame}
+ frameno {incr i; CreateGotoFrame [lindex $var $i] base}
+ default {CreateGotoFrame [lindex $var $i] base}
+ }
+ }
+}
+
+proc ProcessSendFrameCmd {proc id param} {
+ global ds9
+ global current
+ global rgb
+ global panzoom
+
+ switch -- [lindex $param 0] {
+ lock {$proc $id "$panzoom(lock)\n"}
+ active {
+ set r {}
+ foreach f $ds9(active) {
+ append r "[string range $f 5 end] "
+ }
+ $proc $id "$r\n"
+ }
+ all {
+ set r {}
+ foreach f $ds9(frames) {
+ append r "[string range $f 5 end] "
+ }
+ $proc $id "$r\n"
+ }
+ has {
+ if {$current(frame) == {}} {
+ Error [msgcat::mc {No current frame}]
+ return
+ }
+
+ switch [lindex $param 1] {
+ amplifier -
+ datamin -
+ datasec -
+ detector -
+ grid -
+ iis -
+ irafmin -
+ physical -
+ smooth {$proc $id [ToYesNo [$current(frame) has [lindex $param 1]]]}
+ contour {
+ switch [lindex $param 2] {
+ aux {$proc $id [ToYesNo [$current(frame) has contour aux]]}
+ default {$proc $id [ToYesNo [$current(frame) has contour]]}
+ }
+ }
+ fits {
+ switch [lindex $param 2] {
+ bin -
+ cube -
+ mosaic {$proc $id [ToYesNo [$current(frame) has fits [lindex $param 2]]]}
+ default {$proc $id [ToYesNo [$current(frame) has fits]]}
+ }
+ }
+ marker {
+ switch [lindex $param 2] {
+ highlite -
+ paste -
+ select -
+ undo {$proc $id [ToYesNo [$current(frame) has marker [lindex $param 2]]]}
+ }
+ }
+ system {$proc $id [ToYesNo [$current(frame) has system [lindex $param 2]]]}
+ wcs {
+ switch [lindex $param 2] {
+ equatorial -
+ linear {$proc $id [ToYesNo [$current(frame) has wcs [lindex $param 2] [lindex $param 3]]]}
+ default {$proc $id [ToYesNo [$current(frame) has wcs [lindex $param 2]]]}
+ }
+ }
+ }
+ }
+ default {$proc $id "[string range $current(frame) 5 end]\n"}
+ }
+}
+
+proc ProcessSingleCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ global current
+ set current(display) single
+ DisplayMode
+}
+
+proc ProcessSendSingleCmd {proc id param} {
+ global current
+
+ if {$current(display) == "single"} {
+ $proc $id [ToYesNo 1]
+ } else {
+ $proc $id [ToYesNo 0]
+ }
+}
+
+proc ProcessTileCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+ global tile
+
+ switch -- [string tolower [lindex $var $i]] {
+ mode {
+ incr i
+ set tile(mode) [lindex $var $i]
+ }
+ grid {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ mode {
+ incr i
+ set tile(grid,mode) [lindex $var $i]
+ }
+ direction {
+ incr i
+ set tile(grid,dir) [lindex $var $i]
+ }
+ layout {
+ incr i
+ set tile(grid,col) [lindex $var $i]
+ incr i
+ set tile(grid,row) [lindex $var $i]
+ set tile(grid,mode) {manual}
+ }
+ gap {
+ incr i
+ set tile(grid,gap) [lindex $var $i]
+ }
+ default {
+ if {[string range [lindex $var $i] 0 0] != {-}} {
+ set tile(mode) grid
+ } else {
+ incr i -1
+ }
+ }
+ }
+ }
+ column {
+ set tile(mode) column
+ }
+ row {
+ set tile(mode) row
+ }
+
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ if {[FromYesNo [lindex $var $i]]} {
+ set current(display) tile
+ } else {
+ set current(display) single
+ }
+ }
+ default {
+ set current(display) tile
+ incr i -1
+ }
+ }
+ DisplayMode
+}
+
+proc ProcessSendTileCmd {proc id param} {
+ global current
+ global tile
+
+ switch -- [lindex $param 0] {
+ mode {$proc $id "$tile(mode)\n"}
+ grid {
+ switch -- [lindex $param 1] {
+ mode {$proc $id "$tile(grid,mode)\n"}
+ direction {$proc $id "$tile(grid,dir)\n"}
+ layout {$proc $id "$tile(grid,col) $tile(grid,row)\n"}
+ gap {$proc $id "$tile(grid,gap)\n"}
+ }
+ }
+ default {
+ if {$current(display)=="tile"} {
+ $proc $id [ToYesNo 1]
+ } else {
+ $proc $id [ToYesNo 0]
+ }
+ }
+ }
+}
+
+proc ProcessBlinkCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+ global blink
+
+ switch -- [string tolower [lindex $var $i]] {
+ interval {
+ incr i
+ set blink(interval) [expr int([lindex $var $i]*1000)]
+ }
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ if {[FromYesNo [lindex $var $i]]} {
+ set current(display) blink
+ } else {
+ set current(display) single
+ }
+ }
+ default {
+ set current(display) blink
+ incr i -1
+ }
+ }
+ DisplayMode
+}
+
+proc ProcessSendBlinkCmd {proc id param} {
+ global current
+ global blink
+
+ switch -- [lindex $param 0] {
+ interval {$proc $id "[expr $blink(interval)/1000.]\n"}
+ default {
+ if {$current(display) == {blink}} {
+ $proc $id [ToYesNo 1]
+ } else {
+ $proc $id [ToYesNo 0]
+ }
+ }
+ }
+}
+
+proc ProcessLockCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global panzoom
+ global crop
+ global crosshair
+ global cube
+ global ime
+ global bin
+ global scale
+ global colorbar
+ global block
+ global smooth
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ frame -
+ frames {
+ incr i
+ set panzoom(lock) [lindex $var $i]
+ LockFrameCurrent
+ }
+ crosshair -
+ crosshairs {
+ incr i
+ set crosshair(lock) [lindex $var $i]
+ LockCrosshairCurrent
+ }
+ crop {
+ incr i
+ set crop(lock) [lindex $var $i]
+ LockCropCurrent
+ }
+ slice -
+ cube -
+ datacube {
+ 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
+ }
+ bin {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set bin(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set bin(lock) 1
+ incr i -1
+ }
+ LockBinCurrent
+ }
+ axes -
+ order {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set cube(lock,axes) [FromYesNo [lindex $var $i]]
+ } else {
+ set cube(lock,axes) 1
+ incr i -1
+ }
+ LockAxesCurrent
+ }
+ scale -
+ scales {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set scale(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set scale(lock) 1
+ incr i -1
+ }
+ LockScaleCurrent
+ }
+ limits -
+ scalelimits {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set scale(lock,limits) [FromYesNo [lindex $var $i]]
+ } else {
+ set scale(lock,limits) 1
+ incr i -1
+ }
+ LockScaleLimitsCurrent
+ }
+ color -
+ colormap -
+ colorbar -
+ colorbars {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set colorbar(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set colorbar(lock) 1
+ incr i -1
+ }
+ LockColorCurrent
+ }
+ block {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set block(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set block(lock) 1
+ incr i -1
+ }
+ LockBlockCurrent
+ }
+ smooth {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set smooth(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set smooth(lock) 1
+ incr i -1
+ }
+ LockSmoothCurrent
+ }
+ }
+}
+
+proc ProcessSendLockCmd {proc id param} {
+ global panzoom
+ global crop
+ global crosshair
+ global cube
+ global ime
+ global bin
+ global scale
+ global colorbar
+ global block
+ global smooth
+
+ switch -- [lindex $param 0] {
+ frame -
+ frames {$proc $id "$panzoom(lock)\n"}
+ crosshair -
+ crosshairs {$proc $id "$crosshair(lock)\n"}
+ crop {$proc $id "$crop(lock)\n"}
+ slice -
+ cube -
+ datacube {$proc $id "$cube(lock)\n"}
+ analysis {$proc $id "$ime(lock)\n"}
+ bin {$proc $id [ToYesNo $bin(lock)]}
+ axes -
+ order {$proc $id [ToYesNo $cube(lock,axes)]}
+ scale -
+ scales {$proc $id [ToYesNo $scale(lock)]}
+ limits -
+ scalelimits {$proc $id [ToYesNo $scale(lock,limits)]}
+ color -
+ colormap -
+ colorbar -
+ colorbars {$proc $id [ToYesNo $colorbar(lock)]}
+ block {$proc $id [ToYesNo $block(lock)]}
+ smooth {$proc $id [ToYesNo $smooth(lock)]}
+ }
+}
+
+proc ProcessMatchCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+ global current
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ frame -
+ frames {
+ incr i
+ MatchFrameCurrent [lindex $var $i]
+ }
+ crosshair -
+ crosshairs {
+ incr i
+ MatchCrosshairCurrent [lindex $var $i]
+ }
+ crop {
+ incr i
+ MatchCropCurrent [lindex $var $i]
+ }
+ slice -
+ cube -
+ datacube {
+ 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
+ }
+ }
+ bin {MatchBinCurrent}
+ axes -
+ order {MatchAxesCurrent}
+ scale -
+ scales {MatchScaleCurrent}
+ limits -
+ scalelimits {MatchScaleLimitsCurrent}
+ color -
+ colormap -
+ colorbar -
+ colorbars {MatchColorCurrent}
+ block {MatchBlockCurrent}
+ smooth {MatchSmoothCurrent}
+ }
+}
+
diff --git a/ds9/library/graph.tcl b/ds9/library/graph.tcl
new file mode 100644
index 0000000..4e42610
--- /dev/null
+++ b/ds9/library/graph.tcl
@@ -0,0 +1,419 @@
+# 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 GraphDef {} {
+ global igraph
+ global pgraph
+
+ set igraph(horz,id) 0
+ set igraph(vert,id) 0
+
+ set igraph(size) 150
+ set igraph(gap,x) 50
+ set igraph(gap,y) 25
+
+ set igraph(x,min) 0
+ set igraph(x,max) 10
+ set igraph(y,min) 1
+ set igraph(y,max) 100
+
+ global graphHorzX graphHorzY
+ global graphVertX graphVertY
+ global histX histY
+
+ blt::vector create graphHorzX graphHorzY
+ blt::vector create graphVertX graphVertY
+ blt::vector create histX histY
+
+ # prefs only
+ set pgraph(horz,grid) 1
+ set pgraph(horz,log) false
+ set pgraph(vert,grid) 1
+ set pgraph(vert,log) false
+}
+
+proc CreateGraphs {} {
+ global igraph
+
+ global ds9
+ global canvas
+
+ # Horizontal Graph
+ set ds9(graph,horz) [blt::graph $ds9(main).horz \
+ -width $canvas(width) -height $igraph(size) \
+ -takefocus 0 \
+ -background $ds9(bg) \
+ -highlightthickness 0 \
+ -plotborderwidth 2 \
+ -plotrelief groove \
+ -plotbackground $ds9(bg) \
+ -font [font actual TkDefaultFont] \
+ ]
+ # we need to manually set the element foreground color, i.e. use graph fg
+ set fgcolor [$ds9(graph,horz) cget -foreground]
+
+ $ds9(graph,horz) legend configure -hide yes
+ $ds9(graph,horz) crosshairs configure -color green
+
+ $ds9(graph,horz) xaxis configure -hide no -showticks no -bg $ds9(bg)
+ $ds9(graph,horz) x2axis configure -hide yes
+ $ds9(graph,horz) yaxis configure -hide yes
+ $ds9(graph,horz) y2axis configure -hide no -bg $ds9(bg) \
+ -tickfont [font actual TkDefaultFont]
+
+ $ds9(graph,horz) element create line1 -xdata graphHorzX -ydata graphHorzY \
+ -color $fgcolor -symbol none
+
+ bind $ds9(graph,horz) <Enter> [list EnterGraph $ds9(graph,horz) 1]
+ bind $ds9(graph,horz) <Leave> [list LeaveGraph $ds9(graph,horz)]
+ bind $ds9(graph,horz) <Button-1> \
+ [list MotionGraph $ds9(graph,horz) %x %y 1]
+ bind $ds9(graph,horz) <B1-Motion> \
+ [list MotionGraph $ds9(graph,horz) %x %y 1]
+ bind $ds9(graph,horz) <Up> [list ArrowKeyGraph $ds9(graph,horz) 0 -1 1]
+ bind $ds9(graph,horz) <Down> [list ArrowKeyGraph $ds9(graph,horz) 0 1 1]
+ bind $ds9(graph,horz) <Left> [list ArrowKeyGraph $ds9(graph,horz) -1 0 1]
+ bind $ds9(graph,horz) <Right> [list ArrowKeyGraph $ds9(graph,horz) 1 0 1]
+
+ # Vertical Graph
+ set ds9(graph,vert) [blt::graph $ds9(main).vert \
+ -width $igraph(size) -height $canvas(height) \
+ -invertxy yes \
+ -takefocus 0 \
+ -background $ds9(bg) \
+ -highlightthickness 0 \
+ -plotrelief groove \
+ -plotborderwidth 2 \
+ -plotbackground $ds9(bg)
+ ]
+ $ds9(graph,vert) legend configure -hide yes
+ $ds9(graph,vert) crosshairs configure -color green
+
+ $ds9(graph,vert) xaxis configure -hide yes -descending yes
+ $ds9(graph,vert) x2axis configure -hide no -descending yes \
+ -showticks no -bg $ds9(bg)
+ $ds9(graph,vert) yaxis configure -hide no -descending yes \
+ -bg $ds9(bg) -tickfont [font actual TkDefaultFont]
+ $ds9(graph,vert) y2axis configure -hide yes -descending yes
+
+ $ds9(graph,vert) element create line1 -xdata graphVertX -ydata graphVertY \
+ -color $fgcolor -symbol none
+
+ bind $ds9(graph,vert) <Enter> [list EnterGraph $ds9(graph,vert) 0]
+ bind $ds9(graph,vert) <Leave> [list LeaveGraph $ds9(graph,vert)]
+ bind $ds9(graph,vert) <Button-1> \
+ [list MotionGraph $ds9(graph,vert) %x %y 0]
+ bind $ds9(graph,vert) <B1-Motion> \
+ [list MotionGraph $ds9(graph,vert) %x %y 0]
+ bind $ds9(graph,vert) <Up> [list ArrowKeyGraph $ds9(graph,vert) 0 -1 0]
+ bind $ds9(graph,vert) <Down> [list ArrowKeyGraph $ds9(graph,vert) 0 1 0]
+ bind $ds9(graph,vert) <Left> [list ArrowKeyGraph $ds9(graph,vert) -1 0 0]
+ bind $ds9(graph,vert) <Right> [list ArrowKeyGraph $ds9(graph,vert) 1 0 0]
+
+ UpdateGraphGrid
+}
+
+proc UpdateGraphFont {} {
+ global ds9
+
+ $ds9(graph,horz) y2axis configure -tickfont [font actual TkDefaultFont]
+ $ds9(graph,vert) yaxis configure -tickfont [font actual TkDefaultFont]
+}
+
+proc UpdateGraphGrid {} {
+ global pgraph
+ global ds9
+
+ $ds9(graph,horz) xaxis configure -grid $pgraph(horz,grid) -tickdefault 4
+ $ds9(graph,horz) y2axis configure -grid $pgraph(horz,grid)
+
+ $ds9(graph,vert) x2axis configure -grid $pgraph(vert,grid)
+ $ds9(graph,vert) yaxis configure -grid $pgraph(vert,grid) -tickdefault 4
+}
+
+proc UpdateGraphXAxis {which} {
+ global ds9
+ global view
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateGraphXAxis"
+ }
+
+ if {$view(graph,horz)} {
+ UpdateGraphXAxisHV $which $ds9(graph,horz) graphHorzX graphHorzY 1
+ }
+
+ if {$view(graph,vert)} {
+ UpdateGraphXAxisHV $which $ds9(graph,vert) graphVertX graphVertY 0
+ }
+}
+
+proc UpdateGraphXAxisHV {which what vectorX vectorY cut} {
+ global igraph
+
+ global graphHorzX graphHorzY
+ global graphVertX graphVertY
+
+ if {$which != {}} {
+ set xMin [expr "$$vectorX\(min\)"]
+ set xMax [expr "$$vectorX\(max\)"]
+
+ $what xaxis configure -min $xMin -max $xMax
+ $what x2axis configure -min $xMin -max $xMax
+ } else {
+ $what xaxis configure -min $igraph(x,min) -max $igraph(x,max)
+ $what x2axis configure -min $igraph(x,min) -max $igraph(x,max)
+ }
+}
+
+proc UpdateGraphYAxis {which} {
+ global pgraph
+
+ global ds9
+ global view
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateGraphYAxis"
+ }
+
+ if {$view(graph,horz)} {
+ UpdateGraphYAxisHV $which $ds9(graph,horz) $pgraph(horz,log)
+ }
+
+ if {$view(graph,vert)} {
+ UpdateGraphYAxisHV $which $ds9(graph,vert) $pgraph(vert,log)
+ }
+}
+
+proc UpdateGraphYAxisHV {which what log} {
+ global igraph
+
+ if {$which != {}} {
+ set minmax [$which get clip]
+ set yMin [lindex $minmax 0]
+ set yMax [lindex $minmax 1]
+
+ # must use .eq. since "nan" is a legal double value
+ if {$yMin eq "nan" || $yMax eq "nan"} {
+ set yMin 0
+ set yMax 1
+ }
+
+ if {$yMin >= $yMax} {
+ set yMax [expr $yMin + 1]
+ }
+
+ $what yaxis configure -min $yMin -max $yMax -logscale $log -tickdefault 4
+ $what y2axis configure -min $yMin -max $yMax -logscale $log -tickdefault 4
+ } else {
+ $what yaxis configure -min $igraph(y,min) -max $igraph(y,max) \
+ -logscale $log -tickdefault 4
+ $what y2axis configure -min $igraph(y,min) -max $igraph(y,max) \
+ -logscale $log -tickdefault 4
+ }
+}
+
+proc ShowGraphData {which} {
+ global ds9
+ global view
+
+ if {$view(graph,horz)} {
+ ShowGraphDataHV $which $ds9(graph,horz)
+ }
+ if {$view(graph,vert)} {
+ ShowGraphDataHV $which $ds9(graph,vert)
+ }
+}
+
+proc ShowGraphDataHV {which what} {
+ if {$which != {}} {
+ if {[$which has fits]} {
+ $what element configure line1 -hide no
+ } else {
+ $what element configure line1 -hide yes
+ }
+ } else {
+ $what element configure line1 -hide yes
+ }
+}
+
+proc ClearGraphData {} {
+ global ds9
+ global view
+
+ if {$view(graph,horz)} {
+ $ds9(graph,horz) element configure line1 -hide yes
+ }
+
+ if {$view(graph,vert)} {
+ $ds9(graph,vert) element configure line1 -hide yes
+ }
+}
+
+proc UpdateGraph {which x y sys} {
+ global ds9
+ global view
+
+ if {[$which has fits]} {
+ if {$view(graph,horz)} {
+ $which get horizontal cut graphHorzX graphHorzY $x $y $sys
+ $ds9(graph,horz) element configure line1 -hide no
+ }
+
+ if {$view(graph,vert)} {
+ $which get vertical cut graphVertX graphVertY $x $y $sys
+ $ds9(graph,vert) element configure line1 -hide no
+ }
+ }
+}
+
+proc EnterGraph {which horz} {
+ global current
+
+ focus $which
+ $which crosshairs on
+
+ if {$current(frame) != {}} {
+ switch $current(mode) {
+ crosshair -
+ analysis {
+
+ set x [$which crosshairs cget -x]
+ set y [$which crosshairs cget -y]
+
+ set coord [$current(frame) get crosshair canvas]
+ set X [lindex $coord 0]
+ set Y [lindex $coord 1]
+
+ if {$horz} {
+ EnterInfoBox $current(frame)
+ UpdateInfoBox $current(frame) $x $Y canvas
+ UpdatePixelTableDialog $current(frame) $x $Y canvas
+ } else {
+ EnterInfoBox $current(frame)
+ UpdateInfoBox $current(frame) $X $y canvas
+ UpdatePixelTableDialog $current(frame) $X $y canvas
+ }
+ }
+ }
+ }
+}
+
+proc LeaveGraph {which} {
+ focus {}
+ $which crosshairs off
+
+ LeaveInfoBox
+ PixelTableClearDialog
+}
+
+proc MotionGraph {which x y horz} {
+ global current
+
+ $which crosshairs configure -x $x -y $y
+
+ if {$current(frame) != {}} {
+ switch $current(mode) {
+ crosshair -
+ analysis {
+ set coord [$current(frame) get crosshair canvas]
+ set X [lindex $coord 0]
+ set Y [lindex $coord 1]
+
+ if {$horz} {
+ UpdateInfoBox $current(frame) $x $Y canvas
+ UpdatePixelTableDialog $current(frame) $x $Y canvas
+ } else {
+ UpdateInfoBox $current(frame) $X $y canvas
+ UpdatePixelTableDialog $current(frame) $X $y canvas
+ }
+ }
+ }
+ }
+}
+
+proc ArrowKeyGraph {which x y horz} {
+ set cx [$which crosshairs cget -x]
+ set cy [$which crosshairs cget -y]
+
+ set cx [expr $cx+$x]
+ set cy [expr $cy+$y]
+
+ MotionGraph $which $cx $cy $horz
+}
+
+proc LayoutGraphs {} {
+ global igraph
+
+ global ds9
+ global canvas
+ global view
+ global colorbar
+ global icolorbar
+
+ set cbh [expr $view(colorbar) && \
+ [string equal $colorbar(orientation) {horizontal}]]
+ set cbv [expr $view(colorbar) && \
+ [string equal $colorbar(orientation) {vertical}]]
+ set grh [expr $view(graph,horz)]
+ set grv [expr $view(graph,vert)]
+
+ if {$grh} {
+ set xx 0
+ set yy [expr $canvas(height) + $canvas(gap)]
+ if {$cbh} {
+ incr yy $icolorbar(horizontal,height)
+ }
+ if {$grv && !$cbh} {
+ incr yy $igraph(gap,y)
+ }
+
+ if {$igraph(horz,id) == 0} {
+ set igraph(horz,id) [$ds9(canvas) create window $xx $yy \
+ -window $ds9(graph,horz) -anchor nw]
+ } else {
+ $ds9(canvas) coords $igraph(horz,id) $xx $yy
+ }
+
+ set ww [expr $canvas(width)+$igraph(gap,x)]
+ $ds9(graph,horz) configure -width $ww
+
+ } else {
+ if {$igraph(horz,id)>0} {
+ $ds9(canvas) delete $igraph(horz,id)
+ set igraph(horz,id) 0
+ }
+ }
+
+ if {$grv} {
+ set yy 0
+ set xx [expr $canvas(width) + $canvas(gap)]
+ if {$cbv} {
+ incr xx $icolorbar(vertical,width)
+ }
+ if {$grh && !$cbv} {
+ incr xx $igraph(gap,x)
+ }
+
+ if {$igraph(vert,id) == 0} {
+ set igraph(vert,id) [$ds9(canvas) create window $xx $yy \
+ -window $ds9(graph,vert) -anchor nw]
+ } else {
+ $ds9(canvas) coords $igraph(vert,id) $xx $yy
+ }
+
+ set hh [expr $canvas(height)+$igraph(gap,y)]
+ $ds9(graph,vert) configure -height $hh
+
+ } else {
+ if {$igraph(vert,id)>0} {
+ $ds9(canvas) delete $igraph(vert,id)
+ set igraph(vert,id) 0
+ }
+ }
+}
diff --git a/ds9/library/grid.tcl b/ds9/library/grid.tcl
new file mode 100644
index 0000000..dfdc4b0
--- /dev/null
+++ b/ds9/library/grid.tcl
@@ -0,0 +1,1550 @@
+# 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 GridDef {} {
+ global igrid
+ global grid
+ global pgrid
+
+ set igrid(top) .grid
+ set igrid(mb) .gridmb
+
+ set grid(view) 0
+
+ array set pgrid [array get grid]
+
+ GridDefault
+}
+
+proc GridDefault {} {
+ global grid
+
+ set grid(type) analysis
+ set grid(system) wcs
+ set grid(sky) fk5
+ set grid(skyformat) sexagesimal
+
+ set grid(grid) 1
+ set grid(grid,color) blue
+ set grid(grid,width) 1
+ set grid(grid,style) 0
+ set grid(grid,gap1) {}
+ set grid(grid,gap2) {}
+ set grid(grid,gap3) {}
+ set grid(grid,gapunit1) {}
+ set grid(grid,gapunit2) {}
+ set grid(grid,gapunit3) {}
+
+ set grid(axes) 1
+ set grid(axes,color) red
+ set grid(axes,width) 1
+ set grid(axes,style) 0
+ set grid(axes,type) interior
+ set grid(axes,origin) lll
+
+ set grid(tick) 1
+ set grid(tick,color) white
+ set grid(tick,width) 1
+ set grid(tick,style) 0
+
+ set grid(border) 1
+ set grid(border,color) blue
+ set grid(border,width) 1
+ set grid(border,style) 0
+
+ set grid(format1) {}
+ set grid(format2) {}
+
+ set grid(numlab) 1
+ set grid(numlab,font) helvetica
+ set grid(numlab,size) 10
+ set grid(numlab,weight) normal
+ set grid(numlab,slant) roman
+ set grid(numlab,color) green
+ set grid(numlab,gap1) {}
+ set grid(numlab,gap2) {}
+ set grid(numlab,gap3) {}
+ set grid(numlab,type) interior
+ set grid(numlab,vertical) 0
+
+ set grid(title) 1
+ set grid(title,text) {}
+ set grid(title,def) 1
+ set grid(title,gap) {}
+ set grid(title,font) helvetica
+ set grid(title,size) 12
+ set grid(title,weight) normal
+ set grid(title,slant) roman
+ set grid(title,color) black
+
+ set grid(textlab) 1
+ set grid(textlab,text1) {}
+ set grid(textlab,text2) {}
+ set grid(textlab,def1) 1
+ set grid(textlab,def2) 1
+ set grid(textlab,gap1) {}
+ set grid(textlab,gap2) {}
+ set grid(textlab,font) helvetica
+ set grid(textlab,size) 10
+ set grid(textlab,weight) normal
+ set grid(textlab,slant) roman
+ set grid(textlab,color) black
+}
+
+proc GridUpdateCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ GridUpdate $current(frame)
+ }
+}
+
+proc GridUpdate {which} {
+ global grid
+
+ GridAdjustOptions $which
+
+ if {$grid(view) && [$which has fits]} {
+ $which grid create $grid(system) $grid(sky) \
+ $grid(skyformat) $grid(type) \
+ [GridBuildOptions $which] "\"[array get grid]\""
+ } else {
+ $which grid delete
+ }
+}
+
+proc GridUpdateZoom {} {
+ global grid
+
+ if {$grid(type) == "publication"} {
+ GridUpdateCurrent
+ }
+}
+
+proc GridAdjustOptions {which} {
+ global grid
+
+ if {$which != {}} {
+ if {[$which has fits]} {
+ # change values if needed for coordmenu
+ AdjustCoordSystem grid system
+ }
+ }
+
+ set grid(grid,gapunit1) pixels
+ set grid(grid,gapunit2) pixels
+ set grid(grid,gapunit3) pixels
+
+ # adjust units
+ switch -- $grid(system) {
+ image -
+ physical -
+ amplifier -
+ detector {}
+ default {
+ if {$which != {}} {
+ if {[$which has wcs celestrial $grid(system)]} {
+ set grid(grid,gapunit1) degrees
+ set grid(grid,gapunit2) degrees
+ }
+ if {[$which has wcs 3d $grid(system)]} {
+ set tt [string trim [$which get fits header keyword CTYPE3]]
+ if {$tt != {}} {
+ set grid(grid,gapunit3) $tt
+ }
+ }
+ }
+ }
+ }
+}
+
+proc GridBuildOptions {which} {
+ global grid
+ global current
+
+ set opt "\""
+
+ # Grid
+ append opt " Grid=$grid(grid),"
+ append opt " Colour(grid)=[GridColor2Ast $grid(grid,color)],"
+ append opt " Width(grid)=$grid(grid,width),"
+ append opt " Style(grid)=$grid(grid,style),"
+
+ # Axes
+ append opt " DrawAxes=$grid(axes),"
+ append opt " Colour(axes)=[GridColor2Ast $grid(axes,color)],"
+ append opt " Width(axes)=$grid(axes,width),"
+ append opt " Style(axes)=$grid(axes,style),"
+
+ # Format
+ if {$grid(format1) != {}} {
+ append opt " Format(1)=$grid(format1),"
+ } else {
+ set ff [GridDefaultFormat1]
+ if {$ff != {}} {
+ append opt " Format(1)=$ff,"
+ }
+ }
+
+ if {$grid(format2) != {}} {
+ append opt " Format(2)=$grid(format2),"
+ } else {
+ set ff [GridDefaultFormat2]
+ if {$ff != {}} {
+ append opt " Format(2)=$ff,"
+ }
+ }
+
+ # Ticks
+ if {!$grid(tick)} {
+ append opt " MajTickLen=0,"
+ append opt " MinTick(1)=0,"
+ append opt " MinTick(2)=0,"
+ switch -- $grid(type) {
+ analysis {}
+ publication {
+ switch -- [$which get type] {
+ base -
+ rgb {}
+ 3d {append opt " MinTick(3)=0,"}
+ }
+ }
+ }
+ }
+ append opt " Colour(ticks)=[GridColor2Ast $grid(tick,color)],"
+ append opt " Width(ticks)=$grid(tick,width),"
+ append opt " Style(ticks)=$grid(tick,style),"
+
+ # Border
+ append opt " Border=$grid(border),"
+ append opt " Colour(border)=[GridColor2Ast $grid(border,color)],"
+ append opt " Width(border)=$grid(border,width),"
+ append opt " Style(border)=$grid(border,style),"
+
+ # Labels
+ append opt " Labelling=$grid(axes,type),"
+ switch -- [$which get type] {
+ base -
+ rgb {append opt " LabelUp=$grid(numlab,vertical),"}
+ 3d {append opt " LabelUp=1,"}
+ }
+
+ # NumLab
+ append opt " NumLab=$grid(numlab),"
+ set opt "$opt Font(numlab)=[GridFont2Ast $grid(numlab,font) $grid(numlab,weight) $grid(numlab,slant)],"
+ append opt " Size(numlab)=$grid(numlab,size),"
+ append opt " Colour(numlab)=[GridColor2Ast $grid(numlab,color)],"
+
+ # TextLab
+ switch -- $grid(type) {
+ analysis {append opt " TextLab=0,"}
+ publication {
+ switch -- [$which get type] {
+ base -
+ rgb {append opt " TextLab=$grid(textlab),"}
+ 3d {append opt " TextLab=0,"}
+ }
+ }
+ }
+ if {!$grid(textlab,def1)} {
+ append opt " Label(1)=[GridStripComma $grid(textlab,text1)] ,"
+ }
+ if {!$grid(textlab,def2)} {
+ append opt " Label(2)=[GridStripComma $grid(textlab,text2)] ,"
+ }
+
+ set opt "$opt Font(textlab)=[GridFont2Ast $grid(textlab,font) $grid(textlab,weight) $grid(textlab,slant)],"
+ append opt " Size(textlab)=$grid(textlab,size),"
+ append opt " Colour(textlab)=[GridColor2Ast $grid(textlab,color)],"
+
+ # Title
+ switch -- $grid(type) {
+ analysis {append opt " DrawTitle=0,"}
+ publication {
+ switch -- [$which get type] {
+ base -
+ rgb {append opt " DrawTitle=$grid(title),"}
+ 3d {append opt " DrawTitle=0,"}
+ }
+ }
+ }
+
+ if {$grid(title,def)} {
+ set t [GridStripComma "[$which get fits object name]"]
+ if {$t != {}} {
+ append opt " Title=$t ,"
+ }
+ } else {
+ set t [GridStripComma "$grid(title,text)"]
+ if {$t != {}} {
+ append opt " Title=$t ,"
+ }
+ }
+
+ set opt "$opt Font(title)=[GridFont2Ast $grid(title,font) $grid(title,weight) $grid(title,slant)],"
+ append opt " Size(title)=$grid(title,size),"
+ append opt " Colour(title)=[GridColor2Ast $grid(title,color)],"
+
+ # Grid Spacing
+ if {$grid(grid,gap1) != {}} {
+ if {$grid(grid,gapunit1) == "degrees"} {
+ append opt " Gap(1)=[expr 3.14159/180.*$grid(grid,gap1)],"
+ } else {
+ append opt " Gap(1)=$grid(grid,gap1),"
+ }
+ }
+
+ if {$grid(grid,gap2) != {}} {
+ if {$grid(grid,gapunit2) == "degrees"} {
+ append opt " Gap(2)=[expr 3.14159/180.*$grid(grid,gap2)],"
+ } else {
+ append opt " Gap(2)=$grid(grid,gap2),"
+ }
+ }
+
+ switch -- [$which get type] {
+ base -
+ rgb {}
+ 3d {
+ if {$grid(grid,gap3) != {}} {
+ if {$grid(grid,gapunit3) == "degrees"} {
+ append opt " Gap(3)=[expr 3.14159/180.*$grid(grid,gap3)],"
+ } else {
+ append opt " Gap(3)=$grid(grid,gap3),"
+ }
+ }
+ }
+ }
+
+ # axes numerics
+ set flip 0
+ set numx 0
+ set numy 0
+ switch -- $grid(type) {
+ analysis {
+ switch -- [$which get type] {
+ base -
+ rgb {
+ set numx -.03
+ set numy -.03
+ }
+ 3d {}
+ }
+ }
+ publication {
+ switch -- [$which get type] {
+ base -
+ rgb {
+ set numx -.02
+ set numy -.01
+ switch -- $grid(axes,type) {
+ interior {}
+ exterior {
+ switch -- $grid(numlab,type) {
+ interior {}
+ exterior {set flip 1}
+ }
+ }
+ }
+ }
+ 3d {}
+ }
+ }
+ }
+
+ # override
+ if {$grid(numlab,gap1) != {}} {
+ set numx [expr -$grid(numlab,gap1)/100.]
+ }
+ if {$grid(numlab,gap2) != {}} {
+ set numy [expr -$grid(numlab,gap2)/100.]
+ }
+ if {$grid(numlab,gap3) != {}} {
+ set numy [expr -$grid(numlab,gap3)/100.]
+ }
+ if {$flip} {
+ set numx [expr -$numx]
+ set numy [expr -$numy]
+ }
+ append opt " NumLabGap(1)=$numx,"
+ append opt " NumLabGap(2)=$numy,"
+
+ # Label gaps
+ switch -- $grid(type) {
+ analysis {
+ set axisx 0
+ set axisy 0
+ set title 0
+ }
+ publication {
+ if {$grid(textlab,gap1) != {}} {
+ set axisx [expr $grid(textlab,gap1)/100.]
+ } else {
+ set axisx 0
+ }
+ if {$grid(textlab,gap2) != {}} {
+ set axisy [expr $grid(textlab,gap2)/100.]
+ } else {
+ set axisy .1
+ }
+
+ if {$grid(title,gap) != {}} {
+ set title [expr $grid(title,gap)/100.]
+ } else {
+ set title .30
+ }
+ }
+ }
+
+ append opt " TextLabGap(1)=$axisx,"
+ append opt " TextLabGap(2)=$axisy,"
+ append opt " TitleGap=[expr -1-$title],"
+
+ # Orientation
+ switch -- [$which get type] {
+ base -
+ rgb {
+ append opt " Edge(1)=top,"
+ append opt " Edge(2)=left,"
+ }
+ 3d {
+ switch -- $grid(type) {
+ analysis {
+ append opt " Edge(1)=bottom,"
+ append opt " Edge(2)=left,"
+ }
+ publication {
+ append opt " RootCorner=$grid(axes,origin),"
+ }
+ }
+ }
+ }
+
+ # 3D Normal
+ switch -- $grid(type) {
+ analysis {}
+ publication {
+ switch -- [$which get type] {
+ base -
+ rgb {}
+ 3d {append opt " Norm(1)=0, Norm(2)=0, Norm(3)=-1,"}
+ }
+ }
+ }
+
+ # The End
+ append opt " \""
+
+ global debug
+
+ if {$debug(tcl,grid)} {
+ puts stderr "GridBuildOptions"
+ puts stderr "$opt"
+ }
+
+ return $opt
+}
+
+proc GridAst2Color {ast} {
+ switch -- $ast {
+ 0 {return {black}}
+ 1 {return white}
+ 2 {return red}
+ 3 {return green}
+ 4 {return blue}
+ 5 {return cyan}
+ 6 {return magenta}
+ 7 {return yellow}
+
+ 16777215 {return {white}}
+ 16711680 {return {red}}
+ 65280 {return {green}}
+ 255 {return {blue}}
+ 65535 {return {cyan}}
+ 16711935 {return {magenta}}
+ 16776960 {return {yellow}}
+
+ default {return "#[format %x $ast]"}
+ }
+}
+
+proc GridColor2Ast {which} {
+ switch -- $which {
+ black {return [expr 0x000000]}
+ white {return [expr 0xffffff]}
+ red {return [expr 0xff0000]}
+ green {return [expr 0x00ff00]}
+ blue {return [expr 0x0000ff]}
+ cyan {return [expr 0x00ffff]}
+ magenta {return [expr 0xff00ff]}
+ yellow {return [expr 0xffff00]}
+
+ default {
+ if {[string range $which 0 0] == "#"} {
+ return [expr 0x[string range $which 1 end]]
+ } else {
+ return [expr $which]
+ }
+ }
+ }
+}
+
+proc GridAst2Font {ast fnvar fwvar fsvar} {
+ upvar $fnvar fn
+ upvar $fwvar fw
+ upvar $fsvar fs
+
+ switch -- $ast {
+ 0 -
+ 2 -
+ 3 {set fn "helvetica"; set fw "normal"; set fs "roman"}
+ 1 {set fn "times"; set fw "normal"; set fs "roman"}
+ 4 {set fn "courier"; set fw "normal"; set fs "roman"}
+ 10 -
+ 12 -
+ 13 {set fn "helvetica"; set fw "bold"; set fs "roman"}
+ 11 {set fn "times"; set fw "bold"; set fs "roman"}
+ 14 {set fn "courier"; set fw "bold"; set fs "roman"}
+ 20 -
+ 22 -
+ 23 {set fn "helvetica"; set fw "normal"; set fs "italic"}
+ 21 {set fn "times"; set fw "normal"; set fs "italic"}
+ 24 {set fn "courier"; set fw "normal"; set fs "italic"}
+ 30 -
+ 32 -
+ 33 {set fn "helvetica"; set fw "bold"; set fs "italic"}
+ 31 {set fn "times"; set fw "bold"; set fs "italic"}
+ 34 {set fn "courier"; set fw "bold"; set fs "italic"}
+
+ default {set fn "helvetica"; set fw "normal"; set fs "roman"}
+ }
+}
+
+proc GridFont2Ast {fn fw fs} {
+ if {$fn == "times" && $fw == "normal" && $fs == "roman"} {
+ return 1;
+ } elseif {$fn == "helvetica" && $fw == "normal" && $fs == "roman"} {
+ return 2;
+ } elseif {$fn == "courier" && $fw == "normal" && $fs == "roman"} {
+ return 4;
+ } elseif {$fn == "times" && $fw == "bold" && $fs == "roman"} {
+ return 11;
+ } elseif {$fn == "helvetica" && $fw == "bold" && $fs == "roman"} {
+ return 12;
+ } elseif {$fn == "courier" && $fw == "bold" && $fs == "roman"} {
+ return 14;
+ } elseif {$fn == "times" && $fw == "normal" && $fs == "italic"} {
+ return 21;
+ } elseif {$fn == "helvetica" && $fw == "normal" && $fs == "italic"} {
+ return 22;
+ } elseif {$fn == "courier" && $fw == "normal" && $fs == "italic"} {
+ return 24;
+ } elseif {$fn == "times" && $fw == "bold" && $fs == "italic"} {
+ return 31;
+ } elseif {$fn == "helvetica" && $fw == "bold" && $fs == "italic"} {
+ return 32;
+ } elseif {$fn == "courier" && $fw == "bold" && $fs == "italic"} {
+ return 34;
+ } else {
+ return 2;
+ }
+}
+
+proc GridDialog {} {
+ global igrid
+ global grid
+ global current
+ global ds9
+
+ # see if we already have a window visible
+
+ if {[winfo exists $igrid(top)]} {
+ raise $igrid(top)
+ return
+ }
+
+ # create the window
+ set w $igrid(top)
+ set mb $igrid(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Coordinate Grid Parameters}] \
+ GridDestroyDialog
+
+ $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 {Type}] -menu $mb.type
+ $mb add cascade -label [msgcat::mc {Coordinate}] -menu $mb.coord
+ $mb add cascade -label [msgcat::mc {Grid}] -menu $mb.grid
+ $mb add cascade -label [msgcat::mc {Axes}] -menu $mb.axes
+ $mb add cascade -label [msgcat::mc {Numerics}] -menu $mb.numlab
+ $mb add cascade -label [msgcat::mc {Labels}] -menu $mb.textlab
+ $mb add cascade -label [msgcat::mc {Tickmarks}] -menu $mb.tick
+ $mb add cascade -label [msgcat::mc {Title}] -menu $mb.title
+ $mb add cascade -label [msgcat::mc {Border}] -menu $mb.border
+
+ # File
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command GridApplyDialog
+ $mb.file add command -label [msgcat::mc {Reset}] -command GridResetDialog
+ $mb.file add command -label [msgcat::mc {Clear}] -command GridClearDialog
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load Configuration}]..." \
+ -command GridLoadDialog
+ $mb.file add command -label "[msgcat::mc {Save Configuration}]..." \
+ -command GridSaveDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command GridDestroyDialog
+
+ # Edit
+ EditMenu $mb igrid
+
+ # Type
+ menu $mb.type
+ $mb.type add radiobutton -label [msgcat::mc {Analysis}] \
+ -variable grid(type) -value analysis -command GridApplyDialog
+ $mb.type add radiobutton -label [msgcat::mc {Publication}] \
+ -variable grid(type) -value publication -command GridApplyDialog
+ $mb.type add separator
+ $mb.type add radiobutton -label [msgcat::mc {Interior Axes}] \
+ -variable grid(axes,type) -value interior -command GridApplyDialog
+ $mb.type add radiobutton -label [msgcat::mc {Exterior Axes}] \
+ -variable grid(axes,type) -value exterior -command GridApplyDialog
+ $mb.type add separator
+ $mb.type add radiobutton -label [msgcat::mc {Interior Numerics}] \
+ -variable grid(numlab,type) -value interior -command GridApplyDialog
+ $mb.type add radiobutton -label [msgcat::mc {Exterior Numerics}] \
+ -variable grid(numlab,type) -value exterior -command GridApplyDialog
+ $mb.type add separator
+ $mb.type add checkbutton -label [msgcat::mc {Vertical Text}] \
+ -variable grid(numlab,vertical) -command GridApplyDialog
+
+ # Coordinate
+ CoordMenu $mb.coord grid system 1 sky skyformat GridApplyDialog
+
+ # Grid
+ menu $mb.grid
+ $mb.grid add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(grid) -command GridApplyDialog
+ $mb.grid add separator
+ $mb.grid add cascade -label [msgcat::mc {Color}] -menu $mb.grid.color
+ $mb.grid add cascade -label [msgcat::mc {Line}] -menu $mb.grid.line
+
+ ColorMenu $mb.grid.color grid grid,color GridApplyDialog
+ GridCreateLineMenu $mb.grid.line grid,width grid,style
+
+ # Axes
+ menu $mb.axes
+ $mb.axes add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(axes) -command GridApplyDialog
+ $mb.axes add separator
+ $mb.axes add cascade -label [msgcat::mc {Color}] -menu $mb.axes.color
+ $mb.axes add cascade -label [msgcat::mc {Line}] -menu $mb.axes.line
+ $mb.axes add separator
+ $mb.axes add cascade -label [msgcat::mc {Origin}] -menu $mb.axes.origin
+
+ ColorMenu $mb.axes.color grid axes,color GridApplyDialog
+ GridCreateLineMenu $mb.axes.line axes,width axes,style
+
+ menu $mb.axes.origin
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Lower Left Front}] \
+ -variable grid(axes,origin) -value lll -command GridApplyDialog
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Lower Right Front}] \
+ -variable grid(axes,origin) -value ull -command GridApplyDialog
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Upper Right Front}] \
+ -variable grid(axes,origin) -value uul -command GridApplyDialog
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Upper Left Front}] \
+ -variable grid(axes,origin) -value lul -command GridApplyDialog
+ $mb.axes.origin add separator
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Lower Left Back}] \
+ -variable grid(axes,origin) -value llu -command GridApplyDialog
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Lower Right Back}] \
+ -variable grid(axes,origin) -value ulu -command GridApplyDialog
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Upper Right Back}] \
+ -variable grid(axes,origin) -value uuu -command GridApplyDialog
+ $mb.axes.origin add radiobutton -label [msgcat::mc {Upper Left Back}] \
+ -variable grid(axes,origin) -value luu -command GridApplyDialog
+
+ # Numerics
+ menu $mb.numlab
+ $mb.numlab add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(numlab) -command GridApplyDialog
+ $mb.numlab add separator
+ $mb.numlab add cascade -label [msgcat::mc {Color}] \
+ -menu $mb.numlab.color
+ $mb.numlab add cascade -label [msgcat::mc {Font}] \
+ -menu $mb.numlab.font
+
+ ColorMenu $mb.numlab.color grid numlab,color GridApplyDialog
+ FontMenu $mb.numlab.font \
+ grid numlab,font numlab,size numlab,weight numlab,slant \
+ GridApplyDialog
+
+ # Labels
+ menu $mb.textlab
+ $mb.textlab add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(textlab) -command GridApplyDialog
+ $mb.textlab add separator
+ $mb.textlab add cascade -label [msgcat::mc {Color}] \
+ -menu $mb.textlab.color
+ $mb.textlab add cascade -label [msgcat::mc {Font}] \
+ -menu $mb.textlab.font
+
+ ColorMenu $mb.textlab.color grid textlab,color GridApplyDialog
+ FontMenu $mb.textlab.font \
+ grid textlab,font textlab,size textlab,weight textlab,slant \
+ GridApplyDialog
+
+ # Tickmarks
+ menu $mb.tick
+ $mb.tick add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(tick) -command GridApplyDialog
+ $mb.tick add separator
+ $mb.tick add cascade -label [msgcat::mc {Color}] \
+ -menu $mb.tick.color
+ $mb.tick add cascade -label [msgcat::mc {Line}] \
+ -menu $mb.tick.line
+
+ ColorMenu $mb.tick.color grid tick,color GridApplyDialog
+ GridCreateLineMenu $mb.tick.line tick,width tick,style
+
+ # Title
+ menu $mb.title
+ $mb.title add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(title) -command GridApplyDialog
+ $mb.title add separator
+ $mb.title add cascade -label [msgcat::mc {Color}] -menu $mb.title.color
+ $mb.title add cascade -label [msgcat::mc {Font}] -menu $mb.title.font
+
+ ColorMenu $mb.title.color grid title,color GridApplyDialog
+ FontMenu $mb.title.font \
+ grid title,font title,size title,weight title,slant \
+ GridApplyDialog
+
+ # Border
+ menu $mb.border
+ $mb.border add checkbutton -label [msgcat::mc {Show}] \
+ -variable grid(border) -command GridApplyDialog
+ $mb.border add separator
+ $mb.border add cascade -label [msgcat::mc {Color}] -menu $mb.border.color
+ $mb.border add cascade -label [msgcat::mc {Line}] -menu $mb.border.line
+
+ ColorMenu $mb.border.color grid border,color GridApplyDialog
+ GridCreateLineMenu $mb.border.line border,width border,style
+
+ # Labels
+ set f [ttk::labelframe $w.label -text [msgcat::mc {Labels}] -padding 2]
+ ttk::label $f.label -text [msgcat::mc {Title}]
+ ttk::entry $f.title -textvariable grid(title,text) \
+ -width 60
+ ttk::checkbutton $f.default -text [msgcat::mc {Default}] \
+ -variable grid(title,def) -command GridApplyDialog
+ ttk::label $f.label1 -text "[msgcat::mc {Axis}] 1"
+ ttk::entry $f.title1 -textvariable grid(textlab,text1) \
+ -width 60
+ ttk::checkbutton $f.default1 -text [msgcat::mc {Default}] \
+ -variable grid(textlab,def1) -command GridApplyDialog
+ ttk::label $f.label2 -text "[msgcat::mc {Axis}] 2"
+ ttk::entry $f.title2 -textvariable grid(textlab,text2) \
+ -width 60
+ ttk::checkbutton $f.default2 -text [msgcat::mc {Default}] \
+ -variable grid(textlab,def2) -command GridApplyDialog
+
+ grid $f.label $f.title $f.default -padx 2 -pady 2 -sticky ew
+ grid $f.label1 $f.title1 $f.default1 -padx 2 -pady 2 -sticky ew
+ grid $f.label2 $f.title2 $f.default2 -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 1 -weight 1
+
+ # Params
+ set f [ttk::labelframe $w.param -text [msgcat::mc {Spacing}] -padding 2]
+ ttk::label $f.lspace -text "[msgcat::mc {Label}] %"
+ ttk::label $f.ngap -text "[msgcat::mc {Numerics}] %"
+ ttk::label $f.lformat -text [msgcat::mc {Format}]
+ ttk::label $f.lgap -text [msgcat::mc {Grid Gap}]
+
+ ttk::label $f.titlet -text [msgcat::mc {Title}]
+ ttk::entry $f.spacet -textvariable grid(title,gap) \
+ -width 8
+
+ ttk::label $f.title1 -text "[msgcat::mc {Axis}] 1"
+ ttk::entry $f.tspace1 -textvariable grid(textlab,gap1) -width 8
+ ttk::entry $f.nspace1 -textvariable grid(numlab,gap1) -width 8
+ ttk::entry $f.format1 -textvariable grid(format1) -width 8
+ ttk::entry $f.gap1 -textvariable grid(grid,gap1) -width 8
+ ttk::label $f.gapunit1 -textvariable grid(grid,gapunit1)
+
+ ttk::label $f.title2 -text "[msgcat::mc {Axis}] 2"
+ ttk::entry $f.tspace2 -textvariable grid(textlab,gap2) -width 8
+ ttk::entry $f.nspace2 -textvariable grid(numlab,gap2) -width 8
+ ttk::entry $f.format2 -textvariable grid(format2) -width 8
+ ttk::entry $f.gap2 -textvariable grid(grid,gap2) -width 8
+ ttk::label $f.gapunit2 -textvariable grid(grid,gapunit2)
+
+ ttk::label $f.title3 -text "[msgcat::mc {Axis}] 3"
+ ttk::entry $f.nspace3 -textvariable grid(numlab,gap3) -width 8
+ ttk::entry $f.format3 -textvariable grid(format3) -width 8
+ ttk::entry $f.gap3 -textvariable grid(grid,gap3) -width 8
+ ttk::label $f.gapunit3 -textvariable grid(grid,gapunit3)
+
+ grid x $f.lspace $f.ngap $f.lformat $f.lgap -padx 2 -pady 2 -sticky w
+ grid $f.titlet $f.spacet -padx 2 -pady 2 -sticky w
+ grid $f.title1 $f.tspace1 $f.nspace1 $f.format1 $f.gap1 $f.gapunit1 \
+ -padx 2 -pady 2 -sticky w
+ grid $f.title2 $f.tspace2 $f.nspace2 $f.format2 $f.gap2 $f.gapunit2 \
+ -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command GridApplyDialog
+ ttk::button $f.reset -text [msgcat::mc {Reset}] -command GridResetDialog
+ ttk::button $f.clear -text [msgcat::mc {Clear}] -command GridClearDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command GridDestroyDialog
+ pack $f.apply $f.reset $f.clear $f.close -side left -expand true \
+ -padx 2 -pady 4
+
+ bind $w <Return> "GridApplyDialog"
+
+ # Fini
+ grid $w.label -sticky news
+ grid $w.param -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ # some window managers need a hint
+ raise $w
+
+ UpdateGridDialog
+}
+
+proc GridApplyDialog {} {
+ global grid
+
+ set grid(view) 1
+ GridUpdateCurrent
+}
+
+proc GridResetDialog {} {
+ GridDefault
+ GridUpdateCurrent
+}
+
+proc GridClearDialog {} {
+ global grid
+
+ set grid(view) 0
+ GridUpdateCurrent
+}
+
+proc GridDestroyDialog {} {
+ global igrid
+
+ if {[winfo exists $igrid(top)]} {
+ destroy $igrid(top)
+ destroy $igrid(mb)
+ }
+}
+
+proc UpdateGridMenu {} {
+ global grid
+ global current
+ global wcs
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateGridMenu"
+ }
+
+ if {($current(frame) == {})} {
+ return
+ }
+
+ # set menu
+ if {[$current(frame) has fits]} {
+ set grid(view) [$current(frame) has grid]
+ }
+
+ # reassign system and format
+ if {[$current(frame) has fits] && [$current(frame) has grid]} {
+ set ll [$current(frame) get grid]
+ set grid(system) [lindex $ll 0]
+ set grid(sky) [lindex $ll 1]
+ set grid(skyformat) [lindex $ll 2]
+ set grid(type) [lindex $ll 3]
+
+ # fix for grids create with old backup command
+ if {[$current(frame) get grid var] == {}} {
+ $current(frame) grid delete
+ $current(frame) grid create $grid(system) $grid(sky) \
+ $grid(skyformat) $grid(type) \
+ [GridBuildOptions $current(frame)] "\"[array get grid]\""
+ }
+ array set grid [$current(frame) get grid var]
+ } else {
+ # can be changed by wcs
+ SetCoordSystem grid system sky skyformat
+ }
+}
+
+proc UpdateGridDialog {} {
+ global current
+ global igrid
+ global grid
+
+ set mb $igrid(mb)
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateGridDialog"
+ }
+
+ GridAdjustOptions $current(frame)
+
+ if {[winfo exists $igrid(top)]} {
+ set f $igrid(top).label
+ set g $igrid(top).param
+
+ if {$current(frame) != {}} {
+ switch -- [$current(frame) get type] {
+ base -
+ rgb {
+ $mb entryconfig [msgcat::mc {Labels}] -state normal
+ $mb entryconfig [msgcat::mc {Title}] -state normal
+ $mb.type entryconfig [msgcat::mc {Interior Numerics}] \
+ -state normal
+ $mb.type entryconfig [msgcat::mc {Exterior Numerics}] \
+ -state normal
+ $mb.type entryconfig [msgcat::mc {Vertical Text}] \
+ -state normal
+ $mb.axes entryconfig [msgcat::mc {Origin}] \
+ -state disable
+
+ $f.label configure -state normal
+ $f.title configure -state normal
+ $f.default configure -state normal
+ $f.label1 configure -state normal
+ $f.title1 configure -state normal
+ $f.default1 configure -state normal
+ $f.label2 configure -state normal
+ $f.title2 configure -state normal
+ $f.default2 configure -state normal
+
+ $g.lspace configure -state normal
+ $g.spacet configure -state normal
+ $g.tspace1 configure -state normal
+ $g.tspace2 configure -state normal
+
+ grid forget $g.title3 $g.nspace3 $g.format3 $g.gap3 \
+ $g.gapunit3
+ }
+ 3d {
+ $mb entryconfig [msgcat::mc {Labels}] -state disabled
+ $mb entryconfig [msgcat::mc {Title}] -state disabled
+ $mb.type entryconfig [msgcat::mc {Interior Numerics}] \
+ -state disabled
+ $mb.type entryconfig [msgcat::mc {Exterior Numerics}] \
+ -state disabled
+ $mb.type entryconfig [msgcat::mc {Vertical Text}] \
+ -state disabled
+ $mb.axes entryconfig [msgcat::mc {Origin}] -state normal
+
+ $f.label configure -state disabled
+ $f.title configure -state disabled
+ $f.default configure -state disabled
+ $f.label1 configure -state disabled
+ $f.title1 configure -state disabled
+ $f.default1 configure -state disabled
+ $f.label2 configure -state disabled
+ $f.title2 configure -state disabled
+ $f.default2 configure -state disabled
+
+ $g.lspace configure -state disabled
+ $g.spacet configure -state disabled
+ $g.tspace1 configure -state disabled
+ $g.tspace2 configure -state disabled
+
+ grid $g.title3 x $g.nspace3 $g.format3 $g.gap3 $g.gapunit3 \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+
+ set grid(frame) $current(frame)
+ if {[$current(frame) has fits]} {
+ CoordMenuEnable $igrid(mb).coord grid system 1 sky skyformat
+ } else {
+ CoordMenuReset $igrid(mb).coord grid system 1 sky skyformat
+ }
+ }
+ }
+}
+
+proc GridCreateLineMenu {which width dash} {
+ global igrid
+ global grid
+
+ WidthDashMenu $which grid $width $dash GridApplyDialog GridApplyDialog
+}
+
+proc GridLoadDialog {} {
+ GridLoad [OpenFileDialog gridfbox]
+}
+
+proc GridLoad {filename} {
+ global grid
+
+ if {$filename != {}} {
+ source $filename
+ }
+
+ # backward compatibility
+ FixFontVar grid(numlab,weight) grid(numlab,slant) grid(numlab,style)
+ FixFontVar grid(textlab,weight) grid(textlab,slant) grid(textlab,style)
+ FixFontVar grid(title,weight) grid(title,slant) grid(title,style)
+
+ set grid(view) 1
+ GridUpdateCurrent
+}
+
+proc GridSaveDialog {} {
+ GridSave [SaveFileDialog gridfbox]
+}
+
+proc GridSave {filename} {
+ global grid
+
+ if {$filename != {}} {
+ set file [open $filename w]
+ puts $file "global grid"
+ puts $file "array set grid \{ [array get grid] \}"
+ close $file
+ }
+}
+
+proc GridStripComma {str} {
+ # strip ','
+ set t {}
+ regsub -all "," "$str" " " t
+ return $t
+}
+
+proc GridDefaultFormat1 {} {
+ global grid
+ global current
+
+ switch $grid(system) {
+ image -
+ physical -
+ detector -
+ amplifier {return {}}
+ default {
+ if {[$current(frame) has wcs equatorial $grid(system)]} {
+ switch $grid(sky) {
+ fk4 -
+ fk5 -
+ icrs {
+ switch $grid(skyformat) {
+ degrees {return {d.3}}
+ sexagesimal {return {hms.1}}
+ hms {return {lhms.1}}
+ }
+ }
+ galactic -
+ ecliptic {
+ switch $grid(skyformat) {
+ degrees {return {d.3}}
+ sexagesimal {return {dms.1}}
+ hms {return {ldms}}
+ }
+ }
+ }
+ return {}
+ }
+ if {[$current(frame) has wcs celestrial $grid(system)]} {
+ switch $grid(skyformat) {
+ degrees {return {d.3}}
+ sexagesimal {return {dms.1}}
+ hms {return {ldms}}
+ }
+ return {}
+ }
+ }
+ }
+}
+
+proc GridDefaultFormat2 {} {
+ global grid
+ global current
+
+ switch $grid(system) {
+ image -
+ physical -
+ detector -
+ amplifier {return {}}
+ default {
+ if {[$current(frame) has wcs equatorial $grid(system)]} {
+ switch $grid(sky) {
+ fk4 -
+ fk5 -
+ icrs {
+ switch $grid(skyformat) {
+ degrees {return {d.3}}
+ sexagesimal {return {dms.1}}
+ hms {return {ldms.1}}
+ }
+ }
+ galactic -
+ ecliptic {
+ switch $grid(skyformat) {
+ degrees {return {d.3}}
+ sexagesimal {return {dms.1}}
+ hms {return {ldms}}
+ }
+ }
+ }
+ return {}
+ }
+ if {[$current(frame) has wcs celestrial $grid(system)]} {
+ switch $grid(skyformat) {
+ degrees {return {d.3}}
+ sexagesimal {return {dms.1}}
+ hms {return {ldms}}
+ }
+ return {}
+ }
+ }
+ }
+}
+
+proc GridBackup {ch which} {
+ global grid
+
+ if {[$which has grid]} {
+ set ll [$which get grid]
+ set system [lindex $ll 0]
+ set sky [lindex $ll 1]
+ set skyformat [lindex $ll 2]
+ set type [lindex $ll 3]
+ set opts [$which get grid option]
+ set vars [array get grid]
+
+ puts $ch "$which grid create $system $sky $skyformat $type \{\"$opts\"\} \{\"$vars\"\}"
+ }
+}
+
+# Process Cmds
+
+proc ProcessGridCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global grid
+ switch -- [string tolower [lindex $var $i]] {
+ open {GridDialog}
+ close {GridDestroyDialog}
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ set grid(view) [FromYesNo [lindex $var $i]]
+ GridUpdateCurrent
+ }
+
+ type {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ axes {
+ # backward compatible
+ incr i; set grid(axes,type) [lindex $var $i]
+ }
+ numerics {
+ # backward compatible
+ incr i; set grid(numlab,type) [lindex $var $i]
+ }
+ default {set grid(type) [lindex $var $i]}
+ }
+ GridUpdateCurrent
+ }
+
+ system {incr i; set grid(system) [lindex $var $i]; GridUpdateCurrent}
+ sky {incr i
+ set grid(sky) [string tolower [lindex $var $i]]
+ GridUpdateCurrent
+ }
+ skyformat {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ deg -
+ degree -
+ degrees {set grid(skyformat) degrees}
+ default {set grid(skyformat) [string tolower [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ grid {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ color {incr i; set grid(grid,color) [lindex $var $i]}
+ width {incr i; set grid(grid,width) [lindex $var $i]}
+ style {incr i; set grid(grid,style) [lindex $var $i]}
+ gap1 {incr i; set grid(grid,gap1) [lindex $var $i]}
+ gap2 {incr i; set grid(grid,gap2) [lindex $var $i]}
+ gap3 {incr i; set grid(grid,gap3) [lindex $var $i]}
+ default {set grid(grid) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ axes {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ color {incr i; set grid(axes,color) [lindex $var $i]}
+ width {incr i; set grid(axes,width) [lindex $var $i]}
+ style {incr i; set grid(axes,style) [lindex $var $i]}
+ type {incr i; set grid(axes,type) [lindex $var $i]}
+ origin {incr i; set grid(axes,origin) [lindex $var $i]}
+ default {set grid(axes) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ format1 {
+ incr i; set grid(format1) [lindex $var $i]
+ GridUpdateCurrent
+ }
+ format2 {
+ incr i; set grid(format2) [lindex $var $i]
+ GridUpdateCurrent
+ }
+
+ tickmark -
+ tickmarks -
+ tick {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ color {incr i; set grid(tick,color) [lindex $var $i]}
+ width {incr i; set grid(tick,width) [lindex $var $i]}
+ style {incr i; set grid(tick,style) [lindex $var $i]}
+ default {set grid(tick) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ border {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ color {incr i; set grid(border,color) [lindex $var $i]}
+ width {incr i; set grid(border,width) [lindex $var $i]}
+ style {incr i; set grid(border,style) [lindex $var $i]}
+ default {set grid(border) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ numeric -
+ numerics -
+ numlab {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ font {incr i; set grid(numlab,font) [lindex $var $i]}
+ fontsize {incr i; set grid(numlab,size) [lindex $var $i]}
+ fontweight {incr i; set grid(numlab,weight) [lindex $var $i]}
+ fontslant {incr i; set grid(numlab,slant) [lindex $var $i]}
+ fontstyle {
+ incr i
+ switch [lindex $var $i] {
+ normal {
+ set grid(numlab,weight) normal
+ set grid(numlab,slant) roman
+ }
+ bold {
+ set grid(numlab,weight) bold
+ set grid(numlab,slant) roman
+ }
+ italic {
+ set grid(numlab,weight) normal
+ set grid(numlab,slant) italic
+ }
+ }
+ }
+ color {incr i; set grid(numlab,color) [lindex $var $i]}
+ gap1 {incr i; set grid(numlab,gap1) [lindex $var $i]}
+ gap2 {incr i; set grid(numlab,gap2) [lindex $var $i]}
+ gap3 {incr i; set grid(numlab,gap3) [lindex $var $i]}
+ type {incr i; set grid(numlab,type) [lindex $var $i]}
+ vertical {incr i; set grid(numlab,vertical) [FromYesNo [lindex $var $i]]}
+ default {set grid(numlab) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ title {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ text {incr i; set grid(title,text) [lindex $var $i]}
+ def {incr i; set grid(title,def) [FromYesNo [lindex $var $i]]}
+ gap {incr i; set grid(title,gap) [lindex $var $i]}
+ font {incr i; set grid(title,font) [lindex $var $i]}
+ fontsize {incr i; set grid(title,size) [lindex $var $i]}
+ fontweight {incr i; set grid(title,weight) [lindex $var $i]}
+ fontslant {incr i; set grid(title,slant) [lindex $var $i]}
+ fontstyle {
+ incr i
+ switch [lindex $var $i] {
+ normal {
+ set grid(title,weight) normal
+ set grid(title,slant) roman
+ }
+ bold {
+ set grid(title,weight) bold
+ set grid(title,slant) roman
+ }
+ italic {
+ set grid(title,weight) normal
+ set grid(title,slant) italic
+ }
+ }
+ }
+ color {incr i; set grid(title,color) [lindex $var $i]}
+ default {set grid(title) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ label -
+ labels -
+ textlab {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ text1 {incr i; set grid(textlab,text1) [lindex $var $i]}
+ text2 {incr i; set grid(textlab,text2) [lindex $var $i]}
+ def1 {incr i; set grid(textlab,def1) [FromYesNo [lindex $var $i]]}
+ def2 {incr i; set grid(textlab,def2) [FromYesNo [lindex $var $i]]}
+ gap1 {incr i; set grid(textlab,gap1) [lindex $var $i]}
+ gap2 {incr i; set grid(textlab,gap2) [lindex $var $i]}
+ font {incr i; set grid(textlab,font) [lindex $var $i]}
+ fontsize {incr i; set grid(textlab,size) [lindex $var $i]}
+ fontweight {incr i; set grid(textlab,weight) [lindex $var $i]}
+ fontslant {incr i; set grid(textlab,slant) [lindex $var $i]}
+ fontstyle {
+ incr i
+ switch [lindex $var $i] {
+ normal {
+ set grid(textlab,weight) normal
+ set grid(textlab,slant) roman
+ }
+ bold {
+ set grid(textlab,weight) bold
+ set grid(textlab,slant) roman
+ }
+ italic {
+ set grid(textlab,weight) normal
+ set grid(textlab,slant) italic
+ }
+ }
+ }
+ color {incr i; set grid(textlab,color) [lindex $var $i]}
+ default {set grid(textlab) [FromYesNo [lindex $var $i]]}
+ }
+ GridUpdateCurrent
+ }
+
+ view {
+ # backward compatable
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ grid {incr i; set grid(grid) [FromYesNo [lindex $var $i]]}
+ axes {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ numbers {incr i; set grid(numlab) \
+ [FromYesNo [lindex $var $i]]}
+ tickmarks {incr i; set grid(tick) \
+ [FromYesNo [lindex $var $i]]}
+ label {incr i; set grid(textlab) \
+ [FromYesNo [lindex $var $i]]}
+ default {set grid(axes) [FromYesNo [lindex $var $i]]}
+ }
+ }
+ title {incr i; set grid(title) [FromYesNo [lindex $var $i]]}
+ border {incr i; set grid(border) [FromYesNo [lindex $var $i]]}
+ vertical {
+ incr i
+ set grid(numlab,vertical) [FromYesNo [lindex $var $i]]
+ }
+ }
+ GridUpdateCurrent
+ }
+
+ reset {GridResetDialog}
+ load {
+ incr i
+ set fn [lindex $var $i]
+ FileLast gridfbox $fn
+
+ GridLoad $fn
+ }
+ save {
+ incr i
+ set fn [lindex $var $i]
+ FileLast gridfbox $fn
+
+ GridSave $fn
+ }
+ default {
+ set grid(view) 1
+ GridUpdateCurrent
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendGridCmd {proc id param} {
+ global grid
+
+ switch -- [lindex $param 0] {
+ type {
+ switch -- [lindex $param 1] {
+ axes {
+ # backward compatible
+ $proc $id "$grid(axes,type)\n"
+ }
+ numerics {
+ # backward compatible
+ $proc $id "$grid(numlab,type)\n"
+ }
+ default {$proc $id "$grid(type)\n"}
+ }
+ }
+
+ system {$proc $id "$grid(system)\n"}
+ sky {$proc $id "$grid(sky)\n"}
+ skyformat {$proc $id "$grid(skyformat)\n"}
+
+ grid {
+ switch -- [lindex $param 1] {
+ color {$proc $id "$grid(grid,color)\n"}
+ width {$proc $id "$grid(grid,width)\n"}
+ style {$proc $id "$grid(grid,style)\n"}
+ gap1 {$proc $id "$grid(grid,gap1)\n"}
+ gap2 {$proc $id "$grid(grid,gap2)\n"}
+ gap3 {$proc $id "$grid(grid,gap3)\n"}
+ default {$proc $id [ToYesNo $grid(grid)]}
+ }
+ }
+
+ axes {
+ switch -- [lindex $param 1] {
+ color {$proc $id "$grid(axes,color)\n"}
+ width {$proc $id "$grid(axes,width)\n"}
+ style {$proc $id "$grid(axes,style)\n"}
+ type {$proc $id "$grid(axes,type)\n"}
+ origin {$proc $id "$grid(axes,origin)\n"}
+ default {$proc $id [ToYesNo $grid(axes)]}
+ }
+ }
+
+ format1 {$proc $id "$grid(format1)\n"}
+ format2 {$proc $id "$grid(format2)\n"}
+
+ tickmark -
+ tickmarks -
+ tick {
+ switch -- [lindex $param 1] {
+ color {$proc $id "$grid(tick,color)\n"}
+ width {$proc $id "$grid(tick,width)\n"}
+ style {$proc $id "$grid(tick,style)\n"}
+ default {$proc $id [ToYesNo $grid(tick)]}
+ }
+ }
+
+ border {
+ switch -- [lindex $param 1] {
+ color {$proc $id "$grid(border,color)\n"}
+ width {$proc $id "$grid(border,width)\n"}
+ style {$proc $id "$grid(border,style)\n"}
+ default {$proc $id [ToYesNo $grid(border)]}
+ }
+ }
+
+ numeric -
+ numerics -
+ numlab {
+ switch -- [lindex $param 1] {
+ font {$proc $id "$grid(numlab,font)\n"}
+ fontsize {$proc $id "$grid(numlab,size)\n"}
+ fontstyle -
+ fontweight {$proc $id "$grid(numlab,weight)\n"}
+ fontslant {$proc $id "$grid(numlab,slant)\n"}
+ color {$proc $id "$grid(numlab,color)\n"}
+ gap1 {$proc $id "$grid(numlab,gap1)\n"}
+ gap2 {$proc $id "$grid(numlab,gap2)\n"}
+ gap3 {$proc $id "$grid(numlab,gap3)\n"}
+ type {$proc $id "$grid(numlab,type)\n"}
+ vertical {$proc $id "$grid(numlab,vertical)\n"}
+ default {$proc $id [ToYesNo $grid(numlab)]}
+ }
+ }
+
+ title {
+ switch -- [lindex $param 1] {
+ text {$proc $id "$grid(title,text)\n"}
+ def {$proc $id [ToYesNo $grid(title,def)]}
+ gap {$proc $id "$grid(title,gap)\n"}
+ font {$proc $id "$grid(title,font)\n"}
+ fontsize {$proc $id "$grid(title,size)\n"}
+ fontstyle -
+ fontweight {$proc $id "$grid(title,weight)\n"}
+ fontslant {$proc $id "$grid(title,slant)\n"}
+ color {$proc $id "$grid(title,color)\n"}
+ default {$proc $id [ToYesNo $grid(title)]}
+ }
+ }
+
+ label -
+ labels -
+ textlab {
+ switch -- [lindex $param 1] {
+ text1 {$proc $id "$grid(textlab,text1)\n"}
+ text2 {$proc $id "$grid(textlab,text2)\n"}
+ def1 {$proc $id [ToYesNo $grid(textlab,def1)]}
+ def2 {$proc $id [ToYesNo $grid(textlab,def2)]}
+ gap1 {$proc $id "$grid(textlab,gap1)\n"}
+ gap2 {$proc $id "$grid(textlab,gap2)\n"}
+ font {$proc $id "$grid(textlab,font)\n"}
+ fontsize {$proc $id "$grid(textlab,size)\n"}
+ fontstyle -
+ fontweight {$proc $id "$grid(textlab,weight)\n"}
+ fontslant {$proc $id "$grid(textlab,slant)\n"}
+ color {$proc $id "$grid(textlab,color)\n"}
+ default {$proc $id [ToYesNo $grid(textlab)]}
+ }
+ }
+
+ view {
+ # backward compatible
+ switch -- [lindex $param 1] {
+ grid {$proc $id [ToYesNo $grid(grid)]}
+ axes {
+ switch -- [lindex $param 2] {
+ numbers {$proc $id [ToYesNo $grid(numlab)]}
+ tickmarks {$proc $id [ToYesNo $grid(tick)]}
+ label {$proc $id [ToYesNo $grid(textlab)]}
+ default {$proc $id [ToYesNo $grid(axes)]}
+ }
+ }
+ title {$proc $id [ToYesNo $grid(title)]}
+ border {$proc $id [ToYesNo $grid(border)]}
+ vertical {$proc $id [ToYesNo $grid(numlab,vertical)]}
+ }
+ }
+ default {$proc $id [ToYesNo $grid(view)]}
+ }
+}
diff --git a/ds9/library/group.tcl b/ds9/library/group.tcl
new file mode 100644
index 0000000..95bb524
--- /dev/null
+++ b/ds9/library/group.tcl
@@ -0,0 +1,208 @@
+# 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 GroupDef {} {
+ global igroup
+ global dgroup
+
+ set igroup(top) .grp
+ set igroup(mb) .grpmb
+
+ set dgroup(list) {}
+}
+
+proc GroupCreate {} {
+ global current
+
+ if {$current(frame) != {}} {
+ set name [$current(frame) get marker tag default name]
+ if {[EntryDialog [msgcat::mc {New Group}] [msgcat::mc {Enter Group Name}] 30 name]} {
+ $current(frame) marker tag "\{$name\}"
+ UpdateGroupDialog
+ }
+ }
+}
+
+proc GroupCreateSilent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ set name [$current(frame) get marker tag default name]
+ $current(frame) marker tag "\{$name\}"
+ UpdateGroupDialog
+ }
+}
+
+proc GroupDialog {} {
+ global ds9
+ global igroup
+ global dgroup
+
+ # see if we already have a window visible
+ if {[winfo exists $igroup(top)]} {
+ raise $igroup(top)
+ return
+ }
+
+ # create the window
+ set w $igroup(top)
+ set mb $igroup(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Groups}] GroupDestroyDialog
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Update Group}] \
+ -command GroupUpdateDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {New Group}] \
+ -command GroupCreate
+ $mb.file add command -label [msgcat::mc {Edit Group Name}] \
+ -command GroupEditDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Delete Group}] \
+ -command GroupDeleteDialog
+ $mb.file add command -label [msgcat::mc {Delete All Groups}] \
+ -command GroupDeleteAllDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command GroupDestroyDialog
+
+ # List
+ set f [ttk::frame $w.param]
+
+ ttk::scrollbar $f.scroll -command [list $f.box yview] -orient vertical
+ set dgroup(list) [listbox $f.box \
+ -yscroll [list $f.scroll set] \
+ -setgrid true \
+ -selectmode multiple \
+ ]
+ grid $f.box $f.scroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ bind $dgroup(list) <<ListboxSelect>> GroupButtonDialog
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.update -text [msgcat::mc {Update}] \
+ -command GroupUpdateDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command GroupDestroyDialog
+ pack $f.update $f.close -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 -fill both -expand true
+
+ UpdateGroupDialog
+}
+
+proc GroupButtonDialog {} {
+ global dgroup
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker unselect all
+ set rr [$dgroup(list) curselection]
+ foreach ii $rr {
+ if {[string length $ii] != 0} {
+ $current(frame) marker "\{[$dgroup(list) get $ii]\}" select
+ }
+ }
+ }
+}
+
+proc GroupDestroyDialog {} {
+ global igroup
+
+ if {[winfo exists $igroup(top)]} {
+ destroy $igroup(top)
+ destroy $igroup(mb)
+ }
+}
+
+proc GroupUpdateDialog {} {
+ global dgroup
+ global current
+
+ if {$current(frame) != {}} {
+ set ll [$dgroup(list) curselection]
+ if {[string length $ll] != 0} {
+ $current(frame) marker tag update "\{[$dgroup(list) get $ll]\}"
+ }
+ }
+}
+
+proc GroupEditDialog {} {
+ global dgroup
+ global current
+
+ if {$current(frame) != {}} {
+ set i [$dgroup(list) curselection]
+ if {[string length $i] != 0} {
+ set which [$dgroup(list) get $i]
+ if {[EntryDialog [msgcat::mc {Group Name}] [msgcat::mc {Enter Group Name}] 40 which]} {
+ $current(frame) marker tag edit "\{[$dgroup(list) get $i]\}" "\{$which\}"
+ UpdateGroupDialog
+ }
+ }
+ }
+}
+
+proc GroupDeleteDialog {} {
+ global dgroup
+ global current
+
+ if {$current(frame) != {}} {
+ set i [$dgroup(list) curselection]
+ if {[string length $i] != 0} {
+ set which [$dgroup(list) get $i]
+ $current(frame) marker tag delete "\{$which\}"
+ UpdateGroupDialog
+ }
+ }
+}
+
+proc GroupDeleteAllDialog {} {
+ global current
+ global pds9
+
+ if {$current(frame) != {}} {
+ if {$pds9(confirm)} {
+ if {[tk_messageBox -type okcancel -icon question -message \
+ [msgcat::mc {Delete All Groups?}]] != {ok}} {
+ return
+ }
+ }
+ $current(frame) marker tag delete all
+ UpdateGroupDialog
+ }
+}
+
+proc UpdateGroupDialog {} {
+ global igroup
+ global dgroup
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateGroupDialog"
+ }
+
+ if {[winfo exists $igroup(top)]} {
+ # clear the list
+ $dgroup(list) delete 0 end
+
+ if {$current(frame) != {}} {
+ set grps [lsort [$current(frame) get marker tag all]]
+ foreach f $grps {
+ $dgroup(list) insert end $f
+ }
+ }
+ }
+}
diff --git a/ds9/library/header.tcl b/ds9/library/header.tcl
new file mode 100644
index 0000000..e07b3d8
--- /dev/null
+++ b/ds9/library/header.tcl
@@ -0,0 +1,195 @@
+# 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 DisplayHeaderMenu {} {
+ global current
+
+ # possible cases
+ # image primary
+ # image xtension
+ # compressed primary
+ # compressed xtension
+ # bin table xtension
+ # hpx xtension
+ # cube primary
+ # cube xtension
+ # multiple xtension cube
+ # multiple file cube
+ # mosaic extension
+ # mosaic image xtension
+ # mosaic cube xtension
+ # mosaic image cube xtension
+
+ set cnt [$current(frame) get fits count]
+
+ if {$cnt > 0} {
+ set slb(count) 0
+
+ # check for primary
+ set fn [$current(frame) get fits file name 1]
+ set xten \
+ [string trim [$current(frame) get fits header 1 keyword {XTENSION}]]
+ if {$xten != {}} {
+ set bb [string first {[} $fn]
+ if {$bb>0} {
+ set pn [string range $fn 0 [expr $bb-1]]
+ } else {
+ set pn "primary"
+ }
+ incr slb(count)
+ set slb($slb(count),item) $pn
+ set slb($slb(count),value) -1
+ }
+
+ set last {}
+ for {set ii 1} {$ii <= $cnt} {incr ii} {
+ set fn [$current(frame) get fits file name $ii]
+ set bb [string first {[} $fn]
+ if {$bb<0} {
+ set nn [$current(frame) get fits ext $ii]
+ if {$nn > 0} {
+ set fn "$fn\[\]"
+ }
+ }
+
+ if {$fn != $last} {
+ incr slb(count)
+ set slb($slb(count),item) $fn
+ set slb($slb(count),value) $ii
+ set last $fn
+ }
+ }
+
+ if {$slb(count) <= 1} {
+ DisplayHeader $current(frame) 1 $fn
+ } else {
+ if {[SLBDialog slb {Select Header} 40]} {
+ DisplayHeader $current(frame) $slb(value) $slb(item)
+ }
+ }
+ }
+}
+
+proc DisplayHeader {frame id title} {
+ global current
+
+ set varname "hd-$frame-$id"
+ upvar #0 $varname var
+ global $varname
+
+ SimpleTextDialog $varname $title 80 40 insert top \
+ [$current(frame) get fits header $id]
+
+ # create a special text tag for keywords
+ $var(text) tag configure keyword -foreground blue
+
+ # color tag keywords
+ set stop [$var(text) index end]
+ for {set ii 1.0} {$ii<$stop} {set ii [expr $ii+1]} {
+ $var(text) tag add keyword $ii "$ii +8 chars"
+ }
+}
+
+proc UpdateHeaderDialog {} {
+ global current
+
+ set frame $current(frame)
+ set cnt 1
+ if {[$frame has fits mosaic]} {
+ set cnt [$frame get fits count]
+ }
+
+ for {set id 1} {$id <= $cnt} {incr id} {
+ set varname "hd-$frame-$id"
+ upvar #0 $varname var
+ global $varname
+ if {![info exists var(top)]} {
+ continue
+ }
+ if {![winfo exists $var(top)]} {
+ continue
+ }
+
+ $var(text) delete 1.0 end
+ $var(text) insert end [$frame get fits header $id]
+
+ # color tag keywords
+ set stop [$var(text) index end]
+ for {set ii 1.0} {$ii<$stop} {set ii [expr $ii+1]} {
+ $var(text) tag add keyword $ii "$ii +8 chars"
+ }
+ }
+}
+
+proc DestroyHeader {frame} {
+ set cnt 1
+ if {[$frame has fits mosaic]} {
+ set cnt [$frame get fits count]
+ }
+
+ for {set id 1} {$id <= $cnt} {incr id} {
+ set varname "hd-$frame-$id"
+ upvar #0 $varname var
+ global $varname
+
+ if {[info exists $varname]} {
+ if {[winfo exists $var(top)]} {
+ SimpleTextDestroy $varname
+ }
+ }
+ }
+}
+
+proc ProcessHeaderCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ close -
+ save {incr i}
+ }
+
+ if {[lindex $var $i] != {} && [string is integer [lindex $var $i]]} {
+ set jj [lindex $var $i]
+ incr i
+ } else {
+ set jj 1
+ }
+
+ global current
+ if {$current(frame) != {}} {
+ switch -- $item {
+ close {
+ set vvarname "hd[string range $current(frame) end end]-$jj"
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists vvar(top)]} {
+ SimpleTextDestroy $vvarname
+ }
+ incr i -1
+ }
+ save {
+ set fn [lindex $var $i]
+ if {$fn != {}} {
+ if {[catch {set ch [open "| cat > \"$fn\"" w]}]} {
+ Error [msgcat::mc {An error has occurred while saving}]
+ return
+ }
+ puts -nonewline $ch [$current(frame) get fits header $jj]
+ close $ch
+ }
+ }
+ default {
+ catch {DisplayHeader $current(frame) $jj \
+ [$current(frame) get fits file name $jj]}
+ incr i -1
+ }
+ }
+ }
+}
+
diff --git a/ds9/library/help.tcl b/ds9/library/help.tcl
new file mode 100644
index 0000000..8705678
--- /dev/null
+++ b/ds9/library/help.tcl
@@ -0,0 +1,85 @@
+# 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 HelpDef {} {
+ global help
+ global ds9
+
+ set help(refman) "$ds9(root)/doc/ref/index.html"
+ set help(command) "$ds9(root)/doc/ref/command.html"
+ set help(userman) "$ds9(root)/doc/user/index.html"
+ set help(keyboard) "$ds9(root)/doc/ref/keyboard.html"
+ set help(faq) "$ds9(root)/doc/faq.html"
+ set help(new) "$ds9(root)/doc/new.html"
+ set help(release) "$ds9(root)/doc/release/r7.0.html"
+ set help(helpdesk) "$ds9(root)/doc/helpdesk.html"
+ set help(story) "$ds9(root)/doc/story.html"
+ set help(ack) "$ds9(root)/doc/acknowledgment.html"
+ set help(vo) "$ds9(root)/doc/ref/vo.html"
+
+ set help(authors) "William Joye (Smithsonian Astrophysical Observatory)\nEric Mandel (Smithsonian Astrophysical Observatory)\nSteve Murray (Smithsonian Astrophysical Observatory)\n"
+ set help(about) "SAOImage DS9\nVersion $ds9(version)\n\nAuthors\n$help(authors)\nSAOImage DS9 development has been made possible by funding from NASA's Applied Information Systems Research Program, Chandra X-ray Science Center (CXC), and the High Energy Astrophysics Science Archive Center (HEASARC). Additional funding was provided by the JWST Mission office at Space Telescope Science Institute to improve capabilities for 3D data visualization.\n\nColormaps\nh5utils: Steven Johnson (MIT)\nViridis: Eric Firing (UW)\nCubehelix: Dave Green (Cavendish)\nGist: David Munro (LLNL)\nTopographic: Tom Patterson (US National Park Service) "
+}
+
+proc HelpRef {} {
+ global help
+ HV hlpref [msgcat::mc {Reference Manual}] $help(refman)
+}
+
+proc HelpCommand {} {
+ global help
+ HV hlpcmd [msgcat::mc {Command}] $help(command)
+}
+
+proc HelpUser {} {
+ global help
+ HV hlpuser [msgcat::mc {User Manual}] $help(userman)
+}
+
+proc HelpKeyboard {} {
+ global help
+ HV hlpkeyboard [msgcat::mc {Keyboard Shortcuts}] $help(keyboard)
+}
+
+proc HelpFAQ {} {
+ global help
+ HV hlpfaq [msgcat::mc {FAQ}] $help(faq)
+}
+
+proc HelpNew {} {
+ global help
+ HV hlpnew [msgcat::mc {New Features}] $help(new)
+}
+
+proc HelpRelease {} {
+ global help
+ HV hlprelease [msgcat::mc {Release Notes}] $help(release)
+}
+
+proc HelpDesk {} {
+ global help
+ HV hlpdsk [msgcat::mc {Help Desk}] $help(helpdesk)
+}
+
+proc HelpStory {} {
+ global help
+ HV hlpstory [msgcat::mc {Story of SAOImage DS9}] $help(story)
+}
+
+proc HelpAck {} {
+ global help
+ HV hlpack [msgcat::mc {Acknowledgment}] $help(ack)
+}
+
+proc HelpVO {} {
+ global help
+ HV hlvo [msgcat::mc {Virtual Observatory}] $help(vo)
+}
+
+proc ProcessSendAboutCmd {proc id param sock fn} {
+ global help
+ ProcessSend $proc $id $sock $fn {.txt} "$help(about)\n"
+}
diff --git a/ds9/library/htp.tcl b/ds9/library/htp.tcl
new file mode 100644
index 0000000..42fd919
--- /dev/null
+++ b/ds9/library/htp.tcl
@@ -0,0 +1,22 @@
+# Needed because some sites return 'x-fits' (CADC) in Content-Encoding
+proc http::ContentEncoding {token} {
+ upvar 0 $token state
+ set r {}
+ if {[info exists state(coding)]} {
+ foreach coding [split $state(coding) ,] {
+ switch -exact -- $coding {
+ deflate { lappend r inflate }
+ gzip - x-gzip { lappend r gunzip }
+ compress - x-compress { lappend r decompress }
+ identity {}
+ x-fits {}
+ default {
+# just do nothing
+# return -code error "unsupported content-encoding \"$coding\""
+ }
+ }
+ }
+ }
+ return $r
+}
+
diff --git a/ds9/library/http.tcl b/ds9/library/http.tcl
new file mode 100644
index 0000000..adb162c
--- /dev/null
+++ b/ds9/library/http.tcl
@@ -0,0 +1,54 @@
+# 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 HTTPDef {} {
+ global ihttp
+ global phttp
+
+ # 1 minute
+ set ihttp(timeout) 60000
+
+ # prefs only
+ set phttp(proxy) 0
+ set phttp(proxy,host) {}
+ set phttp(proxy,port) {}
+ set phttp(auth) 0
+ set phttp(auth,user) {}
+ set phttp(auth,passwd) {}
+}
+
+proc PrefsDialogHTTP {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {HTTP}]
+ lappend dprefs(tabs) [ttk::frame $w.http]
+
+ set f [ttk::labelframe $w.http.params -text [msgcat::mc {HTTP}]]
+
+ ttk::label $f.tproxy -text [msgcat::mc {Use Proxy}]
+ ttk::checkbutton $f.proxy -variable phttp(proxy)
+ ttk::label $f.thost -text [msgcat::mc {Proxy Host}]
+ ttk::entry $f.host -textvariable phttp(proxy,host) -width 50
+ ttk::label $f.tport -text [msgcat::mc {Proxy Port}]
+ ttk::entry $f.port -textvariable phttp(proxy,port) -width 10
+ ttk::label $f.tauth -text [msgcat::mc {Use Authentication}]
+ ttk::checkbutton $f.auth -variable phttp(auth)
+ ttk::label $f.tuser -text [msgcat::mc {Username}]
+ ttk::entry $f.user -textvariable phttp(auth,user) -width 30
+ ttk::label $f.tpasswd -text [msgcat::mc {Password}]
+ ttk::entry $f.passwd -textvariable phttp(auth,passwd) -show "*" -width 10
+
+ grid $f.tproxy $f.proxy -padx 2 -pady 2 -sticky w
+ grid $f.thost $f.host -padx 2 -pady 2 -sticky w
+ grid $f.tport $f.port -padx 2 -pady 2 -sticky w
+ grid $f.tauth $f.auth -padx 2 -pady 2 -sticky w
+ grid $f.tuser $f.user -padx 2 -pady 2 -sticky w
+ grid $f.tpasswd $f.passwd -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
diff --git a/ds9/library/hv.tcl b/ds9/library/hv.tcl
new file mode 100644
index 0000000..b4d5307
--- /dev/null
+++ b/ds9/library/hv.tcl
@@ -0,0 +1,931 @@
+# 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 HVDef {} {
+ global ihv
+
+ set ihv(unique) 0
+ set ihv(windows) {}
+}
+
+# Public
+
+proc HV {varname title url {init {}} {sync 0}} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global ihv
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HV $varname $title $url $init $sync"
+ }
+
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+
+ set w $var(top)
+ set mb $var(mb)
+
+ # see if we already have a window visible
+
+ if {[winfo exists $w]} {
+ raise $w
+ } else {
+ # add it to our xpa list
+ lappend ihv(windows) $varname
+
+ set var(widget) {}
+ set var(status) {}
+ set var(sync) $sync
+ set var(frame) new
+ set var(save) 0
+ set var(title) "$title"
+ set var(copy) {}
+ set var(search) {}
+ set var(search,start) 0
+
+ set var(active) 0
+ set var(index) 0
+ set var(font) $ds9(times)
+ switch $ds9(wm) {
+ x11 {set var(font,size) 10}
+ aqua {set var(font,size) 16}
+ win32 {set var(font,size) 14}
+ }
+ set var(font,weight) normal
+ set var(font,slant) roman
+ set var(init) $init
+ set var(cookies) {}
+
+ set var(images,forward) ${varname}forward
+ set var(images,back) ${varname}back
+ set var(images,reload) ${varname}reload
+ set var(images,stop) ${varname}stop
+ set var(images,gray) ${varname}gray
+
+ # init some vars
+ HVClearAll $varname
+ set var(delete) 0
+
+ # create window
+ Toplevel $w $mb 7 $title "HVDestroy $varname"
+
+ $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 {View}] -menu $mb.view
+ $mb add cascade -label [msgcat::mc {Frame}] -menu $mb.frame
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Open URL}] \
+ -command "HVURLDialogCmd $varname"
+ $mb.file add command -label [msgcat::mc {Open File}] \
+ -command "HVFileDialogCmd $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Clear}] \
+ -command "HVClearCmd $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command "HVDestroy $varname"
+
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -state disabled -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command "HVCopyCmd $varname" -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -state disabled -accelerator "${ds9(ctrl)}V"
+ $mb.edit add separator
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $mb.edit add command -label "[msgcat::mc {Find}]..." \
+ -command "HVFindCmd $varname" -accelerator "${ds9(ctrl)}F"
+ }
+ aqua {
+ # Known bug in Tk, can't have dialogs invoked by accelerator
+ $mb.edit add command -label "[msgcat::mc {Find}]..." \
+ -command "HVFindCmd $varname"
+ }
+ }
+ $mb.edit add command -label [msgcat::mc {Find Next}] \
+ -command "HVFindNextCmd $varname" -accelerator "${ds9(ctrl)}G"
+ $mb.edit add separator
+ $mb.edit add command -label [msgcat::mc {Clear Cache}] \
+ -command "HVClearCache $varname"
+
+ menu $mb.view
+ $mb.view add command -label [msgcat::mc {Back}] \
+ -command "HVBackCmd $varname"
+ $mb.view add command -label [msgcat::mc {Forward}] \
+ -command "HVForwardCmd $varname"
+ $mb.view add separator
+ $mb.view add command -label [msgcat::mc {Stop}] \
+ -command "HVStopCmd $varname"
+ $mb.view add command -label [msgcat::mc {Reload}] \
+ -command "HVReloadCmd $varname"
+ $mb.view add separator
+ $mb.view add command -label [msgcat::mc {Page Source}] \
+ -command "HVPageSourceCmd $varname"
+
+ menu $mb.frame
+ $mb.frame add checkbutton \
+ -label [msgcat::mc {Save Image on Download}] \
+ -variable ${varname}(save)
+ $mb.frame add separator
+ $mb.frame add radiobutton \
+ -label [msgcat::mc {Create New Frame on Download}] \
+ -variable ${varname}(frame) -value new
+ $mb.frame add radiobutton \
+ -label [msgcat::mc {Use Current Frame on Download}] \
+ -variable ${varname}(frame) -value current
+
+ image create photo $var(images,back) -data {R0lGODlhDwANAKL/AM///8DAwJD//y/I/y+X/y9n/wAAAAAAACH5BAEAAAEALAAAAAAPAA0AAAM0GLq2/qE0+AqYVFmB6eZFKEoRIAyCaaYCYWxDLM9uYBAxoe/7dA8ug3AoZOg6mRsyuUxmEgA7}
+ image create photo $var(images,forward) -data {R0lGODlhDwANAKL/AM///8DAwJD//y/I/y+X/y9n/wAAAAAAACH5BAEAAAEALAAAAAAPAA0AAAM3GLpa/K8YSMuYlBVwV/kgCAhdsAFoig7ktA1wLA9SQdw4DkuB4f8/Ag2TMRB4GYUBmewRm09FAgA7}
+ image create photo $var(images,stop) -data {R0lGODlhDQANALP/AP///1Lq81I5Of+EhCEAAHsAAMYAAP+UQv9zCHuMjP8AMf8AKf+MnK1CSv8QIQAAACH5BAEAAAEALAAAAAANAA0AAARWMMjUTC1J6ubOQYdiCBuIIMuiiCT1OWu6Ys05AMPC4ItBGB8dYMdI+RoHR4qY6v1CwlvRcEQ4brndwFAgJAwIRdPIzVTEYiqXJBEU1FQCW5Mg2O0ZSQQAOw==}
+ image create photo $var(images,reload) -data {R0lGODlhDAANALP/AP///zk5OVJSUoSEhKWlpcDAwP//1v//xr3erZTOezGcEFKtSimce3NzezkxOQAAACH5BAEAAAUALAAAAAAMAA0AAARRcJBJyRilEMC5AcjQaB1wHMYkCFuXLKDQONsBLIuynEBAGAcJAnYy0AyGBOLENPg4qGUISTMdEIoEg4A6ohK6BND4YyqBqCdyve453vB44BEBADs=}
+
+ image create photo $var(images,gray) -data {R0lGODdhPAA+APAAALi4uAAAACwAAAAAPAA+AAACQISPqcvtD6OctNqLs968+w+G4kiW5omm6sq27gvH8kzX9o3n+s73/g8MCofEovGITCqXzKbzCY1Kp9Sq9YrNFgsAO}
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.back -image $var(images,back) -takefocus 0 \
+ -command "HVBackCmd $varname"
+ ttk::button $f.forward -image $var(images,forward) -takefocus 0 \
+ -command "HVForwardCmd $varname"
+ ttk::button $f.stop -image $var(images,stop) -takefocus 0 \
+ -command "HVStopCmd $varname"
+ ttk::button $f.reload -image $var(images,reload) -takefocus 0 \
+ -command "HVReloadCmd $varname"
+ pack $f.back $f.forward $f.stop $f.reload -side left
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ set var(widget) [html $f.html \
+ -yscrollcommand "$f.yscroll set" \
+ -xscrollcommand "$f.xscroll set" \
+ -padx 5 \
+ -pady 9 \
+ -formcommand "HVFormCB $varname" \
+ -imagecommand "HVImageCB $varname" \
+ -scriptcommand "HVScriptCB $varname"\
+ -appletcommand "HVAppletCB $varname" \
+ -framecommand "HVFrameCB $varname" \
+ -underlinehyperlinks 1 \
+ -bg white \
+ -width 640 \
+ -height 512 \
+ -fontcommand "HVFontCB $varname" \
+ -tablerelief raised \
+ ]
+
+ $var(widget) token handler {NOSCRIPT} "HVNoScriptCB $varname"
+ $var(widget) token handler {/NOSCRIPT} "HVNoScriptCB $varname"
+
+ ttk::scrollbar $f.yscroll -orient vertical \
+ -command "$f.html yview"
+ ttk::scrollbar $f.xscroll -orient horizontal \
+ -command "$f.html xview"
+
+ grid $f.html $f.yscroll -sticky news
+ grid $f.xscroll -stick news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ bind $var(widget).x <Motion> "HVMotion $varname %x %y"
+ bind $var(widget).x <Button-1> "HVButton1 $varname %x %y"
+ bind $var(widget).x <B1-Motion> "HVMotion1 $varname %x %y"
+ bind $var(widget).x <ButtonRelease-1> "HVRelease1 $varname %x %y"
+
+ bind $w <Up> "$f.html yview scroll -1 units"
+ bind $w <Down> "$f.html yview scroll 1 units"
+ bind $w <Right> "$f.html xview scroll 1 units"
+ bind $w <Left> "$f.html xview scroll -1 units"
+ bind $w <<Copy>> "HVCopyCmd $varname"
+ switch $ds9(wm) {
+ x11 {
+ bind $w <Button-4> "HVMouseWheel $varname 1"
+ bind $w <Button-5> "HVMouseWheel $varname -1"
+ bind $w <<Find>> [list HVFindCmd $varname]
+ }
+ aqua {
+ bind $w <MouseWheel> "HVMouseWheel $varname %D"
+ # Known bug in Tk, can't have dialogs invoked by accelerator
+ }
+ win32 {
+ bind $w <MouseWheel> "HVMouseWheel $varname %D"
+ bind $w <<Find>> [list HVFindCmd $varname]
+ }
+ }
+ bind $w <<FindNext>> [list HVFindNextCmd $varname]
+
+ # Status
+ set f [ttk::frame $w.status]
+ ttk::label $f.status -textvariable ${varname}(status) \
+ -width 120 -anchor w
+ pack $f.status -side left
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ pack $w.status $w.sep -side bottom -fill x
+ pack $w.buttons -side top -fill x
+ pack $w.param -side top -fill both -expand true
+
+ # we have a problem with the html widget. first time thur, some
+ # structures are not allocated/initialized. if we first display
+ # a blank page, all seems ok
+ $var(widget) clear
+ $var(widget) parse "<html>\n<body>\n<form method=\"get\" action=\"foo\">\n</form>\n</body>\n</html>"
+
+ global debug
+ if {$debug(tcl,idletasks)} {
+ puts stderr "HV"
+ }
+ update idletasks
+ }
+
+ selection handle $w [list HVExportSelection $varname]
+
+ if {$url != {}} {
+ # no need to resolve
+ HVLoadURL $varname $url {} $var(sync)
+ }
+}
+
+# Bindings
+
+proc HVMotion {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ set url [$var(widget) href $x $y]
+
+ if {[string length $url] > 0} {
+ switch $ds9(wm) {
+ x11 -
+ win32 {$var(widget) configure -cursor hand2}
+ aqua {$var(widget) configure -cursor pointinghand}
+ }
+ } else {
+ $var(widget) configure -cursor {}
+ }
+
+ HVStatus $varname $url
+}
+
+proc HVButton1 {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVButton1"
+ }
+
+ $var(widget) selection clear
+ set var(sel,x) -1
+ set var(sel,y) -1
+
+ HVClearIndex $varname $var(index)
+
+ set url [$var(widget) href $x $y]
+ if {[string length $url] != 0} {
+ HVResolveURL $varname $url
+ } else {
+ set var(sel,x) $x
+ set var(sel,y) $y
+ }
+}
+
+proc HVMotion1 {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVMotion1"
+ }
+
+ if {$var(sel,x) != -1 && $var(sel,y) != -1} {
+ $var(widget) selection set @$var(sel,x),$var(sel,y) @$x,$y
+ }
+}
+
+proc HVRelease1 {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVRelease1"
+ }
+
+ if {$var(sel,x) != -1 && $var(sel,y) != -1} {
+ set var(copy) [$var(widget) text ascii @$var(sel,x),$var(sel,y) @$x,$y]
+ selection own -command [list HVLostSelection $varname] $var(top)
+ }
+}
+
+proc HVMouseWheel {varname cnt} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVMouseWheel"
+ }
+
+ $var(widget) yview scroll [expr -$cnt] units
+}
+
+# Commands
+
+proc HVClearCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # clear the widge and all images
+ $var(widget) clear
+
+ HVClearCache $varname
+ HVClearAll $varname
+}
+
+proc HVCopyCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ clipboard clear -displayof $var(top)
+ clipboard append -displayof $var(top) $var(copy)
+}
+
+proc HVExportSelection {varname offset bytes} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(copy) != {}} {
+ return [string range $var(copy) $offset [expr $offset+$bytes]]
+ }
+}
+
+proc HVLostSelection {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(widget) selection clear
+ set var(copy) {}
+}
+
+proc HVURLDialogCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+
+ set url "$var(url)"
+ if {[EntryDialog [msgcat::mc {URL}] [msgcat::mc {Enter URL}] 80 url]} {
+ if {[string length $url] == 0} {
+ return
+ }
+
+ ParseURL $url r
+ switch -- $r(scheme) {
+ {} {
+ # append 'http://' if needed
+ if {[string range $r(path) 0 0] == "/"} {
+ set url "http:/$url"
+ } else {
+ set url "http://$url"
+ }
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVURLDialogCmd new $url"
+ }
+ }
+ }
+
+ # clear the base
+ $var(widget) config -base {}
+
+ HVClearIndex $varname 0
+ HVClearAll $varname
+ # no need to resolve
+ HVLoadURL $varname $url {}
+ }
+}
+
+proc HVFileDialogCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+
+ set fn [OpenFileDialog hvhtmlfbox]
+ if {"$fn" != {}} {
+ HVFileDialog $varname "$fn"
+ }
+}
+
+proc HVFileDialog {varname fn} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+
+ # clear the base
+ $var(widget) config -base {}
+
+ HVClearIndex $varname 0
+ HVClearAll $varname
+ # no need to resolve
+ HVLoadURL $varname "$fn" {}
+}
+
+proc HVBackCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVBackCmd index $var(index)"
+ }
+
+ incr ${varname}(index) -1
+ if {[info exists ${varname}(index,$var(index))]} {
+ set url [lindex $var(index,$var(index)) 0]
+ set query [lindex $var(index,$var(index)) 1]
+ if {$debug(tcl,hv)} {
+ puts stderr "HVBackCmd :$var(index):$url:$query:"
+ }
+ # clear the base
+ $var(widget) config -base {}
+
+ # HVGotoHTML will incr the index again
+ incr ${varname}(index) -1
+ # no need to resolve
+ HVLoadURL $varname $url $query $var(sync)
+ } else {
+ incr ${varname}(index)
+ }
+}
+
+proc HVFind {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set toks [$var(widget) token list 1.0 end]
+
+ set aa -1
+ set bb 0
+ set cc -1
+ set dd 0
+ set id -1
+ set ss $var(search,start)
+
+ while {$ss<[llength $toks] && $cc==-1} {
+ set pat [lindex $var(search) 0]
+ set id [lsearch -glob -start $ss $toks "Text *$pat*"]
+
+ if {$id != -1} {
+ set ok 1
+
+ set aa $id
+ set ss $id
+ set tt [string first $pat [lindex [lindex $toks $aa] 1]]
+ if {$tt != -1} {
+ set bb $tt
+ }
+
+ for {set ii 1} {$ii<[llength $var(search)]} {incr ii} {
+ set pat [lindex $var(search) $ii]
+ set str [lindex [lindex $toks [expr $id+$ii*2]] 1]
+ if {[string compare -length [string length $pat] $pat $str]} {
+ incr ss
+ set ok 0
+ break
+ }
+ }
+
+ if {$ok} {
+ set cc [expr $aa+([llength $var(search)]-1)*2]
+ set tt [string last $pat [lindex [lindex $toks $cc] 1]]
+ if {$tt != -1} {
+ set dd [expr $tt+[string length $pat]]
+ }
+ }
+ } else {
+ break
+ }
+ }
+
+ if {$aa == -1 || $cc == -1} {
+ return 0
+ } else {
+ set var(search,start) [expr $cc+1]
+ $var(widget) selection set "[expr $aa+1].$bb" "[expr $cc+1].$dd"
+ $var(widget) yview text "[expr $aa+1].$bb"
+ return 1
+ }
+}
+
+proc HVFindCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set result "$var(search)"
+ if {[EntryDialog [msgcat::mc {Search}] [msgcat::mc {Enter Search Expression}] 40 result]} {
+ set var(search) "$result"
+ set var(search,start) 0
+ $var(widget) selection clear
+
+ if {![HVFind $varname]} {
+ Error "$var(search) [msgcat::mc {Not Found}]"
+ }
+ }
+}
+
+proc HVFindNextCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(search,start) == 0} {
+ HVFindCmd $varname
+ } else {
+ if {![HVFind $varname]} {
+ # wrap
+ set var(search,start) 0
+ if {![HVFind $varname]} {
+ Error "$var(search) [msgcat::mc {Not Found}]"
+ }
+ }
+ }
+}
+
+proc HVForwardCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVForwardCmd $var(index)"
+ }
+
+ incr ${varname}(index)
+ if {[info exists ${varname}(index,$var(index))]} {
+ set url [lindex $var(index,$var(index)) 0]
+ set query [lindex $var(index,$var(index)) 1]
+ if {$debug(tcl,hv)} {
+ puts stderr "HVForwardCmd :$var(index):$url:$query:"
+ }
+ # clear the base
+ $var(widget) config -base {}
+
+ # HVGotoHTML will incr the index again
+ incr ${varname}(index) -1
+ # no need to resolve
+ HVLoadURL $varname $url $query $var(sync)
+ } else {
+ incr ${varname}(index) -1
+ }
+}
+
+proc HVGotoCmd {varname nn} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVGotoCmd $nn"
+ }
+
+ set var(index) $nn
+ if {[info exists ${varname}(index,$var(index))]} {
+ set url [lindex $var(index,$var(index)) 0]
+ set query [lindex $var(index,$var(index)) 1]
+ if {$debug(tcl,hv)} {
+ puts stderr "HVGotoCmd :$var(index):$url:$query:"
+ }
+ # clear the base
+ $var(widget) config -base {}
+
+ # HVGotoHTML will incr the index again
+ incr ${varname}(index) -1
+ # no need to resolve
+ HVLoadURL $varname $url $query $var(sync)
+ } else {
+ incr ${varname}(index)
+ }
+}
+
+proc HVReloadCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVReloadCmd"
+ }
+
+ # clear the base
+ $var(widget) config -base {}
+
+ # HVGotoHTML will incr the index again
+ incr ${varname}(index) -1
+ # no need to resolve
+ HVLoadURL $varname $var(url) $var(query) $var(sync)
+}
+
+proc HVStopCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "\n*** HVStopCmd ***\n"
+ }
+
+ HVCancel $varname
+}
+
+proc HVPageSourceCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVPageSourceCmd"
+ }
+
+ SimpleTextDialog ${varname}txt $var(url) 80 20 insert top $var(data)
+}
+
+proc HVArchUserCmd {varname title url} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVArchUserCmd"
+ }
+
+ if {[string length $url] == 0} {
+ return
+ }
+
+ ParseURL $url r
+ switch -- $r(scheme) {
+ {} {
+ # append 'http://' if needed
+ if {[string range $r(path) 0 0] == "/"} {
+ set url "http:/$url"
+ } else {
+ set url "http://$url"
+ }
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVArchUserCmd new $url"
+ }
+ }
+ }
+ HV $varname $title $url
+}
+
+proc HVAnalysisCmd {varname title url sync} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVAnalysisCmd $varname $title $url $sync"
+ }
+
+ if {[string length $url] == 0} {
+ HV $varname "$title" {} {} $sync
+ } else {
+ ParseURL $url r
+ switch -- $r(scheme) {
+ {} {
+ # append 'http://' if needed
+ if {[string range $r(path) 0 0] == "/"} {
+ set url "http:/$url"
+ } else {
+ set url "http://$url"
+ }
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVAnalysisCmd new $url"
+ }
+ }
+ }
+ HV $varname "$title" $url {} $sync
+ }
+}
+
+proc HVAnalysisURL {which i url sync} {
+ set varname "at${which}${i}"
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVAnalysisURL $which $i $url"
+ }
+
+ set ${varname}(cookies) {}
+ set ${varname}(sync) $sync
+ HVClearAll $varname
+ HVSetAnalysis $varname 1 $which $i
+ HVLoadURL $varname $url {} $sync
+}
+
+proc HVAnalysisCancel {which i} {
+ set varname "at${which}${i}"
+ global $varname
+
+ HVCancel $varname
+}
+
+# Archive Servers
+
+proc HVArchChandraChaser {} {
+ global current
+
+ set coord {}
+ if {$current(frame) != {}} {
+ if {[$current(frame) has wcs equatorial wcs]} {
+ set coord [$current(frame) get fits center wcs fk5 degrees]
+ set size \
+ [expr [lindex [$current(frame) get fits size wcs fk5 arcmin] 0]/2.]
+ }
+ }
+
+ set l {}
+ if {[string length $coord] != 0} {
+ lappend l "1 lon [lindex $coord 0]"
+ lappend l "1 lat [lindex $coord 1]"
+ lappend l "1 radius $size"
+ }
+
+ global hvchandrachaser
+ HV hvchandrachaser {Chandra Chaser} http://cda.harvard.edu/chaser/mainEntry.do $l
+}
+
+proc HVArchChandraPop {} {
+ global current
+
+ set coord {}
+ if {$current(frame) != {}} {
+ if {[$current(frame) has wcs equatorial wcs]} {
+ set coord [$current(frame) get fits center wcs fk5 degrees]
+ set size \
+ [expr [lindex [$current(frame) get fits size wcs fk5 arcmin] 0]/2.]
+ }
+ }
+
+ set l {}
+ if {[string length $coord] != 0} {
+ lappend l "1 lon [lindex $coord 0]"
+ lappend l "1 lat [lindex $coord 1]"
+ lappend l "1 radius $size"
+ lappend l "1 searchBy position"
+ }
+
+ global hvchandrapop
+ HV hvchandrapop {Chandra Popular} http://cda.harvard.edu/pop/mainEntry.do $l
+}
+
+proc HVArchChandraFTP {} {
+ global current
+
+ set ra {}
+ set dec {}
+ set wid {}
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has wcs equatorial wcs]} {
+ set coord [$current(frame) get fits center wcs fk5 sexagesimal]
+ set ra [lindex $coord 0]
+ set dec [lindex $coord 1]
+
+ set wid [lindex [$current(frame) get fits size wcs fk5 degrees] 0]
+ }
+ }
+
+ set l {}
+ if {[string length $ra] != 0} {
+ lappend l "1 ra \{$ra\}"
+ lappend l "1 dec \{$dec\}"
+ lappend l "1 wid \{$wid\}"
+ }
+
+ global hvchandraftp
+ HV hvchandraftp {Chandra FTP} \
+ http://www.cfa.harvard.edu/archive/chandra/search $l
+}
+
+# Other
+
+# Process Cmds
+
+proc ProcessWebCmd {varname iname} {
+ global ihv
+
+ set w {hvweb}
+
+ upvar $varname var
+ upvar $iname i
+
+ # determine which web browser window
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ set ii [lsearch $ihv(windows) $w]
+ if {$ii>=0} {
+ append w $ihv(unique)
+ incr ihv(unique)
+ }
+ }
+ close -
+ clear -
+ click {set w [lindex $ihv(windows) end]}
+
+ default {
+ set ii [lsearch $ihv(windows) [lindex $var $i]]
+ if {$ii>=0} {
+ set w [lindex $var $i]
+ incr i
+ }
+ }
+ }
+
+ switch -- [string tolower [lindex $var $i]] {
+ close {HVDestroy $w}
+ clear {HVClearCmd $w}
+ click {
+ set vvarname $w
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ back {HVBackCmd $vvarname}
+ forward {HVForwardCmd $vvarname}
+ stop {HVStopCmd $vvarname}
+ reload {HVReloadCmd $vvarname}
+ default {
+ set id [lindex $var $i]
+
+ if {![info exists vvar(widget)]} {
+ return
+ }
+
+ set tokens [$vvar(widget) token list 1.0 end]
+ set cnt 0
+ for {set ii 0} {$ii<[llength $tokens]} {incr ii} {
+ set tok [lindex $tokens $ii]
+ if {[string tolower [lindex $tok 0]] == "markup" &&
+ [string tolower [lindex $tok 2]] == "href"} {
+ set url [lindex $tok 3]
+ incr cnt
+ if {$cnt == $id} {
+ HVResolveURL $vvarname [$vvar(widget) resolve $url]
+ break;
+ }
+ }
+ }
+ }
+ }
+ }
+ default {
+ set url [lindex $var $i]
+ if {[string length $url] == 0} {
+ HV $w Web {} {} 1
+ } else {
+ ParseURL $url r
+ switch -- $r(scheme) {
+ {} {
+ # append 'http://' if needed
+ if {[string range $r(path) 0 0] == "/"} {
+ set url "http:/$url"
+ } else {
+ set url "http://$url"
+ }
+ }
+ }
+ HV $w Web $url {} 1
+ }
+ }
+ }
+}
+
+proc ProcessSendWebCmd {proc id param} {
+ global ihv
+ $proc $id "$ihv(windows)\n"
+}
+
diff --git a/ds9/library/hvform.tcl b/ds9/library/hvform.tcl
new file mode 100644
index 0000000..b7109cf
--- /dev/null
+++ b/ds9/library/hvform.tcl
@@ -0,0 +1,525 @@
+# 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 HVFormCB {varname n cmd args} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormCB $varname $n $cmd $args"
+ }
+
+ switch -- [string tolower $cmd] {
+ form {HVFormForm $varname $n args}
+ flush {HVFormFlush $varname $n args}
+ input {HVFormInput $varname $n args}
+ select {HVFormSelect $varname $n args}
+ textarea {HVFormTextArea $varname $n args}
+ }
+}
+
+proc HVFormForm {varname n a} {
+ upvar #0 $varname var
+ global $varname
+ upvar $a args
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormForm $n $args"
+ }
+
+ # try to clean up lose vars from previous forms
+ HVFormFlush $varname $n {}
+
+ set aa [lindex $args 2]
+ set var(form,$n,action) [lindex $args 0]
+ set var(form,$n,method) [HVattrs method $aa get]
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormForm method $var(form,$n,method)"
+ puts stderr "HVFormForm action $var(form,$n,action)"
+ }
+}
+
+proc HVFormFlush {varname n a} {
+ upvar #0 $varname var
+ global $varname
+ upvar $a args
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormFlush $n"
+ }
+
+ # unset all var(form,$n,*)
+ foreach x [array names $varname "form,$n,*"] {
+ unset ${varname}($x)
+ }
+
+ bind $var(top) <Return> {}
+}
+
+proc HVFormInput {varname n a} {
+ upvar #0 $varname var
+ global $varname
+ upvar $a args
+
+ global debug
+
+ set path [lindex $args 0]
+ set attrs [lindex $args 1]
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormInput $n $path $attrs"
+ }
+
+ set id [lindex [split $path .] end]
+ set type [HVattrs type $attrs {}]
+ set disabled [HVattrs disabled $attrs normal]
+ set readonly [HVattrs readonly $attrs normal]
+
+ switch -- [string tolower $type] {
+ checkbox {
+ set name [HVattrs name $attrs var]
+ set value [HVattrs value $attrs on]
+ set checked [HVattrs checked $attrs nochecked]
+
+ set var(form,$n,name,$id) $name
+ if {$checked != "nochecked"} {
+ set var(form,$n,var,$id) $value
+ } else {
+ set var(form,$n,var,$id) {}
+ }
+ set var(form,$n,init,$id) $$var(form,$n,var,$id)
+
+ ttk::checkbutton $path -variable ${varname}(form,$n,var,$id) \
+ -onvalue $value -offvalue {} -state $disabled
+ }
+ radio {
+ set name [HVattrs name $attrs var]
+ # we need this so that all share the same variable
+ set id $name
+ set value [HVattrs value $attrs on]
+ set checked [HVattrs checked $attrs nochecked]
+
+ set var(form,$n,name,$id) $name
+ if {$checked != "nochecked"} {
+ set var(form,$n,var,$id) $value
+ set var(form,$n,init,$id) $var(form,$n,var,$id)
+ }
+
+ # override init value
+ foreach f $var(init) {
+ if {$n == [lindex $f 0] &&
+ $name == [lindex $f 1] &&
+ $value == [lindex $f 2]} {
+
+ set var(form,$n,var,$id) $value
+ set var(form,$n,init,$id) $var(form,$n,var,$id)
+ }
+ }
+
+ ttk::radiobutton $path -variable ${varname}(form,$n,var,$id) \
+ -value $value -state $disabled
+ }
+ button {
+ set name [HVattrs name $attrs submit]
+ set value [HVattrs value $attrs "Submit"]
+
+ ttk::button $path -text $value \
+ -command "HVSubmitForm $varname $n \{$name\} \{$value\}"
+ }
+ submit {
+ set name [HVattrs name $attrs submit]
+ set value [HVattrs value $attrs "Submit"]
+
+ ttk::button $path -text $value \
+ -command "HVSubmitForm $varname $n \{$name\} \{$value\}"
+
+ bind $var(top) <Return> \
+ "HVSubmitForm $varname $n \{$name\} \{$value\}"
+ }
+ reset {
+ set name [HVattrs name $attrs reset]
+ set value [HVattrs value $attrs "Reset"]
+
+ ttk::button $path -text $value -command "HVResetForm $varname $n"
+ }
+ image {
+ set name [HVattrs name $attrs submit]
+ set value [HVattrs value $attrs "Submit"]
+ set src [HVattrs src $attrs {}]
+
+ set img [HVImageCB $varname [$var(widget) resolve $src]]
+ if {$img != "$var(images,gray)"} {
+ ttk::button $path -image $img \
+ -command "HVSubmitForm $varname $n \{$name\} \{$value\}"
+ } else {
+ ttk::button $path -text $value -state $disabled \
+ -command "HVSubmitForm $varname $n \{$name\} \{$value\}"
+ }
+ return
+ }
+ hidden {
+ set name [HVattrs name $attrs var]
+ set value [HVattrs value $attrs {}]
+
+ set var(form,$n,name,$id) $name
+ set var(form,$n,var,$id) $value
+ }
+ password {
+ set name [HVattrs name $attrs var]
+ set value [HVattrs value $attrs {}]
+ set size [HVattrs size $attrs 20]
+
+ set var(form,$n,name,$id) $name
+ set var(form,$n,var,$id) $value
+ set var(form,$n,init,$id) $var(form,$n,var,$id)
+
+ ttk::entry $path -textvariable ${varname}(form,$n,var,$id) \
+ -width $size -show "*" -state $readonly
+ }
+ file {
+ set name [HVattrs name $attrs var]
+ set value [HVattrs value $attrs {}]
+ set size [HVattrs size $attrs 20]
+
+ set var(form,$n,name,$id) $name
+ set var(form,$n,var,$id) [HVInitVar $varname $n $name $value]
+ set var(form,$n,init,$id) $var(form,$n,var,$id)
+
+ ttk::entry $path -textvariable ${varname}(form,$n,var,$id) \
+ -width $size -state $readonly
+ }
+ text -
+ default {
+ set name [HVattrs name $attrs var]
+ set value [HVattrs value $attrs {}]
+ set size [HVattrs size $attrs 20]
+
+ set var(form,$n,name,$id) $name
+ set var(form,$n,var,$id) [HVInitVar $varname $n $name $value]
+ set var(form,$n,init,$id) $var(form,$n,var,$id)
+
+ ttk::entry $path -textvariable ${varname}(form,$n,var,$id) \
+ -width $size -state $readonly
+ }
+ }
+}
+
+proc HVFormSelect {varname n a} {
+ upvar #0 $varname var
+ global $varname
+ upvar $a args
+
+ global ds9
+ global debug
+
+ set path [lindex $args 0]
+ set attrs [lindex $args 1]
+ set choices [lindex $args 2]
+ set initial [lindex $args 3]
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormSelect :$n:$path:$attrs:$choices:$initial:"
+ }
+
+ set id [lindex [split $path .] end]
+ set name [HVattrs name $attrs var]
+
+ set size [HVattrs size $attrs 0]
+ set multiple [HVattrs multiple $attrs single]
+ if {[string length $multiple] == 0} {
+ set multiple multiple
+ }
+
+ switch -- $multiple {
+ single {
+ set var(form,$n,name,$id) $name
+
+ ttk::menubutton $path -textvariable ${varname}(form,$n,single,$id) \
+ -menu $path.m
+ menu $path.m -tearoff 0
+
+ set l 0
+ set first 1
+ foreach f $choices {
+ set i [lindex $f 0]
+ set v [lindex $f 1]
+ set m [lindex $f 2]
+ if {[string length $v] == 0} {
+ set v $m
+ }
+
+ if {$i || $first} {
+ set var(form,$n,var,$id) $v
+ set var(form,$n,init,$id) $v
+ set var(form,$n,single,$id) $m
+ set var(form,$n,singleinit,$id) $m
+ set first 0
+ }
+
+ if {[string length $m]>$l} {
+ set l [string length $m]
+ }
+ $path.m add command -label $m -command \
+ "upvar #0 $varname var; set var(form,$n,var,$id) \"$v\"; set var(form,$n,single,$id) \"$m\""
+ }
+
+ # override init value
+ foreach f $var(init) {
+ if {$n == [lindex $f 0] && $name == [lindex $f 1]} {
+ set v [lindex $f 2]
+ set m [lindex $f 3]
+
+ set var(form,$n,var,$id) $v
+ set var(form,$n,init,$id) $v
+ set var(form,$n,single,$id) $m
+ set var(form,$n,singleinit,$id) $m
+ }
+ }
+
+ $path configure -width $l
+ }
+ multiple {
+ set var(form,$n,name,$id) $name
+ set var(form,$n,multivar,$id) {}
+ set var(form,$n,multiinit,$id) {}
+ set var(form,$n,multimenu,$id) {}
+
+ set l 0
+ set long {}
+ set ii 0
+ foreach f $choices {
+ if {[lindex $f 0]} {
+ lappend var(form,$n,multiinit,$id) $ii
+ }
+ set foo [lindex $f 1]
+ if {[string length $foo] == 0} {
+ set foo [lindex $f 2]
+ }
+ lappend var(form,$n,multivar,$id) $foo
+ lappend var(form,$n,multimenu,$id) [lindex $f 2]
+
+ set m [lindex $f 2]
+ if {[string length $m]>$l} {
+ set long $m
+ set l [string length $m]
+ }
+ incr ii
+ }
+ set var(form,$n,multiple,$id) $path
+
+ # we have a problem
+ # the frame we create will not resize itself based on the
+ # interior size of the listbox and the scrollbar
+ # so, we need to set the frame size by hand
+
+ set font "$var(font) $var(font,size) $var(font,weight) $var(font,slant)"
+ ttk::frame $path
+ ttk::scrollbar $path.scroll -command "$path.list yview"
+ listbox $path.list -selectmode multiple \
+ -width 0 -height $size \
+ -listvar ${varname}(form,$n,multimenu,$id) \
+ -font $font \
+ -yscroll "$path.scroll set" \
+ -exportselection false
+
+ set w [expr [font measure $font $long]+30]
+ set h [expr $size*[font metrics $font -linespace]]
+ $path configure -width $w -height $h
+
+ pack $path.list $path.scroll -side left -fill y -expand 1
+
+ foreach ii $var(form,$n,multiinit,$id) {
+ $path.list selection set $ii
+ }
+ }
+ }
+}
+
+proc HVFormTextArea {varname n a} {
+ upvar #0 $varname var
+ global $varname
+ upvar $a args
+
+ set path [lindex $args 0]
+ set attrs [lindex $args 1]
+ set initial [string range [lindex $args 2] 1 end]
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFormTextArea $n $path $attrs $initial"
+ }
+
+ set id [lindex [split $path .] end]
+ set name [HVattrs name $attrs var]
+
+ set rows [HVattrs rows $attrs 4]
+ set cols [HVattrs cols $attrs 20]
+ set readonly [HVattrs disabled $attrs normal]
+
+ # update initial
+ set initial [HVInitVar $varname $n $name $initial]
+
+ text $path -height $rows -width $cols -wrap none -state $readonly
+ $path insert end $initial
+
+ set var(form,$n,name,$id) $name
+ set var(form,$n,var,$id) $initial
+ set var(form,$n,init,$id) $var(form,$n,var,$id)
+ set var(form,$n,textarea,$id) $path
+}
+
+proc HVattrs {k l def} {
+ # break list up into key/value pairs
+ set key {}
+ set value {}
+ set w 1
+ foreach f $l {
+ if {$w} {
+ lappend key [string tolower $f]
+ set w 0
+ } else {
+ lappend value $f
+ set w 1
+ }
+ }
+ set a [lsearch -exact $key [string tolower $k]]
+ if {$a>=0} {
+ return [lindex $value $a]
+ } else {
+ return $def
+ }
+}
+
+proc HVSubmitForm {varname n name value} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVSubmitForm $n"
+ }
+
+ bind $var(top) <Return> {}
+
+ # update textareas
+ foreach x [array names $varname "form,$n,textarea,*"] {
+ set f [split $x ,]
+ set id [lindex $f 3]
+ set path $var($x)
+ set var(form,$n,var,$id) [$path get 1.0 end]
+ }
+
+ set query {}
+ # append button name=value
+ append query "[http::formatQuery $name $value]&"
+
+ # append normal vars
+ foreach x [array names $varname "form,$n,var,*"] {
+ set f [split $x ,]
+ set id [lindex $f 3]
+ set v [string trim $var($x)]
+ if {[string length $v] != 0} {
+ append query "[http::formatQuery $var(form,$n,name,$id) $v]&"
+ }
+ }
+
+ # append multiple select
+ foreach x [array names $varname "form,$n,multiple,*"] {
+ set f [split $x ,]
+ set id [lindex $f 3]
+ set path $var($x)
+ set iii [$path.list curselection]
+ foreach ii $iii {
+ set v [string trim [lindex $var(form,$n,multivar,$id) $ii]]
+ if {[string length $v] != 0} {
+ append query "[http::formatQuery $var(form,$n,name,$id) $v]&"
+ }
+ }
+ }
+
+ # remove last '&'
+ set query [string trimright $query &]
+
+ HVClearIndex $varname $var(index)
+
+ # and do it
+ # already resolved
+ switch -- [string tolower $var(form,$n,method)] {
+ get {HVLoadURL $varname "$var(form,$n,action)?$query" {} $var(sync)}
+ post {HVLoadURL $varname "$var(form,$n,action)" "$query" $var(sync)}
+ }
+}
+
+proc HVResetForm {varname n} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVResetForm $n"
+ }
+
+ foreach x [array names $varname "form,$n,init,*"] {
+ set f [split $x ,]
+ set var(form,$n,var,[lindex $f 3]) $var($x)
+ }
+
+ #update single select
+ foreach x [array names $varname "form,$n,singleinit,*"] {
+ set f [split $x ,]
+ set var(form,$n,single,[lindex $f 3]) $var($x)
+ }
+
+ # update multiple select
+ foreach x [array names $varname "form,$n,multiinit,*"] {
+ set f [split $x ,]
+ set path $var(form,$n,multiple,[lindex $f 3])
+ $path.list selection clear 0
+ foreach ii $var($x) {
+ $path.list selection set $ii
+ }
+ }
+
+ # update textareas
+ foreach x [array names $varname "form,$n,textarea,*"] {
+ set f [split $x ,]
+ set path $var($x)
+ $path delete 1.0 end
+ $path insert end $var(form,$n,init,[lindex $f 3])
+ }
+}
+
+proc HVInitVar {varname n name def} {
+ upvar #0 $varname var
+ global $varname
+
+ foreach f $var(init) {
+ if {$n == [lindex $f 0] && $name == [lindex $f 1]} {
+ return [lindex $f 2]
+ }
+ }
+ return $def
+}
+
+proc HVFixHTMLForm {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+
+ if {[regexp -nocase {<form [^>]*} $var(data) r]} {
+ if {![regexp -nocase {action=} $r]} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFixFormHTML action fixed"
+ }
+
+ set rr "$r action=[$var(widget) cget -base]"
+ regsub -nocase {<form [^>]*} $var(data) $rr var(data)
+ }
+ }
+}
diff --git a/ds9/library/hvsup.tcl b/ds9/library/hvsup.tcl
new file mode 100644
index 0000000..c16545a
--- /dev/null
+++ b/ds9/library/hvsup.tcl
@@ -0,0 +1,2089 @@
+# 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 HVCancel {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVCancel"
+ }
+
+ # set state to 0 so that we don't process the finish proc
+ set var(active) 0
+
+ # stop any refresh
+ if {$var(refresh,id)>0} {
+ after cancel $var(refresh,id)
+ set var(refresh,id) 0
+ }
+
+ # analysis
+ if {$var(analysis)} {
+ AnalysisTaskEnd $var(analysis,which) $var(analysis,i)
+ HVSetAnalysis $varname 0 {} 0
+ }
+
+ # clean up
+ HVClearTmpFile $varname
+
+ if {[info exists var(token)]} {
+ http::reset $var(token)
+ }
+
+ if {[info exists var(widget)]} {
+ $var(widget) configure -cursor {}
+ }
+}
+
+proc HVDestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+ global ihv
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVDestroy"
+ }
+
+ HVCancel $varname
+
+ # clear the widge and all images
+ $var(widget) clear
+
+ # clear image cache
+ foreach x [array names $varname "images,*"] {
+ image delete $var($x)
+ unset ${varname}($x)
+ }
+
+ # clear cache
+ HVClearCache $varname
+
+ # destroy the window and menubar
+ if {[winfo exists $var(top)]} {
+ destroy $var(top)
+ destroy $var(mb)
+ }
+
+ # delete it from the xpa list
+ set ii [lsearch $ihv(windows) $varname]
+ if {$ii>=0} {
+ set ihv(windows) [lreplace $ihv(windows) $ii $ii]
+ }
+
+ # clear varname
+ unset $varname
+}
+
+proc HVReset {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(active) 0
+
+ if {[info exists var(token)]} {
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVReset ***cleanup***"
+ }
+ http::cleanup $var(token)
+ unset var(token)
+ }
+}
+
+proc HVDone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ HVStatus $varname {}
+ HVReset $varname
+}
+
+proc HVCancelled {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ HVStatus $varname {}
+ HVReset $varname
+}
+
+proc HVError {varname err} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVError $err"
+ }
+
+ HVReset $varname
+ Error $err
+}
+
+proc HVStatus {varname message} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(status) $message
+}
+
+proc HVResolveURL {varname url} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ global pvo
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVResolveURL $varname $url"
+ }
+
+ set sync $var(sync)
+ # sub xpa method
+ set exp {%40%40XPA_METHOD%40%40|@@XPA_METHOD@@}
+ if {[regexp $exp $url]} {
+ regsub -all $exp $url [XPAMethod] url
+ if {$debug(tcl,hv)} {
+ puts stderr "HVResolveURL XPA_METHOD $url"
+ }
+ }
+
+ # sub vo method
+ set exp {%40%40VO_METHOD%40%40|@@VO_METHOD@@}
+ if {[regexp $exp $url]} {
+ regsub -all $exp $url $pvo(method) url
+ if {$debug(tcl,hv)} {
+ puts stderr "HVResolveURL VO_METHOD $url"
+ }
+ }
+
+ # if pvo(method) is xpa, HV has to be async
+ if {$pvo(method) == {xpa}} {
+ set sync 0
+ }
+
+ # some old sites have a problem with '?' in the query not encoded
+ ParseURL $url rr
+ if {$rr(query) != {}} {
+ if {[regsub -all {\?} $rr(query) {%25} query]} {
+ set newurl "$rr(scheme)://$rr(authority)$rr(path)?$query"
+ if {$rr(fragment) != {}} {
+ append newurl "#$rr(fragment)"
+ }
+ HVLoadURL $varname $newurl {} $sync
+ } else {
+ HVLoadURL $varname $url {} $sync
+ }
+ } else {
+ HVLoadURL $varname $url {} $sync
+ }
+}
+
+# this is the main entry point, everybody calls here
+
+proc HVLoadURL {varname url query {sync 0}} {
+ upvar #0 $varname var
+ global $varname
+
+ # this assumes the url has been already resolved
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVLoadURL :$varname:$url:$query:$sync:"
+ }
+
+ # do we have anything?
+ if {$url == {}} {
+ return
+ }
+
+ HVStatus $varname {}
+
+ # parse url
+ ParseURL $url r
+ if {$debug(tcl,hv)} {
+ puts stderr "HVLoadURL |$r(scheme)|$r(authority)|$r(path)|$r(query)|$r(fragment)|$query|"
+ }
+
+ switch -- $r(scheme) {
+ file -
+ {} {HVProcessURLFile $varname $url $query r}
+ ftp {HVProcessURLFTP $varname $url $query r}
+ http {HVProcessURLHTTP $varname $url $query r $sync}
+ default {HVError $varname "[msgcat::mc {Sorry, DS9 does not support}] $r(scheme)"}
+ }
+}
+
+proc HVProcessURLFile {varname url query rr} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar $rr r
+
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLFile"
+ }
+
+ if {[file exists $r(path)]} {
+ if {[file isdirectory $r(path)]} {
+ HVSetURL $varname $url {} {}
+ HVSetResult $varname 200 "text/html"
+ HVSetData $varname \
+ [HVFileHtmlList $r(path) [HVDirList $r(path)]] {}
+
+ set var(delete) 0
+ HVParse $varname
+ } else {
+ HVSetURL $varname $url {} $r(fragment)
+ set var(delete) 0
+ HVLoadFile $varname $r(path)
+ }
+ }
+}
+
+proc HVProcessURLFTP {varname url query rr} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar $rr r
+
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLFTP"
+ DumpURL r
+ }
+
+ set fn [tmpnam [file extension $r(path)]]
+ set ftp [ftp::Open $r(authority) "ftp" "-ds9@" -mode passive]
+ if {$ftp > -1} {
+ # first try to get as file
+ set ftp::VERBOSE $debug(tcl,ftp)
+ set "ftp::ftp${ftp}(Output)" FTPLog
+ ftp::Type $ftp binary
+ if {[ftp::Get $ftp $r(path) "$fn"]} {
+ ftp::Close $ftp
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLFTP get $fn"
+ }
+ HVSetURL $varname $url {} $r(fragment)
+
+ set var(delete) 1
+ HVLoadFile $varname "$fn"
+
+ HVClearTmpFile $varname
+ } else {
+ # from the prev attempt
+ catch {file delete -force "$fn"}
+
+ # is it a dir or file that could not be download?
+ if {[file extension $r(path)] == {}} {
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLFTP list"
+ }
+
+ # now as a directory
+ set list [ftp::List $ftp $r(path)]
+ ftp::Close $ftp
+
+ HVSetURL $varname $url {} {}
+ HVSetResult $varname 200 "text/html"
+ HVSetData $varname [HVFTPHtmlList $r(authority) $r(path) $list] {}
+
+ set var(delete) 0
+ HVParse $varname
+ } else {
+ HVError $varname "[msgcat::mc {Unable to open file}] $r(path)"
+ return
+ }
+ }
+ }
+}
+
+proc HVProcessURLHTTP {varname url query rr sync} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar $rr r
+
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLHTTP"
+ }
+
+ # stop any refresh
+ if {[info exists ${varname}(refresh,id)]} {
+ if {$var(refresh,id)>0} {
+ after cancel $var(refresh,id)
+ }
+ }
+
+ # do we already have it in cache?
+ if {[info exists ${varname}(cache,file,$url,$query)]} {
+
+ # has it expired?
+ if {($var(cache,expire,$url,$query) == 0) ||
+ ($var(cache,expire,$url,$query) > [clock seconds])} {
+
+ # just in case
+ if {[file exists $var(cache,file,$url,$query)]} {
+ # ok, to it
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLHTTP found $url at $var(cache,file,$url,$query)"
+ }
+
+ HVSetURL $varname $url $query $r(fragment)
+ set var(delete) 0
+ HVSetResult $varname 200 $var(cache,mime,$url,$query)
+ HVSetData $varname {} $var(cache,file,$url,$query)
+
+ HVParse $varname
+
+ return
+ }
+ }
+
+ # expired or invalid, clean up
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLHTTP expired or invalid $var(cache,file,$url,$query)"
+ }
+ catch {file delete $var(cache,file,$url,$query)}
+ unset var(cache,file,$url,$query)
+ unset var(cache,mime,$url,$query)
+ unset var(cache,expire,$url,$query)
+ }
+
+ HVSetURL $varname $url $query $r(fragment)
+ HVSetResult $varname {} {}
+ HVSetData $varname {} {}
+
+ set var(ch) {}
+
+ # do we have html? if so, use a var
+ ParseURL $url r
+
+ # geturl as file
+ set var(fn) [tmpnam {.http}]
+ if {[catch {open "$var(fn)" w} ${varname}(ch)]} {
+ HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)"
+ return
+ }
+
+ # disable timeouts for analysis
+ global ihttp
+ set timeout $ihttp(timeout)
+ if {$var(analysis)} {
+ set timeout 0
+ }
+
+ if {$sync} {
+ if {![catch {set var(token) [http::geturl $url \
+ -query "$query" \
+ -timeout $timeout \
+ -headers "[HVHTTPHeader $varname]" \
+ -progress [list HVProgress $varname] \
+ -binary 1 \
+ -channel $var(ch)]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ set var(delete) 1
+ HVProcessURLHTTPFinish $varname $var(token)
+ } else {
+ catch {close $var(ch)}
+ HVError $varname "[msgcat::mc {Unable to locate URL}] $url"
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $url \
+ -query "$query" \
+ -timeout $timeout \
+ -headers "[HVHTTPHeader $varname]" \
+ -progress [list HVProgress $varname] \
+ -binary 1 \
+ -channel $var(ch) \
+ -command [list HVProcessURLHTTPFinish $varname]]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ set var(delete) 1
+ } else {
+ catch {close $var(ch)}
+ HVError $varname "[msgcat::mc {Unable to locate URL}] $url"
+ }
+ }
+}
+
+proc HVProcessURLHTTPFinish {varname token} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLHTTPFinish"
+ }
+
+ catch {close $var(ch)}
+
+ if {!($var(active))} {
+ HVCancelled $varname
+ return
+ }
+
+ upvar #0 $token t
+
+ # Code
+ set var(code) [http::ncode $token]
+
+ # Meta
+ set var(meta) $t(meta)
+
+ # Cache defaults
+ set var(cache) 1
+ set var(cache,images) 1
+ set var(expire) 0
+
+ HVParseMeta $varname
+
+ # Log it
+ HTTPLog $token
+
+ # Result?
+ switch -- $var(code) {
+ 200 -
+ 203 -
+ 404 -
+ 503 {
+ if {$var(cache)} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLHTTPFinish cacheing:$var(url),$var(query):$var(fn)"
+ }
+ set url $var(url)
+ set query $var(query)
+ set var(cache,file,$url,$query) $var(fn)
+ set var(cache,mime,$url,$query) $var(mime)
+ set var(cache,expire,$url,$query) $var(expire)
+ set var(delete) 0
+ }
+ HVParse $varname
+ HVDone $varname
+ }
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $var(meta) {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProcessURLHTTPFinish redirect $var(code) to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset var(token)
+
+ HVClearTmpFile $varname
+
+ if {[info exists var(widget)]} {
+ HVLoadURL $varname [$var(widget) resolve $value] {} $var(sync)
+ } else {
+ HVLoadURL $varname $value {} $var(sync)
+ }
+ }
+ }
+ }
+
+ default {HVError $varname "HTTP [msgcat::mc {Error}] $var(code)"}
+ }
+}
+
+proc HVHTTPHeader {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set domain {}
+ ParseURL $var(url) rr
+ regexp {[^:]*} $rr(authority) domain
+
+ set result "[ProxyHTTP]"
+ foreach cc $var(cookies) {
+ if {$domain == [lindex $cc 2]} {
+ append result " Cookie [lindex $cc 0]=[lindex $cc 3]"
+ }
+ }
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVHTTPHeader:$result"
+ }
+
+ return $result
+}
+
+proc HVParseMeta {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseMeta: $var(meta)"
+ }
+
+ foreach {name value} $var(meta) {
+ switch -- [string tolower $name] {
+ content-type {
+ regexp -nocase {([^;]*);?(.*)} $value foo \
+ ${varname}(mime) ${varname}(mime,param)
+ set var(mime) [string tolower $var(mime)]
+ }
+ content-length {}
+ content-encoding {
+ switch -- [string tolower $value] {
+ gzip -
+ x-gzip {set var(encoding) gzip}
+ bzip2 {set var(encoding) bzip2}
+ compress -
+ Z {set var(encoding) compress}
+ pack -
+ z {set var(encoding) pack}
+ default {}
+ }
+ }
+ content-transfer-encoding {
+ switch -- [string tolower $value] {
+ binary -
+ base64 {set var(transfer) [string tolower $value]}
+ default {}
+ }
+ }
+
+ refresh {
+ set f [split $value \;]
+ set var(refresh,time) [lindex $f 0]
+ set var(refresh,url) [string range [lindex $f 1] 4 end]
+ if {$var(refresh,url) != {} & $var(refresh,time) != {}} {
+ set var(refresh,id) [after [expr $var(refresh,time)*1000] "HVLoadURL $varname \{$var(refresh,url)\} {} $var(sync)"]
+ } else {
+ set var(refresh,id) 0
+ }
+ }
+ expires {
+ if {[catch {set ss [clock scan $value]}]} {
+ set var(cache) 0
+ } else {
+ set var(cache) 1
+ set var(expire) $ss
+ }
+ }
+ cache-control {
+ foreach cc [split $value {,}] {
+ foreach {nn vv} [split $cc {=}] {
+ switch $nn {
+ public {set var(cache) 1}
+ private {set var(cache) 1}
+ no-cache {set var(cache) 0}
+ no-store {set var(cache) 1}
+
+ s-maxage -
+ min-fresh -
+ max-age {
+ set var(cache) 1
+ set var(expire) \
+ [expr [file mtime $var(fn)]+$vv]
+ }
+ max-stale {}
+ no-transform {}
+ only-if-cached {}
+ cache-extension {}
+
+ must-revalidate {}
+ proxy-revalidate {}
+ }
+ }
+ }
+ }
+ pragma {
+ switch $value {
+ no-cache {set var(cache) 0}
+ }
+ }
+ last-modified {
+ }
+ if-none-match {
+ }
+ set-cookie {
+ set cname {}
+ set cpath {/}
+ set cdomain {}
+ set cvalue {}
+
+ ParseURL $var(url) rr
+ regexp {[^:]*} $rr(authority) cdomain
+
+ foreach cc [split $value {;}] {
+ foreach {nn vv} [split $cc {=}] {
+ switch [string tolower [string trim $nn]] {
+ httponly {}
+ expires {}
+ path {set cpath $vv}
+ domain {set cdomain $vv}
+ {} {append cvalue {=}}
+ default {
+ if {$nn != {}} {
+ set cname $nn
+ set cvalue $vv
+ }
+ }
+ }
+ }
+ }
+ if {$cname != {}} {
+ lappend ${varname}(cookies) [list $cname $cpath $cdomain $cvalue]
+ }
+ }
+ }
+ }
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseMeta Content-Type:$var(mime):$var(mime,param):"
+ puts stderr "HVParseMeta Content-Encoding:$var(encoding):"
+ puts stderr "HVParseMeta Content-Transfer-Encoding:$var(transfer):"
+ puts stderr "HVParseMeta Refresh:$var(refresh,time):$var(refresh,url):"
+ puts stderr "HVParseMeta Cache:$var(cache)"
+ puts stderr "HVParseMeta Expires:$var(expire)"
+ puts stderr "HVParseMeta Cookies:$var(cookies)"
+ }
+}
+
+proc HVLoadFile {varname path} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVLoadFile $path"
+ }
+
+ HVSetResult $varname 200 {}
+ HVSetData $varname {} $path
+
+ # content-encoding
+ switch -- [string tolower [file extension $path]] {
+ .gz {
+ set path [file rootname $path]
+ set var(encoding) gzip
+ }
+ .bz2 {
+ set path [file rootname $path]
+ set var(encoding) bzip2
+ }
+ .Z {
+ set path [file rootname $path]
+ set var(encoding) compress
+ }
+ .z {
+ set path [file rootname $path]
+ set var(encoding) pack
+ }
+ }
+
+ switch -- [string tolower [file extension $path]] {
+ .html -
+ .htm {set var(mime) "text/html"}
+ .gif {set var(mime) "image/gif"}
+ .jpeg -
+ .jpg {set var(mime) "image/jpeg"}
+ .tiff -
+ .tif {set var(mime) "image/tiff"}
+ .png {set var(mime) "image/png"}
+
+ .fits -
+ .fit -
+ .fts {set var(mime) "image/fits"}
+
+ .ftz -
+ .fits.gz -
+ .fgz {
+ set var(mime) "image/fits"
+ set var(encoding) "gzip"
+ }
+
+ .text -
+ .txt {set var(mime) "text/plain"}
+ .multi {
+ set var(mime) "multipart/mixed"
+ set var(xpa,target) "*:*"
+ if {[file exists "$path"]} {
+ set ch [open "$path" r]
+ if {[gets $ch line] >= 0} {
+ set var(mime,param) "Content-Type: multipart/mixed; Boundary=[string range $line 2 end]"
+ }
+ catch {close $ch}
+ }
+ }
+
+ .sao {set var(mime) "text/x-cmap-sao"}
+
+ default {
+ switch -- $var(encoding) {
+ gzip -
+ bzip2 -
+ compress -
+ pack {set var(mime) "application/octet-stream"}
+ default {set var(mime) "text/plain"}
+ }
+ }
+ }
+
+ HVParse $varname
+}
+
+proc HVParse {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParse"
+ }
+
+ switch -- $var(mime) {
+ "multipart/alternative" -
+ "multipart/parallel" -
+ "multipart/digest" -
+ "multipart/related" -
+ "multipart/signed" -
+ "multipart/encrypted" -
+ "multipart/report" {}
+
+ "multipart/x-mixed-replace" -
+ "multipart/mixed" {
+ HVParseMulti $varname
+ HVClearCache $varname
+ }
+
+ default {HVParseSingle $varname}
+ }
+
+ if {$var(analysis)} {
+ AnalysisTaskEnd $var(analysis,which) $var(analysis,i)
+ HVSetAnalysis $varname 0 {} 0
+ }
+}
+
+proc HVParseMulti {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseMulti"
+ }
+
+ # do it now, to be restored later
+ if {[info exists var(index)]} {
+ incr ${varname}(index)
+ set var(index,$var(index)) [list $var(url) $var(query)]
+ set index $var(index)
+ }
+
+ set fn $var(fn)
+ set del $var(delete)
+
+ if {[file exists "$var(fn)"]} {
+ if {[catch {open "$var(fn)" r} ch]} {
+ HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)"
+ return
+ }
+ }
+
+ set boundary [HVParseMimeParam $varname "boundary"]
+ if {[string equal "$boundary" {}]} {
+ HVError $varname [msgcat::mc {Invalid formated multipart/mixed mime type message}]
+ return
+ }
+
+ set state 1
+ set var(ch) {}
+
+ HVSetResult $varname 200 {}
+ HVSetData $varname {} {}
+
+ while {[gets $ch line] >= 0} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseMulti $state:$line"
+ }
+
+ switch -- $state {
+ 1 {
+ # boundary
+ if {[string equal "--$boundary" $line]} {
+ set state 2
+ }
+ }
+ 2 {
+ # header
+ if {[string length $line] == 0} {
+ HVParseMeta $varname
+
+ # save to a file
+ set var(fn) [tmpnam {.http}]
+ set var(delete) 1
+ if {[catch {open "$var(fn)" w} ${varname}(ch)]} {
+ HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)"
+ return
+ }
+ switch $var(transfer) {
+ binary -
+ base64 {
+ fconfigure $var(ch) \
+ -translation binary -encoding binary
+ }
+ }
+
+ set state 3
+ } else {
+ if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
+ lappend var(meta) $key [string trim $value]
+ }
+ }
+ }
+ 3 {
+ # body
+ if {[string equal "--$boundary" $line]} {
+ catch {close $var(ch)}
+ HVParseSingle $varname
+ HVClearTmpFile $varname
+
+ set var(ch) {}
+
+ HVSetResult $varname 200 {}
+
+ # we want to preserve var(text)
+ # HVSetData $varname {} {}
+ set var(data) {}
+ set var(fn) {}
+
+ set state 2
+
+ } elseif {[string equal "--$boundary--" $line]} {
+ catch {close $var(ch)}
+ catch {close $ch}
+
+ HVParseSingle $varname
+ HVClearTmpFile $varname
+
+ # reset file values
+ set var(fn) $fn
+ set var(delete) $del
+
+ if {[info exists var(index)]} {
+ # reset index
+ set var(index) $index
+ HVClearIndex $varname $index
+ }
+
+ return
+
+ } else {
+ switch $var(transfer) {
+ binary {puts -nonewline $var(ch) $line}
+ base64 {
+ puts -nonewline $var(ch) [base64::decode $line]
+ }
+ default {puts $var(ch) $line}
+ }
+ }
+ }
+ }
+ }
+
+ # clean up
+ catch {close $ch}
+ set var(fn) $fn
+}
+
+proc HVParseSingle {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseSingle $var(url)"
+ }
+
+ switch -- $var(mime) {
+ "text/html" -
+ "text/plain" -
+ "application/octet-stream" {
+ # its never fails, someone can't get there mime types correct.
+ # Override the mime type based on path
+
+ ParseURL $var(url) r
+ set path [file tail $r(path)]
+
+ # set content-encoding
+ switch -- [file extension $path] {
+ .gz {
+ set path [file rootname $path]
+ set var(encoding) gzip
+ }
+ .bz2 {
+ set path [file rootname $path]
+ set var(encoding) bzip2
+ }
+ .Z {
+ set path [file rootname $path]
+ set var(encoding) compress
+ }
+ .z {
+ set path [file rootname $path]
+ set var(encoding) pack
+ }
+ }
+
+ # set Content-Type
+ switch -- [file extension $path] {
+ .html -
+ .htm {set var(mime) "text/html"}
+ .gif {set var(mime) "image/gif"}
+ .jpeg -
+ .jpg {set var(mime) "image/jpeg"}
+ .tiff -
+ .tif {set var(mime) "image/tiff"}
+ .png {set var(mime) "image/png"}
+
+ .fits -
+ .fit -
+ .fts {set var(mime) "image/fits"}
+
+ .ftz -
+ .fgz {
+ set var(mime) "image/fits"
+ set var(encoding) "gzip"
+ }
+
+ .xml -
+ .vot -
+ .votable {set var(mime) "text/xml"}
+
+ .text -
+ .txt {set var(mime) "text/plain"}
+
+ .sao {set var(mime) "text/x-cmap-sao"}
+ }
+ }
+ }
+
+ switch -- $var(mime) {
+ "text/html" {HVParseHTML $varname}
+ "text/plain" {HVParseText $varname}
+ "application/octet-stream" {HVParseSave $varname}
+
+ "image/gif" -
+ "image/jpeg" -
+ "image/tiff" -
+ "image/png" {HVParseImg $varname}
+
+ "image/fits" -
+ "application/fits" {HVParseFITS $varname}
+
+ "application/fits-image" -
+ "application/fits-table" -
+ "application/fits-group" {HVParseFITS $varname}
+
+ "image/x-fits" -
+ "binary/x-fits" -
+ "application/x-fits" {HVParseFITS $varname}
+
+ "image/fits-hcompress" -
+ "image/x-fits-h" {HVParseFITS $varname}
+
+ "image/x-gfits" -
+ "binary/x-gfits" -
+ "image/gz-fits" -
+ "application/x-gzip" -
+ "display/gz-fits" {
+ set var(encoding) gzip
+ HVParseFITS $varname
+ }
+
+ "image/bz2-fits" -
+ "display/bz2-fits" {
+ set var(encoding) bzip2
+ HVParseFITS $varname
+ }
+
+ "image/x-cfits" -
+ "binary/x-cfits" {
+ set var(encoding) compress
+ HVParseFITS $varname
+ }
+
+ "image/x-zfits" -
+ "binary/x-zfits" {
+ set var(encoding) pack
+ HVParseFITS $varname
+ }
+
+ "text/xml" -
+ "application/xml" -
+ "application/x-votable+xml" {HVParseVOT $varname}
+
+ "x-xpa/xpaget" {}
+ "x-xpa/xpaset" {HVParseXPASet $varname}
+ "x-xpa/xpainfo" {}
+ "x-xpa/xpaaccess" {}
+
+ "text/x-cmap-sao" {HVParseColormap $varname}
+
+ default {HVParseSave $varname}
+ }
+}
+
+proc HVParseText {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseText"
+ }
+
+ if {[string length $var(data)] == 0} {
+ if {[file exists "$var(fn)"]} {
+ if {[catch {open "$var(fn)" r} ch]} {
+ HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)"
+ return
+ }
+ set var(data) [read $ch]
+ close $ch
+ }
+ }
+
+ if {$var(analysis)} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseText Analysis"
+ }
+ AnalysisProcessGetURL $var(analysis,which) $var(analysis,i) $var(data)
+ } else {
+ append var(text) $var(data)
+ set var(data) \
+ "<html>\n<body>\n$var(text)\n</body>\n</html>"
+ HVSetResult $varname 200 "text/html"
+ HVParseHTML $varname
+ }
+
+ HVClearCache $varname
+}
+
+proc HVParseHTML {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseHTML"
+ }
+
+ if {[string length $var(data)] == 0} {
+ if {[file exists "$var(fn)"]} {
+ if {[catch {open "$var(fn)" r} ch]} {
+ HVError $varname "[msgcat::mc {Unable to open file}] $var(fn)"
+ return
+ }
+ set var(data) [read $ch]
+ close $ch
+ }
+ }
+
+ # figure out the base
+ # we don't want any query or fragments
+ ParseURL $var(url) r
+
+ set base {}
+ # scheme
+ switch $r(scheme) {
+ http {append base "$r(scheme)://"}
+ ftp {}
+ file {}
+ }
+ # authority
+ if {[string length $r(authority)] != 0} {
+ append base "$r(authority)"
+ }
+ # path
+ if {[string length $r(path)] != 0} {
+ append base "$r(path)"
+ } else {
+ append base "/"
+ }
+ # query
+ if {[string length $r(query)] != 0} {
+ append base "?$r(query)"
+ }
+
+ # spaces?
+ # regsub { } $base {\ } base
+
+ $var(widget) config -base $base
+
+ if {$debug(tcl,hv)} {
+ DumpURL r
+ puts stderr "HVParseHTML base [$var(widget) cget -base]"
+ }
+
+ # we have a valid html
+ $var(widget) clear
+
+ # fix forms with no action
+ HVFixHTMLForm $varname
+
+ # and now, parse it
+ $var(widget) parse $var(data)
+
+ HVGotoHTML $varname
+}
+
+proc HVParseImg {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseImg $var(url)"
+ }
+
+ if {$var(save)} {
+ switch -- $var(mime) {
+ "image/gif" {set fn [SaveFileDialog giffbox]}
+ "image/jpeg" {set fn [SaveFileDialog jpegfbox]}
+ "image/tiff" {set fn [SaveFileDialog tifffbox]}
+ "image/png" {set fn [SaveFileDialog pngfbox]}
+ }
+
+ if {[string length "$fn"] != 0} {
+ if {![catch {file rename -force "$var(fn)" "$fn"}]} {
+ set var(fn) "$fn"
+ set var(delete) 0
+ }
+ }
+ }
+
+ switch -- $var(frame) {
+ new {MultiLoadBase}
+ current {}
+ }
+
+ ImportPhotoFile $var(fn) {}
+
+ HVClearTmpFile $varname
+ HVClearAll $varname
+ HVUpdateDialog $varname
+}
+
+proc HVParseFITS {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global debug
+
+ if {$var(save)} {
+ switch -- $var(encoding) {
+ gzip {FileLast savefitsfbox "ds9.fits.gz"}
+ bzip2 {FileLast savefitsfbox "ds9.fits.bz2"}
+ compress {FileLast savefitsfbox "ds9.fits.Z"}
+ pack {FileLast savefitsfbox "ds9.fits.z"}
+ default {FileLast savefitsfbox "ds9.fits"}
+ }
+
+ set fn [SaveFileDialog savefitsfbox]
+ if {[string length "$fn"] != 0} {
+ if {![catch {file rename -force "$var(fn)" "$fn"}]} {
+ set var(fn) "$fn"
+ set var(delete) 0
+ }
+ }
+ }
+
+ switch -- $var(frame) {
+ new {MultiLoadBase}
+ current {}
+ }
+
+ StartLoad
+ global loadParam
+ set loadParam(load,type) allocgz
+ set loadParam(load,layer) {}
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {}
+ set loadParam(file,name) "$var(fn)"
+ set loadParam(file,fn) $loadParam(file,name)
+
+ # may have to convert the file, based on content-encoding
+ switch -- "$var(encoding)" {
+ bzip2 {
+ catch {set ch [open "| bunzip2 < $var(fn) " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ compress {
+ catch {set ch [open "| uncompress < $var(fn) " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ pack {
+ catch {set ch [open "| pcat $var(fn) " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ }
+
+ ProcessLoad
+ FinishLoad
+
+ HVClearTmpFile $varname
+ HVClearAll $varname
+ HVUpdateDialog $varname
+}
+
+proc HVParseColormap {varname} {
+ upvar #0 $varname var
+ global $varname
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseColormap"
+ }
+
+ set fn [HVParseMimeParam $varname "name"]
+ if {$fn == {}} {
+ ParseURL $var(url) r
+ set fn [file tail $r(path)]
+ }
+
+ if {![catch {file rename -force $var(fn) $ds9(tmpdir)/$fn}]} {
+ LoadColormapFile $ds9(tmpdir)/$fn
+ }
+
+ HVClearAll $varname
+ HVUpdateDialog $varname
+}
+
+proc HVParseVOT {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseVOT"
+ }
+
+ if {[file exists "$var(fn)"]} {
+ CATVOTFile "$var(fn)"
+ }
+
+ HVClearTmpFile $varname
+ HVClearAll $varname
+ HVUpdateDialog $varname
+}
+
+proc HVParseSave {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseSave"
+ }
+
+ set fn [HVParseMimeParam $varname "name"]
+ if {$fn == {}} {
+ ParseURL $var(url) r
+ set fn [file tail $r(path)]
+ }
+ FileLast savefitsfbox $fn
+ set fn [SaveFileDialog savefitsfbox]
+ if {[string length "$fn"] != 0} {
+ if {![catch {file rename -force "$var(fn)" "$fn"}]} {
+ set var(delete) 0
+ }
+ }
+
+ HVClearAll $varname
+ HVUpdateDialog $varname
+}
+
+proc HVParseXPASet {varname} {
+ upvar #0 $varname var
+ global $varname
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVParseXPASet: [HVParseMimeParam $varname paramlist]"
+ }
+
+ if {[info exists var(xpa,target)]} {
+ set target $var(xpa,target)
+ } else {
+ set target [HVParseMimeParam $varname target]
+ }
+
+ if {$target == "$ds9(title)" ||
+ $target == "DS9:*" ||
+ $target == "DS9:$ds9(title)" ||
+ $target == "*:$ds9(title)" ||
+ $target == "*:*" ||
+ $target == [XPAMethod]} {
+
+ InitError hv
+ CommSet $var(fn) [HVParseMimeParam $varname paramlist] 1
+ } else {
+ HVError $varname "[msgcat::mc {Unable to match target with XPA Mime request}] $url"
+ }
+}
+
+proc HVGotoHTML {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ incr ${varname}(index)
+ set var(index,$var(index)) [list $var(url) $var(query)]
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVGotoHTML $var(index) |$var(url)|$var(query)|$var(fragment)|"
+ }
+
+ if {[string length $var(fragment)] != 0} {
+ if {$debug(tcl,idletasks)} {
+ puts stderr "HVGotoHTML"
+ }
+ update idletasks
+
+ $var(widget) yview $var(fragment)
+ } else {
+ $var(widget) yview moveto 0
+ }
+
+ HVUpdateDialog $varname
+}
+
+proc HVClearCache {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVClearCache $varname"
+ }
+
+ foreach x [array names $varname "cache,file,*"] {
+ catch {file delete $var($x)}
+ }
+ foreach x [array names $varname "cache,*"] {
+ unset ${varname}($x)
+ }
+}
+
+proc HVClearIndex {varname n} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVClearIndex $varname $n"
+ }
+
+ foreach x [array names $varname "index,*"] {
+ set f [split $x ,]
+ if {[lindex $f 1] > $n} {
+ unset ${varname}($x)
+ }
+ }
+ set var(index) $n
+}
+
+proc HVClearTmpFile {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVClearTmpFile"
+ }
+
+ if {$var(delete) && [string length "$var(fn)"] != 0} {
+ if {[file exists "$var(fn)"]} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVClearTmpFile delete $var(fn)"
+ }
+ file delete "$var(fn)"
+ }
+ set var(fn) {}
+ set var(delete) 0
+ }
+}
+
+proc HVUpdateDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # in case we've set the cursor
+ $var(widget) configure -cursor {}
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVUpdateDialog\n"
+ }
+
+ set id $var(index)
+ set id [incr id -1]
+ if {[info exists ${varname}(index,$id)]} {
+ $var(mb).view entryconfig [msgcat::mc {Back}] -state normal
+ } else {
+ $var(mb).view entryconfig [msgcat::mc {Back}] -state disabled
+ }
+
+ set id $var(index)
+ set id [incr id 1]
+ if {[info exists ${varname}(index,$id)]} {
+ $var(mb).view entryconfig [msgcat::mc {Forward}] -state normal
+ } else {
+ $var(mb).view entryconfig [msgcat::mc {Forward}] -state disabled
+ }
+}
+
+proc HVRefresh {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVRefresh"
+ }
+
+ set var(delete) 0
+ HVParse $varname
+}
+
+proc HVProgress {varname token totalsize currentsize} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVProgress:$varname"
+ }
+
+ if {$totalsize != 0} {
+ HVStatus $varname "$currentsize bytes of $totalsize bytes [expr int(double($currentsize)/$totalsize*100)]%"
+ } else {
+ HVStatus $varname "$currentsize bytes"
+ }
+}
+
+proc HVFTPHtmlList {host path list} {
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFTPHtmlList $host $path"
+ }
+ if {[string range $path end end] != "/"} {
+ append path {/}
+ }
+
+ set html {}
+ append html "<html>\n"
+ append html "<head>\n"
+ append html "<title>Index of $path on $host</title>\n"
+ append html "</head>\n"
+ append html "<body>\n"
+ append html "<h1>Index on $path on $host</h1>\n"
+ append html "<hr>\n"
+ append html "<pre>\n"
+ foreach l $list {
+ switch -- [llength $l] {
+ 8 {set offset 4}
+ 9 {set offset 5}
+ 10 {set offset 4}
+ 11 {set offset 5}
+ default {set offset 5}
+ }
+
+ set ii [lindex $l [expr $offset+3]]
+ switch -- [string range $l 0 0] {
+ d {
+ set new "<a href=\"ftp://$host$path$ii/\">$ii</A>"
+ }
+ l {
+ set new "<a href=\"ftp://$host$path$ii\">$ii</A>"
+ }
+ default {
+ set new "<a href=\"ftp://$host$path$ii\">$ii</A>"
+ }
+ }
+
+ regsub $ii $l $new l
+ append html "$l\n"
+ }
+ append html "</pre>\n"
+ append html "</hr>\n"
+ append html "</body>\n"
+
+ return $html
+}
+
+proc HVFileHtmlList {path list} {
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFileHtmlList $path"
+ }
+
+ if {[string range $path end end] != "/"} {
+ append path {/}
+ }
+
+ set html {}
+ append html "<html>\n"
+ append html "<head>\n"
+ append html "<title>Index of $path</title>\n"
+ append html "</head>\n"
+ append html "<body>\n"
+ append html "<h1>Index on $path</h1>\n"
+ append html "<hr>\n"
+ append html "<pre>\n"
+ foreach l $list {
+ switch -- [llength $l] {
+ 8 {set offset 4}
+ 9 {set offset 5}
+ 10 {set offset 4}
+ 11 {set offset 5}
+ default {set offset 5}
+ }
+
+ set ii [lindex $l [expr $offset+3]]
+ switch -- [string range $l 0 0] {
+ d {
+ set new "<a href=\"file:$path$ii/\">$ii</A>"
+ }
+ l {
+ set new "<a href=\"file:$path$ii\">$ii</A>"
+ }
+ default {
+ set new "<a href=\"file:$path$ii\">$ii</A>"
+ }
+ }
+
+ regsub $ii $l $new l
+ append html "$l\n"
+ }
+ append html "</pre>\n"
+ append html "</hr>\n"
+ append html "</body>\n"
+
+ return $html
+}
+
+proc HVDirList {path} {
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVDirList $path"
+ }
+ return [split [exec ls -l $path] \n]
+}
+
+proc HVSetURL {varname url query fragment} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVSetURL $url $query $fragment"
+ }
+
+ set var(url) $url
+ set var(query) $query
+ set var(fragment) $fragment
+}
+
+proc HVSetResult {varname code mime} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVSetResult $code $mime"
+ }
+
+ set var(code) $code
+ set var(meta) {}
+ set var(mime) $mime
+ set var(mime,param) {}
+ set var(cache) 0
+ set var(cache,images) 1
+ set var(expire) 0
+ set var(encoding) {}
+ set var(transfer) {}
+ set var(refresh,time) 0
+ set var(refresh,url) {}
+ set var(refresh,id) 0
+}
+
+proc HVSetData {varname data fn} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVSetData $fn"
+ }
+
+ set var(data) $data
+ set var(text) {}
+ set var(fn) "$fn"
+}
+
+proc HVSetAnalysis {varname aa which ii} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVSetAnalysis"
+ }
+
+ set var(analysis) $aa
+ set var(analysis,which) $which
+ set var(analysis,i) $ii
+}
+
+proc HVClearAll {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVClearAll"
+ }
+
+ HVSetURL $varname {} {} {}
+ HVSetResult $varname {} {}
+ HVSetData $varname {} {}
+ HVSetAnalysis $varname 0 {} 0
+}
+
+# CallBacks
+
+proc HVImageCB {varname args} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageCB $varname args: $args"
+ }
+
+ set url [lindex $args 0]
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageCB url: $url"
+ }
+
+ # do we have anything?
+ if {[string length $url] == 0} {
+ return
+ }
+
+ # do we have a width/height?
+ set aa [lindex $args 3]
+ set width [HVattrs width $aa 0]
+ set height [HVattrs height $aa 0]
+ set src [HVattrs src $aa 0]
+
+ # check for percent (100%) in width/height
+ if {![string is integer $width]} {
+ set width 0
+ }
+ if {![string is integer $height]} {
+ set height 0
+ }
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageCB src: $width $height $src"
+ }
+
+ # we have a problem in that htmlwidget will not properly resolve a windows
+ # file name, there for we may have a bad file name url
+ # double check with the src attribute
+ global tcl_platform
+ switch $tcl_platform(platform) {
+ unix {}
+ windows {
+ ParseURL $url r
+
+ switch -- $r(scheme) {
+ {} -
+ file {
+ if {![file exists $url]} {
+ # bad, try src
+ if {[file exists $src]} {
+ set url $src
+ }
+ }
+ }
+ }
+ }
+ }
+
+ set img [HVImageURL $varname $url $width $height]
+
+ if {[string length $img] != 0} {
+ return $img
+ } else {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageCB FAIL $url"
+ }
+ return $var(images,gray)
+ }
+}
+
+proc HVImageURL {varname url width height} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL $varname $url $width $height"
+ }
+
+ # do we already have the image?
+ if {[info exists ${varname}(images,$url)]} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL found image a $url"
+ }
+ return $var(images,$url)
+ }
+
+ ParseURL $url r
+
+ set fn {}
+ switch -- $r(scheme) {
+ {} -
+ file {
+ if {[file exists $r(path)]} {
+ # can't use -file for zvfs
+ # catch {image create photo -file $r(path)} img
+ set ch [open $r(path) r]
+ fconfigure $ch -translation binary -encoding binary
+ set dd [read $ch]
+ close $ch
+ unset ch
+
+ catch {image create photo -data "$dd"} img
+ unset dd
+ }
+ }
+ ftp {
+ set fn [tmpnam [file extension $r(path)]]
+ set ftp [ftp::Open $r(authority) "ftp" "-ds9@" -mode passive]
+ if {$ftp > -1} {
+ set ftp::VERBOSE $debug(tcl,ftp)
+ set "ftp::ftp${ftp}(Output)" FTPLog
+ ftp::Type $ftp binary
+ if {[ftp::Get $ftp $r(path) "$fn"]} {
+ ftp::Close $ftp
+
+ if {[file size "$fn"] == 0} {
+ catch {file delete -force "$fn"}
+ return {}
+ }
+ if {[catch {image create photo -file "$fn"} img]} {
+ catch {file delete -force "$fn"}
+ return {}
+ }
+ }
+ }
+ }
+ http {
+ set ch {}
+
+ set fn [tmpnam [file extension $r(path)]]
+
+ for {set ii 5} {$ii>0} {incr ii -1} {
+ if {[catch {open "$fn" w} ch]} {
+ HVError $varname "[msgcat::mc {Unable to open file}] $fn"
+ return {}
+ }
+
+ global ihttp
+ if {[catch {set token \
+ [http::geturl $url \
+ -timeout $ihttp(timeout) \
+ -progress [list HVProgress $varname] \
+ -channel $ch \
+ -binary 1 \
+ -headers "[HVHTTPHeader $varname]" \
+ ]}]} {
+
+ # if there is a problem, just bail
+ set ii 0
+ continue
+ }
+
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ catch {close $ch}
+
+ upvar #0 $token t
+ set code [http::ncode $token]
+ set meta $t(meta)
+
+ # result?
+ switch -- $code {
+ 200 -
+ 203 -
+ 503 {set ii 0}
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $meta {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL redirect $code to $value"
+ }
+ # clean up and resubmit
+ set url $value
+ http::cleanup $token
+ catch {file delete -force "$fn"}
+ }
+ }
+ }
+
+ default {
+ # in general, we don't want to know about this
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL HTTP Error: $code"
+ }
+ set ii 0
+ }
+ }
+ }
+
+ catch {http::cleanup $token}
+
+ if {[file size "$fn"] == 0} {
+ catch {file delete -force "$fn"}
+ return {}
+ }
+ if {[catch {image create photo -file "$fn"} img]} {
+ catch {file delete -force "$fn"}
+ return {}
+ }
+ }
+ }
+
+ # do we have an img?
+ if {![info exists img]} {
+ return {}
+ }
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL got image $img"
+ }
+
+ # adjust image size if needed
+ if {$width != 0 || $height != 0} {
+ set iw [image width $img]
+ set ih [image height $img]
+
+ set doit 1
+ # check for one dimension of 0. calculate to maintain aspect ratio
+ if {$width == 0} {
+ set width [expr $iw*$height/$ih]
+
+ # see if we have a bad resample dimension
+ set wf [expr double($iw)*$height/$ih]
+ if {$width != $wf} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL abort resample image $img width $wf"
+ }
+ set doit 0
+ }
+ }
+ if {$height == 0} {
+ set height [expr $ih*$width/$iw]
+
+ # see if we have a bad resample dimension
+ set hf [expr double($ih)*$width/$iw]
+ if {$height != $hf} {
+ if {$debug(tcl,hv)} {
+ puts stderr \
+ "HVImageURL abort resample image $img height $hf"
+ }
+ set doit 0
+ }
+ }
+
+ # check to resample
+ if {$doit && ($width != $iw || $height != $ih)} {
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL resample image $iw->$width $ih->$height"
+ }
+
+ set img2 \
+ [image create photo -width $width -height $height]
+ if {[catch {blt::winop image resample $img $img2 box} ]} {
+ # just use existing img
+ if {$debug(tcl,hv)} {
+ puts stderr "HVImageURL error resample image $img"
+ }
+ } else {
+ set tmp $img
+ set img $img2
+ catch {image delete $tmp}
+ }
+ }
+ }
+
+ # delete any tmp files
+ if {"$fn" != {}} {
+ catch {file delete -force "$fn"}
+ }
+
+ if {$var(cache,images)} {
+ set var(images,$url) $img
+ }
+
+ return $img
+}
+
+proc HVFontCB {varname sz args} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFontCB $varname $sz $args"
+ }
+
+ set family $var(font)
+ set size $var(font,size)
+ set weight $var(font,weight)
+ set slant $var(font,slant)
+
+ global ds9
+ foreach ff [concat [lindex $args 0]] {
+ switch -- $ff {
+ fixed {
+ set family $ds9(courier)
+ set sz [expr $sz-1]
+ }
+ bold {set weight bold}
+ italic {set slant italic}
+ }
+ }
+
+ switch -- $sz {
+ 0 {incr size -3}
+ 1 {incr size -2}
+ 2 {incr size -1}
+ 3 {}
+ 4 {incr size 6}
+ 5 {incr size 12}
+ 6 {incr size 24}
+ 7 {incr size 36}
+ }
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFontCB \{$family\} $size $weight $slant"
+ }
+ return "\{$family\} $size $weight $slant"
+}
+
+proc HVNoScriptCB {varname n tag args} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+# puts stderr "HVNoScriptCB $varname $n $tag $args"
+ }
+}
+
+proc HVScriptCB {varname args} {
+ upvar #0 $varname var
+
+ global debug
+ if {$debug(tcl,hv)} {
+# puts stderr "HVScriptCB $varname $args"
+ }
+}
+
+proc HVFrameCB {varname args} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$debug(tcl,hv)} {
+ puts stderr "HVFrameCB $varname $args"
+ }
+}
+
+proc HVAppletCB {varname w args} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,hv)} {
+ puts stderr "HVAppletCB $varname $w $args"
+ }
+}
+
+proc HVParseMimeParam {varname key} {
+ upvar #0 $varname var
+ global $varname
+
+ foreach {pp} [split $var(mime,param) {;}] {
+ set id [string first {=} $pp]
+ set name [string trim [string range $pp 0 [expr $id-1]]]
+ set value [string trim [string range $pp [expr $id+1] end]]
+ if {[string equal -nocase $name $key]} {
+ return [string trim $value {"'}]
+ }
+ }
+
+ return {}
+}
diff --git a/ds9/library/iexam.tcl b/ds9/library/iexam.tcl
new file mode 100644
index 0000000..aa6795b
--- /dev/null
+++ b/ds9/library/iexam.tcl
@@ -0,0 +1,189 @@
+# 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 IExamDef {} {
+ global iexam
+
+ set iexam(button) 0
+ set iexam(key) 0
+ set iexam(any) 0
+ set iexam(frame) {}
+ set iexam(x) {}
+ set iexam(y) {}
+ set iexam(event) {}
+ set iexam(mode) {}
+}
+
+proc IExamButton {which xx yy} {
+ global iexam
+ global imarker
+
+ if {$iexam(button) || $iexam(any)} {
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ set iexam(frame) $which
+ set iexam(x) $xx
+ set iexam(y) $yy
+
+ if {$iexam(any)} {
+ set iexam(event) {<1>}
+ }
+ set iexam(button) 0
+ set iexam(any) 0
+ }
+}
+
+proc IExamKey {which K xx yy} {
+ global iexam
+
+ if {$iexam(key) || $iexam(any)} {
+ set iexam(frame) $which
+ set iexam(x) $xx
+ set iexam(y) $yy
+ set iexam(event) $K
+
+ set iexam(key) 0
+ set iexam(any) 0
+ }
+}
+
+proc ProcessSendIExamCmd {proc id param} {
+ global iexam
+
+ global icursor
+ global current
+
+ set iexam(frame) {}
+ set iexam(x) {}
+ set iexam(y) {}
+ set iexam(event) {}
+ set iexam(mode) $current(mode)
+
+ set current(mode) iexam
+
+ set iexam(button) 0
+ set iexam(key) 0
+ set iexam(any) 0
+
+ # turn on blinking cursor
+ set icursor(timer) 1
+ CursorTimer
+
+ switch -- [string tolower [lindex $param 0]] {
+ button {
+ set iexam(button) 1
+ set varname {iexam(button)}
+ set param [join [lreplace $param 0 0]]
+ }
+ key {
+ set iexam(key) 1
+ set varname {iexam(key)}
+ set param [join [lreplace $param 0 0]]
+ }
+ any {
+ set iexam(any) 1
+ set varname {iexam(any)}
+ set param [join [lreplace $param 0 0]]
+ }
+ default {
+ set iexam(button) 1
+ set varname {iexam(button)}
+ }
+ }
+
+ switch -- [string tolower [lindex $param 0]] {
+ value -
+ data {
+ vwait $varname
+ set w [lindex $param 1]
+ set h [lindex $param 2]
+ if {$w == {}} {
+ set w 1
+ }
+ if {$h == {}} {
+ set h 1
+ }
+ $proc $id "$iexam(event) [$iexam(frame) get data canvas $iexam(x) $iexam(y) $w $h]\n"
+ }
+ coordinate {
+ set sys [lindex $param 1]
+ set sky [lindex $param 2]
+ set skyformat [lindex $param 3]
+ switch -- $skyformat {
+ {} {set skyformat degrees}
+ }
+ switch -- $sky {
+ {} {set sky fk5}
+ }
+ switch -- $sys {
+ {} {set sys physical}
+ fk4 -
+ fk5 -
+ icrs -
+ galactic -
+ ecliptic {set sky $sys; set sys wcs}
+ }
+
+ vwait $varname
+ $proc $id "$iexam(event) [$iexam(frame) get coordinates $iexam(x) $iexam(y) $sys $sky $skyformat]\n"
+ }
+ {} {
+ vwait $varname
+ $proc $id "$iexam(event) [$iexam(frame) get coordinates $iexam(x) $iexam(y) image fk5 degrees]\n"
+ }
+ default {
+ vwait $varname
+ set cmd $param
+
+ # $width,$height,$depth,$bitpix
+ ParseXYBitpixMacro cmd $iexam(frame)
+
+ # $filename[$regions]
+ ParseFilenameRegionMacro cmd $iexam(frame)
+
+ # $filename
+ ParseFilenameMacro cmd $iexam(frame)
+
+ # $regions
+ ParseRegionMacro cmd $iexam(frame)
+
+ # $env
+ ParseEnvMacro cmd
+
+ # $pan
+ ParsePanMacro cmd $iexam(frame)
+
+ # $value
+ ParseValueMacro cmd $iexam(frame) $iexam(x) $iexam(y)
+
+ # $x,$y
+ ParseXYMacro cmd $iexam(frame) $iexam(x) $iexam(y)
+
+ # $z
+ ParseZMacro cmd $iexam(frame)
+
+ $proc $id "$iexam(event) $cmd\n"
+ }
+ }
+
+ # turn off blinking cursor
+ set icursor(timer) 0
+
+ set current(mode) $iexam(mode)
+
+ set iexam(button) 0
+ set iexam(key) 0
+
+ set iexam(frame) {}
+ set iexam(x) {}
+ set iexam(y) {}
+ set iexam(event) {}
+ set iexam(mode) {}
+}
+
diff --git a/ds9/library/iis.tcl b/ds9/library/iis.tcl
new file mode 100644
index 0000000..5672ebf
--- /dev/null
+++ b/ds9/library/iis.tcl
@@ -0,0 +1,398 @@
+# 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 IISDef {} {
+ global iis
+
+ # all internal
+ set iis(state) 0
+ set iis(width) 512
+ set iis(height) 512
+ set iis(x) -1
+ set iis(y) -1
+ set iis(frame) {}
+
+ set iis(ififo) "/dev/imt1i"
+ set iis(ofifo) "/dev/imt1o"
+ set iis(port) 5137
+ set iis(unix) "/tmp/.IMT%d"
+}
+
+proc IISInit {} {
+ global iis
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISInit:"
+ }
+
+ iis open $iis(ififo) $iis(ofifo) $iis(port) $iis(unix)
+}
+
+proc IISClose {} {
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISClose:"
+ }
+
+ iis close
+}
+
+proc IISDebug {} {
+ global debug
+
+ iis debug $debug(iis)
+}
+
+# Callbacks
+
+proc IISInitializeCmd {w h} {
+ global iis
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISInitializeCmd: $w $h"
+ }
+
+ # default frame size
+ set iis(width) $w
+ set iis(height) $h
+}
+
+proc IISInitFrameCmd {which} {
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISInitFrameCmd: $which"
+ }
+}
+
+proc IISSetDisplayFrameCmd {which w h} {
+ global iis
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISSetDisplayFrameCmd: $which $w $h"
+ }
+ IISGotoFrame $which
+ IISLoadFrame $which
+}
+
+proc IISSetRefFrameCmd {which} {
+ global iis
+ global ds9
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISSetRefFrameCmd: $which"
+ }
+
+ if {[lsearch $ds9(frames) Frame$which] == -1} {
+ return {[NOSUCHFRAME]}
+ }
+
+ if {[Frame$which has iis]} {
+ return {}
+ }
+
+ set filename [Frame$which get iis file name $iis(x) $iis(y)]
+
+ if {![string equal [string index $filename 0] "/"] } {
+ set filename [file join [pwd] $filename]
+ }
+
+ return "$filename 1. 0. 0. 1. 0. 0. 1. 32767. 1."
+}
+
+proc IISEraseFrameCmd {which} {
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISEraseFrameCmd: $which"
+ }
+
+ Frame$which iis erase
+ IISResetTimer $which
+}
+
+proc IISMessageCmd {message} {
+ global current
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISMessageCmd: $message"
+ }
+
+ $current(frame) iis message "\"$message\""
+ RefreshInfoBox $current(frame)
+}
+
+proc IISWritePixelsCmd {which ptr x y dx dy} {
+ global debug
+ if {$debug(iis)} {
+# puts stderr "IISWritePixelsCmd: $which $x $y $dx $dy"
+ }
+
+ Frame$which iis set $ptr $x $y $dx $dy
+ IISResetTimer $which
+}
+
+proc IISReadPixelsCmd {which ptr x y dx dy} {
+ global current
+
+ global debug
+ if {$debug(iis)} {
+# puts stderr "IISReadPixelsCmd: $which $x $y $dx $dy"
+ }
+
+ if {$which > 0} {
+ Frame$which get iis $ptr $x $y $dx $dy
+ } else {
+ $current(frame) get iis $ptr $x $y $dx $dy
+ }
+# IISResetTimer $which
+}
+
+proc IISWCSCmd {which a b c d e f z1 z2 zt} {
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISWCSCmd: $which $a $b $c $d $e $f $z1 $z2 $zt"
+ }
+
+ # if there is a change in config, we are not told until now
+ if {$which > 0} {
+ IISLoadFrame $which
+ Frame$which iis wcs $a $b $c $d $e $f $z1 $z2 $zt
+ }
+}
+
+proc IISSetCursorPosCmd {x y} {
+ global current
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "***IISSetCursorPosCmd: $x $y"
+ }
+
+ $current(frame) iis cursor $x $y image
+}
+
+proc IISGetCursorPosCmd {} {
+ global current
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "***IISGetCursorPosCmd:"
+ }
+
+ if {[$current(frame) has iis]} {
+ # assume frame name 'Framexxx'
+ set num [string range $current(frame) 5 end]
+ return "[$current(frame) get iis cursor] $num"
+ } else {
+ # default to first frame
+ return "1 1 0"
+ }
+}
+
+proc IISCursorModeCmd {state} {
+ global iis
+ global current
+ global icursor
+ global ds9
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISCursorModeCmd: $iis(state)=$state $current(frame)=$iis(frame)"
+ }
+
+ if {$state != $iis(state)} {
+ # iis(frame) may have been deleted
+ if {[lsearch $ds9(frames) $iis(frame)] == -1} {
+ set iis(frame) {}
+ }
+
+ if {$iis(frame) == {}} {
+ set which $current(frame)
+ } else {
+ set which $iis(frame)
+ }
+
+ set iis(state) $state
+ $which iis cursor mode $state
+
+ if {$state} {
+ bind $ds9(canvas) <Key> [list IISCursorKey %K %A %x %y]
+ bind $ds9(canvas) <f> {}
+ UnBindEventsFrameKey $which
+
+ if {$icursor(timer,abort)} {
+ set icursor(timer,abort) 0
+ set icursor(timer) 1
+ } else {
+ set icursor(timer) 1
+ CursorTimer
+ }
+ } else {
+ bind $ds9(canvas) <Key> {}
+ bind $ds9(canvas) <f> {ToggleBindEvents}
+ BindEventsFrameKey $which
+
+ set icursor(timer,abort) 1
+ set icursor(timer) 0
+ set iis(frame) [lindex [$ds9(canvas) gettags current] 0]
+ }
+ }
+}
+
+proc IISLoadFrame {which} {
+ global iis
+ global ds9
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISLoadFrame: $which"
+ }
+
+ if {$which > 0} {
+ if {(![Frame$which has iis]) || \
+ ([Frame$which get fits width] != $iis(width)) || \
+ ([Frame$which get fits height] != $iis(height))} {
+
+ StartLoad
+ Frame$which iis new $iis(width) $iis(height)
+ FinishLoad
+ } else {
+ # make sure any previous data is rendered
+ Frame$which update now
+ }
+ }
+}
+
+proc IISGotoFrame {which} {
+ global current
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISGotoFrame: $which"
+ }
+
+ if {$which > 0} {
+ if {$current(frame) != "Frame$which"} {
+ CreateGotoFrame $which base
+ }
+ }
+}
+
+proc IISResetTimer {which} {
+ global iis
+
+ if {![info exists iis(timer$which)]} {
+ after 500 IISTimer $which
+ }
+ set iis(timer$which) 1
+}
+
+proc IISTimer {which} {
+ global iis
+
+ if {$iis(timer$which)} {
+ after 500 IISTimer $which
+ set iis(timer$which) 0
+ } else {
+ if {$which > 0} {
+ Frame$which iis update
+ # re-execute FinishLoad again since we are finally done loading
+ FinishLoad
+ }
+ unset iis(timer$which)
+ }
+}
+
+proc IISCursorKey {sym key xx yy} {
+ global current
+ global iis
+ global ds9
+
+ # MacOSX and Ubuntu returns bogus values in xx,yy
+ # calculate our own values
+ set xx [expr {[winfo pointerx $ds9(canvas)] - [winfo rootx $ds9(canvas)]}]
+ set yy [expr {[winfo pointery $ds9(canvas)] - [winfo rooty $ds9(canvas)]}]
+
+ global debug
+ if {$debug(iis)} {
+ puts stderr "IISCursorKey: $sym $key $xx $yy"
+ }
+
+ set which [lindex [$ds9(canvas) gettags current] 0]
+ if {$which == {}} {
+ return
+ }
+
+ set iis(x) $xx
+ set iis(y) $yy
+
+ switch -- $sym {
+ Up {$which warp 0 -1}
+ Down {$which warp 0 1}
+ Left {$which warp -1 0}
+ Right {$which warp 1 0}
+
+ default {
+ if {$key!={}} {
+ set num [string range $which end end]
+ set coord [$which get coordinates $xx $yy physical]
+ if {$coord == {}} {
+ switch -- $key {
+ : -
+ q {set coord "0 0"}
+ default {return}
+ }
+ }
+ $which iis cursor $xx $yy canvas
+ iis retcur [lindex $coord 0] [lindex $coord 1] $key $num
+ }
+ }
+ }
+}
+
+# Cmds
+
+proc ProcessIISCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+
+ switch -- [string tolower [lindex $var $i]] {
+ filename {
+ if {[string is integer [lindex $var [expr $i+2]]]} {
+ if {$current(frame) != {}} {
+ $current(frame) iis set file name \
+ [lindex $var [expr $i+1]] [lindex $var [expr $i+2]]
+ }
+ incr i 2
+ } else {
+ if {$current(frame) != {}} {
+ $current(frame) iis set file name [lindex $var [expr $i+1]]
+ }
+ incr i
+ }
+ }
+ }
+}
+
+proc ProcessSendIISCmd {proc id param} {
+ global current
+
+ switch -- [string tolower [lindex $param 0]] {
+ filename {
+ if {$current(frame) != {}} {
+ $proc $id \
+ "[$current(frame) get iis file name [lindex $param 1]]\n"
+ }
+ }
+ }
+}
+
diff --git a/ds9/library/ime.tcl b/ds9/library/ime.tcl
new file mode 100644
index 0000000..96deb0f
--- /dev/null
+++ b/ds9/library/ime.tcl
@@ -0,0 +1,609 @@
+# 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 IMEDef {} {
+ global iime
+ global ime
+ global pime
+
+ set ime(task) stats
+ set ime(shape) circle
+
+ array set pime [array get ime]
+}
+
+proc IMEChangeTask {} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {$current(mode) != {analysis}} {
+ return
+ }
+
+ UpdateTaskMenu
+ IMEChangeShape
+}
+
+proc IMEChangeShape {} {
+ global ime
+ global ds9
+ global current
+
+ switch $ime(task) {
+ stats -
+ hist {
+ switch $ime(shape) {
+ circle -
+ ellipse -
+ box -
+ polygon {}
+ default {set ime(shape) circle}
+ }
+ }
+ radial {
+ switch $ime(shape) {
+ annulus -
+ ellipseannulus -
+ boxannulus {}
+ default {set ime(shape) annulus}
+ }
+ }
+ plot2d {}
+ plot3d {
+ switch $ime(shape) {
+ circle -
+ ellipse -
+ box -
+ polygon -
+ point {}
+ default {set ime(shape) point}
+ }
+ }
+ }
+
+ foreach ff $ds9(frames) {
+ $ff marker analysis unselect all
+ set coord [$ff get crosshair canvas]
+ set XX [lindex $coord 0]
+ set YY [lindex $coord 1]
+
+ $ff analysis shape $ime(shape) $XX $YY
+
+ if {$current(frame) == $ff} {
+ IMEDoTask $current(frame)
+ }
+ }
+}
+
+proc IMEDoTask {which} {
+ global ime
+
+ if {![$which has fits]} {
+ return
+ }
+
+ switch $ime(task) {
+ stats {IMEStatsTask $which}
+ hist {IMEHistTask $which}
+ radial {IMERadialTask $which}
+ plot2d {IMEPlot2DTask $which}
+ plot3d {IMEPlot3DTask $which}
+ }
+}
+
+proc IMEKey {which K xx yy} {
+ global ime
+
+ # always available
+ switch $K {
+ question {
+ IMEHelp
+ return
+ }
+ }
+
+ if {![$which has fits]} {
+ return
+ }
+
+ switch $K {
+ a {
+ # FWHM (Aperture Sum)
+ }
+ b {
+ # Box Coords?
+ }
+ c {
+ # Column Cut
+ }
+ d {
+ # remap (Load Display)
+ set ime(task) plot3d
+ IMEKeyTask $which $xx $yy
+ }
+ e {
+ # remap (Contour)
+ }
+ f {
+ # remap (Redraw)
+ }
+ g {
+ # remap (Graphics Cursor)
+ }
+ h {
+ set ime(task) hist
+ IMEKeyTask $which $xx $yy
+ }
+ i {
+ # remap (Image Cursor)
+ }
+ j {
+ # Line Guassian Fit
+ }
+ k {
+ # Col Gaussian Fit
+ }
+ l {
+ # Line Cut
+ }
+ m {
+ set ime(task) stats
+ IMEKeyTask $which $xx $yy
+ }
+ n {
+ # remap (Next Frame)
+ }
+ o {
+ # remap (Overplot)
+ }
+ p {
+ # remap (Prev Frame)
+ }
+ q {
+ # remap (Quit)
+ }
+ r {
+ set ime(task) radial
+ IMEKeyTask $which $xx $yy
+ }
+ s {
+ # Surface Plot
+ }
+ t {
+ # remap (Output Image)
+ }
+ u {
+ # Vector Plot
+ }
+ v {
+ set ime(task) plot2d
+ IMEKeyTask $which $xx $yy
+ }
+ w {
+ # remap (Toggle Logfile)
+ }
+ x {
+ # Print coords/values
+ }
+ y {
+ # remap (Set Origin)
+ }
+ z {
+ # Print value grid
+ }
+ , {
+ # Quick Profile Photometry
+ }
+ . {
+ # Quick Radial Profile Plot and Fit
+ }
+ }
+}
+
+proc IMEKeyTask {which xx yy} {
+ global ime
+
+ $which crosshair canvas $xx $yy
+
+ $which analysis shape $ime(shape) $xx $yy
+ IMEDoTask $which
+
+ UpdateColormapLevelMosaic $which $xx $yy canvas
+ UpdateInfoBox $which $xx $yy canvas
+ UpdatePixelTableDialog $which $xx $yy canvas
+ UpdateGraph $which $xx $yy canvas
+}
+
+proc IMEButton {which xx yy} {
+ global ime
+ global imarker
+
+ global debug
+ if {$debug(tcl,ime)} {
+ puts stderr "IMEButton $which $xx $yy"
+ }
+
+ # see if we are on a handle
+ set hh [$which get marker analysis handle $xx $yy]
+ set id [lindex $hh 0]
+ set imarker(handle) [lindex $hh 1]
+
+ if {$imarker(handle)} {
+ $which marker analysis $id edit begin $imarker(handle)
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # else, see if we are on a segment of a polygon
+ set hh [$which get marker analysis polygon segment $xx $yy]
+ set id [lindex $hh 0]
+ set segment [lindex $hh 1]
+ if {$segment} {
+ $which marker analysis $id create polygon vertex $segment $xx $yy
+ $which marker analysis $id edit begin $imarker(handle)
+ set imarker(handle) [expr 4+$segment+1]
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # see if any markers are selected
+ if {[$which get marker analysis select number]>0} {
+ # else, see if we are on a marker
+ if {[$which get marker analysis id $xx $yy]} {
+ $which marker analysis $id move begin
+ set imarker(motion) beginMove
+ return
+ } else {
+ $which marker analysis unselect all
+ set imarker(motion) none
+ return
+ }
+ }
+
+ $which marker analysis $id move begin
+ set imarker(motion) beginMove
+
+ $which crosshair canvas $xx $yy
+ $which analysis shape $ime(shape) $xx $yy
+ IMEDoTask $which
+}
+
+proc IMEShift {which xx yy} {
+ global ime
+ global imarker
+
+ global debug
+ if {$debug(tcl,ime)} {
+ puts stderr "IMEShift $which $xx $yy"
+ }
+
+ # see if we are on a handle
+ set hh [$which get marker analysis handle $xx $yy]
+ set id [lindex $hh 0]
+ set imarker(handle) [lindex $hh 1]
+
+ if {$imarker(handle)} {
+ $which marker analysis $id rotate begin
+ set imarker(motion) beginRotate
+ }
+}
+
+proc IMEDouble {which xx yy} {
+ global ime
+ global imarker
+
+ global debug
+ if {$debug(tcl,ime)} {
+ puts stderr "IMEDouble $which $xx $yy"
+ }
+
+ if {[$which get marker analysis id $xx $yy]} {
+ $which marker analysis select only $xx $yy
+ }
+}
+
+proc IMEMotion {which xx yy} {
+ global ime
+ global imarker
+
+ global debug
+ if {$debug(tcl,ime)} {
+ puts stderr "IMEMotion $which $xx $yy"
+ }
+
+ switch -- $imarker(motion) {
+ none {}
+ beginMove -
+ move {
+ $which marker analysis move motion $x $y
+ set imarker(motion) move
+ $which crosshair canvas $xx $yy
+ $which analysis shape $ime(shape) $xx $yy
+ IMEDoTask $which
+ }
+ beginEdit -
+ edit {
+ set imarker(motion) edit
+ $which marker analysis edit motion $xx $yy $imarker(handle)
+ IMEDoTask $which
+ }
+ beginRotate -
+ rotate {
+ set imarker(motion) rotate
+ $which marker analysis rotate motion $xx $yy $imarker(handle)
+ IMEDoTask $which
+ }
+ region -
+ shiftregion {}
+ }
+}
+
+proc IMERelease {which xx yy} {
+ global ime
+ global imarker
+
+ global debug
+ if {$debug(tcl,ime)} {
+ puts stderr "IMERelease $which $xx $yy"
+ }
+
+ switch -- $imarker(motion) {
+ none {}
+ beginMove -
+ beginRotate {}
+ beginEdit {}
+ move {
+ $which marker analysis move end
+ IMEDoTask $which
+ }
+ edit {
+ $which marker analysis edit end
+ IMEDoTask $which
+ }
+ rotate {
+ $which marker analysis rotate end
+ IMEDoTask $which
+ }
+ region -
+ shiftregion {}
+ }
+
+ set imarker(motion) none
+ set imarker(handle) -1
+}
+
+proc IMEArrowKey {which xx yy} {
+ global ime
+ global ds9
+
+ global debug
+ if {$debug(tcl,ime)} {
+ puts stderr "IMEArrow $which $xx $yy"
+ }
+
+ $which crosshair warp $xx $yy
+
+ set coord [$which get crosshair canvas]
+ set XX [lindex $coord 0]
+ set YY [lindex $coord 1]
+
+ $which analysis shape $ime(shape) $XX $YY
+ IMEDoTask $which
+
+ UpdateColormapLevelMosaic $which $XX $YY canvas
+ UpdateInfoBox $which $XX $YY canvas
+ UpdatePixelTableDialog $which $XX $YY canvas
+ UpdateGraph $which $XX $YY canvas
+}
+
+proc IMEHelp {} {
+ global ime
+
+ set rr "\tAnalysis Help\n\n?\tPrint Help\nd\tPlot 3D\nm\tStatistics\nv\tPlot 2D\n"
+
+ SimpleTextDialog imehlp "Analysis Help" 80 20 insert top $rr
+}
+
+proc IMEStatsTask {which} {
+ global ime
+
+ set rr [$which get marker analysis hide analysis stats physical fk5]
+
+ SimpleTextDialog "imestat" "Statistics" 80 20 insert top $rr
+}
+
+proc IMEHistTask {which} {
+ global iime
+ global ime
+
+ set id 0
+
+ set varname imehist
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname analysishist
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ global $xdata $ydata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ PlotLineDialog $vvarname Histogram {} Values Counts
+
+ set vvar(manage) 0
+ set vvar(dim) xy
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ blt::vector create $xdata $ydata
+ }
+
+ $which get marker analysis hide analysis histogram $xdata $ydata 512
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ set vvar(smooth) step
+ set vvar(fill) 1
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc IMERadialTask {which} {
+ global iime
+ global ime
+
+ set varname imerad
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname analysisrad
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(system) physical
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ set yedata ${vvarname}ye
+ global $xdata $ydata $yedata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ PlotLineDialog $vvarname "Radial Profile" {} physical {}
+ MarkerAnalysisRadialAxisTitle $vvarname
+
+ set vvar(manage) 0
+ set vvar(dim) xyey
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ set vvar(yedata) $yedata
+ blt::vector create $xdata $ydata $yedata
+ }
+
+ $which get marker analysis hide analysis radial $xdata $ydata $yedata physical
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc IMEPlot2DTask {which} {
+ global iime
+ global ime
+
+ set varname imeplot2d
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname analysisplot2d
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(system) physical
+ set vvar(sky) fk5
+ set vvar(method) average
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ set xcdata ${vvarname}xc
+ set ycdata ${vvarname}yc
+ global $xdata $ydata $xcdata $ycdata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ PlotLineDialog $vvarname Plot2D {} physical Counts
+ MarkerAnalysisPlot2dXAxisTitle $vvarname
+ MarkerAnalysisPlot2dYAxisTitle $vvarname
+
+ # setup our own formatting
+ set vvar(graph,format) 0
+ set vvar(xcdata) $xcdata
+ set vvar(ycdata) $ycdata
+ $vvar(graph) xaxis configure \
+ -command "MarkerAnalysisPlot2dXAxis $vvarname"
+
+ set vvar(manage) 0
+ set vvar(dim) xy
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ blt::vector create $xdata $ydata $xcdata $ycdata
+ }
+
+ $which get marker analysis hide analysis plot2d $xdata $ydata $xcdata $ycdata physical fk5 average
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc IMEPlot3DTask {which} {
+ global iime
+ global ime
+
+ set varname imeplot3d
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname analysisplot3d
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(system) image
+ set vvar(method) average
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ global $xdata $ydata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ PlotLineDialog $vvarname Plot3D {} image Counts
+ MarkerAnalysisPlot3dXAxisTitle $vvarname
+ MarkerAnalysisPlot3dYAxisTitle $vvarname
+
+ set vvar(manage) 0
+ set vvar(dim) xy
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ blt::vector create $xdata $ydata
+ }
+
+ $which get marker analysis hide analysis plot3d $xdata $ydata physical average
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
diff --git a/ds9/library/imgsvr.tcl b/ds9/library/imgsvr.tcl
new file mode 100644
index 0000000..2b3b4fb
--- /dev/null
+++ b/ds9/library/imgsvr.tcl
@@ -0,0 +1,585 @@
+# 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 IMGSVRInit {varname title exec ack done error} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global pds9
+
+ # AR variables
+ ARInit $varname IMGSVRServer
+
+ # IMG variables
+ set var(proc,exec) $exec
+ set var(proc,ack) $ack
+ set var(proc,done) $done
+ set var(proc,error) $error
+
+ # create the window
+ set w $var(top)
+ set mb $var(mb)
+
+ Toplevel $w $mb 6 $title "ARDestroy $varname"
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Retrieve}] \
+ -command "IMGSVRApply $varname 0"
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Update from Current Frame}] \
+ -command "IMGSVRUpdate $varname"
+ $mb.file add command \
+ -label [msgcat::mc {Update from Current Crosshair}] \
+ -command "IMGSVRCrosshair $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Acknowledgment}] \
+ -command "IMGSVRAck $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command "ARDestroy $varname"
+
+ AREditMenu $varname
+ NSVRServerMenu $varname
+
+ $mb add cascade -label [msgcat::mc {Preferences}] -menu $mb.prefs
+ menu $mb.prefs
+ $mb.prefs add checkbutton -label [msgcat::mc {Save Image on Download}] \
+ -variable ${varname}(save)
+ $mb.prefs add separator
+ $mb.prefs add radiobutton -label [msgcat::mc {New Frame}] \
+ -variable ${varname}(mode) -value new
+ $mb.prefs add radiobutton -label [msgcat::mc {Current Frame}] \
+ -variable ${varname}(mode) -value current
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.nametitle -text [msgcat::mc {Object}]
+ ttk::entry $f.name -textvariable ${varname}(name) -width 50
+ ttk::label $f.sky -textvariable ${varname}(sky) -anchor w
+ set var(xname) [ttk::label $f.xtitle -text {} -width 1]
+ ttk::entry $f.x -textvariable ${varname}(x) -width 14
+ set var(yname) [ttk::label $f.ytitle -text {} -width 1]
+ ttk::entry $f.y -textvariable ${varname}(y) -width 14
+ ARSkyFormat $f.skyformat $varname
+ ttk::label $f.wtitle -text [msgcat::mc {Width}]
+ ttk::entry $f.w -textvariable ${varname}(width) -width 14
+ ttk::label $f.htitle -text [msgcat::mc {Height}]
+ ttk::entry $f.h -textvariable ${varname}(height) -width 14
+ ARRFormat $f.format $varname
+
+ grid $f.nametitle x $f.name - - - - -padx 2 -pady 2 -sticky ew
+ grid $f.sky $f.xtitle $f.x $f.ytitle $f.y $f.skyformat \
+ -padx 2 -pady 2 -sticky w
+ grid $f.wtitle x $f.w $f.htitle $f.h $f.format -padx 2 -pady 2 -sticky w
+
+ # Status
+ set f [ttk::frame $w.status]
+ ttk::label $f.title -text [msgcat::mc {Status}]
+ ttk::label $f.item -textvariable ${varname}(status)
+ grid $f.title $f.item -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ set var(apply) [ttk::button $f.apply -text [msgcat::mc {Retrieve}] \
+ -command "IMGSVRApply $varname 0"]
+ set var(cancel) [ttk::button $f.cancel -text [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname" -state disabled]
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command "ARDestroy $varname"
+ pack $f.apply $f.cancel $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ ttk::separator $w.sep2 -orient horizontal
+ pack $w.buttons $w.sep $w.status $w.sep2 -side bottom -fill x
+ pack $w.param -side top -fill both -expand true
+
+ ARCoord $varname
+ ARStatus $varname {}
+}
+
+proc IMGSVRApply {varname sync} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRApply $varname $sync"
+ }
+
+ set var(sync) $sync
+ ARApply $varname
+ if {($var(name) != {})} {
+ set var(sky) fk5
+ ARCoord $varname
+
+ NSVRServer $varname
+ } else {
+ IMGSVRServer $varname
+ }
+}
+
+proc IMGSVRAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRAck $varname"
+ }
+
+ eval "$var(proc,ack) $varname"
+}
+
+proc IMGSVRUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global current
+ global wcs
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRUpdate $varname"
+ }
+
+ if {[winfo exists $var(top)]} {
+ set var(name) {}
+ if {$current(frame) != {} } {
+ if {[$current(frame) has wcs equatorial $wcs(system)]} {
+ set coord [$current(frame) get fits center \
+ $wcs(system) $var(sky) $var(skyformat)]
+ set var(x) [lindex $coord 0]
+ set var(y) [lindex $coord 1]
+
+ set size [$current(frame) get fits size \
+ $wcs(system) $var(sky) $var(rformat)]
+ set var(width) [lindex $size 0]
+ set var(height) [lindex $size 1]
+
+ return
+ }
+ } else {
+ set var(x) {}
+ set var(y) {}
+ set var(width) {}
+ set var(height) {}
+ }
+ }
+}
+
+proc IMGSVRCrosshair {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRCrosshair $varname"
+ }
+
+ global current
+ global wcs
+
+ if {[winfo exists $var(top)]} {
+ set var(name) {}
+ if {$current(frame) != {} } {
+ if {[$current(frame) has wcs equatorial $wcs(system)]} {
+ set coord [$current(frame) get crosshair \
+ $wcs(system) $var(sky) $var(skyformat)]
+ set var(x) [lindex $coord 0]
+ set var(y) [lindex $coord 1]
+
+ return
+ }
+ }
+ set var(x) {}
+ set var(y) {}
+ }
+}
+
+proc IMGSVRServer {varname} {
+ upvar #0 $varname var
+ global $varname
+ global current
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRServer $varname"
+ }
+
+ if {($var(x) != {}) &&
+ ($var(y) != {}) &&
+ ($var(width) != {}) &&
+ ($var(height) != {})} {
+
+ ARStatus $varname [msgcat::mc {Contacting Image Server}]
+ eval [list $var(proc,exec) $varname]
+ } else {
+ eval [list $var(proc,error) $varname [msgcat::mc {Please specify width, height, and either name or (ra,dec)}]]
+ }
+}
+
+proc IMGSVRGetURL {varname url} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRGetURL $varname $url $var(query)"
+ }
+
+ set var(ch) [open "$var(fn)" w]
+
+ global ihttp
+ if {$var(sync)} {
+ if {![catch {set var(token) [http::geturl $url \
+ -timeout $ihttp(timeout) \
+ -channel $var(ch) \
+ -progress \
+ [list IMGSVRProgress $varname] \
+ -binary 1 \
+ -headers "[ProxyHTTP]" \
+ -query "$var(query)"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ IMGSVRGetURLFinish $varname $var(token)
+ } else {
+ catch {close $var(ch)}
+ eval [list $var(proc,error) $varname "[msgcat::mc {Unable to locate URL}] $url"]
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $url \
+ -timeout $ihttp(timeout) \
+ -channel $var(ch) \
+ -command \
+ [list IMGSVRGetURLFinish $varname] \
+ -progress \
+ [list IMGSVRProgress $varname] \
+ -binary 1 \
+ -headers "[ProxyHTTP]" \
+ -query "$var(query)"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ } else {
+ catch {close $var(ch)}
+ eval [list $var(proc,error) $varname "[msgcat::mc {Unable to locate URL}] $url"]
+ }
+ }
+}
+
+proc IMGSVRGetURLFinish {varname token} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRGetURLFinish $varname"
+ }
+
+ global current
+ global ds9
+ global loadParam
+
+ catch {close $var(ch)}
+
+ if {!($var(active))} {
+ ARCancelled $varname
+ return
+ }
+
+ upvar #0 $token t
+
+ # Code
+ set var(code) [http::ncode $token]
+
+ # Meta
+ set var(meta) $t(meta)
+
+ # Mime-type
+ # we want to strip and extra info after ';'
+ regexp -nocase {([^;])*} $t(type) var(mime)
+
+ # Content-Encoding
+ set var(encoding) {}
+ foreach {name value} $var(meta) {
+ if {[regexp -nocase ^content-encoding $name]} {
+ switch -- [string tolower $value] {
+ compress -
+ bzip2 {set var(encoding) bzip2}
+ Z {set var(encoding) compress}
+ pack -
+ z {set var(encoding) pack}
+ default {}
+ }
+ }
+ }
+
+ HTTPLog $token
+ # Result?
+ switch -- $var(code) {
+ 200 -
+ 203 {IMGSVRParse $varname}
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $var(meta) {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRGetURLFinish redirect $var(code) to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset var(token)
+
+ IMGSVRGetURL $varname $value
+ }
+ }
+ }
+
+ default {
+ eval [list $var(proc,error) $varname "[msgcat::mc {Error code was returned}] $var(code)"]
+ }
+ }
+}
+
+proc IMGSVRParse {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global current
+ global ds9
+ global loadParam
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "IMGSVRParse: $varname : fn $var(fn) : code $var(code) : meta $var(meta) : mime $var(mime) : encoding $var(encoding)"
+ }
+
+ switch -- [string tolower $var(mime)] {
+ "application/octet-stream" {
+ # its never fails, someone can't get there mime types correct.
+ # Override the mime type based on path
+ switch -- [file extension $var(fn)] {
+ .bz2 {set var(encoding) bzip2}
+ .Z {set var(encoding) compress}
+ .z {set var(encoding) pack}
+ }
+ }
+
+ "image/fits" -
+ "application/fits" {}
+
+ "application/fits-image" -
+ "application/fits-table" -
+ "application/fits-group" {}
+
+ "image/x-fits" -
+ "binary/x-fits" -
+ "application/x-fits" {}
+
+ "image/x-gfits" -
+ "binary/x-gfits" -
+ "image/gz-fits" -
+ "application/x-gzip" -
+ "display/gz-fits" {}
+
+ "image/fits-hcompress" -
+ "image/x-fits-h" {}
+
+ "image/bz2-fits" -
+ "display/bz2-fits" {set var(encoding) bzip2}
+
+ "image/x-cfits" -
+ "binary/x-cfits" {set var(encoding) compress}
+
+ "image/x-zfits" -
+ "binary/x-zfits" {set var(encoding) pack}
+
+ "text/html" -
+ "text/plain" -
+ default {
+ # NOTE: error notices may come as text/html
+ eval [list $var(proc,error) $varname [msgcat::mc {No Data Available}]]
+ return
+ }
+ }
+
+ switch -- $var(mode) {
+ new {MultiLoadBase}
+ current {}
+ }
+
+ StartLoad
+ # alloc it because we are going to delete it after load
+ set loadParam(load,type) allocgz
+ set loadParam(load,layer) {}
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {}
+ set loadParam(file,name) $var(fn)
+ set loadParam(file,fn) $loadParam(file,name)
+
+ # may have to convert the file, based on content-encoding
+ switch -- "$var(encoding)" {
+ bzip2 {
+ catch {set ch [open "| bunzip2 < $var(fn) " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ compress {
+ catch {set ch [open "| uncompress < $var(fn) " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ pack {
+ catch {set ch [open "| pcat $var(fn) " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ }
+ ProcessLoad
+ FinishLoad
+
+ if {!$var(save)} {
+ if {[file exists $var(fn)]} {
+ catch {file delete -force $var(fn)}
+ }
+ }
+
+ $var(proc,done) $varname
+}
+
+proc IMGSVRProgress {varname token totalsize currentsize} {
+ upvar #0 $varname var
+ global $varname
+
+ # sometimes we get nothing
+ if {$totalsize == {} || $currentsize == {}} {
+ ARStatus $varname {}
+ } elseif {$totalsize != 0} {
+ ARStatus $varname "$currentsize bytes of $totalsize bytes [expr int(double($currentsize)/$totalsize*100)]%"
+ } else {
+ ARStatus $varname "$currentsize bytes"
+ }
+}
+
+proc IMGSVRProcessCmd {varname iname vvarname} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ upvar #0 $vvarname vvar
+
+ switch -- [string tolower [lindex $var $i]] {
+ {} {
+ if {$vvar(name) != {} || ($vvar(x) != {} && $vvar(y) != {})} {
+ IMGSVRApply $vvarname 1
+ }
+ }
+ open {}
+ close {ARDestroy $vvarname}
+ save {
+ incr i
+ set vvar(save) [FromYesNo [lindex $var $i]]
+ }
+ frame {
+ incr i
+ set vvar(mode) [string tolower [lindex $var $i]]
+ }
+ survey {
+ incr i
+ set vvar(survey) [lindex $var $i]
+ }
+ size {
+ incr i
+ set vvar(width) [lindex $var $i]
+ incr i
+ set vvar(height) [lindex $var $i]
+ incr i
+ if {[lindex $var $i] != {} && \
+ [string range [lindex $var $i] 0 0] != {-}} {
+ set vvar(rformat) [lindex $var $i]
+ set vvar(rformat,msg) $vvar(rformat)
+ } else {
+ incr i -1
+ }
+ }
+ pixels {
+ incr i
+ set vvar(width,pixels) [lindex $var $i]
+ incr i
+ set vvar(height,pixels) [lindex $var $i]
+ }
+ update {
+ incr i
+ switch [string tolower [lindex $var $i]] {
+ frame {IMGSVRUpdate $vvarname}
+ crosshair {IMGSVRCrosshair $vvarname}
+ }
+ IMGSVRApply $vvarname 1
+ }
+ coord {
+ incr i
+ set vvar(x) [lindex $var $i]
+ incr i
+ set vvar(y) [lindex $var $i]
+ incr i
+ if {[lindex $var $i] != {} && \
+ [string range [lindex $var $i] 0 0] != {-}} {
+ set vvar(skyformat) [lindex $var $i]
+ set vvar(skyformat,msg) $vvar(skyformat)
+ } else {
+ incr i -1
+ }
+ IMGSVRApply $vvarname 1
+ }
+ name {
+ incr i
+ set vvar(name) [lindex $var $i]
+ if {$vvar(name) != {}} {
+ IMGSVRApply $vvarname 1
+ }
+ }
+ default {
+ set vvar(name) [lindex $var $i]
+ if {$vvar(name) != {}} {
+ IMGSVRApply $vvarname 1
+ }
+ }
+ }
+}
+
+proc IMGSVRProcessSendCmd {proc id param vvarname} {
+ upvar #0 $vvarname vvar
+
+ switch -- [string tolower [lindex $param 0]] {
+ save {$proc $id [ToYesNo $vvar(save)]}
+ frame {$proc $id "$vvar(mode)\n"}
+ survey {$proc $id "$vvar(survey)\n"}
+ size {$proc $id "$vvar(width) $vvar(height) $vvar(rformat)\n"}
+ pixels {$proc $id "$vvar(width,pixels) $vvar(height,pixels)\n"}
+ coord {$proc $id "$vvar(x) $vvar(y) $vvar(skyformat)\n"}
+ name -
+ default {$proc $id "$vvar(name)\n"}
+ }
+}
diff --git a/ds9/library/import.tcl b/ds9/library/import.tcl
new file mode 100644
index 0000000..cd7df24
--- /dev/null
+++ b/ds9/library/import.tcl
@@ -0,0 +1,230 @@
+# 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 Import {fn format layer mode fn2} {
+ global current
+
+ if {$fn == {}} {
+ return
+ }
+
+ StartLoad
+ switch -- $format {
+ array {ImportArrayFile $fn $layer}
+ rgbarray {
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {CreateRGBFrame}
+ rgb {}
+ }
+ ImportRGBArrayFile $fn
+ }
+ nrrd {ImportNRRDFile $fn $layer}
+ envi {ImportENVIFile $fn $fn2}
+ gif -
+ tiff -
+ jpeg -
+ png {ImportPhotoFile $fn $mode}
+ }
+ FinishLoad
+}
+
+# Support
+
+proc ImportDialog {format {layer {}} {mode {}}} {
+ global arrayfbox
+ global rgbarrayfbox
+ global nrrdfbox
+ global envifbox
+ global envi2fbox
+ global giffbox
+ global jpegfbox
+ global tifffbox
+ global pngfbox
+
+ switch -- $format {
+ array {set fn [OpenFileDialog arrayfbox]}
+ rgbarray {set fn [OpenFileDialog rgbarrayfbox]}
+ nrrd {set fn [OpenFileDialog nrrdfbox]}
+ envi {set fn [OpenFileDialog envifbox]}
+ gif {set fn [OpenFileDialog giffbox]}
+ jpeg {set fn [OpenFileDialog jpegfbox]}
+ tiff {set fn [OpenFileDialog tifffbox]}
+ png {set fn [OpenFileDialog pngfbox]}
+ }
+ set fn2 {}
+
+ if {$fn != {}} {
+ set ok 1
+ switch -- $format {
+ array {
+ # do we have an array spec tag'd on
+ if {![regexp -nocase {(.*)(\[.*\])} $fn foo base ext]} {
+ set ext {}
+ set ok [ArrayImportDialog 1 ext]
+ if {$ok} {
+ append fn "$ext"
+ }
+ }
+ }
+ rgbarray {
+ # do we have an array spec tag'd on
+ if {![regexp -nocase {(.*)(\[.*\])} $fn foo base ext]} {
+ set ext {}
+ set ok [ArrayImportDialog 3 ext]
+ if {$ok} {
+ append fn "$ext"
+ }
+ }
+ }
+ envi {
+ set fn2 [FindENVIDataFile $fn]
+ if {$fn2 == {}} {
+ set fn2 "[file rootname $fn].bsq"
+ SetFileLast envi2 $fn2
+ set fn2 [OpenFileDialog envi2fbox]
+ if {$fn2 == {}} {
+ set ok 0
+ }
+ }
+ }
+ nrrd -
+ gif -
+ jpeg -
+ tiff -
+ png {}
+ }
+
+ if {$ok} {
+ Import $fn $format $layer $mode $fn2
+ }
+ }
+}
+
+proc ArrayImportDialog {depth varname} {
+ upvar $varname var
+ global env
+ global ed
+ global ds9
+
+ set w {.arr}
+
+ set ed(ok) 0
+ set ed(x) $ds9(array,x)
+ set ed(y) $ds9(array,y)
+ set ed(z) $depth
+ set ed(bitpix) $ds9(array,bitpix)
+ set ed(skip) $ds9(array,skip)
+ set ed(arch) $ds9(array,arch)
+
+ if {[info exists env(DS9_ARRAY)]} {
+ if {[regexp {.*(dims.?=)([0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(x) $item
+ set ed(y) $item
+ }
+ if {[regexp {.*(dim.?=)([0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(x) $item
+ set ed(y) $item
+ }
+ if {[regexp {.*(xdim.?=)([0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(x) $item
+ }
+ if {[regexp {.*(ydim.?=)([0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(y) $item
+ }
+ if {[regexp {.*(zdim.?=)([0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(z) $item
+ }
+ if {[regexp {.*(bitpix.?=)(-?[0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(bitpix) $item
+ }
+ if {[regexp {.*(skip.?=)(-?[0-9]+)} $env(DS9_ARRAY) foo f1 item]} {
+ set ed(skip) $item
+ }
+ if {[regexp {.*arch.?=bigendian} $env(DS9_ARRAY) foo item]} {
+ set ed(arch) $item
+ }
+ if {[regexp {.*arch.?=littleendian} $env(DS9_ARRAY) foo item]} {
+ set ed(arch) $item
+ }
+ }
+
+ DialogCreate $w [msgcat::mc {Import Array}] ed(ok)
+
+ # Dim
+ set f [ttk::labelframe $w.dim -text [msgcat::mc {Dimension}] -padding 2]
+ ttk::entry $f.x -textvariable ed(x) -width 6
+ ttk::entry $f.y -textvariable ed(y) -width 6
+ ttk::entry $f.z -textvariable ed(z) -width 6
+ grid $f.x $f.y $f.z -padx 2 -pady 2 -sticky w
+
+ # Bitpix
+ set f [ttk::labelframe $w.bitpix -text [msgcat::mc {Pixel Size}] -padding 2]
+ ttk::radiobutton $f.char -text {Char} -variable ed(bitpix) -value 8
+ ttk::radiobutton $f.short -text {Short} -variable ed(bitpix) -value 16
+ ttk::radiobutton $f.ushort -text {UShort} -variable ed(bitpix) -value -16
+ ttk::radiobutton $f.long -text {Long} -variable ed(bitpix) -value 32
+ ttk::radiobutton $f.float -text {Float} -variable ed(bitpix) -value -32
+ ttk::radiobutton $f.double -text {Double} -variable ed(bitpix) -value -64
+ grid $f.char -padx 2 -pady 2 -sticky w
+ grid $f.short $f.ushort $f.long -padx 2 -pady 2 -sticky w
+ grid $f.float $f.double -padx 2 -pady 2 -sticky w
+
+ # Skip
+ set f [ttk::labelframe $w.skip -text [msgcat::mc {Header}] -padding 2]
+ ttk::label $f.t1 -text [msgcat::mc {Skip First}]
+ ttk::label $f.t2 -text [msgcat::mc {Bytes}]
+ ttk::entry $f.skip -textvariable ed(skip) -width 6
+ grid $f.t1 $f.skip $f.t2 -padx 2 -pady 2 -sticky w
+
+ # Arch
+ set f [ttk::labelframe $w.arch -text [msgcat::mc {Architecture}] -padding 2]
+ ttk::radiobutton $f.big -text {Big-Endian} -variable ed(arch) \
+ -value bigendian
+ ttk::radiobutton $f.little -text {Little-Endian} -variable ed(arch) \
+ -value littleendian
+ grid $f.big $f.little -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ grid $w.dim -sticky news
+ grid $w.bitpix -sticky news
+ grid $w.skip -sticky news
+ grid $w.arch -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid rowconfigure $w 2 -weight 1
+ grid rowconfigure $w 3 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set ds9(array,x) $ed(x)
+ set ds9(array,y) $ed(y)
+ set ds9(array,bitpix) $ed(bitpix)
+ set ds9(array,skip) $ed(skip)
+ set ds9(array,arch) $ed(arch)
+
+ set var "\[xdim=$ed(x),ydim=$ed(y),zdim=$ed(z),bitpix=$ed(bitpix),skip=$ed(skip),arch=$ed(arch)\]"
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
diff --git a/ds9/library/info.tcl b/ds9/library/info.tcl
new file mode 100644
index 0000000..1c05fa2
--- /dev/null
+++ b/ds9/library/info.tcl
@@ -0,0 +1,1177 @@
+# 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 CreateInfoPanel {} {
+ global ds9
+ global pds9
+ global view
+ global infobox
+
+ # Panel Frame
+ set ds9(panel) [ttk::frame $ds9(main).panel]
+ set ds9(panel,sep) [ttk::separator $ds9(main).spanel -orient horizontal]
+
+ # Info
+ set ds9(info) [ttk::frame $ds9(panel).info]
+ ttk::frame $ds9(info).dummy
+
+ ttk::label $ds9(info).fileTitle -text [msgcat::mc {File}]
+ ttk::label $ds9(info).fileValue -relief groove \
+ -textvariable infobox(filename)
+
+ ttk::label $ds9(info).objTitle -text [msgcat::mc {Object}]
+ ttk::label $ds9(info).objValue -relief groove \
+ -textvariable infobox(object)
+
+ ttk::entry $ds9(info).keyWord -textvariable view(info,keyvalue)
+ ttk::label $ds9(info).keyValue -relief groove \
+ -textvariable infobox(keyvalue)
+
+ ttk::label $ds9(info).minTitle -text [msgcat::mc {Minimum}]
+ ttk::label $ds9(info).minValue -relief groove \
+ -textvariable infobox(min) -anchor center
+
+ ttk::label $ds9(info).minXLabel -text {X}
+ ttk::label $ds9(info).minXValue -relief groove \
+ -textvariable infobox(min,x) -anchor center
+ ttk::label $ds9(info).minYLabel -text {Y}
+ ttk::label $ds9(info).minYValue -relief groove \
+ -textvariable infobox(min,y) -anchor center
+
+ ttk::label $ds9(info).maxTitle -text [msgcat::mc {Maximum}]
+ ttk::label $ds9(info).maxValue -relief groove \
+ -textvariable infobox(max) -anchor center
+
+ ttk::label $ds9(info).maxXLabel -text {X}
+ ttk::label $ds9(info).maxXValue -relief groove \
+ -textvariable infobox(max,x) -anchor center
+ ttk::label $ds9(info).maxYLabel -text {Y}
+ ttk::label $ds9(info).maxYValue -relief groove \
+ -textvariable infobox(max,y) -anchor center
+
+ ttk::label $ds9(info).lowhighTitle \
+ -text "[msgcat::mc {Low}] [msgcat::mc {High}]"
+ ttk::label $ds9(info).lowValue -relief groove \
+ -textvariable infobox(low) -anchor center
+ ttk::label $ds9(info).highValue -relief groove \
+ -textvariable infobox(high) -anchor center
+
+ ttk::label $ds9(info).valueTitle -text [msgcat::mc {Value}]
+ ttk::label $ds9(info).value -relief groove \
+ -textvariable infobox(value) -anchor center
+
+ ttk::label $ds9(info).valueRTitle -text [msgcat::mc {r}]
+ ttk::label $ds9(info).valueR -relief groove \
+ -textvariable infobox(value,red) -anchor center
+ ttk::label $ds9(info).valueGTitle -text [msgcat::mc {g}]
+ ttk::label $ds9(info).valueG -relief groove \
+ -textvariable infobox(value,green) -anchor center
+ ttk::label $ds9(info).valueBTitle -text [msgcat::mc {b}]
+ ttk::label $ds9(info).valueB -relief groove \
+ -textvariable infobox(value,blue) -anchor center
+
+ ttk::label $ds9(info).bunitTitle -text [msgcat::mc {Units}]
+ ttk::label $ds9(info).bunitValue -relief groove \
+ -textvariable infobox(bunit)
+
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set infobox(wcs$ll,sys) "[msgcat::mc {WCS}] $ll"
+ ttk::label $ds9(info).wcsLabel$ll -textvariable infobox(wcs$ll,sys)
+
+ set infobox(wcs$ll,x,nm) [ttk::label $ds9(info).wcsXLabel$ll -text {}]
+ ttk::label $ds9(info).wcsXValue$ll -relief groove \
+ -textvariable infobox(wcs$ll,x) -anchor center
+ set infobox(wcs$ll,y,nm) [ttk::label $ds9(info).wcsYLabel$ll -text {}]
+ ttk::label $ds9(info).wcsYValue$ll -relief groove \
+ -textvariable infobox(wcs$ll,y) -anchor center
+ set infobox(wcs$ll,z,nm) [ttk::label $ds9(info).wcsZLabel$ll -text {}]
+ ttk::label $ds9(info).wcsZValue$ll -relief groove \
+ -textvariable infobox(wcs$ll,z) -anchor center
+ }
+
+ ttk::label $ds9(info).detectorTitle -text [msgcat::mc {Detector}]
+ ttk::label $ds9(info).detectorXLabel -text {X}
+ ttk::label $ds9(info).detectorXValue -relief groove \
+ -textvariable infobox(detector,x) -anchor center
+ ttk::label $ds9(info).detectorYLabel -text {Y}
+ ttk::label $ds9(info).detectorYValue -relief groove \
+ -textvariable infobox(detector,y) -anchor center
+ ttk::label $ds9(info).detectorZLabel -text {Z}
+ ttk::label $ds9(info).detectorZValue -relief groove \
+ -textvariable infobox(detector,z) -anchor center
+
+ ttk::label $ds9(info).amplifierTitle -text [msgcat::mc {Amplifier}]
+ ttk::label $ds9(info).amplifierXLabel -text {X}
+ ttk::label $ds9(info).amplifierXValue -relief groove \
+ -textvariable infobox(amplifier,x) -anchor center
+ ttk::label $ds9(info).amplifierYLabel -text {Y}
+ ttk::label $ds9(info).amplifierYValue -relief groove \
+ -textvariable infobox(amplifier,y) -anchor center
+ ttk::label $ds9(info).amplifierZLabel -text {Z}
+ ttk::label $ds9(info).amplifierZValue -relief groove \
+ -textvariable infobox(amplifier,z) -anchor center
+
+ ttk::label $ds9(info).physicalTitle -text [msgcat::mc {Physical}]
+ ttk::label $ds9(info).physicalXLabel -text {X}
+ ttk::label $ds9(info).physicalXValue -relief groove \
+ -textvariable infobox(physical,x) -anchor center
+ ttk::label $ds9(info).physicalYLabel -text {Y}
+ ttk::label $ds9(info).physicalYValue -relief groove \
+ -textvariable infobox(physical,y) -anchor center
+ ttk::label $ds9(info).physicalZLabel -text {Z}
+ ttk::label $ds9(info).physicalZValue -relief groove \
+ -textvariable infobox(physical,z) -anchor center
+
+ ttk::label $ds9(info).imageTitle -text [msgcat::mc {Image}]
+ ttk::label $ds9(info).imageXLabel -text {X}
+ ttk::label $ds9(info).imageXValue -relief groove \
+ -textvariable infobox(image,x) -anchor center
+ ttk::label $ds9(info).imageYLabel -text {Y}
+ ttk::label $ds9(info).imageYValue -relief groove \
+ -textvariable infobox(image,y) -anchor center
+ ttk::label $ds9(info).imageZLabel -text {Z}
+ ttk::label $ds9(info).imageZValue -relief groove \
+ -textvariable infobox(image,z) -anchor center
+
+ ttk::label $ds9(info).frame -textvariable infobox(frame) \
+ -width [expr [string length [msgcat::mc {Frame}]]+4]
+
+ ttk::label $ds9(info).zoomtitle -text [msgcat::mc {x}]
+ ttk::label $ds9(info).zoomValue -relief groove \
+ -textvariable infobox(zoom) -anchor center
+
+ ttk::label $ds9(info).angleTitle -text {°}
+ ttk::label $ds9(info).angleValue -relief groove \
+ -textvariable infobox(angle) -anchor center
+}
+
+proc UpdateFrameInfoBox {which} {
+ global ds9
+ global view
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "UpdateFrameInfoBox"
+ }
+
+ switch -- $which {
+ base {
+ grid forget $ds9(info).valueRTitle $ds9(info).valueR \
+ $ds9(info).valueGTitle $ds9(info).valueG \
+ $ds9(info).valueBTitle $ds9(info).valueB
+
+ switch -- $view(layout) {
+ vertical {
+ grid $ds9(info).value \
+ -row $ds9(info,row,value) \
+ -column 1 -padx 2 -sticky w
+ }
+ horizontal {
+ grid $ds9(info).value \
+ -row $ds9(info,row,value) \
+ -column 2 -padx 2 -sticky w
+ }
+ }
+
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ grid forget $ds9(info).wcsZLabel$ll
+ grid forget $ds9(info).wcsZValue$ll
+ }
+ grid forget $ds9(info).detectorZLabel $ds9(info).detectorZValue
+ grid forget $ds9(info).amplifierZLabel $ds9(info).amplifierZValue
+ grid forget $ds9(info).physicalZLabel $ds9(info).physicalZValue
+ grid forget $ds9(info).imageZLabel $ds9(info).imageZValue
+ }
+ rgb {
+ grid forget $ds9(info).value
+ switch $view(layout) {
+ vertical {
+ grid $ds9(info).valueRTitle \
+ -row $ds9(info,row,value,red) \
+ -column 0 -sticky w
+ grid $ds9(info).valueR -row $ds9(info,row,value,red) \
+ -column 1 -padx 2 -sticky w
+ grid $ds9(info).valueGTitle \
+ -row $ds9(info,row,value,green) \
+ -column 0 -sticky w
+ grid $ds9(info).valueG \
+ -row $ds9(info,row,value,green) \
+ -column 1 -padx 2 -sticky w
+ grid $ds9(info).valueBTitle \
+ -row $ds9(info,row,value,blue) \
+ -column 0 -sticky w
+ grid $ds9(info).valueB \
+ -row $ds9(info,row,value,blue) \
+ -column 1 -padx 2 -sticky w
+ }
+ horizontal {
+ grid $ds9(info).valueRTitle \
+ -row $ds9(info,row,value,red) \
+ -column 1 -sticky w
+ grid $ds9(info).valueR \
+ -row $ds9(info,row,value,red) \
+ -column 2 -padx 2 -sticky w
+ grid $ds9(info).valueGTitle \
+ -row $ds9(info,row,value,green) \
+ -column 3 -sticky w
+ grid $ds9(info).valueG \
+ -row $ds9(info,row,value,green) \
+ -column 4 -padx 2 -sticky w
+ grid $ds9(info).valueBTitle \
+ -row $ds9(info,row,value,blue) \
+ -column 5 -sticky w
+ grid $ds9(info).valueB \
+ -row $ds9(info,row,value,blue) \
+ -column 6 -padx 2 -sticky w
+ }
+ }
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ grid forget $ds9(info).wcsZLabel$ll
+ grid forget $ds9(info).wcsZValue$ll
+ }
+ grid forget $ds9(info).detectorZLabel $ds9(info).detectorZValue
+ grid forget $ds9(info).amplifierZLabel $ds9(info).amplifierZValue
+ grid forget $ds9(info).physicalZLabel $ds9(info).physicalZValue
+ grid forget $ds9(info).imageZLabel $ds9(info).imageZValue
+ }
+ 3d {
+ grid forget $ds9(info).valueRTitle $ds9(info).valueR \
+ $ds9(info).valueGTitle $ds9(info).valueG \
+ $ds9(info).valueBTitle $ds9(info).valueB
+
+ switch -- $view(layout) {
+ vertical {
+ grid $ds9(info).value -row $ds9(info,row,value) \
+ -column 1 -padx 2 -sticky w
+
+ foreach ll {{} a b c d e f g h i j
+ k l m n o p q r s t u v w x y z} {
+ if {$view(info,wcs$ll)} {
+ grid $ds9(info).wcsZLabel$ll \
+ -row $ds9(info,row,wcs$ll) \
+ -column 0 -sticky w
+ grid $ds9(info).wcsZValue$ll \
+ -row $ds9(info,row,wcs$ll) \
+ -column 1 -padx 2
+ incr row
+ } else {
+ grid forget $ds9(info).wcsZLabel$ll
+ grid forget $ds9(info).wcsZValue$ll
+ }
+ }
+
+ if {$view(info,detector)} {
+ grid $ds9(info).detectorZLabel \
+ -row $ds9(info,row,detector) \
+ -column 0 -sticky w
+ grid $ds9(info).detectorZValue \
+ -row $ds9(info,row,detector) \
+ -column 1 -padx 2
+ } else {
+ grid forget $ds9(info).detectorZLabel \
+ $ds9(info).detectorZValue
+ }
+ if {$view(info,amplifier)} {
+ grid $ds9(info).amplifierZLabel \
+ -row $ds9(info,row,amplifier) \
+ -column 0 -sticky w
+ grid $ds9(info).amplifierZValue \
+ -row $ds9(info,row,amplifier) \
+ -column 1 -padx 2
+ } else {
+ grid forget $ds9(info).amplifierZLabel \
+ $ds9(info).amplifierZValue
+ }
+ if {$view(info,physical)} {
+ grid $ds9(info).physicalZLabel \
+ -row $ds9(info,row,physical) \
+ -column 0 -sticky w
+ grid $ds9(info).physicalZValue \
+ -row $ds9(info,row,physical) \
+ -column 1 -padx 2
+ } else {
+ grid forget $ds9(info).physicalZLabel \
+ $ds9(info).physicalZValue
+ }
+ if {$view(info,image)} {
+ grid $ds9(info).imageZLabel \
+ -row $ds9(info,row,image) \
+ -column 0 -sticky w
+ grid $ds9(info).imageZValue \
+ -row $ds9(info,row,image) \
+ -column 1 -padx 2
+ } else {
+ grid forget $ds9(info).imageZLabel \
+ $ds9(info).imageZValue
+ }
+ }
+ horizontal {
+ grid $ds9(info).value -row $ds9(info,row,value) \
+ -column 2 -padx 2 -sticky w
+
+ foreach ll {{} a b c d e f g h i j
+ k l m n o p q r s t u v w x y z} {
+ if {$view(info,wcs$ll)} {
+ grid $ds9(info).wcsZLabel$ll \
+ -row $ds9(info,row,wcs$ll) \
+ -column 5 -sticky w
+ grid $ds9(info).wcsZValue$ll \
+ -row $ds9(info,row,wcs$ll) \
+ -column 6 -padx 2
+ incr row
+ } else {
+ grid forget $ds9(info).wcsZLabel$ll
+ grid forget $ds9(info).wcsZValue$ll
+ }
+ }
+
+ if {$view(info,detector)} {
+ grid $ds9(info).detectorZLabel \
+ -row $ds9(info,row,detector) \
+ -column 5 -sticky w
+ grid $ds9(info).detectorZValue \
+ -row $ds9(info,row,detector) \
+ -column 6 -padx 2
+ } else {
+ grid forget $ds9(info).detectorZLabel \
+ $ds9(info).detectorZValue
+ }
+ if {$view(info,amplifier)} {
+ grid $ds9(info).amplifierZLabel \
+ -row $ds9(info,row,amplifier) \
+ -column 5 -sticky w
+ grid $ds9(info).amplifierZValue \
+ -row $ds9(info,row,amplifier) \
+ -column 6 -padx 2
+ } else {
+ grid forget $ds9(info).amplifierZLabel \
+ $ds9(info).amplifierZValue
+ }
+ if {$view(info,physical)} {
+ grid $ds9(info).physicalZLabel \
+ -row $ds9(info,row,physical) \
+ -column 5 -sticky w
+ grid $ds9(info).physicalZValue \
+ -row $ds9(info,row,physical) \
+ -column 6 -padx 2
+ } else {
+ grid forget $ds9(info).physicalZLabel \
+ $ds9(info).physicalZValue
+ }
+ if {$view(info,image)} {
+ grid $ds9(info).imageZLabel \
+ -row $ds9(info,row,image) \
+ -column 5 -sticky w
+ grid $ds9(info).imageZValue \
+ -row $ds9(info,row,image) \
+ -column 6 -padx 2
+ } else {
+ grid forget $ds9(info).imageZLabel \
+ $ds9(info).imageZValue
+ }
+ }
+ }
+ }
+ }
+}
+
+proc EnterInfoBox {which} {
+ global infobox
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "EnterInfo $which"
+ }
+
+ UpdateFrameInfoBox [$which get type]
+ UpdateWCSInfoBox $which
+
+ set infobox(frame) "[msgcat::mc {Frame}] [string range $which 5 end]"
+ set infobox(angle) [$which get rotate]
+
+ set z [$which get zoom]
+ set z1 [lindex $z 0]
+ set z2 [lindex $z 1]
+ if {$z1 != $z2} {
+ set infobox(zoom) "$z1 $z2"
+ } else {
+ set infobox(zoom) $z1
+ }
+}
+
+proc LeaveInfoBox {} {
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "LeaveInfoBox"
+ }
+
+ ClearInfoBoxCoords
+}
+
+proc ClearInfoBox {} {
+ global infobox
+
+ global debug
+ if {$debug(tcl,info)} {
+ puts stderr "ClearInfoBox"
+ }
+
+ set infobox(filename) {}
+ set infobox(object) {}
+ set infobox(keyvalue) {}
+ set infobox(bunit) {}
+ set infobox(min) {}
+ set infobox(min,x) {}
+ set infobox(min,y) {}
+ set infobox(max) {}
+ set infobox(max,x) {}
+ set infobox(max,y) {}
+ set infobox(low) {}
+ set infobox(high) {}
+
+ ClearInfoBoxCoords
+
+ set infobox(frame) [msgcat::mc {Frame}]
+ set infobox(zoom) {}
+ set infobox(angle) {}
+}
+
+proc ClearInfoBoxCoords {} {
+ global infobox
+
+ global debug
+ if {$debug(tcl,info)} {
+ puts stderr "ClearInfoBoxCoords"
+ }
+
+ set infobox(value) {}
+ set infobox(value,red) {}
+ set infobox(value,green) {}
+ set infobox(value,blue) {}
+
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set infobox(wcs$ll,sys) "WCS $ll"
+ $infobox(wcs$ll,x,nm) configure -text {}
+ $infobox(wcs$ll,y,nm) configure -text {}
+ $infobox(wcs$ll,z,nm) configure -text {}
+ set infobox(wcs$ll,x) {}
+ set infobox(wcs$ll,y) {}
+ set infobox(wcs$ll,z) {}
+ }
+
+ set infobox(detector,x) {}
+ set infobox(detector,y) {}
+ set infobox(detector,z) {}
+ set infobox(amplifier,x) {}
+ set infobox(amplifier,y) {}
+ set infobox(amplifier,z) {}
+ set infobox(physical,x) {}
+ set infobox(physical,y) {}
+ set infobox(physical,z) {}
+ set infobox(image,x) {}
+ set infobox(image,y) {}
+ set infobox(image,z) {}
+}
+
+proc RefreshInfoBox {which} {
+ global current
+
+ global debug
+ if {$debug(tcl,info)} {
+ puts stderr "RefreshInfoBox"
+ }
+
+ if {$which != {}} {
+ switch -- $current(mode) {
+ crosshair -
+ analysis {
+ set coord [$which get crosshair canvas]
+ set x [lindex $coord 0]
+ set y [lindex $coord 1]
+ EnterInfoBox $which
+ UpdateInfoBox $which $x $y canvas
+ }
+ none -
+ pointer -
+ region -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ catalog -
+ examine -
+ iexam {
+ EnterInfoBox $which
+ ClearInfoBoxCoords
+ }
+ }
+ }
+ return
+}
+
+proc UpdateInfoBoxBase {} {
+ global debug
+ if {$debug(tcl,info)} {
+ puts stderr "UpdateInfoBoxBase"
+ }
+
+ global current
+ global infobox
+ if {$current(frame) != {}} {
+ $current(frame) get info infobox
+ }
+}
+
+proc UpdateInfoBox {which x y sys} {
+ global debug
+ if {$debug(tcl,info)} {
+ puts stderr "UpdateInfoBox $sys"
+ }
+
+ global ds9
+ global pds9
+ global infobox
+ global view
+
+ $which get info $sys $x $y infobox
+ set infobox(bunit) [$which get fits header keyword BUNIT]
+ if {$view(info,keyvalue) != ""} {
+ set infobox(keyvalue) \
+ [$which get fits header keyword \'$view(info,keyvalue)\']
+ } else {
+ set infobox(keyvalue) {}
+ }
+
+ # windows fonts can be larger, causing a layout event
+ switch $ds9(wm) {
+ x11 -
+ aqua {set fsz $pds9(font,size)}
+ win32 {set fsz [expr $pds9(font,size)-3]}
+ }
+
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ if {$view(info,wcs$ll)} {
+ if {![$which has fits]} {
+ set infobox(wcs$ll,sys) "WCS $ll"
+ $infobox(wcs$ll,x,nm) configure -text {}
+ $infobox(wcs$ll,y,nm) configure -text {}
+ } elseif {[$which has wcs equatorial wcs$ll]} {
+ switch -- $infobox(wcs$ll,sys) {
+ fk4 -
+ fk5 -
+ icrs {
+ $infobox(wcs$ll,x,nm) configure -text "\u03b1" \
+ -font "$ds9(times) $fsz"
+ $infobox(wcs$ll,y,nm) configure -text "\u03b4" \
+ -font "$ds9(times) $fsz"
+ }
+ galactic {
+ $infobox(wcs$ll,x,nm) configure -text {l} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ $infobox(wcs$ll,y,nm) configure -text {b} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ }
+ ecliptic {
+ $infobox(wcs$ll,x,nm) configure -text "\u03bb" \
+ -font "$ds9(times) $fsz"
+ $infobox(wcs$ll,y,nm) configure -text "\u03b2" \
+ -font "$ds9(times) $fsz"
+ }
+ }
+ } elseif {[$which has wcs celestrial wcs$ll]} {
+ set infobox(wcs$ll,sys) "WCS $ll"
+ $infobox(wcs$ll,x,nm) configure -text {l} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ $infobox(wcs$ll,y,nm) configure -text {b} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ } else {
+ set infobox(wcs$ll,sys) "WCS $ll"
+ $infobox(wcs$ll,x,nm) configure -text {x} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ $infobox(wcs$ll,y,nm) configure -text {y} \
+ -font "{$ds9(times)} $pds9(font,size) normal italic"
+ }
+ }
+ }
+}
+
+proc LayoutInfoPanel {} {
+ global ds9
+ global view
+
+ # reset
+ grid columnconfigure $ds9(info) 7 -weight 0
+ if {$ds9(row) > -1} {
+ grid rowconfigure $ds9(info) $ds9(row) -weight 0
+ set ds9(row) -1
+ }
+
+ # layout
+ switch $view(layout) {
+ vertical {LayoutInfoPanelVert}
+ horizontal {LayoutInfoPanelHorz}
+ }
+}
+
+proc LayoutInfoPanelHorz {} {
+ global ds9
+ global view
+
+ set ww 12
+ set row 0
+ # also adjust layout.tcl CanvasDef
+ switch $ds9(wm) {
+ x11 {set xx 42}
+ aqua {set xx 40}
+ win32 {set xx 40}
+ }
+
+ grid columnconfigure $ds9(info) 7 -weight 1
+
+ # filename
+ if {$view(info,filename)} {
+ $ds9(info).fileValue configure -width $xx
+
+ grid $ds9(info).fileTitle -row $row -column 0 -sticky w
+ grid $ds9(info).fileValue -row $row -column 2 -padx 2 \
+ -sticky ew -columnspan 6
+ incr row
+ } else {
+ grid forget $ds9(info).fileTitle
+ grid forget $ds9(info).fileValue
+ }
+
+ # object
+ if {$view(info,object)} {
+ $ds9(info).objValue configure -width $xx
+
+ grid $ds9(info).objTitle -row $row -column 0 -sticky w
+ grid $ds9(info).objValue -row $row -column 2 -padx 2 \
+ -sticky ew -columnspan 6
+ incr row
+ } else {
+ grid forget $ds9(info).objTitle
+ grid forget $ds9(info).objValue
+ }
+
+ # keyword
+ if {$view(info,keyword)} {
+ $ds9(info).keyWord configure -width $ww
+ $ds9(info).keyValue configure -width $xx
+
+ grid $ds9(info).keyWord -row $row -column 0 -sticky w
+ grid $ds9(info).keyValue -row $row -column 2 -padx 2 \
+ -sticky w -columnspan 6
+ incr row
+ } else {
+ grid forget $ds9(info).keyWord
+ grid forget $ds9(info).keyValue
+ }
+
+ # minmax
+ if {$view(info,minmax)} {
+ $ds9(info).minValue configure -width $ww
+ $ds9(info).minXValue configure -width $ww
+ $ds9(info).minYValue configure -width $ww
+
+ grid $ds9(info).minTitle -row $row -column 0 -sticky w
+ grid $ds9(info).minXLabel -row $row -column 1 -padx 2 -sticky w
+ grid $ds9(info).minXValue -row $row -column 2 -padx 2 -sticky w
+ grid $ds9(info).minYLabel -row $row -column 3 -padx 2 -sticky w
+ grid $ds9(info).minYValue -row $row -column 4 -padx 2 -sticky w
+ grid $ds9(info).minValue -row $row -column 6 -padx 2 -sticky w
+ incr row
+
+ $ds9(info).maxValue configure -width $ww
+ $ds9(info).maxXValue configure -width $ww
+ $ds9(info).maxYValue configure -width $ww
+
+ grid $ds9(info).maxTitle -row $row -column 0 -sticky w
+ grid $ds9(info).maxXLabel -row $row -column 1 -padx 2 -sticky w
+ grid $ds9(info).maxXValue -row $row -column 2 -padx 2 -sticky w
+ grid $ds9(info).maxYLabel -row $row -column 3 -padx 2 -sticky w
+ grid $ds9(info).maxYValue -row $row -column 4 -padx 2 -sticky w
+ grid $ds9(info).maxValue -row $row -column 6 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).minTitle
+ grid forget $ds9(info).minValue
+ grid forget $ds9(info).minXLabel
+ grid forget $ds9(info).minXValue
+ grid forget $ds9(info).minYLabel
+ grid forget $ds9(info).minYValue
+
+ grid forget $ds9(info).maxTitle
+ grid forget $ds9(info).maxValue
+ grid forget $ds9(info).maxXLabel
+ grid forget $ds9(info).maxXValue
+ grid forget $ds9(info).maxYLabel
+ grid forget $ds9(info).maxYValue
+ }
+
+ # lowhigh
+ if {$view(info,lowhigh)} {
+ $ds9(info).lowValue configure -width $ww
+ $ds9(info).highValue configure -width $ww
+
+ grid $ds9(info).lowhighTitle -row $row -column 0 -sticky w
+ grid $ds9(info).lowValue -row $row -column 2 -padx 2 -sticky w
+ grid $ds9(info).highValue -row $row -column 4 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).lowhighTitle
+ grid forget $ds9(info).lowValue
+ grid forget $ds9(info).highValue
+ }
+
+ # value
+ $ds9(info).value configure -width $ww
+ $ds9(info).valueR configure -width $ww
+ $ds9(info).valueG configure -width $ww
+ $ds9(info).valueB configure -width $ww
+
+ grid $ds9(info).valueTitle -row $row -column 0 -sticky w
+ set ds9(info,row,value) $row
+ set ds9(info,row,value,red) $row
+ set ds9(info,row,value,green) $row
+ set ds9(info,row,value,blue) $row
+ incr row
+ UpdateFrameInfoBox base
+
+ # unit
+ if {$view(info,bunit)} {
+ $ds9(info).bunitValue configure -width $ww
+
+ grid $ds9(info).bunitTitle -row $row -column 0 -sticky w
+ grid $ds9(info).bunitValue -row $row -column 2 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).bunitTitle
+ grid forget $ds9(info).bunitValue
+ }
+
+ # wcs
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $ds9(info).wcsLabel$ll configure -width $ww
+ $ds9(info).wcsXValue$ll configure -width $ww
+ $ds9(info).wcsYValue$ll configure -width $ww
+ $ds9(info).wcsZValue$ll configure -width $ww
+
+ if {$view(info,wcs$ll)} {
+ grid $ds9(info).wcsLabel$ll -row $row -column 0 -sticky w
+ grid $ds9(info).wcsXLabel$ll -row $row -column 1 -sticky w
+ grid $ds9(info).wcsXValue$ll -row $row -column 2 -padx 2
+ grid $ds9(info).wcsYLabel$ll -row $row -column 3 -sticky w
+ grid $ds9(info).wcsYValue$ll -row $row -column 4 -padx 2
+ set ds9(info,row,wcs$ll) $row
+ incr row
+ } else {
+ grid forget $ds9(info).wcsLabel$ll
+ grid forget $ds9(info).wcsXLabel$ll
+ grid forget $ds9(info).wcsXValue$ll
+ grid forget $ds9(info).wcsYLabel$ll
+ grid forget $ds9(info).wcsYValue$ll
+ }
+ }
+
+ # detector
+ if {$view(info,detector)} {
+ $ds9(info).detectorXValue configure -width $ww
+ $ds9(info).detectorYValue configure -width $ww
+ $ds9(info).detectorZValue configure -width $ww
+
+ grid $ds9(info).detectorTitle -row $row -column 0 -sticky w
+ grid $ds9(info).detectorXLabel -row $row -column 1 -sticky w
+ grid $ds9(info).detectorXValue -row $row -column 2 -padx 2
+ grid $ds9(info).detectorYLabel -row $row -column 3 -sticky w
+ grid $ds9(info).detectorYValue -row $row -column 4 -padx 2
+ set ds9(info,row,detector) $row
+ incr row
+ } else {
+ grid forget $ds9(info).detectorTitle
+ grid forget $ds9(info).detectorXLabel
+ grid forget $ds9(info).detectorXValue
+ grid forget $ds9(info).detectorYLabel
+ grid forget $ds9(info).detectorYValue
+ }
+
+ # amplifier
+ if {$view(info,amplifier)} {
+ $ds9(info).amplifierXValue configure -width $ww
+ $ds9(info).amplifierYValue configure -width $ww
+ $ds9(info).amplifierZValue configure -width $ww
+
+ grid $ds9(info).amplifierTitle -row $row -column 0 -sticky w
+ grid $ds9(info).amplifierXLabel -row $row -column 1 -sticky w
+ grid $ds9(info).amplifierXValue -row $row -column 2 -padx 2
+ grid $ds9(info).amplifierYLabel -row $row -column 3 -sticky w
+ grid $ds9(info).amplifierYValue -row $row -column 4 -padx 2
+ set ds9(info,row,amplifier) $row
+ incr row
+ } else {
+ grid forget $ds9(info).amplifierTitle
+ grid forget $ds9(info).amplifierXLabel
+ grid forget $ds9(info).amplifierXValue
+ grid forget $ds9(info).amplifierYLabel
+ grid forget $ds9(info).amplifierYValue
+ }
+
+ # physical
+ if {$view(info,physical)} {
+ $ds9(info).physicalXValue configure -width $ww
+ $ds9(info).physicalYValue configure -width $ww
+ $ds9(info).physicalZValue configure -width $ww
+
+ grid $ds9(info).physicalTitle -row $row -column 0 -sticky w
+ grid $ds9(info).physicalXLabel -row $row -column 1 -sticky w
+ grid $ds9(info).physicalXValue -row $row -column 2 -padx 2
+ grid $ds9(info).physicalYLabel -row $row -column 3 -sticky w
+ grid $ds9(info).physicalYValue -row $row -column 4 -padx 2
+ set ds9(info,row,physical) $row
+ incr row
+ } else {
+ grid forget $ds9(info).physicalTitle
+ grid forget $ds9(info).physicalXLabel
+ grid forget $ds9(info).physicalXValue
+ grid forget $ds9(info).physicalYLabel
+ grid forget $ds9(info).physicalYValue
+ }
+
+ # image
+ if {$view(info,image)} {
+ $ds9(info).imageXValue configure -width $ww
+ $ds9(info).imageYValue configure -width $ww
+ $ds9(info).imageZValue configure -width $ww
+
+ grid $ds9(info).imageTitle -row $row -column 0 -sticky w
+ grid $ds9(info).imageXLabel -row $row -column 1 -sticky w
+ grid $ds9(info).imageXValue -row $row -column 2 -padx 2
+ grid $ds9(info).imageYLabel -row $row -column 3 -sticky w
+ grid $ds9(info).imageYValue -row $row -column 4 -padx 2
+ set ds9(info,row,image) $row
+ incr row
+ } else {
+ grid forget $ds9(info).imageTitle
+ grid forget $ds9(info).imageXLabel
+ grid forget $ds9(info).imageXValue
+ grid forget $ds9(info).imageYLabel
+ grid forget $ds9(info).imageYValue
+ }
+
+ # frame, zoom, angle
+ if {$view(info,frame)} {
+ $ds9(info).zoomValue configure -width $ww
+ $ds9(info).angleValue configure -width $ww
+
+ grid $ds9(info).frame -row $row -column 0 -sticky w
+ grid $ds9(info).zoomtitle -row $row -column 1 -sticky w
+ grid $ds9(info).zoomValue -row $row -column 2 -padx 2 -sticky w
+ grid $ds9(info).angleValue -row $row -column 4 -padx 2 -sticky w
+ grid $ds9(info).angleTitle -row $row -column 5 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).frame
+ grid forget $ds9(info).zoomtitle
+ grid forget $ds9(info).zoomValue
+ grid forget $ds9(info).angleTitle
+ grid forget $ds9(info).angleValue
+ }
+
+ # dummy
+ grid forget $ds9(info).dummy
+}
+
+proc LayoutInfoPanelVert {} {
+ global ds9
+ global view
+
+ set ww 13
+ set row 0
+
+ # filename
+ if {$view(info,filename)} {
+ $ds9(info).fileValue configure -width $ww
+
+ grid $ds9(info).fileTitle -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).fileValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).fileTitle
+ grid forget $ds9(info).fileValue
+ }
+
+ # object
+ if {$view(info,object)} {
+ $ds9(info).objValue configure -width $ww
+
+ grid $ds9(info).objTitle -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).objValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).objTitle
+ grid forget $ds9(info).objValue
+ }
+
+ # keyword
+ if {$view(info,keyword)} {
+ $ds9(info).keyWord configure -width $ww
+ $ds9(info).keyValue configure -width $ww
+
+ grid $ds9(info).keyWord -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).keyValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).keyWord
+ grid forget $ds9(info).keyValue
+ }
+
+ # minmax
+ if {$view(info,minmax)} {
+ $ds9(info).minValue configure -width $ww
+ $ds9(info).minXValue configure -width $ww
+ $ds9(info).minYValue configure -width $ww
+
+ grid $ds9(info).minTitle -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).minXLabel -row $row -column 0 -sticky e
+ grid $ds9(info).minXValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ grid $ds9(info).minYLabel -row $row -column 0 -sticky e
+ grid $ds9(info).minYValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ grid $ds9(info).minValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+
+ $ds9(info).maxXValue configure -width $ww
+ $ds9(info).maxValue configure -width $ww
+ $ds9(info).maxYValue configure -width $ww
+
+ grid $ds9(info).maxTitle -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).maxXLabel -row $row -column 0 -sticky e
+ grid $ds9(info).maxXValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ grid $ds9(info).maxYLabel -row $row -column 0 -sticky e
+ grid $ds9(info).maxYValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ grid $ds9(info).maxValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).minTitle
+ grid forget $ds9(info).minValue
+ grid forget $ds9(info).minXValue
+ grid forget $ds9(info).minYValue
+
+ grid forget $ds9(info).maxTitle
+ grid forget $ds9(info).maxValue
+ grid forget $ds9(info).maxXValue
+ grid forget $ds9(info).maxYValue
+ }
+
+ # lowhigh
+ if {$view(info,lowhigh)} {
+ $ds9(info).lowValue configure -width $ww
+ $ds9(info).highValue configure -width $ww
+
+ grid $ds9(info).lowhighTitle -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).lowValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ grid $ds9(info).highValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).lowhighTitle
+ grid forget $ds9(info).lowValue
+ grid forget $ds9(info).highValue
+ }
+
+ # value
+ $ds9(info).value configure -width $ww
+ $ds9(info).valueR configure -width $ww
+ $ds9(info).valueG configure -width $ww
+ $ds9(info).valueB configure -width $ww
+
+ grid $ds9(info).valueTitle -row $row -column 1 -sticky w
+ incr row
+ set ds9(info,row,value) $row
+ set ds9(info,row,value,red) $row
+ incr row
+ set ds9(info,row,value,green) $row
+ incr row
+ set ds9(info,row,value,blue) $row
+ incr row
+ UpdateFrameInfoBox base
+
+ # units
+ if {$view(info,bunit)} {
+ $ds9(info).bunitValue configure -width $ww
+
+ grid $ds9(info).bunitTitle -row $row -column 1 -sticky w
+ incr row
+ grid $ds9(info).bunitValue -row $row -column 1 -padx 2 -sticky w
+ incr row
+ } else {
+ grid forget $ds9(info).bunitTitle
+ grid forget $ds9(info).bunitValue
+ }
+
+ # wcs
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $ds9(info).wcsLabel$ll configure -width $ww
+ $ds9(info).wcsXValue$ll configure -width $ww
+ $ds9(info).wcsYValue$ll configure -width $ww
+ $ds9(info).wcsZValue$ll configure -width $ww
+
+ if {$view(info,wcs$ll)} {
+ grid $ds9(info).wcsLabel$ll -row $row -column 1 -sticky ew
+ incr row
+ grid $ds9(info).wcsXLabel$ll -row $row -column 0 -sticky e
+ grid $ds9(info).wcsXValue$ll -row $row -column 1 -padx 2
+ incr row
+ grid $ds9(info).wcsYLabel$ll -row $row -column 0 -sticky e
+ grid $ds9(info).wcsYValue$ll -row $row -column 1 -padx 2
+ incr row
+ set ds9(info,row,wcs$ll) $row
+ incr row
+ } else {
+ grid forget $ds9(info).wcsLabel$ll
+ grid forget $ds9(info).wcsXLabel$ll
+ grid forget $ds9(info).wcsXValue$ll
+ grid forget $ds9(info).wcsYLabel$ll
+ grid forget $ds9(info).wcsYValue$ll
+ }
+ }
+
+ # detector
+ if {$view(info,detector)} {
+ $ds9(info).detectorXValue configure -width $ww
+ $ds9(info).detectorYValue configure -width $ww
+ $ds9(info).detectorZValue configure -width $ww
+
+ grid $ds9(info).detectorTitle -row $row -column 1 -sticky ew
+ incr row
+ grid $ds9(info).detectorXLabel -row $row -column 0 -sticky e
+ grid $ds9(info).detectorXValue -row $row -column 1 -padx 2
+ incr row
+ grid $ds9(info).detectorYLabel -row $row -column 0 -sticky e
+ grid $ds9(info).detectorYValue -row $row -column 1 -padx 2
+ incr row
+ set ds9(info,row,detector) $row
+ incr row
+ } else {
+ grid forget $ds9(info).detectorTitle
+ grid forget $ds9(info).detectorXLabel
+ grid forget $ds9(info).detectorXValue
+ grid forget $ds9(info).detectorYLabel
+ grid forget $ds9(info).detectorYValue
+ }
+
+ # amplifier
+ if {$view(info,amplifier)} {
+ $ds9(info).amplifierXValue configure -width $ww
+ $ds9(info).amplifierYValue configure -width $ww
+ $ds9(info).amplifierZValue configure -width $ww
+
+ grid $ds9(info).amplifierTitle -row $row -column 1 -sticky ew
+ incr row
+ grid $ds9(info).amplifierXLabel -row $row -column 0 -sticky e
+ grid $ds9(info).amplifierXValue -row $row -column 1 -padx 2
+ incr row
+ grid $ds9(info).amplifierYLabel -row $row -column 0 -sticky e
+ grid $ds9(info).amplifierYValue -row $row -column 1 -padx 2
+ incr row
+ set ds9(info,row,amplifier) $row
+ incr row
+ } else {
+ grid forget $ds9(info).amplifierTitle
+ grid forget $ds9(info).amplifierXLabel
+ grid forget $ds9(info).amplifierXValue
+ grid forget $ds9(info).amplifierYLabel
+ grid forget $ds9(info).amplifierYValue
+ }
+
+ # physical
+ if {$view(info,physical)} {
+ $ds9(info).physicalXValue configure -width $ww
+ $ds9(info).physicalYValue configure -width $ww
+ $ds9(info).physicalZValue configure -width $ww
+
+ grid $ds9(info).physicalTitle -row $row -column 1 -sticky ew
+ incr row
+ grid $ds9(info).physicalXLabel -row $row -column 0 -sticky e
+ grid $ds9(info).physicalXValue -row $row -column 1 -padx 2
+ incr row
+ grid $ds9(info).physicalYLabel -row $row -column 0 -sticky e
+ grid $ds9(info).physicalYValue -row $row -column 1 -padx 2
+ incr row
+ set ds9(info,row,physical) $row
+ incr row
+ } else {
+ grid forget $ds9(info).physicalTitle
+ grid forget $ds9(info).physicalXLabel
+ grid forget $ds9(info).physicalXValue
+ grid forget $ds9(info).physicalYLabel
+ grid forget $ds9(info).physicalYValue
+ }
+
+ # image
+ if {$view(info,image)} {
+ $ds9(info).imageXValue configure -width $ww
+ $ds9(info).imageYValue configure -width $ww
+ $ds9(info).imageZValue configure -width $ww
+
+ grid $ds9(info).imageTitle -row $row -column 1 -sticky ew
+ incr row
+ grid $ds9(info).imageXLabel -row $row -column 0 -sticky e
+ grid $ds9(info).imageXValue -row $row -column 1 -padx 2
+ incr row
+ grid $ds9(info).imageYLabel -row $row -column 0 -sticky e
+ grid $ds9(info).imageYValue -row $row -column 1 -padx 2
+ incr row
+ set ds9(info,row,image) $row
+ incr row
+ } else {
+ grid forget $ds9(info).imageTitle
+ grid forget $ds9(info).imageXLabel
+ grid forget $ds9(info).imageXValue
+ grid forget $ds9(info).imageYLabel
+ grid forget $ds9(info).imageYValue
+ }
+
+ # frame, zoom, angle
+ if {$view(info,frame)} {
+ $ds9(info).zoomValue configure -width $ww
+ $ds9(info).angleValue configure -width $ww
+
+ grid $ds9(info).frame -row $row -column 1 -sticky ew
+ incr row
+ grid $ds9(info).zoomtitle -row $row -column 0 -sticky e
+ grid $ds9(info).zoomValue -row $row -column 1 -padx 2
+ incr row
+ grid $ds9(info).angleTitle -row $row -column 0 -sticky e
+ grid $ds9(info).angleValue -row $row -column 1 -padx 2
+ incr row
+ } else {
+ grid forget $ds9(info).frame
+ grid forget $ds9(info).zoomtitle
+ grid forget $ds9(info).zoomValue
+ grid forget $ds9(info).angleTitle
+ grid forget $ds9(info).angleValue
+ }
+
+ # dummy
+ global ds9
+ set ds9(row) $row
+
+ grid $ds9(info).dummy -row $row -column 1
+ grid rowconfigure $ds9(info) $row -weight 1
+}
diff --git a/ds9/library/layout.tcl b/ds9/library/layout.tcl
new file mode 100644
index 0000000..191a748
--- /dev/null
+++ b/ds9/library/layout.tcl
@@ -0,0 +1,1086 @@
+# 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 CanvasDef {} {
+ global canvas
+ global icanvas
+ global ds9
+
+ # also adjust info.tcl LayoutInfoPanelHorz
+ switch $ds9(wm) {
+ x11 {set icanvas(horz,width) 738}
+ aqua {set icanvas(horz,width) 777}
+ win32 {set icanvas(horz,width) 740}
+ }
+
+ set icanvas(horz,height) 480
+ set icanvas(vert,width) 640
+ set icanvas(vert,height) 640
+ set canvas(width) $icanvas(horz,width)
+ set canvas(height) $icanvas(horz,height)
+ set canvas(gap) 4
+
+ switch $ds9(wm) {
+ x11 {
+ # this is not fool proof. it does not take into account redirecting
+ # the DISPLAY. There must be a better way.
+ global tcl_platform
+ switch -- $tcl_platform(os) {
+ Darwin {set canvas(gap,bottom) 14}
+ default {set canvas(gap,bottom) 0}
+ }
+ }
+ aqua {set canvas(gap,bottom) 14}
+ win32 {set canvas(gap,bottom) 0}
+ }
+}
+
+proc BlinkDef {} {
+ global blink
+ global iblink
+ global pblink
+
+ set iblink(id) 0
+ set iblink(index) -1
+
+ set blink(interval) 500
+
+ array set pblink [array get blink]
+}
+
+proc TileDef {} {
+ global tile
+ global itile
+ global ptile
+
+ set itile(top) .tile
+ set itile(mb) .tilemb
+
+ set tile(mode) grid
+ set tile(grid,row) 10
+ set tile(grid,col) 10
+ set tile(grid,mode) automatic
+ set tile(grid,dir) x
+ set tile(grid,gap) 4
+
+ array set ptile [array get tile]
+}
+
+proc ViewDef {} {
+ global view
+ global pview
+
+ set view(layout) horizontal
+ set view(info) 1
+ set view(panner) 1
+ set view(magnifier) 1
+ set view(buttons) 1
+ set view(colorbar) 1
+ set view(graph,horz) 0
+ set view(graph,vert) 0
+
+ set view(info,filename) 1
+ set view(info,object) 1
+ set view(info,keyvalue) {}
+ set view(info,keyword) 0
+ set view(info,minmax) 0
+ set view(info,minmax,xy) 0
+ set view(info,lowhigh) 0
+ set view(info,bunit) 0
+ set view(info,wcs) 1
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set "view(info,wcs$l)" 0
+ }
+ set view(info,detector) 0
+ set view(info,amplifier) 0
+ set view(info,physical) 1
+ set view(info,image) 1
+ set view(info,frame) 1
+
+ array set pview [array get view]
+}
+
+# canvas
+
+proc CreateCanvas {} {
+ global ds9
+ global canvas
+
+ LayoutViewAdjust diff
+ set ww [expr $canvas(width)+$diff(x)]
+ set hh [expr $canvas(height)+$diff(y)]
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "CreateCanvas $canvas(width) $canvas(height) ${ww}x${hh}"
+ }
+
+ set ds9(image) [ttk::frame $ds9(main).f]
+ set ds9(canvas) [canvas $ds9(image).c -width $ww -height $hh \
+ -highlightthickness 0 -insertofftime 0 -bg $ds9(bg)]
+ grid rowconfigure $ds9(image) 0 -weight 1
+ grid columnconfigure $ds9(image) 0 -weight 1
+ grid $ds9(canvas) -row 0 -column 0 -sticky news
+
+ # extra space for window tab
+ if {$canvas(gap,bottom)>0} {
+ set f [frame $ds9(image).b -width 1 -height $canvas(gap,bottom) \
+ -bg $ds9(bg)]
+ grid $f -row 1 -column 0 -sticky ew
+ }
+
+ # needed to realize window so Layout routines will work
+ grid $ds9(image)
+}
+
+proc InitCanvas {} {
+ global ds9
+
+ # Bindings
+
+ bind $ds9(canvas) <Tab> [list NextFrame]
+ bind $ds9(canvas) <Shift-Tab> [list PrevFrame]
+ switch $ds9(wm) {
+ x11 {bind $ds9(canvas) <ISO_Left_Tab> [list PrevFrame]}
+ aqua -
+ win32 {}
+ }
+
+ bind $ds9(canvas) <Configure> [list ConfigureView]
+ switch $ds9(wm) {
+ x11 -
+ aqua {
+ bind $ds9(canvas) <Enter> [list focus $ds9(canvas)]
+ bind $ds9(canvas) <Leave> [list focus {}]
+ }
+ win32 {}
+ }
+ switch $ds9(wm) {
+ x11 {}
+ aqua -
+ win32 {bind $ds9(canvas) <MouseWheel> [list MouseWheelFrame %x %y %D]}
+ }
+
+ # backward compatible bindings
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ bind $ds9(canvas) <Button-3> {Button3Canvas %x %y}
+ bind $ds9(canvas) <B3-Motion> {Motion3Canvas %x %y}
+ bind $ds9(canvas) <ButtonRelease-3> {Release3Canvas %x %y}
+ }
+ aqua {
+ # swap button-2 and button-3 on the mighty mouse
+ bind $ds9(canvas) <Button-2> {Button3Canvas %x %y}
+ bind $ds9(canvas) <B2-Motion> {Motion3Canvas %x %y}
+ bind $ds9(canvas) <ButtonRelease-2> {Release3Canvas %x %y}
+
+ # x11 command key emulation
+ bind $ds9(canvas) <Command-Button-1> {Button3Canvas %x %y}
+ bind $ds9(canvas) <Command-B1-Motion> {Motion3Canvas %x %y}
+ bind $ds9(canvas) <Command-ButtonRelease-1> {Release3Canvas %x %y}
+ }
+ }
+
+ # freeze
+ bind $ds9(canvas) <f> {ToggleBindEvents}
+}
+
+proc Button3Canvas {x y} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Button3Canvas"
+ }
+
+ set ds9(b3) 1
+ ColorbarButton3 $x $y
+}
+
+proc Motion3Canvas {x y} {
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Motion3Canvas"
+ }
+
+ ColorbarMotion3 $x $y
+}
+
+proc Release3Canvas {x y} {
+ global ds9
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Release3Canvas"
+ }
+
+ set ds9(b3) 0
+ ColorbarRelease3 $x $y
+}
+
+proc UnBindEventsCanvas {} {
+ global ds9
+
+ foreach f $ds9(active) {
+ UnBindEventsFrame $f
+ }
+}
+
+proc BindEventsCanvas {} {
+ global ds9
+ global current
+
+ switch -- $ds9(display) {
+ single -
+ blink {BindEventsFrame $current(frame)}
+ tile {
+ foreach f $ds9(active) {
+ BindEventsFrame $f
+ }
+ }
+ }
+}
+
+# view
+
+proc ConfigureView {} {
+ global ds9
+ global canvas
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "ConfigureView old $canvas(width) $canvas(height)"
+ }
+
+ # calculate ds9(canvas) size
+ LayoutViewAdjust diff
+
+ # adjust window size
+ set canvas(width) [expr [winfo width $ds9(canvas)]-$diff(x)]
+ set canvas(height) [expr [winfo height $ds9(canvas)]-$diff(y)]
+
+ if {$debug(tcl,layout)} {
+ puts stderr "ConfigureView new $canvas(width) $canvas(height)"
+ }
+
+ LayoutView
+}
+
+proc UpdateView {} {
+ global ds9
+ global canvas
+
+ # note: assume canvas(width) and canvas(height) have been set to desired
+ # values.
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "UpdateView to $canvas(width) x $canvas(height)"
+ }
+
+ # save current size
+ set wo [winfo width $ds9(top)]
+ set ho [winfo height $ds9(top)]
+
+ # calculate ds9(canvas) size
+ LayoutViewAdjust diff
+
+ # adjust window size
+ set ww [expr $canvas(width)+$diff(x)]
+ set hh [expr $canvas(height)+$diff(y)]
+
+ # determine how much to change
+ set wc [winfo width $ds9(canvas)]
+ set hc [winfo height $ds9(canvas)]
+
+ set wt [winfo width $ds9(top)]
+ set ht [winfo height $ds9(top)]
+
+ if {$debug(tcl,layout)} {
+ puts stderr "UpdateView before ds9(top) $wt x $ht"
+ }
+
+ set w [expr $ww - $wc + $wt]
+ set h [expr $hh - $hc + $ht]
+
+ if {$debug(tcl,layout)} {
+ puts stderr "UpdateView after ds9(top) $w x $h"
+ }
+
+ # change window size
+ wm geometry $ds9(top) ${w}x${h}
+
+ LayoutView
+}
+
+proc LayoutView {} {
+ global view
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "LayoutView"
+ }
+
+ switch $view(layout) {
+ horizontal {LayoutViewHorz}
+ vertical {LayoutViewVert}
+ }
+
+ LayoutInfoPanel
+ LayoutButtons
+ LayoutFrames
+ LayoutColorbar
+ LayoutGraphs
+}
+
+proc LayoutViewAdjust {varname} {
+ upvar $varname var
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "LayoutViewAdjust"
+ }
+
+ global view
+ global colorbar
+ global icolorbar
+ global igraph
+ global canvas
+ global ds9
+
+ set var(x) 0
+ set var(y) 0
+
+ set cbh [expr $view(colorbar) && \
+ [string equal $colorbar(orientation) {horizontal}]]
+ set cbv [expr $view(colorbar) && \
+ [string equal $colorbar(orientation) {vertical}]]
+ set grh $view(graph,horz)
+ set grv $view(graph,vert)
+
+ if {$colorbar(numerics)} {
+ # ww horizontal: tickgap
+ set ww 12
+ # hh vertical: approx number of numerals to display
+ set hh 7
+
+ # can't trust 'tk scaling'
+ switch $ds9(wm) {
+ x11 -
+ win32 {set scaling [tk scaling]}
+ aqua {set scaling 1.4}
+ }
+
+ set icolorbar(horizontal,height) \
+ [expr int($colorbar(size) + $colorbar(font,size)*$scaling+$ww)]
+
+ set icolorbar(vertical,width) \
+ [expr $colorbar(size) + $colorbar(font,size)*$hh]
+ } else {
+ set icolorbar(horizontal,height) [expr $colorbar(size) +2]
+ set icolorbar(vertical,width) [expr $colorbar(size) +2]
+ }
+
+ # basics
+ if {$cbh} {
+ incr var(y) $icolorbar(horizontal,height)
+ }
+
+ if {$cbv} {
+ incr var(x) $icolorbar(vertical,width)
+ }
+
+ if {$grh} {
+ incr var(y) $igraph(size)
+ }
+
+ if {$grv} {
+ incr var(x) $igraph(size)
+ }
+
+ # canvas gap
+ if {$cbh || $grh} {
+ incr var(y) $canvas(gap)
+ }
+
+ if {$cbv || $grv} {
+ incr var(x) $canvas(gap)
+ }
+
+ # graph gap
+ if {$grv && !$cbh} {
+ incr var(y) $igraph(gap,y)
+ }
+
+ if {$grh && !$cbv} {
+ incr var(x) $igraph(gap,x)
+ }
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "LayoutViewAdjust $var(x) $var(y)"
+ }
+}
+
+proc LayoutOrient {} {
+ global ds9
+ global canvas
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "LayoutOrient"
+ }
+
+ # save original canvas size
+ set ww $canvas(width)
+ set hh $canvas(height)
+
+ # horizontal
+ grid rowconfigure $ds9(main) 4 -weight 0
+ grid columnconfigure $ds9(main) 0 -weight 0
+
+ # vertical
+ grid rowconfigure $ds9(main) 0 -weight 0
+ grid columnconfigure $ds9(main) 4 -weight 0
+
+ grid forget $ds9(panel)
+ grid forget $ds9(panel,sep)
+ grid forget $ds9(buttons)
+ grid forget $ds9(buttons,sep)
+ grid forget $ds9(image)
+ pack forget $ds9(info)
+ pack forget $ds9(panner)
+ pack forget $ds9(magnifier)
+
+ UpdateView
+ update
+
+ # restore original canvas size
+ set canvas(width) $ww
+ set canvas(height) $hh
+ UpdateView
+}
+
+proc LayoutViewHorz {} {
+ global ds9
+ global current
+ global view
+
+ # canvas
+ grid rowconfigure $ds9(main) 4 -weight 1
+ grid columnconfigure $ds9(main) 0 -weight 1
+ grid $ds9(image) -row 4 -column 0 -sticky news
+
+ # info panel
+ if {$view(info) || $view(magnifier) || $view(panner)} {
+ grid $ds9(panel) -row 0 -column 0 -sticky ew -columnspan 3
+ $ds9(panel,sep) configure -orient horizontal
+ grid $ds9(panel,sep) -row 1 -column 0 -sticky ew -columnspan 3
+ } else {
+ grid forget $ds9(panel)
+ grid forget $ds9(panel,sep)
+ }
+
+ if {$view(info)} {
+ pack $ds9(info) -side left -anchor nw -padx 2 -pady 2 \
+ -fill x -expand true
+ } else {
+ pack forget $ds9(info)
+ }
+
+ if {$view(panner)} {
+ pack $ds9(panner) -side right -padx 2 -pady 2
+ } else {
+ pack forget $ds9(panner)
+ }
+
+ if {$view(magnifier)} {
+ pack $ds9(magnifier) -side right -padx 2 -pady 2
+ if {$view(panner)} {
+ pack $ds9(magnifier) -before $ds9(panner)
+ }
+ } else {
+ pack forget $ds9(magnifier)
+ }
+
+ # buttons
+ if {$view(buttons)} {
+ grid $ds9(buttons) -row 2 -sticky ew -columnspan 3
+ $ds9(buttons,sep) configure -orient horizontal
+ grid $ds9(buttons,sep) -row 3 -column 0 -sticky ew -columnspan 3
+ } else {
+ grid forget $ds9(buttons)
+ grid forget $ds9(buttons,sep)
+ }
+}
+
+proc LayoutViewVert {} {
+ global ds9
+ global current
+ global view
+
+ # canvas
+ grid rowconfigure $ds9(main) 0 -weight 1
+ grid columnconfigure $ds9(main) 4 -weight 1
+ grid $ds9(image) -row 0 -column 4 -sticky news
+
+ # info panel
+ if {$view(info) || $view(magnifier) || $view(panner)} {
+ grid $ds9(panel) -row 0 -column 0 -sticky ns
+ $ds9(panel,sep) configure -orient vertical
+ grid $ds9(panel,sep) -row 0 -column 1 -sticky ns
+ } else {
+ grid forget $ds9(panel)
+ grid forget $ds9(panel,sep)
+ }
+
+ if {$view(magnifier)} {
+ pack $ds9(magnifier) -side top -padx 2 -pady 2
+ } else {
+ pack forget $ds9(magnifier)
+ }
+
+ if {$view(info)} {
+ pack $ds9(info) -side top -padx 2 -pady 2 -fill y -expand true
+ if {$view(magnifier)} {
+ pack $ds9(info) -after $ds9(magnifier)
+ }
+ } else {
+ pack forget $ds9(info)
+ }
+
+ if {$view(panner)} {
+ pack $ds9(panner) -side bottom -padx 2 -pady 2
+ } else {
+ pack forget $ds9(panner)
+ }
+
+ # buttons
+ if {$view(buttons)} {
+ grid $ds9(buttons) -row 0 -column 2 -sticky ns
+ $ds9(buttons,sep) configure -orient vertical
+ grid $ds9(buttons,sep) -row 0 -column 3 -sticky ns
+ } else {
+ grid forget $ds9(buttons)
+ grid forget $ds9(buttons,sep)
+ }
+}
+
+proc LayoutFrames {} {
+ global ds9
+ global current
+ global tile
+ global view
+ global colorbar
+
+ # turn everything off
+ foreach f $ds9(frames) {
+ $f hide
+ $f highlite off
+ $f panner off
+ $f magnifier off
+ UnBindEventsFrame $f
+ }
+
+ if {$ds9(active,num) > 0} {
+ switch -- $ds9(display) {
+ single {TileOne}
+ tile {
+ switch -- $tile(mode) {
+ row {TileRect 1 $ds9(active,num) $tile(grid,gap)}
+ column {TileRect $ds9(active,num) 1 $tile(grid,gap)}
+ grid {
+ switch -- $tile(grid,mode) {
+ automatic {
+ TileRect [expr int(sqrt($ds9(active,num)-1))+1] \
+ [expr int(sqrt($ds9(active,num))+.5)] \
+ $tile(grid,gap)
+ }
+ manual {
+ TileRect \
+ $tile(grid,col) \
+ $tile(grid,row) \
+ $tile(grid,gap)
+ }
+ }
+ }
+ }
+ }
+ blink {TileOne}
+ }
+ } else {
+ set current(frame) {}
+ set ds9(next) {}
+
+ # panner
+ if {$view(panner)} {
+ panner clear
+ }
+
+ # magnifier
+ if {$view(magnifier)} {
+ magnifier clear
+ }
+
+ # process proper colorbar
+ colorbar show
+ colorbarrgb hide
+ $ds9(canvas) raise colorbar colorbarrgb
+
+ set current(colorbar) colorbar
+ set colorbar(map) [colorbar get name]
+ set colorbar(invert) [colorbar get invert]
+
+ # update menus/dialogs
+ UpdateDS9
+ }
+}
+
+
+# This procedure is called when we have only 1 frames to display
+
+proc TileOne {} {
+ global ds9
+ global view
+ global current
+ global canvas
+ global colorbar
+
+ set ww $canvas(width)
+ set hh $canvas(height)
+
+ set xx 0
+ set yy 0
+
+ foreach f $ds9(active) {
+ $f configure -x $xx -y $yy -width $ww -height $hh -anchor nw
+ }
+
+ # only show the current frame
+ $current(frame) show
+ FrameToFront
+}
+
+proc TileRect {numx numy gap} {
+ global view
+ global canvas
+ global tile
+
+ set ww $canvas(width)
+ set hh $canvas(height)
+
+ set w [expr int(($ww-$gap*($numx-1))/$numx)]
+ set h [expr int(($hh-$gap*($numy-1))/$numy)]
+
+ switch $tile(grid,dir) {
+ x {
+ for {set jj 0} {$jj<$numy} {incr jj} {
+ for {set ii 0} {$ii<$numx} {incr ii} {
+ set nn [expr $jj*$numx + $ii]
+ set x($nn) [expr ($w+$gap)*$ii]
+ set y($nn) [expr ($h+$gap)*$jj]
+ }
+ }
+ }
+ y {
+ for {set ii 0} {$ii<$numx} {incr ii} {
+ for {set jj 0} {$jj<$numy} {incr jj} {
+ set nn [expr $ii*$numy + $jj]
+ set x($nn) [expr ($w+$gap)*$ii]
+ set y($nn) [expr ($h+$gap)*$jj]
+ }
+ }
+ }
+ }
+
+ TileIt $w $h x y [expr $numx*$numy]
+}
+
+proc TileIt {ww hh xvar yvar nn} {
+ upvar $xvar x
+ upvar $yvar y
+ global ds9
+ global current
+
+ set ii 0
+ foreach ff $ds9(active) {
+ if {$ii<$nn} {
+ $ff configure -x $x($ii) -y $y($ii) \
+ -width $ww -height $hh -anchor nw
+ $ff show
+ $ds9(canvas) raise $ff
+ if {!$ds9(freeze)} {
+ BindEventsFrame $ff
+ }
+ }
+ incr ii
+ }
+
+ # if manual grid, current frame could be not included
+ if {$current(frame) != {}} {
+ $current(frame) colorbar tag "\{[$current(colorbar) get tag]\}"
+ }
+ if {$ds9(active,num) > $nn} {
+ set current(frame) [lindex $ds9(active) 0]
+ }
+ FrameToFront
+}
+
+proc DisplayDefaultDialog {} {
+ global canvas
+ global ed
+
+ set w {.defdpy}
+
+ set ed(ok) 0
+ set ed(x) $canvas(width)
+ set ed(y) $canvas(height)
+
+ DialogCreate $w [msgcat::mc {Display Size}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.xTitle -text {X}
+ ttk::label $f.yTitle -text {Y}
+ ttk::entry $f.x -textvariable ed(x) -width 10
+ ttk::entry $f.y -textvariable ed(y) -width 10
+ ttk::label $f.xunit -text [msgcat::mc {Pixels}]
+ ttk::label $f.yunit -text [msgcat::mc {Pixels}]
+
+ grid $f.xTitle $f.x $f.xunit -padx 2 -pady 2 -sticky w
+ grid $f.yTitle $f.y $f.yunit -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ $w.param.x select range 0 end
+ DialogWait $w ed(ok) $w.param.x
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set canvas(width) $ed(x)
+ set canvas(height) $ed(y)
+ UpdateView
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc ViewHorzCmd {} {
+ global canvas
+ global icanvas
+
+ set canvas(width) $icanvas(horz,width)
+ set canvas(height) $icanvas(horz,height)
+ LayoutOrient
+}
+
+proc ViewVertCmd {} {
+ global canvas
+ global icanvas
+
+ set canvas(width) $icanvas(vert,width)
+ set canvas(height) $icanvas(vert,height)
+ LayoutOrient
+}
+
+# Process Cmds
+
+proc ProcessHeightCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ # can't use ProcessRealize
+ RealizeDS9
+
+ global canvas
+ set canvas(height) [lindex $var $i]
+ UpdateView
+}
+
+proc ProcessSendHeightCmd {proc id param} {
+ global canvas
+ $proc $id "$canvas(height)\n"
+}
+
+proc ProcessWidthCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ # can't use ProcessRealize
+ RealizeDS9
+
+ global canvas
+ set canvas(width) [lindex $var $i]
+ UpdateView
+}
+
+proc ProcessSendWidthCmd {proc id param} {
+ global canvas
+ $proc $id "$canvas(width)\n"
+}
+
+proc ProcessViewCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global view
+ global rgb
+ global canvas
+ global icanvas
+
+ set item [string tolower [lindex $var $i]]
+
+ switch -- $item {
+ layout {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ horizontal {
+ set view(layout) $item
+ ViewHorzCmd
+ }
+ vertical {
+ set view(layout) $item
+ ViewVertCmd
+ }
+ }
+ }
+ keyvalue {
+ incr i
+ set view(info,keyvalue) [lindex $var $i]
+ }
+ horizontal {
+ # backward compatibility
+ set view(layout) $item
+ ViewHorzCmd
+ }
+ vertical {
+ # backward compatibility
+ set view(layout) $item
+ ViewVertCmd
+ }
+
+ default {
+ set yesno [lindex $var [expr $i+1]]
+ switch -- $yesno {
+ 1 -
+ 0 -
+ yes -
+ no -
+ on -
+ off -
+ true -
+ false {incr i}
+ default {
+ set yesno 1
+ }
+ }
+
+ switch -- $item {
+ info -
+ panner -
+ magnifier -
+ buttons -
+ colorbar {set view($item) [FromYesNo $yesno]}
+
+ colorbarnumerics {
+ # backward compatibility
+ set colorbar(numerics) [FromYesNo $yesno]
+ }
+ graph {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ horizontal {
+ set yesno [lindex $var [expr $i+1]]
+ switch -- $yesno {
+ 1 -
+ 0 -
+ yes -
+ no -
+ on -
+ off -
+ true -
+ false {incr i}
+ default {
+ set yesno 1
+ }
+ }
+ set view(graph,horz) [FromYesNo $yesno]
+ }
+ vertical {
+ set yesno [lindex $var [expr $i+1]]
+ switch -- $yesno {
+ 1 -
+ 0 -
+ yes -
+ no -
+ on -
+ off -
+ true -
+ false {incr i}
+ default {
+ set yesno 1
+ }
+ }
+ set view(graph,vert) [FromYesNo $yesno]
+ }
+ }
+ }
+ horzgraph {
+ # backward compatibility
+ set view(graph,horz) [FromYesNo $yesno]
+ }
+ vertgraph {
+ # backward compatibility
+ set view(graph,vert) [FromYesNo $yesno]
+ }
+
+ filename -
+ object -
+ keyword -
+ minmax -
+ lowhigh -
+ units -
+
+ detector -
+ amplifier -
+ physical -
+ image -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz -
+
+ frame {set view(info,$item) [FromYesNo $yesno]}
+
+ red -
+ green -
+ blue {set rgb($item) [FromYesNo $yesno]; RGBView}
+ }
+ UpdateView
+ }
+ }
+}
+
+proc ProcessSendViewCmd {proc id param} {
+ global view
+
+ switch -- [string tolower [lindex $param 0]] {
+ layout {$proc $id "$view(layout)\n"}
+ keyvalue {$proc $id "$view(info,keyvalue)\n"}
+ info {$proc $id [ToYesNo $view(info)]}
+ panner {$proc $id [ToYesNo $view(panner)]}
+ magnifier {$proc $id [ToYesNo $view(magnifier)]}
+ buttons {$proc $id [ToYesNo $view(buttons)]}
+ colorbar {$proc $id [ToYesNo $view(colorbar)]}
+ colorbarnumerics {
+ # backward compatibility
+ $proc $id [ToYesNo $colorbar(numerics)]
+ }
+ graph {
+ switch -- [string tolower [lindex $param 1]] {
+ horizontal {$proc $id [ToYesNo $view(graph,horz)]}
+ vertical {$proc $id [ToYesNo $view(graph,vert)]}
+ }
+ }
+ horzgraph {
+ # backward compatibility
+ $proc $id [ToYesNo $view(graph,horz)]
+ }
+ vertgraph {
+ # backward compatibility
+ $proc $id [ToYesNo $view(graph,vert)]
+ }
+
+ filename {$proc $id [ToYesNo $view(info,filename)]}
+ object {$proc $id [ToYesNo $view(info,object)]}
+ keyword {$proc $id [ToYesNo $view(info,keyword)]}
+ minmax {$proc $id [ToYesNo $view(info,minmax)]}
+ minmaxxy {$proc $id [ToYesNo $view(info,minmax,xy)]}
+ lowhigh {$proc $id [ToYesNo $view(info,lowhigh)]}
+ units {$proc $id [ToYesNo $view(info,bunit)]}
+
+ detector {$proc $id [ToYesNo $view(info,detector)]}
+ amplifier {$proc $id [ToYesNo $view(info,amplifier)]}
+ physical {$proc $id [ToYesNo $view(info,physical)]}
+ image {$proc $id [ToYesNo $view(info,image)]}
+ wcs {$proc $id [ToYesNo $view(info,wcs)]}
+ wcsa {$proc $id [ToYesNo $view(info,wcsa)]}
+ wcsb {$proc $id [ToYesNo $view(info,wcsb)]}
+ wcsc {$proc $id [ToYesNo $view(info,wcsc)]}
+ wcsd {$proc $id [ToYesNo $view(info,wcsd)]}
+ wcse {$proc $id [ToYesNo $view(info,wcse)]}
+ wcsf {$proc $id [ToYesNo $view(info,wcsf)]}
+ wcsg {$proc $id [ToYesNo $view(info,wcsg)]}
+ wcsh {$proc $id [ToYesNo $view(info,wcsh)]}
+ wcsi {$proc $id [ToYesNo $view(info,wcsi)]}
+ wcsj {$proc $id [ToYesNo $view(info,wcsj)]}
+ wcsk {$proc $id [ToYesNo $view(info,wcsk)]}
+ wcsl {$proc $id [ToYesNo $view(info,wcsl)]}
+ wcsm {$proc $id [ToYesNo $view(info,wcsm)]}
+ wcsn {$proc $id [ToYesNo $view(info,wcsn)]}
+ wcso {$proc $id [ToYesNo $view(info,wcso)]}
+ wcsp {$proc $id [ToYesNo $view(info,wcsp)]}
+ wcsq {$proc $id [ToYesNo $view(info,wcsq)]}
+ wcsr {$proc $id [ToYesNo $view(info,wcsr)]}
+ wcss {$proc $id [ToYesNo $view(info,wcss)]}
+ wcst {$proc $id [ToYesNo $view(info,wcst)]}
+ wcsu {$proc $id [ToYesNo $view(info,wcsu)]}
+ wcsv {$proc $id [ToYesNo $view(info,wcsv)]}
+ wcsw {$proc $id [ToYesNo $view(info,wcsw)]}
+ wcsx {$proc $id [ToYesNo $view(info,wcsx)]}
+ wcsy {$proc $id [ToYesNo $view(info,wcsy)]}
+ wcsz {$proc $id [ToYesNo $view(info,wcsz)]}
+
+ frame {$proc $id [ToYesNo $view(info,frame)]}
+ default {
+ # backward compatibility
+ $proc $id "$view(layout)\n"
+ }
+ }
+}
diff --git a/ds9/library/line.tcl b/ds9/library/line.tcl
new file mode 100644
index 0000000..bdea1b5
--- /dev/null
+++ b/ds9/library/line.tcl
@@ -0,0 +1,121 @@
+# 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 LineDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set arrows [$var(frame) get marker $var(id) line arrow]
+ set var(p1arrow) [lindex $arrows 0]
+ set var(p2arrow) [lindex $arrows 1]
+
+ # procs
+ set var(which) line
+ set var(proc,apply) LineApply
+ set var(proc,coordCB) LineCoordCB
+ set var(proc,editCB) LineEditCB
+ set var(proc,distCB) LineDistCB
+
+ # base
+ MarkerBaseLineDialog $varname 375 150
+ # raise plot?
+ global marker
+ set var(plot2d) $marker(plot2d)
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ # plot2d
+ MarkerAnalysisPlot2dDialog $varname
+
+ set f $var(top).param
+
+ # Arrows
+ ttk::label $f.tarrow -text [msgcat::mc {Arrow}]
+ ttk::checkbutton $f.p1arrow -variable ${varname}(p1arrow) \
+ -text [msgcat::mc {Left}] -command "LineArrow $varname"
+ ttk::checkbutton $f.p2arrow -variable ${varname}(p2arrow) \
+ -text [msgcat::mc {Right}] -command "LineArrow $varname"
+
+ grid $f.tarrow $f.p1arrow $f.p2arrow -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc LineApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) line point $var(system) $var(sky) \
+ $var(x) $var(y) $var(x2) $var(y2)
+
+ MarkerBaseLineApply $varname
+}
+
+# support
+
+proc LineArrow {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) line arrow $var(p1arrow) $var(p2arrow)
+}
+
+# callbacks
+
+proc LineCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "LineCoordCB"
+ }
+
+ MarkerAnalysisPlot2dSystem $varname
+ MarkerBaseCoordCB $varname
+ LineEditCB $varname
+}
+
+proc LineEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "LineEditCB"
+ }
+
+ MarkerBaseLineEditCB $varname
+
+ set var(dist) [$var(frame) get marker $var(id) line length \
+ $var(dcoord) $var(dformat)]
+ set var(angle) [$var(frame) get marker $var(id) angle \
+ $var(system) $var(sky)]
+}
+
+proc LineDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "LineDistCB"
+ }
+
+ set var(dist) [$var(frame) get marker $var(id) line length \
+ $var(dcoord) $var(dformat)]
+}
+
+
diff --git a/ds9/library/load.tcl b/ds9/library/load.tcl
new file mode 100644
index 0000000..4742977
--- /dev/null
+++ b/ds9/library/load.tcl
@@ -0,0 +1,534 @@
+# 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 MultiLoad {{layer {}} {mode {}}} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "MultiLoad"
+ }
+
+ if {$layer != {} || $mode != {}} {
+ return
+ }
+
+ if {$current(frame) != {}} {
+ if {![$current(frame) has fits]} {
+ return
+ }
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {CreateFrame}
+ rgb {}
+ }
+ } else {
+ CreateFrame
+ return
+ }
+
+ # go into tile mode if more than one
+ set cnt [llength $ds9(frames)]
+ if {$cnt > 1 && $current(display) != "tile"} {
+ set current(display) tile
+ DisplayMode
+ }
+}
+
+proc MultiLoadBase {} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "MultiLoadBase"
+ }
+
+ if {$current(frame) != {}} {
+ if {![$current(frame) has fits]} {
+ return
+ }
+ CreateFrame
+ } else {
+ CreateFrame
+ return
+ }
+
+ # go into tile mode if more than one
+ set cnt [llength $ds9(frames)]
+ if {$cnt > 1 && $current(display) != "tile"} {
+ set current(display) tile
+ DisplayMode
+ }
+}
+
+proc MultiLoadRGB {} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,layout)} {
+ puts stderr "MultiLoadRGB"
+ }
+
+ if {$current(frame) != {}} {
+ if {![$current(frame) has fits]} {
+ return
+ }
+ CreateRGBFrame
+ } else {
+ CreateRGBFrame
+ return
+ }
+
+ # go into tile mode if more than one
+ set cnt [llength $ds9(frames)]
+ if {$cnt > 1 && $current(display) != "tile"} {
+ set current(display) tile
+ DisplayMode
+ }
+}
+
+# used by backup
+proc ProcessLoad {{err 1}} {
+ global current
+ global loadParam
+ global ds9
+
+ # restrict load type for windows
+ switch $ds9(wm) {
+ x11 -
+ aqua {}
+ win32 {
+ switch -- $loadParam(load,type) {
+ alloc -
+ allocgz -
+ channel -
+ var -
+ photo {}
+
+ mmap -
+ mmapincr {
+ set loadParam(load,type) allocgz
+ set loadParam(file,fn) $loadParam(file,name)
+ }
+
+ smmap -
+ shared -
+ sshared -
+ socket -
+ socketgz {Error "[msgcat::mc {This function is not currently supported for this port.}]"}
+ }
+ }
+ }
+
+ if {[catch {
+ switch -- $loadParam(load,type) {
+ alloc -
+ allocgz {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ \{$loadParam(file,fn)\} \
+ $loadParam(load,layer)}
+ channel {
+ fconfigure $loadParam(channel,name) -translation binary \
+ -encoding binary
+ $current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(channel,name) \
+ $loadParam(load,layer)
+
+ # clean up
+ catch {close $loadParam(channel,name)}
+ }
+ mmap -
+ mmapincr {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(load,layer)}
+ smmap {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,header)\} \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(load,layer)}
+ shared {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(shared,idtype) \
+ $loadParam(shared,id) \
+ $loadParam(load,layer)}
+ sshared {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(shared,idtype) \
+ $loadParam(shared,hdr) \
+ $loadParam(shared,id) \
+ $loadParam(load,layer)}
+ socket -
+ socketgz {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(socket,id) \
+ $loadParam(load,layer)}
+ var {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ \{$loadParam(file,name)\} \
+ $loadParam(load,type) \
+ $loadParam(var,name) \
+ $loadParam(load,layer)}
+ photo {$current(frame) load $loadParam(file,type) \
+ $loadParam(file,mode) \
+ $loadParam(var,name) \{$loadParam(file,name)\}
+ }
+ }
+ } rr]} {
+ if {$err} {
+ Error "[msgcat::mc {Unable to load}] $loadParam(file,type) $loadParam(file,mode) $loadParam(file,name)"
+ }
+ return 0
+ }
+
+ # save loadParam
+ if {$loadParam(load,layer) == {}} {
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {ProcessLoadSaveParams $current(frame)}
+ rgb {
+ switch -- $loadParam(file,mode) {
+ {rgb image} -
+ {rgb cube} {ProcessLoadSaveParams $current(frame)}
+ default {
+ ProcessLoadSaveParams \
+ "$current(frame)[$current(frame) get rgb channel]"
+ }
+ }
+ }
+ }
+ }
+
+ unset loadParam
+ return 1
+}
+
+proc ProcessLoadSaveParams {varname} {
+ global loadParam
+ global current
+
+ switch $loadParam(file,mode) {
+ slice -
+ {mosaic wcs} -
+ {mosaic iraf} {
+ # special case
+ global $varname
+ if {[info exists $varname]} {
+ set varname "$varname.[$current(frame) get fits count]"
+ }
+ }
+ }
+
+ global $varname
+ if {[info exists $varname]} {
+ unset $varname
+ }
+
+ array set $varname [array get loadParam]
+
+ # always save absolute path
+ upvar #0 $varname var
+ if {[file pathtype $var(file,name)] == {relative}} {
+ set var(file,name) [file join [pwd] $var(file,name)]
+ }
+}
+
+proc StartLoad {} {
+}
+
+proc FinishLoadPre {} {
+ global loadParam
+ global current
+ global threed
+
+ UpdateWCS
+
+ # generate grid so updatemenu is correct
+ GridUpdateCurrent
+
+ # generate contour so updatemenu is correct
+ UpdateContourScale
+ ContourUpdate
+
+ # just in case, frame may have been deleted before FinishLoad during startup
+ if {$current(frame) == {}} {
+ return
+ }
+
+ # if header(s) were open, remove them
+ DestroyHeader $current(frame)
+
+ # Cube?
+ if {[$current(frame) has fits cube]} {
+ CubeDialog
+ }
+}
+
+proc FinishLoadPost {} {
+ UpdateDS9
+}
+
+proc FinishLoad {} {
+ FinishLoadPre
+ FinishLoadPost
+}
+
+proc IsLocalFile {fn} {
+ # strip any brackets
+ set aa [string first "\[" $fn]
+ if {$aa > 0} {
+ set fn [string range $fn 0 [expr $aa-1]]
+ }
+
+ if {![file exists $fn]} {
+ return 0
+ }
+ if {![file isfile $fn]} {
+ return 0
+ }
+ if {[file isdirectory $fn]} {
+ return 0
+ }
+ if {[file readable $fn]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc ConvertFitsFile {} {
+ foreach t {Stdin ExternalFits GzipFile BZip2File CompressFile PackFile} {
+ if {[$t]} {
+ return
+ }
+ }
+}
+
+proc ConvertArrayFile {} {
+ foreach t {Stdin GzipFile BZip2File CompressFile PackFile} {
+ if {[$t]} {
+ return
+ }
+ }
+}
+
+# File Types
+
+proc Stdin {} {
+ global loadParam
+
+ # find -, -[], -[foo] but not -abc
+ if {[regexp -- {^-(\[.*)?$} $loadParam(file,name)]} {
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) "stdin[string range $loadParam(file,name) 1 end]"
+ set loadParam(file,fn) $loadParam(file,name)
+ return 1
+ } elseif {[string range $loadParam(file,name) 0 4] == "stdin" ||
+ [string range $loadParam(file,name) 0 4] == "STDIN"} {
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) "stdin[string range $loadParam(file,name) 5 end]"
+ set loadParam(file,fn) $loadParam(file,name)
+ return 1
+ }
+ return 0
+}
+
+proc BZip2File {} {
+ global loadParam
+
+ if { [regexp {(.*)\.bz2($|\[)} $loadParam(file,name) matched root] } {
+ if {[catch {set ch [open "| bunzip2 < $root.bz2 " r]}]} {
+ return 0
+ }
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ return 1
+ }
+ return 0
+}
+
+proc CompressFile {} {
+ global loadParam
+
+ if {[regexp {(.*)\.Z($|\[)} $loadParam(file,name) matched root]} {
+ if {[catch {set ch [open "| uncompress < $root.Z " r]}]} {
+ return 0
+ }
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ return 1
+ }
+ return 0
+}
+
+proc PackFile {} {
+ global loadParam
+
+ if {[regexp {(.*)\.z($|\[)} $loadParam(file,name) matched root]} {
+ if {[catch {set ch [open "| pcat $root.z " r]}]} {
+ return 0
+ }
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ return 1
+ }
+ return 0
+}
+
+proc GzipFile {} {
+ global loadParam
+
+ set fn $loadParam(file,name)
+ set id [string first "\[" $fn]
+ if {$id > 0} {
+ set fn [string range $fn 0 [expr $id-1]]
+ }
+
+ catch {
+ set ch [open $fn r]
+ fconfigure $ch -encoding binary -translation binary
+ set bb [read $ch 2]
+ close $ch
+ binary scan $bb H4 cc
+ if {$cc == {1f8b}} {
+ set loadParam(load,type) allocgz
+ set loadParam(file,fn) $loadParam(file,name)
+ return 1
+ }
+ }
+ return 0
+}
+
+proc ExternalFits {} {
+ global loadParam
+ global extFits
+
+ foreach id [array names extFits] {
+ if {[string match $id "$loadParam(file,name)"]} {
+ regsub -all {\$filename} $extFits($id) "$loadParam(file,name)" \
+ result
+ set cmd "| $result"
+ if {[catch {set ch [open "$cmd" r]} err]} {
+ Error "open $cmd failed: $err"
+ return 0
+ }
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ return 1
+ }
+ }
+ return 0
+}
+
+# Preserve
+
+proc ProcessPreserveCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ global scale
+ global panzoom
+ global marker
+
+ switch -- [string tolower [lindex $var $i]] {
+ pan {
+ incr i
+ set panzoom(preserve) [FromYesNo [lindex $var $i]]
+ PreservePan
+ }
+ marker -
+ regions {
+ incr i
+ set marker(preserve) [FromYesNo [lindex $var $i]]
+ MarkerPreserve
+ }
+ }
+}
+
+proc ProcessSendPreserveCmd {proc id param} {
+ global scale
+ global panzoom
+ global marker
+
+ switch -- [string tolower $param] {
+ scale {
+ # backward compatibility
+ $proc $id "no\n"
+ }
+ pan {$proc $id [ToYesNo $panzoom(preserve)]}
+ regions {$proc $id [ToYesNo $marker(preserve)]}
+ }
+}
+
+# Update
+
+proc ProcessUpdateCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+ global ds9
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {[lindex $var $i] != {} && [string range [lindex $var $i] 0 0] != {-}} {
+ switch -- [string tolower [lindex $var $i]] {
+ on -
+ yes -
+ no -
+ off {
+ # backward compatibility
+ }
+
+ now {
+ if {[string is integer [lindex $var [expr $i+1]]]} {
+ $current(frame) update now \
+ [lindex $var [expr $i+1]] \
+ [lindex $var [expr $i+2]] [lindex $var [expr $i+3]] \
+ [lindex $var [expr $i+4]] [lindex $var [expr $i+5]]
+
+ incr i 5
+ } else {
+ $current(frame) update now
+ }
+ }
+ {} {
+ $current(frame) update
+ incr i -1
+ }
+
+ default {
+ $current(frame) update \
+ [lindex $var $i] \
+ [lindex $var [expr $i+1]] [lindex $var [expr $i+2]] \
+ [lindex $var [expr $i+3]] [lindex $var [expr $i+4]]
+ incr i 4
+ }
+ }
+ } else {
+ $current(frame) update
+ incr i -1
+ }
+}
diff --git a/ds9/library/macosx.tcl b/ds9/library/macosx.tcl
new file mode 100644
index 0000000..782f11d
--- /dev/null
+++ b/ds9/library/macosx.tcl
@@ -0,0 +1,82 @@
+# 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 MacOSXOpenDocEvent {fc} {
+ global ds9
+
+ if {$ds9(event,opendoc) != {}} {
+ StartLoad
+ foreach f $ds9(event,opendoc) {
+ MultiLoad
+ LoadFitsFile $f {} {}
+ FileLast fitsfbox $f
+ }
+ FinishLoad
+ }
+}
+
+proc MacOSXPrintDocEvent {bye} {
+ global ds9
+
+ if {$ds9(event,printdoc) != {}} {
+ set fc 0
+
+ foreach f $ds9(event,printdoc) {
+ RealizeDS9
+ StartLoad
+
+ MultiLoad
+ LoadFitsFile $f {} {}
+ FileLast fitsfbox $f
+
+ FinishLoad
+ PostScript
+ }
+
+ if {$bye} {
+ Quit
+ }
+ }
+}
+
+proc MacOSXGetLocale {} {
+ return [macosx locale]
+}
+
+#proc MacOSXPrint {} {
+# global ds9
+#
+# we need to be realized
+# RealizeDS9
+# need the colorbar levels updated
+# UpdateColormapLevel
+#
+# if {[macosx pm print begin [winfo width $ds9(canvas)] [winfo height $ds9(canvas)] yes]} {
+# foreach f $ds9(frames) {
+# $f macosx print
+# }
+# colorbar macosx print
+# colorbarrgb macosx print
+# macosx pm print end
+# }
+#}
+
+#proc MacOSXPrintPre {} {
+# global ds9
+
+# if {[macosx pm print begin [winfo width $ds9(canvas)] [winfo height $ds9(canvas)] no]} {
+# foreach f $ds9(frames) {
+# $f macosx print
+# }
+# colorbar macosx print
+# colorbarrgb macosx print
+# macosx pm print end
+# }
+#}
+
+#proc MacOSXPageSetup {} {
+# macosx pm pagesetup
+#}
diff --git a/ds9/library/magnifier.tcl b/ds9/library/magnifier.tcl
new file mode 100644
index 0000000..f1883dd
--- /dev/null
+++ b/ds9/library/magnifier.tcl
@@ -0,0 +1,187 @@
+# 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 CreateMagnifier {} {
+ global imagnifier
+ global ds9
+
+ set ds9(magnifier) [canvas $ds9(panel).mag -width $imagnifier(size) \
+ -height $imagnifier(size) \
+ -relief groove \
+ -borderwidth 2 \
+ -highlightthickness 0 \
+ -insertofftime 0 \
+ -takefocus 0]
+ $ds9(magnifier) create magnifier$ds9(visual) \
+ -width $imagnifier(size) \
+ -height $imagnifier(size) \
+ -command magnifier \
+ -tag magnifier \
+ -helvetica $ds9(helvetica) \
+ -courier $ds9(courier) \
+ -times $ds9(times)
+}
+
+proc MagnifierDef {} {
+ global imagnifier
+ global pmagnifier
+
+ set imagnifier(size) 128
+
+ # prefs only
+ set pmagnifier(cursor) 1
+ set pmagnifier(zoom) 4
+ set pmagnifier(region) 1
+ set pmagnifier(color) white
+}
+
+proc UpdateMagnifier {which x y} {
+ global view
+
+ if {$view(magnifier)} {
+ $which magnifier update $x $y
+ }
+}
+
+proc MagnifierFrameBackup {ch which} {
+ global pmagnifier
+
+ puts $ch "$which magnifier graphics $pmagnifier(region)"
+ puts $ch "$which magnifier cursor $pmagnifier(cursor)"
+ puts $ch "$which magnifier zoom $pmagnifier(zoom)"
+ puts $ch "$which magnifier color $pmagnifier(color)"
+}
+
+# Prefs Cmds
+
+proc MagnifierRegion {} {
+ global pmagnifier
+ global ds9
+
+ foreach ff $ds9(frames) {
+ $ff magnifier graphics $pmagnifier(region)
+ }
+}
+
+proc MagnifierCursor {} {
+ global pmagnifier
+ global ds9
+
+ foreach ff $ds9(frames) {
+ $ff magnifier cursor $pmagnifier(cursor)
+ }
+}
+
+proc MagnifierZoom {} {
+ global pmagnifier
+ global ds9
+
+ foreach ff $ds9(frames) {
+ $ff magnifier zoom $pmagnifier(zoom)
+ }
+}
+
+proc MagnifierColor {} {
+ global pmagnifier
+ global ds9
+
+ foreach ff $ds9(frames) {
+ $ff magnifier color $pmagnifier(color)
+ }
+}
+
+# Prefs
+
+proc PrefsDialogMagnifier {} {
+ global dprefs
+ global pmagnifier
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Magnifier}]
+ lappend dprefs(tabs) [ttk::frame $w.magnifier]
+
+ set f [ttk::labelframe $w.magnifier.param -text [msgcat::mc {Magnifier}]]
+
+ ttk::label $f.tshow -text [msgcat::mc {Show}]
+ ttk::checkbutton $f.graphics -text [msgcat::mc {Graphics}] \
+ -variable pmagnifier(region) -command MagnifierRegion
+ ttk::checkbutton $f.cursor -text [msgcat::mc {Cursor}] \
+ -variable pmagnifier(cursor) -command MagnifierCursor
+
+ ttk::label $f.tcolor -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color pmagnifier color MagnifierColor
+
+ ttk::label $f.tx -text [msgcat::mc {Magnification}]
+ ttk::radiobutton $f.x1 -text {1x} \
+ -variable pmagnifier(zoom) -value 1 -command MagnifierZoom
+ ttk::radiobutton $f.x2 -text {2x} \
+ -variable pmagnifier(zoom) -value 2 -command MagnifierZoom
+ ttk::radiobutton $f.x4 -text {4x} \
+ -variable pmagnifier(zoom) -value 4 -command MagnifierZoom
+ ttk::radiobutton $f.x8 -text {8x} \
+ -variable pmagnifier(zoom) -value 8 -command MagnifierZoom
+ ttk::radiobutton $f.x16 -text {16x} \
+ -variable pmagnifier(zoom) -value 16 -command MagnifierZoom
+
+ grid $f.tshow $f.graphics - $f.cursor - -padx 2 -pady 2 -sticky w
+ grid $f.tcolor $f.color - - -padx 2 -pady 2 -sticky w
+ grid $f.tx $f.x1 $f.x2 $f.x4 $f.x8 $f.x16 -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+# Process Cmds
+
+proc ProcessMagnifierCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global pmagnifier
+ global view
+
+ switch -- [string tolower [lindex $var $i]] {
+ color {
+ incr i
+ set pmagnifier(color) [lindex $var $i]
+ MagnifierColor
+ }
+ zoom {
+ incr i
+ set pmagnifier(zoom) [lindex $var $i]
+ MagnifierZoom
+ }
+ cursor {
+ incr i
+ set pmagnifier(cursor) [FromYesNo [lindex $var $i]]
+ MagnifierCursor
+ }
+ region {
+ incr i
+ set pmagnifier(region) [FromYesNo [lindex $var $i]]
+ MagnifierRegion
+ }
+ default {
+ # backward compatibility
+ set view(magnifier) 1
+ UpdateView
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendMagnifierCmd {proc id param} {
+ global pmagnifier
+
+ switch -- [string tolower [lindex $param 0]] {
+ color {$proc $id "$pmagnifier(color)\n"}
+ zoom {$proc $id "$pmagnifier(zoom)\n"}
+ cursor {$proc $id [ToYesNo $pmagnifier(cursor)]}
+ region {$proc $id [ToYesNo $pmagnifier(region)]}
+ }
+}
+
+
diff --git a/ds9/library/manalysis.tcl b/ds9/library/manalysis.tcl
new file mode 100644
index 0000000..67a93b0
--- /dev/null
+++ b/ds9/library/manalysis.tcl
@@ -0,0 +1,602 @@
+# 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 AnalysisMainMenu {} {
+ global ds9
+
+ # WARNING: this is a variable length menu.
+ # Be sure to update ds9(menu,size,analysis)
+ menu $ds9(mb).analysis
+# IME
+# $ds9(mb).analysis add cascade -label [msgcat::mc {Task}]
+# -menu $ds9(mb).analysis.task
+# $ds9(mb).analysis add separator
+ $ds9(mb).analysis add command -label "[msgcat::mc {Pixel Table}]..." \
+ -command PixelTableDialog
+ $ds9(mb).analysis add command -label "[msgcat::mc {Mask Parameters}]..." \
+ -command MaskDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add checkbutton -label [msgcat::mc {Contours}] \
+ -variable contour(view) -command ContourUpdate
+ $ds9(mb).analysis add command -label "[msgcat::mc {Contour Parameters}]..."\
+ -command ContourDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add checkbutton -label [msgcat::mc {Coordinate Grid}] \
+ -variable grid(view) -command GridUpdateCurrent
+ $ds9(mb).analysis add command \
+ -label "[msgcat::mc {Coordinate Grid Parameters}]..." \
+ -command GridDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add cascade -label [msgcat::mc {Block}] \
+ -menu $ds9(mb).analysis.block
+ $ds9(mb).analysis add command -label "[msgcat::mc {Block Parameters}]..."\
+ -command BlockDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable smooth(view) -command SmoothUpdate
+ $ds9(mb).analysis add command -label "[msgcat::mc {Smooth Parameters}]..." \
+ -command SmoothDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add command \
+ -label "[msgcat::mc {Crosshair Parameters}]..." \
+ -command CrosshairDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add command -label "[msgcat::mc {Name Resolution}]..." \
+ -command NRESDialog
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add cascade -label [msgcat::mc {Image Servers}] \
+ -menu $ds9(mb).analysis.image
+ $ds9(mb).analysis add cascade -label [msgcat::mc {Archives}] \
+ -menu $ds9(mb).analysis.arch
+ $ds9(mb).analysis add cascade -label [msgcat::mc {Catalogs}] \
+ -menu $ds9(mb).analysis.cat
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add command -label "[msgcat::mc {Catalog Tool}]..." \
+ -command CATTool
+ $ds9(mb).analysis add command -label "[msgcat::mc {Line Plot Tool}]..." \
+ -command PlotLineTool
+ $ds9(mb).analysis add command -label "[msgcat::mc {Bar Plot Tool}]..." \
+ -command PlotBarTool
+ $ds9(mb).analysis add command -label "[msgcat::mc {Scatter Plot Tool}]..." \
+ -command PlotScatterTool
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add command \
+ -label "[msgcat::mc {Virtual Observatory}]..."\
+ -command VODialog
+ $ds9(mb).analysis add command -label "[msgcat::mc {Web Browser}]..." \
+ -command {HV web Web {}}
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add checkbutton \
+ -label [msgcat::mc {Analysis Command Log}] \
+ -variable panalysis(log)
+ $ds9(mb).analysis add separator
+ $ds9(mb).analysis add command \
+ -label "[msgcat::mc {Load Analysis Commands}]..." \
+ -command OpenAnalysisMenu
+ $ds9(mb).analysis add command \
+ -label [msgcat::mc {Clear Analysis Commands}] \
+ -command ClearAnalysisMenu
+
+ menu $ds9(mb).analysis.task
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Statistics}] \
+ -variable ime(task) -value stats -command IMEChangeTask
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Histogram}] \
+ -variable ime(task) -value hist -command IMEChangeTask
+ $ds9(mb).analysis.task add radiobutton \
+ -label [msgcat::mc {Radial Profile}] \
+ -variable ime(task) -value radial -command IMEChangeTask
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Plot 2D}] \
+ -variable ime(task) -value plot2d -command IMEChangeTask
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Plot 3D}] \
+ -variable ime(task) -value plot3d -command IMEChangeTask
+ $ds9(mb).analysis.task add separator
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Circle}] \
+ -variable ime(shape) -value circle -command IMEChangeShape
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Ellipse}] \
+ -variable ime(shape) -value ellipse -command IMEChangeShape
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Box}] \
+ -variable ime(shape) -value box -command IMEChangeShape
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Polygon}] \
+ -variable ime(shape) -value polygon -command IMEChangeShape
+ $ds9(mb).analysis.task add separator
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Point}] \
+ -variable ime(shape) -value point -command IMEChangeShape
+ $ds9(mb).analysis.task add separator
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Annulus}] \
+ -variable ime(shape) -value annulus -command IMEChangeShape
+ $ds9(mb).analysis.task add radiobutton \
+ -label [msgcat::mc {Ellipse Annulus}] \
+ -variable ime(shape) -value ellipseannulus -command IMEChangeShape
+ $ds9(mb).analysis.task add radiobutton -label [msgcat::mc {Box Annulus}] \
+ -variable ime(shape) -value boxannulus -command IMEChangeShape
+
+ menu $ds9(mb).analysis.block
+ $ds9(mb).analysis.block add command -label [msgcat::mc {Block In}] \
+ -command {Block .5 .5}
+ $ds9(mb).analysis.block add command -label [msgcat::mc {Block Out}] \
+ -command {Block 2 2}
+ $ds9(mb).analysis.block add command -label [msgcat::mc {Block Fit}] \
+ -command BlockToFit
+ $ds9(mb).analysis.block add separator
+ $ds9(mb).analysis.block add radiobutton -label "[msgcat::mc {Block}] 1" \
+ -variable block(factor) -value { 1 1 } -command ChangeBlock
+ $ds9(mb).analysis.block add radiobutton -label "[msgcat::mc {Block}] 2" \
+ -variable block(factor) -value { 2 2 } -command ChangeBlock
+ $ds9(mb).analysis.block add radiobutton -label "[msgcat::mc {Block}] 4" \
+ -variable block(factor) -value { 4 4 } -command ChangeBlock
+ $ds9(mb).analysis.block add radiobutton -label "[msgcat::mc {Block}] 8" \
+ -variable block(factor) -value { 8 8 } -command ChangeBlock
+ $ds9(mb).analysis.block add radiobutton -label "[msgcat::mc {Block}] 16" \
+ -variable block(factor) -value { 16 16 } -command ChangeBlock
+ $ds9(mb).analysis.block add radiobutton -label "[msgcat::mc {Block}] 32" \
+ -variable block(factor) -value { 32 32 } -command ChangeBlock
+
+ menu $ds9(mb).analysis.image
+ $ds9(mb).analysis.image add command \
+ -label {DSS (SAO)} -command SAODialog
+ $ds9(mb).analysis.image add command \
+ -label {DSS (ESO} -command ESODialog
+ $ds9(mb).analysis.image add command \
+ -label {DSS (STSCI)} -command STSCIDialog
+ $ds9(mb).analysis.image add separator
+ $ds9(mb).analysis.image add command \
+ -label {2MASS (NASA/IPAC)} -command 2MASSDialog
+ $ds9(mb).analysis.image add command \
+ -label {VLA (NRAO)} -command VLADialog
+ $ds9(mb).analysis.image add command \
+ -label {NVSS (NRAO)} -command NVSSDialog
+ $ds9(mb).analysis.image add command \
+ -label {NLSS (NRAO)} -command VLSSDialog
+ $ds9(mb).analysis.image add separator
+ $ds9(mb).analysis.image add command \
+ -label {SkyView (NASA/HEASARC)} -command SkyViewDialog
+
+ menu $ds9(mb).analysis.arch
+ $ds9(mb).analysis.arch add cascade -label {Chandra (NASA/CXC)} \
+ -menu $ds9(mb).analysis.arch.chandra
+ $ds9(mb).analysis.arch add separator
+ SIAAnalysisMenu $ds9(mb).analysis.arch
+
+ menu $ds9(mb).analysis.arch.chandra
+ $ds9(mb).analysis.arch.chandra add command \
+ -label {Chaser} -command HVArchChandraChaser
+ $ds9(mb).analysis.arch.chandra add command \
+ -label {Fast Image} -command HVArchChandraPop
+ $ds9(mb).analysis.arch.chandra add command \
+ -label {Public FTP} -command HVArchChandraFTP
+
+ menu $ds9(mb).analysis.arch.simbad
+ $ds9(mb).analysis.arch.simbad add command -label {SAO} \
+ -command HVArchSIMBADSAO
+ $ds9(mb).analysis.arch.simbad add command -label {CDS} \
+ -command HVArchSIMBADCDS
+
+ menu $ds9(mb).analysis.arch.ads
+ $ds9(mb).analysis.arch.ads add command -label {SAO} \
+ -command HVArchADSSAO
+ $ds9(mb).analysis.arch.ads add command -label {CDS} \
+ -command HVArchADSCDS
+
+ menu $ds9(mb).analysis.cat
+ $ds9(mb).analysis.cat add command \
+ -label [msgcat::mc {Search for Catalogs}] \
+ -command "CATCDSSrchDialog catcdssrch1"
+ $ds9(mb).analysis.cat add command -label [msgcat::mc {Clear All}] \
+ -command CATClearFrame
+ $ds9(mb).analysis.cat add command -label [msgcat::mc {Match}] \
+ -command CATMatchFrame
+ $ds9(mb).analysis.cat add separator
+ CATAnalysisMenu
+}
+
+proc PrefsDialogAnalysisMenu {w} {
+ global ds9
+
+ set f [ttk::labelframe $w.manalysis -text [msgcat::mc {Analysis}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarAnalysis $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+# IME
+# $m add cascade -label [msgcat::mc {Task}]
+# -menu $m.task
+# $m add separator
+ $m add checkbutton -label [msgcat::mc {Contours}] \
+ -variable pcontour(view)
+ $m add checkbutton -label [msgcat::mc {Coordinate Grid}] \
+ -variable pgrid(view)
+ $m add separator
+ $m add cascade -label [msgcat::mc {Block}] \
+ -menu $m.block
+ $m add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable psmooth(view)
+
+ menu $m.task
+ $m.task add radiobutton -label [msgcat::mc {Statistics}] \
+ -variable pime(task) -value stats
+ $m.task add radiobutton -label [msgcat::mc {Histogram}] \
+ -variable pime(task) -value hist
+ $m.task add radiobutton -label [msgcat::mc {Radial Profile}] \
+ -variable pime(task) -value radial
+ $m.task add radiobutton -label [msgcat::mc {Plot 2D}] \
+ -variable pime(task) -value plot2d
+ $m.task add radiobutton -label [msgcat::mc {Plot 3D}] \
+ -variable pime(task) -value plot3d
+
+ menu $m.block
+ $m.block add radiobutton -label "[msgcat::mc {Block}] 1" \
+ -variable pblock(factor) -value { 1 1 }
+ $m.block add radiobutton -label "[msgcat::mc {Block}] 2" \
+ -variable pblock(factor) -value { 2 2 }
+ $m.block add radiobutton -label "[msgcat::mc {Block}] 4" \
+ -variable pblock(factor) -value { 4 4 }
+ $m.block add radiobutton -label "[msgcat::mc {Block}] 8" \
+ -variable pblock(factor) -value { 8 8 }
+ $m.block add radiobutton -label "[msgcat::mc {Block}] 16" \
+ -variable pblock(factor) -value { 16 16 }
+ $m.block add radiobutton -label "[msgcat::mc {Block}] 32" \
+ -variable pblock(factor) -value { 32 32 }
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsAnalysisDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ analysis,contours 1
+ analysis,grid 1
+ analysis,smooth 1
+ analysis,bin 1
+ analysis,bout 1
+ analysis,bfit 1
+ analysis,b1 1
+ analysis,b2 1
+ analysis,b4 1
+ analysis,b8 0
+ analysis,b16 0
+ analysis,b32 0
+ }
+
+# IME
+# analysis,none 1
+# analysis,stats 1
+# analysis,hist 1
+# analysis,radial 1
+# analysis,plot2d 1
+# analysis,plot3d 1
+}
+
+proc CreateButtonsAnalysis {} {
+ global buttons
+ global ds9
+
+ ttk::frame $ds9(buttons).analysis
+
+# IME
+# RadioButton $ds9(buttons).analysis.stats
+# [string tolower [msgcat::mc {Stats}]]
+# ime(task) stats IMEChangeTask
+# RadioButton $ds9(buttons).analysis.hist
+# [string tolower [msgcat::mc {Histogram}]]
+# ime(task) hist IMEChangeTask
+# RadioButton $ds9(buttons).analysis.radial
+# [string tolower [msgcat::mc {Radial}]]
+# ime(task) radial IMEChangeTask
+# RadioButton $ds9(buttons).analysis.plot2d
+# [string tolower [msgcat::mc {Plot 2D}]]
+# ime(task) plot2d IMEChangeTask
+# RadioButton $ds9(buttons).analysis.plot3d
+# [string tolower [msgcat::mc {Plot 3D}]]
+# ime(task) plot3d IMEChangeTask
+
+ CheckButton $ds9(buttons).analysis.contours \
+ [string tolower [msgcat::mc {Contours}]] \
+ contour(view) ContourUpdate
+ CheckButton $ds9(buttons).analysis.grid \
+ [string tolower [msgcat::mc {Grid}]] \
+ grid(view) GridUpdateCurrent
+
+ ButtonButton $ds9(buttons).analysis.bin \
+ [string tolower [msgcat::mc {Block In}]] {Block .5 .5}
+ ButtonButton $ds9(buttons).analysis.bout \
+ [string tolower [msgcat::mc {Block Out}]] {Block 2 2}
+ ButtonButton $ds9(buttons).analysis.bfit \
+ [string tolower [msgcat::mc {Block Fit}]] BlockToFit
+ RadioButton $ds9(buttons).analysis.b1 \
+ "[string tolower [msgcat::mc {Block}]] 1" \
+ block(factor) { 1 1 } ChangeBlock
+ RadioButton $ds9(buttons).analysis.b2 \
+ "[string tolower [msgcat::mc {Block}]] 2" \
+ block(factor) { 2 2 } ChangeBlock
+ RadioButton $ds9(buttons).analysis.b4 \
+ "[string tolower [msgcat::mc {Block}]] 4" \
+ block(factor) { 4 4 } ChangeBlock
+ RadioButton $ds9(buttons).analysis.b8 \
+ "[string tolower [msgcat::mc {Block}]] 8" \
+ block(factor) { 8 8 } ChangeBlock
+ RadioButton $ds9(buttons).analysis.b16 \
+ "[string tolower [msgcat::mc {Block}]] 16" \
+ block(factor) { 16 16 } ChangeBlock
+ RadioButton $ds9(buttons).analysis.b32 \
+ "[string tolower [msgcat::mc {Block}]] 32" \
+ block(factor) { 32 32 } ChangeBlock
+
+ CheckButton $ds9(buttons).analysis.smooth \
+ [string tolower [msgcat::mc {Smooth}]] \
+ smooth(view) SmoothUpdate
+
+ set buttons(analysis) "
+ $ds9(buttons).analysis.contours pbuttons(analysis,contours)
+ $ds9(buttons).analysis.grid pbuttons(analysis,grid)
+
+ $ds9(buttons).analysis.bin pbuttons(analysis,bin)
+ $ds9(buttons).analysis.bout pbuttons(analysis,bout)
+ $ds9(buttons).analysis.bfit pbuttons(analysis,bfit)
+ $ds9(buttons).analysis.b1 pbuttons(analysis,b1)
+ $ds9(buttons).analysis.b2 pbuttons(analysis,b2)
+ $ds9(buttons).analysis.b4 pbuttons(analysis,b4)
+ $ds9(buttons).analysis.b8 pbuttons(analysis,b8)
+ $ds9(buttons).analysis.b16 pbuttons(analysis,b16)
+ $ds9(buttons).analysis.b32 pbuttons(analysis,b32)
+
+ $ds9(buttons).analysis.smooth pbuttons(analysis,smooth)
+ "
+
+# IME
+# $ds9(buttons).analysis.stats pbuttons(analysis,stats)
+# $ds9(buttons).analysis.hist pbuttons(analysis,hist)
+# $ds9(buttons).analysis.radial pbuttons(analysis,radial)
+# $ds9(buttons).analysis.plot2d pbuttons(analysis,plot2d)
+# $ds9(buttons).analysis.plot3d pbuttons(analysis,plot3d)
+}
+
+proc PrefsDialogButtonbarAnalysis {f} {
+ global ds9
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+# IME
+# $m add checkbutton -label [msgcat::mc {Statistics}]
+# -variable pbuttons(analysis,stats)
+# -command {UpdateButtons buttons(analysis)}
+# $m add checkbutton -label [msgcat::mc {Histogram}]
+# -variable pbuttons(analysis,hist)
+# -command {UpdateButtons buttons(analysis)}
+# $m add checkbutton -label [msgcat::mc {Radial Profile}]
+# -variable pbuttons(analysis,radial)
+# -command {UpdateButtons buttons(analysis)}
+# $m add checkbutton -label [msgcat::mc {Plot 2D}]
+# -variable pbuttons(analysis,plot2d)
+# -command {UpdateButtons buttons(analysis)}
+# $m add checkbutton -label [msgcat::mc {Plot 3D}]
+# -variable pbuttons(analysis,plot3d)
+# -command {UpdateButtons buttons(analysis)}
+# $m add separator
+ $m add checkbutton -label [msgcat::mc {Contours}] \
+ -variable pbuttons(analysis,contours) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label [msgcat::mc {Grid}] \
+ -variable pbuttons(analysis,grid) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Block In}] \
+ -variable pbuttons(analysis,bin) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label [msgcat::mc {Block Out}] \
+ -variable pbuttons(analysis,bout) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label [msgcat::mc {Block Fit}] \
+ -variable pbuttons(analysis,bfit) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label "[msgcat::mc {Block}] 1" \
+ -variable pbuttons(analysis,b1) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label "[msgcat::mc {Block}] 2" \
+ -variable pbuttons(analysis,b2) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label "[msgcat::mc {Block}] 4" \
+ -variable pbuttons(analysis,b4) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label "[msgcat::mc {Block}] 8" \
+ -variable pbuttons(analysis,b8) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label "[msgcat::mc {Block}] 16" \
+ -variable pbuttons(analysis,b16) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add checkbutton -label "[msgcat::mc {Block}] 32" \
+ -variable pbuttons(analysis,b32) \
+ -command {UpdateButtons buttons(analysis)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable pbuttons(analysis,smooth) \
+ -command {UpdateButtons buttons(analysis)}
+}
+
+proc UpdateAnalysisMenuStatic {} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateAnalysisMenuStatic"
+ }
+
+ if {$ds9(active,num) > 0} {
+ $ds9(mb) entryconfig [msgcat::mc {Analysis}] -state normal
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Analysis}] -state disabled
+ }
+}
+
+proc UpdateAnalysisMenu {} {
+ global ds9
+ global current
+ global ianalysis
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateAnalysisMenu"
+ }
+
+ if {$current(frame) != {}} {
+ for {set ii 0} {$ii<$ianalysis(menu,count)} {incr ii} {
+
+ if {[$current(frame) has fits]} {
+ set fn [$current(frame) get fits file name 1]
+ } else {
+ set fn {none}
+ }
+
+ # disable by default
+ $ianalysis(menu,$ii,parent) entryconfig $ianalysis(menu,$ii,item) \
+ -state disabled
+
+ foreach tt $ianalysis(menu,$ii,template) {
+ if {[regexp ".$tt" $fn]} {
+ $ianalysis(menu,$ii,parent) entryconfig \
+ $ianalysis(menu,$ii,item) -state normal
+ break
+ }
+ }
+ }
+ }
+}
+
+proc PrefsDialogAnalysis {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Analysis}]
+ lappend dprefs(tabs) [ttk::frame $w.analysis]
+
+ set f [ttk::labelframe $w.analysis.file \
+ -text [msgcat::mc {Analysis File}]]
+
+ ttk::checkbutton $f.auto -text [msgcat::mc {Autoload}] \
+ -variable panalysis(autoload)
+
+ ttk::entry $f.pre -textvariable panalysis(user) -width 60
+ ttk::button $f.browse -text [msgcat::mc {Browse}] \
+ -command "AnalysisPrefOpen panalysis(user)"
+ ttk::entry $f.pre2 -textvariable panalysis(user2) -width 60
+ ttk::button $f.browse2 -text [msgcat::mc {Browse}] \
+ -command "AnalysisPrefOpen panalysis(user2)"
+ ttk::entry $f.pre3 -textvariable panalysis(user3) -width 60
+ ttk::button $f.browse3 -text [msgcat::mc {Browse}] \
+ -command "AnalysisPrefOpen panalysis(user3)"
+ ttk::entry $f.pre4 -textvariable panalysis(user4) -width 60
+ ttk::button $f.browse4 -text [msgcat::mc {Browse}] \
+ -command "AnalysisPrefOpen panalysis(user4)"
+
+ grid $f.auto -padx 2 -pady 2 -sticky w
+ grid $f.pre $f.browse -padx 2 -pady 2 -sticky w
+ grid $f.pre2 $f.browse2 -padx 2 -pady 2 -sticky w
+ grid $f.pre3 $f.browse3 -padx 2 -pady 2 -sticky w
+ grid $f.pre4 $f.browse4 -padx 2 -pady 2 -sticky w
+
+ set f [ttk::labelframe $w.analysis.log -text [msgcat::mc {Analysis Log}]]
+
+ ttk::checkbutton $f.log -text [msgcat::mc {Show Command}] \
+ -variable panalysis(log)
+
+ grid $f.log -padx 2 -pady 2 -sticky w
+
+ pack $w.analysis.file $w.analysis.log -side top -fill both -expand true
+}
+
+# Support
+
+proc UpdateTaskMenu {} {
+ global ds9
+ global ime
+
+ switch $ime(task) {
+ stats -
+ hist {
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Circle}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Polygon}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Point}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Annulus}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse Annulus}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box Annulus}] \
+ -state disabled
+ }
+ radial {
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Circle}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Polygon}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Point}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Annulus}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse Annulus}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box Annulus}] \
+ -state normal
+ }
+ plot2d {
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Circle}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Polygon}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Point}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Annulus}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse Annulus}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box Annulus}] \
+ -state disabled
+ }
+ plot3d {
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Circle}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Polygon}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Point}] \
+ -state normal
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Annulus}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Ellipse Annulus}] \
+ -state disabled
+ $ds9(mb).analysis.task entryconfig [msgcat::mc {Box Annulus}] \
+ -state disabled
+ }
+ }
+}
diff --git a/ds9/library/marker.tcl b/ds9/library/marker.tcl
new file mode 100644
index 0000000..1678a15
--- /dev/null
+++ b/ds9/library/marker.tcl
@@ -0,0 +1,2076 @@
+# 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 MarkerDef {} {
+ global marker
+ global imarker
+ global pmarker
+
+ set imarker(id) -1
+ set imarker(x) -1
+ set imarker(y) -1
+ set imarker(motion) none
+ set imarker(handle) -1
+ set imarker(prefix,dialog) {mkr}
+ set imarker(prefix,plot3d) {plot3d}
+ set imarker(prefix,plot2d) {plot2d}
+ set imarker(prefix,stats) {stats}
+ set imarker(prefix,radial) {radial}
+ set imarker(prefix,panda) {panda}
+ set imarker(prefix,histogram) {hist}
+
+ set marker(show) 1
+ set marker(show,text) 1
+ set marker(centroid,auto) 0
+ set marker(centroid,iteration) 30
+ set marker(centroid,radius) 10
+ set marker(shape) circle
+ set marker(color) green
+ set marker(dashlist) {8 3}
+ set marker(width) 1
+ set marker(dash) 0
+ set marker(fixed) 0
+ set marker(edit) 1
+ set marker(move) 1
+ set marker(rotate) 1
+ set marker(delete) 1
+ set marker(include) 1
+ set marker(source) 1
+ set marker(font) helvetica
+ set marker(font,size) 10
+ set marker(font,weight) normal
+ set marker(font,slant) roman
+ set marker(preserve) 0
+
+ set marker(plot2d) 0
+ set marker(plot3d) 0
+ set marker(stats) 0
+
+ set marker(copy) {}
+ set marker(copy,system) {}
+ set marker(maxdialog) 48
+ set marker(load) current
+
+ set marker(format) ds9
+ # these are only used for save/load/list and are set from current wcs values
+ set marker(system) physical
+ set marker(sky) fk5
+ set marker(skyformat) degrees
+ set marker(strip) 0
+
+ array set pmarker [array get marker]
+ unset pmarker(copy)
+ unset pmarker(copy,system)
+ unset pmarker(maxdialog)
+ unset pmarker(load)
+ unset pmarker(system)
+ unset pmarker(sky)
+ unset pmarker(skyformat)
+ unset pmarker(strip)
+
+ set pmarker(epsilon) 3
+ set pmarker(dformat) degrees
+ set pmarker(circle,radius) 20
+ set pmarker(annulus,inner) 15
+ set pmarker(annulus,outer) 30
+ set pmarker(annulus,annuli) 1
+ set pmarker(panda,inner) 15
+ set pmarker(panda,outer) 30
+ set pmarker(panda,annuli) 1
+ set pmarker(panda,ang1) 0
+ set pmarker(panda,ang2) 360
+ set pmarker(panda,angnum) 4
+ set pmarker(ellipse,radius1) 40
+ set pmarker(ellipse,radius2) 20
+ set pmarker(ellipseannulus,radius1) 40
+ set pmarker(ellipseannulus,radius2) 20
+ set pmarker(ellipseannulus,radius3) 60
+ set pmarker(ellipseannulus,annuli) 1
+ set pmarker(epanda,radius1) 40
+ set pmarker(epanda,radius2) 20
+ set pmarker(epanda,radius3) 60
+ set pmarker(epanda,annuli) 1
+ set pmarker(epanda,ang1) 0
+ set pmarker(epanda,ang2) 360
+ set pmarker(epanda,angnum) 4
+ set pmarker(box,radius1) 80
+ set pmarker(box,radius2) 40
+ set pmarker(boxannulus,radius1) 80
+ set pmarker(boxannulus,radius2) 40
+ set pmarker(boxannulus,radius3) 120
+ set pmarker(boxannulus,annuli) 1
+ set pmarker(bpanda,radius1) 80
+ set pmarker(bpanda,radius2) 40
+ set pmarker(bpanda,radius3) 120
+ set pmarker(bpanda,annuli) 1
+ set pmarker(bpanda,ang1) 0
+ set pmarker(bpanda,ang2) 360
+ set pmarker(bpanda,angnum) 4
+ set pmarker(compass,radius) 40
+ set pmarker(polygon,width) 20
+ set pmarker(polygon,height) 20
+ set pmarker(projection,thick) 0
+ set pmarker(point,size) 11
+ set pmarker(segment,length) 20
+}
+
+# procs shared between region and catalog mode
+
+proc MarkerControl {which x y} {
+ global imarker
+ global current
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ set id [$which get marker $current(mode) id $x $y]
+ if {$id} {
+ # are we on a selected annulus?
+ if {[$which get marker $current(mode) select $x $y] == $id} {
+ switch -- [$which get marker $current(mode) $id type] {
+ annulus {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create annulus radius $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ panda {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create panda radius $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ ellipseannulus {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create ellipseannulus radius $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ epanda {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create epanda radius $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ boxannulus {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create boxannulus radius $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ bpanda {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create bpanda radius $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ }
+ }
+ }
+}
+
+proc MarkerControlShift {which x y} {
+ global imarker
+ global current
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # we need this cause MarkerMotion maybe called,
+ # and we don't want it
+ set imarker(motion) none
+ set imarker(handle) -1
+
+ set id [$which get marker $current(mode) id $x $y]
+ if {$id} {
+ # are we on a selected annulus?
+ if {[$which get marker $current(mode) select $x $y] == $id} {
+ switch -- [$which get marker $current(mode) $id type] {
+ panda {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create panda angle $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ epanda {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create epanda angle $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ bpanda {
+ set imarker(handle) \
+ [$which marker $current(mode) $id create bpanda angle $x $y]
+ $which marker $current(mode) $id edit begin $imarker(handle)
+ set imarker(motion) edit
+ }
+ }
+ }
+ }
+}
+
+proc MarkerCursor {which x y handleCursor overCursor} {
+ global current
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # are we over any selected marker handles?
+ # remember, handles are outside of a marker
+ set h [$which get marker $current(mode) handle $x $y]
+ set id [lindex $h 0]
+ set handle [lindex $h 1]
+ if {$handle} {
+ if {$handle < 5} {
+ # edit/rotate handle
+ SetCursor $handleCursor
+ } else {
+ # polygon/segment/annulus vertex
+ SetCursor dotbox
+ }
+ return
+ }
+
+ # else, see if we are on a segement of a polygon/segment
+ set h [$which get marker $current(mode) polygon segment $x $y]
+ if {[lindex $h 0]} {
+ SetCursor draped_box
+ return
+ }
+ set h [$which get marker $current(mode) segment segment $x $y]
+ if {[lindex $h 0]} {
+ SetCursor draped_box
+ return
+ }
+
+ # are we over a marker?
+ set id [$which get marker $current(mode) select $x $y]
+ if {$id} {
+ # are we on a selected annulus and control key down?
+ switch -- [$which get marker $current(mode) $id type] {
+ annulus -
+ panda -
+ ellipseannulus -
+ epanda -
+ boxannulus -
+ bpanda {SetCursor $overCursor}
+ default {SetCursor fleur}
+ }
+ return
+ }
+
+ # else, set no cursor
+ SetCursor {}
+}
+
+proc MarkerArrowKey {which x y} {
+ global current
+
+ $which warp $x $y
+ $which marker $current(mode) move $x $y
+}
+
+# Marker only
+
+proc MarkerButton {which x y} {
+ global marker
+ global imarker
+ global itemplate
+ global ds9
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # see if we are on a handle
+ set h [$which get marker handle $x $y]
+ set id [lindex $h 0]
+ set imarker(handle) [lindex $h 1]
+
+ if {$imarker(handle)} {
+ $which marker $id edit begin $imarker(handle)
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # else, see if we are on a segment of a polygon
+ set h [$which get marker polygon segment $x $y]
+ set id [lindex $h 0]
+ set segment [lindex $h 1]
+ if {$segment} {
+ $which marker $id create polygon vertex $segment $x $y
+ $which marker $id edit begin $imarker(handle)
+ set imarker(handle) [expr 4+$segment+1]
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # else, see if we are on a segment of a segment
+ set h [$which get marker segment segment $x $y]
+ set id [lindex $h 0]
+ set segment [lindex $h 1]
+ if {$segment} {
+ $which marker $id create segment vertex $segment $x $y
+ $which marker $id edit begin $imarker(handle)
+ set imarker(handle) [expr 4+$segment+1]
+ set imarker(motion) beginEdit
+ return
+ }
+
+ # else, see if we are on a marker
+ if {[$which get marker id $x $y]} {
+ $which marker select only $x $y
+ $which marker move begin $x $y
+ set imarker(motion) beginMove
+ UpdateRegionMenu
+ return
+ }
+
+ # see if any markers are selected
+ if {[$which get marker select number]>0} {
+ $which marker unselect all
+ set imarker(motion) none
+ UpdateRegionMenu
+ return
+ }
+
+ # else, create a marker
+ set imarker(handle) 0
+ set imarker(motion) none
+
+ switch -- $marker(shape) {
+ circle -
+ annulus -
+ panda -
+ ellipse -
+ ellipseannulus -
+ epanda -
+ box -
+ boxannulus -
+ bpanda -
+ polygon -
+ line -
+ vector -
+ projection -
+ segment -
+ text -
+ ruler -
+ compass -
+ {circle point} -
+ {box point} -
+ {diamond point} -
+ {cross point} -
+ {x point} -
+ {arrow point} -
+ {boxcircle point} {MarkerCreateShape $which $x $y}
+ default {
+ set fn "$ds9(root)/template/$itemplate($marker(shape))"
+ set ch [open $fn r]
+
+ global vardata
+ set vardata [read $ch]
+ close $ch
+
+ $which marker create template var vardata $x $y
+ }
+ }
+}
+
+proc MarkerShift {which x y} {
+ global imarker
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # see if we are on a handle
+ set h [$which get marker handle $x $y]
+ set id [lindex $h 0]
+ set imarker(handle) [lindex $h 1]
+
+ if {$imarker(handle)} {
+ $which marker $id rotate begin
+ set imarker(motion) beginRotate
+ return
+ }
+
+ # else, see if we are on a marker
+ if {[$which marker select toggle $x $y]} {
+ UpdateRegionMenu
+ $which marker move begin $x $y
+ set imarker(motion) beginMove
+ return
+ }
+
+ # else, start a region select
+ $which region select begin $x $y
+ set imarker(motion) shiftregion
+}
+
+proc MarkerMotion {which x y} {
+ global imarker
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ switch -- $imarker(motion) {
+ none {}
+
+ beginCreate -
+ create {
+ $which marker edit motion $x $y $imarker(handle)
+ set imarker(motion) create
+ }
+
+ beginMove -
+ move {
+ $which marker move motion $x $y
+ set imarker(motion) move
+ }
+
+ beginEdit -
+ edit {
+ $which marker edit motion $x $y $imarker(handle)
+ set imarker(motion) edit
+ }
+
+ beginRotate -
+ rotate {
+ $which marker rotate motion $x $y $imarker(handle)
+ set imarker(motion) rotate
+ }
+
+ region -
+ shiftregion {$which region select motion $x $y}
+ }
+}
+
+proc MarkerRelease {which x y} {
+ global marker
+ global imarker
+ global current
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ switch -- $imarker(motion) {
+ none {}
+ beginCreate {
+ # the user has just clicked, so resize to make visible or delete
+ # assumes imarker(id) from create
+ $which marker edit end
+ MarkerDefault $which
+
+ if {$imarker(id)>=0} {
+ if {$marker(centroid,auto)} {
+ $which marker centroid $imarker(id)
+ }
+
+ MarkerReleaseCB $which
+ }
+
+ set imarker(id) -1
+ set imarker(x) -1
+ set imarker(y) -1
+ }
+ create {
+ $which marker edit end
+
+ # determine if this is an accident and just create the default
+ set diffx [expr $x-$imarker(x)]
+ set diffy [expr $y-$imarker(y)]
+ if {[expr sqrt($diffx*$diffx + $diffy*$diffy)]<2} {
+ MarkerDefault $which
+ }
+
+ if {$imarker(id)>=0} {
+ if {$marker(centroid,auto)} {
+ $which marker centroid $imarker(id)
+ }
+
+ MarkerReleaseCB $which
+ }
+
+ set imarker(id) -1
+ set imarker(x) -1
+ set imarker(y) -1
+ }
+ beginMove -
+ beginRotate {}
+ beginEdit {}
+ move {
+ $which marker move end
+ if {$marker(centroid,auto)} {
+ $which marker centroid
+ }
+ }
+ edit {
+ $which marker edit end
+ if {$marker(centroid,auto)} {
+ $which marker centroid
+ }
+ }
+ rotate {
+ $which marker rotate end
+ if {$marker(centroid,auto)} {
+ $which marker centroid
+ }
+ }
+ region {$which region select end}
+ shiftregion {$which region select shift end}
+ }
+ set imarker(motion) none
+ set imarker(handle) -1
+}
+
+proc MarkerReleaseCB {which} {
+ global marker
+ global imarker
+ global current
+
+ # special callbacks
+ switch [$which get marker $imarker(id) type] {
+ projection {MarkerAnalysisPlot2d $which $imarker(id) 1}
+ line -
+ vector {
+ if {$marker(plot2d)} {
+ MarkerAnalysisPlot2d $which $imarker(id) 1
+ }
+ }
+ circle -
+ ellipse -
+ box -
+ polygon -
+ point {
+ if {$marker(plot3d)} {
+ MarkerAnalysisPlot3d $which $imarker(id) 1
+ }
+ if {$marker(stats)} {
+ MarkerAnalysisStats $which $imarker(id) 1
+ }
+ }
+ }
+}
+
+proc MarkerDouble {which x y} {
+ global imarker
+
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ set id [$which get marker id $x $y]
+
+ if {$id} {
+ if {[$which get marker $id PROPERTY SELECT]} {
+ MarkerDialog $which $id
+
+ switch [$which get marker $id type] {
+ projection -
+ line -
+ vector -
+ circle -
+ ellipse -
+ box -
+ polygon -
+ point {
+ set vvarname proj${id}${which}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ PlotRaise $vvarname
+ }
+ }
+ }
+ }
+}
+
+proc MarkerCreateShape {which x y} {
+ global marker
+ global imarker
+ global pmarker
+ global current
+ global wcs
+
+ # for compass/ruler
+ global ed
+ set ed(system) $wcs(system)
+ set ed(sky) $wcs(sky)
+ AdjustCoordSystem ed system
+ set ed(dformat) $pmarker(dformat)
+
+ set cmd "$which marker create $marker(shape) $x $y"
+ switch -- $marker(shape) {
+ circle {append cmd " 0"}
+ annulus {append cmd " .001 .002 $pmarker(annulus,annuli)"}
+ panda {append cmd " $pmarker(panda,ang1) $pmarker(panda,ang2) $pmarker(panda,angnum) .001 .002 $pmarker(panda,annuli)"}
+ ellipse {append cmd " 0 0"}
+ ellipseannulus {append cmd " .001 .001 .002 $pmarker(ellipseannulus,annuli)"}
+ epanda {append cmd " $pmarker(epanda,ang1) $pmarker(epanda,ang2) $pmarker(epanda,angnum) .001 .001 .002 $pmarker(epanda,annuli)"}
+ box {append cmd " 0 0"}
+ boxannulus {append cmd " .002 .002 .004 $pmarker(boxannulus,annuli)"}
+ bpanda {append cmd " $pmarker(bpanda,ang1) $pmarker(bpanda,ang2) $pmarker(bpanda,angnum) .001 .001 .002 $pmarker(bpanda,annuli)"}
+ polygon {append cmd " .001 .001"}
+ line {append cmd " $x $y"}
+ vector {append cmd " $x $y"}
+ projection {append cmd " $x $y $pmarker(projection,thick) "}
+ segment {append cmd " .001 .001"}
+ text {
+ set txt "Region"
+ set r [EntryDialog "Text Region" "Enter Text:" 40 txt]
+ if {$r == 1 && $txt != {}} {
+ append cmd " 0 text = \{\{$txt\}\}"
+ } else {
+ return
+ }
+ }
+ ruler {append cmd " $x $y $ed(system) $ed(sky) $ed(system) $ed(dformat)"}
+ compass {append cmd " 15 $ed(system) $ed(sky) "}
+ {circle point} -
+ {box point} -
+ {diamond point} -
+ {cross point} -
+ {x point} -
+ {arrow point} -
+ {boxcircle point} {append cmd " $pmarker(point,size)"}
+ }
+ append cmd " color = $marker(color)"
+ append cmd " width = $marker(width)"
+ append cmd " font = \{\"$marker(font) $marker(font,size) $marker(font,weight) $marker(font,slant)\"\}"
+ append cmd " dash = $marker(dash)"
+ append cmd " fixed = $marker(fixed)"
+ append cmd " edit = $marker(edit)"
+ append cmd " move = $marker(move)"
+ append cmd " rotate = $marker(rotate)"
+ append cmd " delete = $marker(delete)"
+ append cmd " include = $marker(include)"
+ append cmd " source = $marker(source)"
+
+ $which marker unselect all
+
+ set imarker(id) [eval $cmd]
+ set imarker(motion) beginCreate
+ set imarker(x) $x
+ set imarker(y) $y
+
+ switch -- $marker(shape) {
+ circle -
+ annulus -
+ panda -
+ ellipse -
+ ellipseannulus -
+ epanda -
+ box -
+ boxannulus -
+ bpanda -
+ compass -
+ polygon -
+ segment {
+ set imarker(handle) 1
+ $which marker $imarker(id) edit begin $imarker(handle)
+ }
+ line -
+ vector -
+ ruler -
+ projection {
+ set imarker(handle) 2
+ $which marker $imarker(id) edit begin $imarker(handle)
+ }
+ }
+}
+
+proc MarkerDefault {which} {
+ global imarker
+ global pmarker
+ global current
+
+ # scale the default size to take into account the current
+ set z1 double([lindex $current(zoom) 0])
+ set z2 double([lindex $current(zoom) 1])
+ if {$z1>$z2} {
+ set zz $z1
+ } else {
+ set zz $z2
+ }
+
+ set item [$which get marker $imarker(id) type]
+ switch -- $item {
+ circle {
+ $which marker $imarker(id) circle radius \
+ [expr ($pmarker(circle,radius)/$zz)] \
+ image degrees
+ }
+ annulus {
+ $which marker $imarker(id) annulus radius \
+ [expr ($pmarker(annulus,inner)/$zz)] \
+ [expr ($pmarker(annulus,outer)/$zz)] \
+ $pmarker(annulus,annuli) image degrees
+ }
+ panda {
+ $which marker $imarker(id) panda edit \
+ $pmarker(panda,ang1) $pmarker(panda,ang2) \
+ $pmarker(panda,angnum) \
+ [expr ($pmarker(panda,inner)/$zz)] \
+ [expr ($pmarker(panda,outer)/$zz)] \
+ $pmarker(panda,annuli) image
+ }
+ ellipse {
+ $which marker $imarker(id) ellipse radius \
+ [expr ($pmarker(ellipse,radius1)/$z1)] \
+ [expr ($pmarker(ellipse,radius2)/$z2)] \
+ image degrees
+ }
+ ellipseannulus {
+ $which marker $imarker(id) ellipseannulus radius \
+ [expr ($pmarker(ellipseannulus,radius1)/$z1)] \
+ [expr ($pmarker(ellipseannulus,radius2)/$z2)] \
+ [expr ($pmarker(ellipseannulus,radius3)/$z1)] \
+ $pmarker(ellipseannulus,annuli) image
+ }
+ epanda {
+ $which marker $imarker(id) epanda edit \
+ $pmarker(epanda,ang1) $pmarker(epanda,ang2) \
+ $pmarker(epanda,angnum) \
+ [expr ($pmarker(epanda,radius1)/$z1)] \
+ [expr ($pmarker(epanda,radius2)/$z2)] \
+ [expr ($pmarker(epanda,radius3)/$z1)] \
+ $pmarker(epanda,annuli) image
+ }
+ box {
+ $which marker $imarker(id) box radius \
+ [expr ($pmarker(box,radius1)/$z1)] \
+ [expr ($pmarker(box,radius2)/$z2)] \
+ image degrees
+ }
+ boxannulus {
+ $which marker $imarker(id) boxannulus radius \
+ [expr ($pmarker(boxannulus,radius1)/$z1)] \
+ [expr ($pmarker(boxannulus,radius2)/$z2)] \
+ [expr ($pmarker(boxannulus,radius3)/$z1)] \
+ $pmarker(boxannulus,annuli) image
+ }
+ bpanda {
+ $which marker $imarker(id) bpanda edit \
+ $pmarker(bpanda,ang1) $pmarker(bpanda,ang2) \
+ $pmarker(bpanda,angnum) \
+ [expr ($pmarker(bpanda,radius1)/$z1)] \
+ [expr ($pmarker(bpanda,radius2)/$z2)] \
+ [expr ($pmarker(bpanda,radius3)/$z1)] \
+ $pmarker(bpanda,annuli) image
+ }
+ compass {
+ $which marker $imarker(id) compass radius \
+ $pmarker(compass,radius) image degrees
+ }
+ polygon {
+ $which marker $imarker(id) polygon reset \
+ [expr ($pmarker(polygon,width)/$z1)] \
+ [expr ($pmarker(polygon,height)/$z2)] \
+ image degrees
+ }
+ segment {
+ $which marker $imarker(id) segment reset \
+ [expr ($pmarker(segment,length)/$z1)] \
+ [expr ($pmarker(segment,length)/$z2)] \
+ image degrees
+ }
+ line -
+ vector -
+ ruler -
+ projection {
+ $which marker $imarker(id) delete
+ set imarker(id) -1
+ set imarker(x) -1
+ set imarker(y) -1
+ }
+ }
+}
+
+proc MarkerDeleteKey {which x y} {
+ # if nothing is loaded, abort
+ if {![$which has fits]} {
+ return
+ }
+
+ # see if we are on a polygon/segment
+ set h [$which get marker handle $x $y]
+ set id [lindex $h 0]
+ set handle [lindex $h 1]
+
+ set t [$which get marker $id type]
+ switch -- $t {
+ polygon -
+ segment -
+ annulus -
+ panda -
+ ellipseannulus -
+ epanda -
+ boxannulus -
+ bpanda {
+ if {$handle > 4} {
+ switch -- $t {
+ polygon {$which marker $id delete polygon vertex $handle}
+ segment {$which marker $id delete segment vertex $handle}
+ annulus {$which marker $id delete annulus $handle}
+ panda {$which marker $id delete panda $handle}
+ ellipseannulus {$which marker $id delete \
+ ellipseannulus $handle}
+ epanda {$which marker $id delete epanda $handle}
+ boxannulus {$which marker $id delete boxannulus $handle}
+ bpanda {$which marker $id delete bpanda $handle}
+ }
+ } else {
+ # delete polygon/segment
+ $which marker delete
+ UpdateGroupDialog
+ }
+ }
+ default {
+ # delete marker
+ $which marker delete
+ UpdateGroupDialog
+ }
+ }
+}
+
+proc MarkerEpsilon {} {
+ global ds9
+ global pmarker
+
+ foreach ff $ds9(frames) {
+ $ff marker epsilon $pmarker(epsilon)
+ }
+}
+
+proc MarkerShow {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker show $marker(show)
+ }
+}
+
+proc MarkerShowText {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker show text $marker(show,text)
+ }
+}
+
+proc MarkerPreserve {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker preserve $marker(preserve)
+ }
+}
+
+proc MarkerCentroid {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker centroid
+ }
+}
+
+proc MarkerCentroidAuto {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker centroid auto $marker(centroid,auto)
+ }
+}
+
+proc MarkerCentroidRadius {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker centroid radius $marker(centroid,radius)
+ }
+}
+
+proc MarkerCentroidIteration {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker centroid iteration $marker(centroid,iteration)
+ }
+}
+
+proc MarkerFront {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker move front
+ }
+}
+
+proc MarkerBack {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker move back
+ $current(frame) marker unselect all
+ }
+}
+
+proc MarkerSelectAll {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker select all
+ }
+
+ UpdateEditMenu
+}
+
+proc MarkerUnselectAll {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker unselect all
+ }
+
+ UpdateEditMenu
+}
+
+proc MarkerSelectInvert {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker select toggle
+ }
+
+ UpdateEditMenu
+}
+
+proc MarkerDeleteSelect {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker delete
+ UpdateGroupDialog
+ }
+
+ UpdateEditMenu
+}
+
+proc MarkerDeleteAllMenu {} {
+ global current
+ global pds9
+
+ if {$pds9(confirm)} {
+ if {[tk_messageBox -type okcancel -icon question -message [msgcat::mc {Delete All Regions?}]] != {ok}} {
+ return
+ }
+ }
+ MarkerDeleteAll
+}
+
+proc MarkerDeleteAll {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker delete all
+ UpdateGroupDialog
+ }
+
+ UpdateEditMenu
+}
+
+proc MarkerColor {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker color $marker(color)
+ }
+}
+
+proc MarkerWidth {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker width $marker(width)
+ }
+}
+
+proc MarkerProp {prop} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker property $prop $marker($prop)
+ }
+}
+
+proc MarkerFont {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ $current(frame) marker font \"$marker(font) $marker(font,size) $marker(font,weight) $marker(font,slant)\"
+ }
+}
+
+proc MarkerList {} {
+ global current
+ global marker
+
+ if {$current(frame) == {}} {
+ return
+ }
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {[MarkerSaveDialog [msgcat::mc {List Regions}]]} {
+ SimpleTextDialog markertxt [msgcat::mc {Region}] 80 20 insert top \
+ [$current(frame) marker list $marker(format) $marker(system) \
+ $marker(sky) $marker(skyformat) $marker(strip)]
+ }
+}
+
+proc MarkerLoad {} {
+ global ds9
+ global current
+ global marker
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ set fns [OpenFileDialog markerfbox]
+ if {$fns != {}} {
+ if {[MarkerLoadDialog]} {
+ switch -- $marker(load) {
+ current {set frames $current(frame)}
+ all {set frames $ds9(frames)}
+ }
+ MarkerLoadFrames $fns $frames \
+ $marker(format) $marker(system) $marker(sky)
+ }
+ }
+}
+
+proc MarkerLoadFrames {str frames format sys sky} {
+ if {$str == {}} {
+ return
+ }
+
+ if {[catch {glob $str} fns]} {
+ # reset errors, we don't want to hear about it
+ InitError tcl
+
+ # could be an unique name, i.e. foo[bar], just try to load
+ foreach fr $frames {
+ if {[catch {MarkerLoadFile $str $fr $format $sys $sky}]} {
+ return
+ }
+ }
+ } else {
+ foreach fn $fns {
+ foreach fr $frames {
+ if {[catch {MarkerLoadFile $fn $fr $format $sys $sky}]} {
+ return
+ }
+ }
+ }
+ }
+}
+
+proc MarkerLoadFile {filename which format sys sky} {
+ global current
+ global marker
+
+ if {$filename == {}} {
+ return
+ }
+
+ if {![$which has fits]} {
+ return
+ }
+
+ # determine if its a fits file
+ # first, strip the filename
+ if {![regexp -nocase {(.*)(\[.*\])} $filename foo base ext]} {
+ set base $filename
+ set ext {}
+ }
+
+ if {[catch {open $base} fd]} {
+ Error [msgcat::mc {Unable to load region file}]
+ return -code error
+ }
+
+ set ll [read $fd 9]
+ close $fd
+
+ # is it a fits file?
+ if {$ll == "SIMPLE ="} {
+ # see if we need to add an extension
+ if {$ext == {}} {
+ set filename "$base\[REGION\]"
+ }
+
+ # open it
+ if {[catch {$which marker load fits "\{$filename\}" $marker(color) $marker(dashlist) $marker(width) "\{$marker(font) $marker(font,size) $marker(font,weight) $marker(font,slant)\}"}]} {
+ if {$ext == {}} {
+ # ok now try the first extension
+ set filename "$base\[1\]"
+ if {[catch {$which marker load fits "\{$filename\}" $marker(color) $marker(dashlist) $marker(width) "\{$marker(font) $marker(font,size) $marker(font,weight) $marker(font,slant)\}"}]} {
+ Error [msgcat::mc {Unable to load region file}]
+ return -code error
+ }
+
+ # reset errors, we don't want to hear about it
+ InitError tcl
+ } else {
+ Error [msgcat::mc {Unable to load region file}]
+ return -code error
+ }
+ }
+ } else {
+ # no, its ascii
+ if {[catch {$which marker load $format "\{$filename\}" $sys $sky}]} {
+ Error [msgcat::mc {Unable to load region file}]
+ return -code error
+ }
+ }
+
+ FileLast markerfbox $filename
+ UpdateGroupDialog
+}
+
+proc MarkerSave {} {
+ global current
+ global marker
+
+ if {$current(frame) == {}} {
+ return
+ }
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ set filename [SaveFileDialog markerfbox]
+ if {$filename == {}} {
+ return
+ }
+
+ if {[MarkerSaveDialog [msgcat::mc {Save Regions}]]} {
+ $current(frame) marker save "\{$filename\}" \
+ $marker(format) $marker(system) $marker(sky) \
+ $marker(skyformat) $marker(strip)
+ }
+}
+
+proc MarkerInfo {} {
+ global current
+ global marker
+ global pds9
+
+ if {$current(frame) != {}} {
+ set ll [$current(frame) get marker select]
+ if {$ll != {}} {
+ set ii 0
+ foreach dd $ll {
+ incr ii
+ if {$ii > $marker(maxdialog)} {
+ return
+ }
+ MarkerDialog $current(frame) $dd
+ }
+ } else {
+ if {$pds9(confirm)} {
+ tk_messageBox -type ok -icon info -message [msgcat::mc {Please Select a Region}]
+ }
+ }
+ }
+}
+
+proc MarkerDialog {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set var(frame) $frame
+ set var(id) $id
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+
+ switch -- [$frame get marker $id type] {
+ circle {CircleDialog $varname}
+ annulus {AnnulusDialog $varname}
+ panda {PandaDialog $varname}
+ ellipse {EllipseDialog $varname}
+ ellipseannulus {EllipseAnnulusDialog $varname}
+ epanda {EpandaDialog $varname}
+ box {BoxDialog $varname}
+ boxannulus {BoxAnnulusDialog $varname}
+ bpanda {BpandaDialog $varname}
+ polygon {PolygonDialog $varname}
+ line {LineDialog $varname}
+ vector {VectorDialog $varname}
+ projection {ProjectionDialog $varname}
+ segment {SegmentDialog $varname}
+ text {TextDialog $varname}
+ ruler {RulerDialog $varname}
+ compass {CompassDialog $varname}
+ point {PointDialog $varname}
+ composite {CompositeDialog $varname}
+ }
+}
+
+proc MarkerCopy {} {
+ global current
+ global marker
+ global wcs
+
+ if {$current(frame) != {}} {
+ $current(frame) marker copy
+ set marker(copy) $current(frame)
+ set marker(copy,system) $wcs(system)
+ }
+ UpdateEditMenu
+}
+
+proc MarkerCut {} {
+ global current
+ global marker
+ global wcs
+
+ if {$current(frame) != {}} {
+ $current(frame) marker cut
+ set marker(copy) $current(frame)
+ set marker(copy,system) $wcs(system)
+ }
+ UpdateEditMenu
+ UpdateGroupDialog
+}
+
+proc MarkerUndo {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker undo
+ }
+ UpdateEditMenu
+ UpdateGroupDialog
+}
+
+proc MarkerPaste {} {
+ global current
+ global marker
+ global wcs
+
+ # if nothing is loaded, abort
+ if {$current(frame) == {}} {
+ return
+ }
+ if {$marker(copy) == {} || $marker(copy,system) == {}} {
+ return
+ }
+ if {(![$current(frame) has fits]) || (![$marker(copy) has fits])} {
+ return
+ }
+
+ # same frame?
+ if {$current(frame) == $marker(copy)} {
+ # use internal
+ $current(frame) marker paste
+ } else {
+ global cmd
+ # do we have a valid wcs?
+ if {[$marker(copy) has wcs $marker(copy,system)] &&
+ [$current(frame) has wcs $marker(copy,system)]} {
+
+ # do we have an equatorial wcs?
+ if {[$marker(copy) has wcs equatorial $marker(copy,system)] &&
+ [$current(frame) has wcs equatorial $marker(copy,system)]} {
+ # then use wcs
+ set cmd "[$marker(copy) marker paste $marker(copy,system)]"
+ } else {
+ # mix of equatorial and non-equatorial wcs, use physical
+ set cmd "[$marker(copy) marker paste physical]"
+ }
+ } else {
+ # default, use physical
+ set cmd "[$marker(copy) marker paste physical]"
+ }
+ $current(frame) marker command ds9 var cmd
+ unset cmd
+ }
+
+ UpdateEditMenu
+ UpdateGroupDialog
+}
+
+proc CompositeCreate {} {
+ global current
+ global marker
+
+ if {$current(frame) != {}} {
+ set cmd "$current(frame) marker create composite"
+ append cmd " color = $marker(color)"
+ append cmd " width = $marker(width)"
+ append cmd " font = \{\"$marker(font) $marker(font,size) $marker(font,weight) $marker(font,slant)\"\}"
+ append cmd " dash = $marker(dash)"
+ append cmd " edit = $marker(edit)"
+ append cmd " move = $marker(move)"
+ append cmd " rotate = $marker(rotate)"
+ append cmd " delete = $marker(delete)"
+ append cmd " fixed = $marker(fixed)"
+ append cmd " include = $marker(include)"
+ append cmd " source = $marker(source)"
+
+ eval $cmd
+ }
+}
+
+proc CompositeDelete {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) marker composite delete
+ }
+}
+
+proc MarkerBackup {ch which fdir rdir} {
+ if {[$which get marker number] > 0} {
+ set fn $fdir/ds9.reg
+ set rfn $rdir/ds9.reg
+
+ catch {file delete -force $fn}
+ if {[$which has wcs equatorial wcs]} {
+ $which marker save \"$fn\" ds9 wcs fk5 degrees 0
+ } else {
+ $which marker save \"$fn\" ds9 physical fk5 degrees 0
+ }
+ puts $ch "$which marker load ds9 \{\"$rfn\"\}"
+ }
+}
+
+# Process Cmds
+
+proc ProcessRegionsCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ global current
+ global marker
+ global pmarker
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ epsilon {
+ incr i
+ set pmarker(epsilon) [lindex $var $i]
+ MarkerEpsilon
+ }
+ show {
+ incr i
+ set marker(show) [FromYesNo [lindex $var $i]]
+ MarkerShow
+ }
+ showtext {
+ incr i
+ set marker(show,text) [FromYesNo [lindex $var $i]]
+ MarkerShowText
+ }
+ getinfo {MarkerInfo}
+ centroid {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ auto {
+ incr i
+ set marker(centroid,auto) [FromYesNo [lindex $var $i]]
+ MarkerCentroidAuto
+ }
+ radius {
+ incr i
+ set marker(centroid,radius) [lindex $var $i]
+ MarkerCentroidRadius
+ }
+ iteration {
+ incr i
+ set marker(centroid,iteration) [lindex $var $i]
+ MarkerCentroidIteration
+ }
+ default {
+ incr i -1
+ MarkerCentroid
+ }
+ }
+ }
+ autocentroid {
+ # backward compatibilty
+ incr i
+ set marker(centroid,auto) [FromYesNo [lindex $var $i]]
+ MarkerCentroidAuto
+ }
+ movefront {MarkerFront}
+ moveback {MarkerBack}
+ move {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ front {MarkerFront}
+ back {MarkerBack}
+ }
+ }
+
+ selectall {MarkerSelectAll}
+ selectnone {MarkerUnselectAll}
+ select {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ group {
+ # backward compatibility, use group <> select
+ incr i
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker "\{[lindex $var $i]\}" select
+ }
+ }
+ }
+ all {MarkerSelectAll}
+ none {MarkerUnselectAll}
+ invert {MarkerSelectInvert}
+ }
+ }
+
+ deleteall {MarkerDeleteAll}
+ delete {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ select {MarkerDeleteSelect}
+ all {MarkerDeleteAll}
+ }
+ }
+
+ format {
+ incr i
+ set marker(format) [string tolower [lindex $var $i]]
+ }
+ coord -
+ system {
+ # for backward compatibility
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {
+ incr i
+ set marker(system) wcs
+ set marker(sky) [string tolower [lindex $var $i]]
+ }
+
+ default {set marker(system) [string tolower [lindex $var $i]]}
+ }
+ }
+ sky {
+ incr i
+ set marker(sky) [string tolower [lindex $var $i]]
+ }
+ coordformat -
+ skyformat {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ deg -
+ degree -
+ degrees {set marker(skyformat) degrees}
+ default {
+ set marker(skyformat) [string tolower [lindex $var $i]]
+ }
+ }
+ }
+ strip {
+ incr i
+ set marker(strip) [FromYesNo [lindex $var $i]]
+ }
+ delim {
+ incr i
+ if {[lindex $var $i] != "nl"} {
+ set marker(strip) 1
+ } else {
+ set marker(strip) 0
+ }
+ }
+ shape {
+ incr i
+ set marker(shape) [string tolower [lindex $var $i]]
+ }
+ color {
+ incr i
+ set marker(color) [string tolower [lindex $var $i]]
+ MarkerColor
+ }
+ width {
+ incr i
+ set marker(width) [lindex $var $i]
+ MarkerWidth
+ }
+
+ fixed {
+ incr i
+ set marker(fixed) [FromYesNo [lindex $var $i]]
+ MarkerProp fixed
+ }
+ edit {
+ incr i
+ set marker(edit) [FromYesNo [lindex $var $i]]
+ MarkerProp edit
+ }
+ rotate {
+ incr i
+ set marker(rotate) [FromYesNo [lindex $var $i]]
+ MarkerProp rotate
+ }
+ delete {
+ incr i
+ set marker(delete) [FromYesNo [lindex $var $i]]
+ MarkerProp delete
+ }
+ include {
+ set marker(include) 1
+ MarkerProp include
+ }
+ exclude {
+ set marker(include) 0
+ MarkerProp include
+ }
+ source {
+ set marker(source) 1
+ MarkerProp source
+ }
+ background {
+ set marker(source) 0
+ MarkerProp source
+ }
+
+ tag -
+ tags -
+ group -
+ groups {
+ incr i
+
+ if {[string tolower [lindex $var $i]] == {new}} {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ set name [$current(frame) get marker tag default name]
+ $current(frame) marker tag "\{$name\}"
+ UpdateGroupDialog
+ }
+ }
+ } else {
+ set tag "\{[lindex $var $i]\}"
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker tag $tag
+ UpdateGroupDialog
+ }
+ }
+ }
+ update {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker tag update $tag
+ UpdateGroupDialog
+ }
+ }
+ }
+ delete {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag delete
+ UpdateGroupDialog
+ }
+ }
+ }
+ select {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag select
+ }
+ }
+ }
+ color {
+ incr i
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag color \
+ [string tolower [lindex $var $i]]
+ }
+ }
+ }
+ copy {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag copy
+ }
+ }
+ }
+ cut {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag cut
+ }
+ }
+ }
+ font {
+ incr i
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag font \
+ "\{[lindex $var $i]\}"
+ }
+ }
+ }
+ move {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag move \
+ [lindex $var [expr $i+1]] \
+ [lindex $var [expr $i+2]]
+ }
+ }
+ incr i 2
+ }
+ movefront {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag move front
+ }
+ }
+ }
+ moveback {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag move back
+ }
+ }
+ }
+ property {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker $tag property \
+ [lindex $var [expr $i+1]] \
+ [lindex $var [expr $i+2]]
+ }
+ }
+ incr i 2
+ }
+ }
+ }
+ }
+
+ copy {MarkerCopy}
+ cut {MarkerCut}
+ paste {
+ set marker(paste,system) [string tolower [lindex $var [expr $i+1]]]
+ switch -- $marker(paste,system) {
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {}
+ default {set marker(paste,system) wcs}
+ }
+
+# backward compatibility
+ if {[string range [lindex $var [expr $i+2]] 0 0] == {-}} {
+ incr i 1
+ } else {
+ incr i 2
+ }
+
+ MarkerPaste
+ }
+ undo {MarkerUndo}
+
+ composite {CompositeCreate}
+ desolve -
+ dissove {CompositeDelete}
+
+ template {
+ incr i
+ set ff [lindex $var $i]
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ at {
+ incr i
+ set ra [lindex $var $i]
+ incr i
+ set dec [lindex $var $i]
+ incr i
+ set sys [string tolower [lindex $var $i]]
+ incr i
+ set sky [string tolower [lindex $var $i]]
+ switch -- $sys {
+ fk4 -
+ fk5 -
+ icrs -
+ galatic -
+ ecliptic {
+ set sky $sys
+ set sys wcs
+ incr i -1
+ }
+ }
+ LoadTemplateMarkerAt $ff $ra $dec $sys $sky
+ FileLast templatefbox $ff
+ }
+ default {
+ LoadTemplateMarker $ff
+ FileLast templatefbox $ff
+ incr i -1
+ }
+ }
+ }
+ savetemplate {
+ incr i
+ set ff [lindex $var $i]
+ if {$ff != {}} {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker save template "\{$ff\}"
+ }
+ }
+ FileLast templatefbox $ff
+ }
+ }
+
+ command {
+ incr i
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker command $marker(format) \
+ "\{[lindex $var $i]\}"
+ }
+ }
+ UpdateGroupDialog
+ }
+
+ list {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ close {SimpleTextDestroy markertxt}
+ default {
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ SimpleTextDialog markertxt [msgcat::mc {Region}] \
+ 80 20 insert top \
+ [$current(frame) marker list $marker(format) \
+ $marker(system) $marker(sky) \
+ $marker(skyformat) $marker(strip)]
+ }
+ }
+ incr i -1
+ }
+ }
+ }
+ save {
+ incr i
+ set ff [lindex $var $i]
+ if {$ff == {}} {
+ return
+ }
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker save "\{$ff\}" \
+ $marker(format) $marker(system) $marker(sky) \
+ $marker(skyformat) $marker(strip)
+ }
+ }
+ FileLast markerfbox $ff
+ }
+
+ file -
+ load {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ all {
+ incr i
+ set frames $ds9(frames)
+ }
+ default {
+ set frames $current(frame)
+ }
+ }
+ MarkerLoadFrames [lindex $var $i] $frames \
+ $marker(format) $marker(system) $marker(sky)
+ }
+ default {
+ set format $marker(format)
+ set sys $marker(system)
+ set sky $marker(sky)
+
+ while {[string range [lindex $var $i] 0 0] == "-"} {
+ switch -- [string tolower [lindex $var $i]] {
+ -format {
+ incr i
+ set format [lindex $var $i]
+ }
+ -sys -
+ -coord -
+ -system {
+ incr i
+ # for backward compatibility
+ switch -- [lindex $var $i] {
+ fk4 -
+ fk5 -
+ icrs -
+ galactic -
+ ecliptic {
+ set sys wcs
+ set sky [lindex $var $i]
+ }
+ default {
+ set sys [lindex $var $i]
+ }
+ }
+ }
+ -sky {
+ incr i
+ set sky [lindex $var $i]
+ }
+ default {
+ Error "Illegal option: [lindex $var $i]"
+ return
+ }
+ }
+ incr i
+ }
+
+ if {$sock != {}} {
+ # xpa path
+ if {[lindex $var $i] != {}} {
+ MarkerLoadFrames [lindex $var $i] $current(frame) \
+ $format $sys $sky
+ } else {
+ # fits regions files not supported
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $current(frame) marker load $format $sock $sys $sky
+ }
+ }
+ UpdateGroupDialog
+ }
+ } elseif {$fn != {}} {
+ # samp path
+ if {[lindex $var $i] != {}} {
+ MarkerLoadFrames [lindex $var $i] $current(frame) \
+ $format $sys $sky
+ } else {
+ MarkerLoadFrames $fn $current(frame) \
+ $format $sys $sky
+ }
+ } else {
+ # this will open a fits regions file
+ MarkerLoadFrames [lindex $var $i] $current(frame) \
+ $format $sys $sky
+ }
+ }
+ }
+}
+
+proc ProcessSendRegionsCmd {proc id param sock fn} {
+ global current
+ global marker
+ global pmarker
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ switch -- [lindex $param 0] {
+ epsilon {$proc $id "$pmarker(epsilon)\n"}
+ show {$proc $id [ToYesNo $marker(show)]}
+ showtext {$proc $id [ToYesNo $marker(show,text)]}
+ centroid {
+ switch -- [lindex $param 1] {
+ auto {$proc $id [ToYesNo $marker(centroid,auto)]}
+ radius {$proc $id "$marker(centroid,radius)\n"}
+ iteration {$proc $id "$marker(centroid,iteration)\n"}
+ }
+ }
+ autocentroid {$proc $id [ToYesNo $marker(centroid,auto)]}
+ format {$proc $id "$marker(format)\n"}
+ coord -
+ system {$proc $id "$marker(system)\n"}
+ sky {$proc $id "$marker(sky)\n"}
+ coordformat -
+ skyformat {$proc $id "$marker(skyformat)\n"}
+ strip {$proc $id [ToYesNo $marker(strip)]}
+ delim {
+ if {$marker(strip)} {
+ $proc $id "semicolon\n"
+ } else {
+ $proc $id "nl\n"
+ }
+ }
+ shape {$proc $id "$marker(shape)\n"}
+ color {$proc $id "$marker(color)\n"}
+ width {$proc $id "$marker(width)\n"}
+
+ tag -
+ tags -
+ group -
+ groups {$proc $id "[lsort [$current(frame) get marker tag all]]\n"}
+
+ default {
+ set format $marker(format)
+ set sys $marker(system)
+ set sky $marker(sky)
+ set skyformat $marker(skyformat)
+ set strip $marker(strip)
+ set select {}
+ set props {}
+ set tags {}
+
+ set i 0
+ set l [llength $param]
+ while {$i < $l} {
+ switch -- [lindex $param $i] {
+ -format {incr i; set format [lindex $param $i]}
+ -sys -
+ -coord -
+ -system {
+ incr i
+ # for backward compatibility
+ switch -- [lindex $param $i] {
+ fk4 -
+ fk5 -
+ icrs -
+ galactic -
+ ecliptic {
+ set sys wcs
+ set sky [lindex $param $i]
+ }
+
+ default {set sys [lindex $param $i]}
+ }
+ }
+ -sky {incr i; set sky [lindex $param $i]}
+ -coordformat -
+ -skyformat {
+ incr i
+ switch -- [lindex $param $i] {
+ deg -
+ degree -
+ degrees {set skyformat degrees}
+ default {set skyformat [lindex $param $i]}
+ }
+ }
+ -strip {
+ incr i;
+ set strip [FromYesNo [lindex $param $i]]
+ }
+ -delim {
+ incr i;
+ if {[lindex $param $i] != "nl"} {
+ set strip 1
+ } else {
+ set strip 0
+ }
+ }
+
+ include {append props " include = 1"}
+ exclude {append props " include = 0"}
+ source {append props " source = 1"}
+ background {append props " source = 0"}
+ selected {set select "select"}
+ -prop {
+ append props " [lindex $param [expr $i+1]] = [lindex $param [expr $i+2]]"
+ incr i 2
+ }
+ -tag -
+ -group {
+ incr i
+ append tags "tag = \{[lindex $param $i]\}"
+ }
+ }
+ incr i
+ }
+
+ switch -- $format {
+ xml {set ext {.xml}}
+ default {set ext {.rgn}}
+ }
+ ProcessSend $proc $id $sock $fn $ext \
+ [$current(frame) marker list $select $format \
+ $sys $sky $skyformat $strip $props $tags]
+ }
+ }
+}
diff --git a/ds9/library/markeranalysishist.tcl b/ds9/library/markeranalysishist.tcl
new file mode 100644
index 0000000..4e3032d
--- /dev/null
+++ b/ds9/library/markeranalysishist.tcl
@@ -0,0 +1,116 @@
+# 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 MarkerAnalysisHistogramDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set id $var(id)
+ set frame $var(frame)
+
+ set vvarname ${imarker(prefix,histogram)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set var(histogram) [info exists ${vvarname}(top)]
+
+ $var(mb).analysis add checkbutton -label [msgcat::mc {Histogram}] \
+ -variable ${varname}(histogram) \
+ -command "MarkerAnalysisHistogramCmd $varname"
+}
+
+# support
+
+proc MarkerAnalysisHistogramCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerAnalysisHistogram $var(frame) $var(id) $var(histogram)
+}
+
+proc MarkerAnalysisHistogram {frame id plot} {
+ global imarker
+
+ $frame marker $id analysis histogram $plot
+ if {$plot} {
+ MarkerAnalysisHistogramCB $frame $id
+
+ set vvarname ${imarker(prefix,histogram)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ PlotRaise $vvarname
+ } else {
+ MarkerAnalysisHistogramDeleteCB $frame $id
+ }
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisHistogramCB {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname ${imarker(prefix,histogram)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(frame) $frame
+ set vvar(id) $id
+ set vvar(nbins) 512
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ global $xdata $ydata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ set tt [string totitle [$frame get marker $id type]]
+ PlotLineDialog $vvarname $tt Histogram Values Counts
+
+ set vvar(manage) 0
+ set vvar(dim) xy
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ blt::vector create $xdata $ydata
+ }
+
+ $frame get marker $id analysis histogram $xdata $ydata $vvar(nbins)
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ set vvar(smooth) step
+ set vvar(fill) 1
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisHistogramDeleteCB {frame id} {
+ # this routine could be called by the region
+ # after the dialog has been deleted
+
+ global imarker
+
+ set vvarname ${imarker(prefix,histogram)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ # clear any errors
+ global errorInfo
+ set errorInfo {}
+
+ PlotDestroy $vvarname
+}
diff --git a/ds9/library/markeranalysispanda.tcl b/ds9/library/markeranalysispanda.tcl
new file mode 100644
index 0000000..9a726f0
--- /dev/null
+++ b/ds9/library/markeranalysispanda.tcl
@@ -0,0 +1,160 @@
+# 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 MarkerAnalysisPandaDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set id $var(id)
+ set frame $var(frame)
+
+ set vvarname ${imarker(prefix,panda)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set var(panda) [info exists ${vvarname}(top)]
+
+ $var(mb).analysis add checkbutton -label [msgcat::mc {Radial Profile}] \
+ -variable ${varname}(panda) \
+ -command "MarkerAnalysisPandaCmd $varname"
+}
+
+proc MarkerAnalysisPandaCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerAnalysisPanda $var(frame) $var(id) $var(panda)
+}
+
+proc MarkerAnalysisPanda {frame id panda} {
+ global imarker
+
+ $frame marker $id analysis panda $panda
+ if {$panda} {
+ MarkerAnalysisPandaCB $frame $id
+
+ set vvarname ${imarker(prefix,panda)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ PlotRaise $vvarname
+ } else {
+ MarkerAnalysisPandaDeleteCB $frame $id
+ }
+}
+
+proc MarkerAnalysisPandaSystem {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,panda)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(panda)]} {
+ if {$var(panda)} {
+ MarkerAnalysisPandaCB $var(frame) $var(id)
+ MarkerAnalysisPandaAxisTitle $vvarname
+ }
+ }
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisPandaCB {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname ${imarker(prefix,panda)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(frame) $frame
+ set vvar(id) $id
+
+ if {[info exists var(system)]} {
+ set vvar(system) $var(system)
+ set sys $var(system)
+ } elseif {[info exists vvar(system)]} {
+ set sys $vvar(system)
+ } else {
+ global wcs
+ set vvar(system) $wcs(system)
+ set sys $wcs(system)
+ }
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ set tt [string totitle [$frame get marker $id type]]
+ PlotLineDialog $vvarname $tt "Radial Profile" $sys {}
+ MarkerAnalysisPandaAxisTitle $vvarname
+ }
+
+ PlotClearData $vvarname
+ PlotDataSet $vvarname 3 [$frame get marker $id analysis panda $sys]
+ $vvar(proc,updategraph) $vvarname
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc MarkerAnalysisPandaDeleteCB {frame id} {
+ # this routine could be called by the region
+ # after the dialog has been deleted
+
+ global imarker
+
+ set vvarname ${imarker(prefix,panda)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ # clear any errors
+ global errorInfo
+ set errorInfo {}
+
+ PlotDestroy $vvarname
+}
+
+proc MarkerAnalysisPandaAxisTitle {vvarname} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ switch -- $vvar(system) {
+ image -
+ physical -
+ amplifier -
+ detector {
+ set xtitle "Avg Radius (pixels)"
+ set ytitle "Surface Brightness (cnts/pixels**2)"
+ }
+ default {
+ if {[$vvar(frame) has wcs equatorial $vvar(system)]} {
+ set xtitle "Avg Radius (arcsecs)"
+ set ytitle "Surface Brightness (cnts/arcsec**2)"
+ } else {
+ set xtitle "Avg Radius (pixels)"
+ set ytitle "Surface Brightness (cnts/pixels**2)"
+ }
+ }
+ }
+
+ # set for plot code
+ set vvar(axis,x,title) $xtitle
+ set vvar(axis,y,title) $ytitle
+
+ # update now (may not make it into plot code)
+ $vvar(graph) xaxis configure -title $xtitle
+ $vvar(graph) yaxis configure -title $ytitle
+}
diff --git a/ds9/library/markeranalysisplot2d.tcl b/ds9/library/markeranalysisplot2d.tcl
new file mode 100644
index 0000000..615f416
--- /dev/null
+++ b/ds9/library/markeranalysisplot2d.tcl
@@ -0,0 +1,273 @@
+# 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
+
+# support
+
+proc MarkerAnalysisPlot2dDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set id $var(id)
+ set frame $var(frame)
+
+ set vvarname ${imarker(prefix,plot2d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set var(plot2d) [info exists ${vvarname}(top)]
+ set var(method) average
+
+ $var(mb).analysis add checkbutton -label [msgcat::mc {Plot 2D}] \
+ -variable ${varname}(plot2d) \
+ -command "MarkerAnalysisPlot2dCmd $varname"
+ $var(mb).analysis add separator
+ $var(mb).analysis add cascade \
+ -label [msgcat::mc {Method}] \
+ -menu $var(mb).analysis.method
+
+ menu $var(mb).analysis.method
+ $var(mb).analysis.method add radiobutton \
+ -label [msgcat::mc {Average}] \
+ -variable ${varname}(method) -value average \
+ -command "MarkerAnalysisPlot2dMethod $varname"
+ $var(mb).analysis.method add radiobutton \
+ -label [msgcat::mc {Sum}] \
+ -variable ${varname}(method) -value sum \
+ -command "MarkerAnalysisPlot2dMethod $varname"
+}
+
+proc MarkerAnalysisPlot2dCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerAnalysisPlot2d $var(frame) $var(id) $var(plot2d)
+}
+
+proc MarkerAnalysisPlot2d {frame id plot} {
+ global imarker
+
+ $frame marker $id analysis plot2d $plot
+ if {$plot} {
+ MarkerAnalysisPlot2dCB $frame $id
+
+ set vvarname ${imarker(prefix,plot2d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ PlotRaise $vvarname
+ } else {
+ MarkerAnalysisPlot2dDeleteCB $frame $id
+ }
+}
+
+proc MarkerAnalysisPlot2dMethod {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,plot2d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(plot2d)]} {
+ if {$var(plot2d)} {
+ MarkerAnalysisPlot2dCB $var(frame) $var(id)
+ MarkerAnalysisPlot2dYAxisTitle $vvarname
+ }
+ }
+}
+
+proc MarkerAnalysisPlot2dSystem {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,plot2d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(plot2d)]} {
+ if {$var(plot2d)} {
+ MarkerAnalysisPlot2dCB $var(frame) $var(id)
+ MarkerAnalysisPlot2dXAxisTitle $vvarname
+ }
+ }
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisPlot2dCB {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname ${imarker(prefix,plot2d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(frame) $frame
+ set vvar(id) $id
+
+ if {[info exists var(system)]} {
+ set vvar(system) $var(system)
+ set sys $var(system)
+ } elseif {[info exists vvar(system)]} {
+ set sys $vvar(system)
+ } else {
+ global wcs
+ set vvar(system) $wcs(system)
+ set sys $wcs(system)
+ }
+
+ if {[info exists var(sky)]} {
+ set vvar(sky) $var(sky)
+ set sky $var(sky)
+ } elseif {[info exists vvar(sky)]} {
+ set sky $vvar(sky)
+ } else {
+ global wcs
+ set sky $wcs(sky)
+ }
+
+ if {[info exists var(method)]} {
+ set vvar(method) $var(method)
+ set method $var(method)
+ } elseif {[info exists vvar(method)]} {
+ set method $vvar(method)
+ } else {
+ set vvar(method) average
+ set method average
+ }
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ set xcdata ${vvarname}xc
+ set ycdata ${vvarname}yc
+ global $xdata $ydata $xcdata $ycdata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ set tt [string totitle [$frame get marker $id type]]
+ PlotLineDialog $vvarname $tt Plot2D $sys Counts
+ MarkerAnalysisPlot2dXAxisTitle $vvarname
+ MarkerAnalysisPlot2dYAxisTitle $vvarname
+
+ # setup our own formatting
+ set vvar(graph,format) 0
+ set vvar(xcdata) $xcdata
+ set vvar(ycdata) $ycdata
+ $vvar(graph) xaxis configure \
+ -command "MarkerAnalysisPlot2dXAxis $vvarname"
+
+ set vvar(manage) 0
+ set vvar(dim) xy
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ blt::vector create $xdata $ydata $xcdata $ycdata
+ }
+
+ $frame get marker $id analysis plot2d $xdata $ydata $xcdata $ycdata \
+ $sys $sky $method
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc MarkerAnalysisPlot2dDeleteCB {frame id} {
+ # this routine could be called by the region
+ # after the dialog has been deleted
+
+ global imarker
+
+ set vvarname ${imarker(prefix,plot2d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set xcdata ${vvarname}xc
+ set ycdata ${vvarname}yc
+
+ # clear extra vectors
+ global $xcdata $ycdata
+ catch {blt::vector destroy $xcdata $ycdata}
+
+ # clear any errors
+ global errorInfo
+ set errorInfo {}
+
+ PlotDestroy $vvarname
+}
+
+proc MarkerAnalysisPlot2dXAxisTitle {vvarname} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ switch -- $vvar(system) {
+ image -
+ physical -
+ amplifier -
+ detector {set xtitle "$vvar(system)"}
+ default {
+ if {[$vvar(frame) has wcs equatorial $vvar(system)]} {
+ set xtitle "$vvar(system)"
+ } else {
+ set xtitle "[$vvar(frame) get wcs name $vvar(system)]"
+ }
+ }
+ }
+
+ # set for plot code
+ set vvar(axis,x,title) $xtitle
+
+ # update now (may not make it into plot code)
+ $vvar(graph) xaxis configure -title $xtitle
+}
+
+proc MarkerAnalysisPlot2dYAxisTitle {vvarname} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ # set for plot code
+ set vvar(axis,y,title) "Counts [string totitle $vvar(method)]"
+
+ # update now (may not make it into plot code)
+ $vvar(graph) yaxis configure -title $vvar(axis,y,title)
+}
+
+proc MarkerAnalysisPlot2dXAxis {vvarname w xx} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set x [expr $xx-1]
+
+ global $vvar(xcdata) $vvar(ycdata)
+ # sometimes, $x equals $vvar(xcdata) length
+ set ll [$vvar(xcdata) length]
+ if {($ll>=1) && ($x>=0) && ($x<$ll)} {
+ set a [format "%6.3f" [expr "$$vvar(xcdata)\($x\)"]]
+ set b [format "%6.3f" [expr "$$vvar(ycdata)\($x\)"]]
+ return "$a\n$b"
+ } else {
+ return {}
+ }
+}
diff --git a/ds9/library/markeranalysisplot3d.tcl b/ds9/library/markeranalysisplot3d.tcl
new file mode 100644
index 0000000..1e9263a
--- /dev/null
+++ b/ds9/library/markeranalysisplot3d.tcl
@@ -0,0 +1,231 @@
+# 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 MarkerAnalysisPlot3dDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set id $var(id)
+ set frame $var(frame)
+
+ set vvarname ${imarker(prefix,plot3d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set var(plot3d) [info exists ${vvarname}(top)]
+ set var(method) average
+
+ $var(mb).analysis add checkbutton -label [msgcat::mc {Plot 3D}] \
+ -variable ${varname}(plot3d) \
+ -command "MarkerAnalysisPlot3dCmd $varname"
+ $var(mb).analysis add separator
+ $var(mb).analysis add cascade \
+ -label [msgcat::mc {Method}] \
+ -menu $var(mb).analysis.method
+
+ menu $var(mb).analysis.method
+ $var(mb).analysis.method add radiobutton \
+ -label [msgcat::mc {Average}] \
+ -variable ${varname}(method) -value average \
+ -command "MarkerAnalysisPlot3dMethod $varname"
+ $var(mb).analysis.method add radiobutton \
+ -label [msgcat::mc {Sum}] \
+ -variable ${varname}(method) -value sum \
+ -command "MarkerAnalysisPlot3dMethod $varname"
+}
+
+# support
+
+proc MarkerAnalysisPlot3dCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerAnalysisPlot3d $var(frame) $var(id) $var(plot3d)
+}
+
+proc MarkerAnalysisPlot3d {frame id plot} {
+ global imarker
+
+ $frame marker $id analysis plot3d $plot
+ if {$plot} {
+ MarkerAnalysisPlot3dCB $frame $id
+
+ set vvarname ${imarker(prefix,plot3d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ PlotRaise $vvarname
+ } else {
+ MarkerAnalysisPlot3dDeleteCB $frame $id
+ }
+}
+
+proc MarkerAnalysisPlot3dMethod {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,plot3d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(plot3d)]} {
+ if {$var(plot3d)} {
+ MarkerAnalysisPlot3dCB $frame $id
+ MarkerAnalysisPlot3dYAxisTitle $vvarname
+ }
+ }
+}
+
+proc MarkerAnalysisPlot3dSystem {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,plot3d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(plot3d)]} {
+ if {$var(plot3d)} {
+ MarkerAnalysisPlot3dCB $frame $id
+ MarkerAnalysisPlot3dXAxisTitle $vvarname
+ }
+ }
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisPlot3dCB {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname ${imarker(prefix,plot3d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(frame) $frame
+ set vvar(id) $id
+
+ if {[info exists var(system)]} {
+ set vvar(system) $var(system)
+ set sys $var(system)
+ } elseif {[info exists vvar(system)]} {
+ set sys $vvar(system)
+ } else {
+ global wcs
+ set vvar(system) $wcs(system)
+ set sys $wcs(system)
+ }
+
+ if {[info exists var(method)]} {
+ set vvar(method) $var(method)
+ set method $var(method)
+ } elseif {[info exists vvar(method)]} {
+ set method $vvar(method)
+ } else {
+ set vvar(method) average
+ set method average
+ }
+
+ set xdata ${vvarname}x
+ set ydata ${vvarname}y
+ global $xdata $ydata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ set tt [string totitle [$frame get marker $id type]]
+ PlotLineDialog $vvarname $tt Plot3D $sys Counts
+ MarkerAnalysisPlot3dXAxisTitle $vvarname
+ MarkerAnalysisPlot3dYAxisTitle $vvarname
+
+ set vvar(manage) 0
+ set vvar(dim) xy
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ blt::vector create $xdata $ydata
+ }
+
+ $frame get marker $id analysis plot3d $xdata $ydata $sys $method
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisPlot3dDeleteCB {frame id} {
+ # this routine could be called by the region
+ # after the dialog has been deleted
+
+ global imarker
+
+ set vvarname ${imarker(prefix,plot3d)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ # clear any errors
+ global errorInfo
+ set errorInfo {}
+
+ PlotDestroy $vvarname
+}
+
+proc MarkerAnalysisPlot3dXAxisTitle {vvarname} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ switch -- $vvar(system) {
+ image -
+ physical -
+ amplifier -
+ detector {set xtitle "$vvar(system)"}
+ default {
+ set w [string range $vvar(system) 3 3]
+ set tt [string trim [$vvar(frame) get fits header keyword \{CTYPE3$w\}]]
+ if {$tt != {}} {
+ set xtitle "$tt"
+ } else {
+ set xtitle "$vvar(system)"
+ }
+ }
+ }
+
+ # set for plot code
+ set vvar(axis,x,title) $xtitle
+
+ # update now (may not make it into plot code)
+ $vvar(graph) xaxis configure -title $xtitle
+}
+
+proc MarkerAnalysisPlot3dYAxisTitle {vvarname} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ # set for plot code
+ set vvar(axis,y,title) "Counts [string totitle $vvar(method)]"
+
+ # update now (may not make it into plot code)
+ $vvar(graph) yaxis configure -title $vvar(axis,y,title)
+}
diff --git a/ds9/library/markeranalysisradial.tcl b/ds9/library/markeranalysisradial.tcl
new file mode 100644
index 0000000..7eb2f3d
--- /dev/null
+++ b/ds9/library/markeranalysisradial.tcl
@@ -0,0 +1,177 @@
+# 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 MarkerAnalysisRadialDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set id $var(id)
+ set frame $var(frame)
+
+ set vvarname ${imarker(prefix,radial)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set var(radial) [info exists ${vvarname}(top)]
+
+ $var(mb).analysis add checkbutton -label [msgcat::mc {Radial Profile}] \
+ -variable ${varname}(radial) \
+ -command "MarkerAnalysisRadialCmd $varname"
+}
+
+proc MarkerAnalysisRadialCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerAnalysisRadial $var(frame) $var(id) $var(radial)
+}
+
+proc MarkerAnalysisRadial {frame id radial} {
+ global imarker
+
+ $frame marker $id analysis radial $radial
+ if {$radial} {
+ MarkerAnalysisRadialCB $frame $id
+
+ set vvarname ${imarker(prefix,radial)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ PlotRaise $vvarname
+ } else {
+ MarkerAnalysisRadialDeleteCB $frame $id
+ }
+}
+
+proc MarkerAnalysisRadialSystem {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,radial)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(radial)]} {
+ if {$var(radial)} {
+ MarkerAnalysisRadialCB $var(frame) $var(id)
+ MarkerAnalysisRadialAxisTitle $vvarname
+ }
+ }
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisRadialCB {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname ${imarker(prefix,radial)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set vvar(frame) $frame
+ set vvar(id) $id
+
+ if {[info exists var(system)]} {
+ set vvar(system) $var(system)
+ set sys $var(system)
+ } elseif {[info exists vvar(system)]} {
+ set sys $vvar(system)
+ } else {
+ global wcs
+ set vvar(system) $wcs(system)
+ set sys $wcs(system)
+ }
+
+ set xdata ${imarker(prefix,radial)}${id}${frame}x
+ set ydata ${imarker(prefix,radial)}${id}${frame}y
+ set yedata ${imarker(prefix,radial)}${id}${frame}ye
+ global $xdata $ydata $yedata
+
+ set ping [PlotPing $vvarname]
+
+ if {!$ping} {
+ set tt [string totitle [$frame get marker $id type]]
+ PlotLineDialog $vvarname $tt "Radial Profile" $sys {}
+ MarkerAnalysisRadialAxisTitle $vvarname
+
+ set vvar(manage) 0
+ set vvar(dim) xyey
+ set vvar(xdata) $xdata
+ set vvar(ydata) $ydata
+ set vvar(yedata) $yedata
+ blt::vector create $xdata $ydata $yedata
+ }
+
+ $frame get marker $id analysis radial $xdata $ydata $yedata $sys
+
+ if {!$ping} {
+ PlotExternal $vvarname
+ $vvar(proc,updateelement) $vvarname
+ $vvar(proc,updategraph) $vvarname
+ }
+
+ PlotStats $vvarname
+ PlotList $vvarname
+}
+
+proc MarkerAnalysisRadialDeleteCB {frame id} {
+ # this routine could be called by the region
+ # after the dialog has been deleted
+
+ global imarker
+
+ set vvarname ${imarker(prefix,radial)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ # clear any errors
+ global errorInfo
+ set errorInfo {}
+
+ PlotDestroy $vvarname
+}
+
+proc MarkerAnalysisRadialAxisTitle {vvarname} {
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ switch -- $vvar(system) {
+ image -
+ physical -
+ amplifier -
+ detector {
+ set xtitle "Avg Radius (pixels)"
+ set ytitle "Surface Brightness (cnts/pixels**2)"
+ }
+ default {
+ if {[$vvar(frame) has wcs equatorial $vvar(system)]} {
+ set xtitle "Avg Radius (arcsecs)"
+ set ytitle "Surface Brightness (cnts/arcsec**2)"
+ } else {
+ set xtitle "Avg Radius (pixels)"
+ set ytitle "Surface Brightness (cnts/pixels**2)"
+ }
+ }
+ }
+
+ # set for plot code
+ set vvar(axis,x,title) $xtitle
+ set vvar(axis,y,title) $ytitle
+
+ # update now (may not make it into plot code)
+ $vvar(graph) xaxis configure -title $xtitle
+ $vvar(graph) yaxis configure -title $ytitle
+}
diff --git a/ds9/library/markeranalysisstats.tcl b/ds9/library/markeranalysisstats.tcl
new file mode 100644
index 0000000..325b2e2
--- /dev/null
+++ b/ds9/library/markeranalysisstats.tcl
@@ -0,0 +1,102 @@
+# 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 MarkerAnalysisStatsDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global imarker
+
+ set frame $var(frame)
+ set id $var(id)
+
+ set vvarname ${imarker(prefix,stats)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ set var(stats) [info exists ${vvarname}(top)]
+
+ $var(mb).analysis add checkbutton \
+ -label [msgcat::mc {Statistics}] \
+ -variable ${varname}(stats) \
+ -command "MarkerAnalysisStatsCmd $varname"
+}
+
+proc MarkerAnalysisStatsCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerAnalysisStats $var(frame) $var(id) $var(stats)
+}
+
+proc MarkerAnalysisStats {frame id stats} {
+ $frame marker $id analysis stats $stats
+ if {$stats} {
+ MarkerAnalysisStatsCB $frame $id
+ } else {
+ MarkerAnalysisStatsDeleteCB $frame $id
+ }
+}
+
+proc MarkerAnalysisStatsSystem {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[info exists var(stats)]} {
+ if {$var(stats)} {
+ MarkerAnalysisStatsCB $var(frame) $var(id)
+ }
+ }
+}
+
+# hardcoded marker.C
+proc MarkerAnalysisStatsCB {frame id} {
+ global imarker
+
+ set varname ${imarker(prefix,dialog)}${id}${frame}
+ global $varname
+ upvar #0 $varname var
+
+ set vvarname ${imarker(prefix,stats)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists var(system)]} {
+ set vvar(system) $var(system)
+ set sys $var(system)
+ } elseif {[info exists vvar(system)]} {
+ set sys $vvar(system)
+ } else {
+ global wcs
+ set sys $wcs(system)
+ }
+
+ if {[info exists var(sky)]} {
+ set vvar(sky) $var(sky)
+ set sky $var(sky)
+ } elseif {[info exists vvar(sky)]} {
+ set sky $vvar(sky)
+ } else {
+ global wcs
+ set sky $wcs(sky)
+ }
+
+ set tt [string totitle [$frame get marker $id type]]
+ set rr [$frame get marker $id analysis stats $sys $sky]
+ SimpleTextDialog $vvarname $tt 80 20 insert top $rr
+}
+
+proc MarkerAnalysisStatsDeleteCB {frame id} {
+ global imarker
+
+ set vvarname ${imarker(prefix,stats)}${id}${frame}
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ if {[info exists $vvarname]} {
+ SimpleTextDestroy $vvarname
+ }
+}
diff --git a/ds9/library/markerbase.tcl b/ds9/library/markerbase.tcl
new file mode 100644
index 0000000..332380b
--- /dev/null
+++ b/ds9/library/markerbase.tcl
@@ -0,0 +1,313 @@
+# 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 MarkerBaseDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set tt [$var(frame) get marker $var(id) type]
+ switch -- [lindex $tt 1] {
+ point {set type "[string totitle [lindex $tt 0]] [string totitle [lindex $tt 1]]"}
+ {} {set type [string totitle [lindex $tt 0]]}
+ }
+
+ # variables - some may already be initialized (compass,ruler)
+ if {![info exists var(system)]} {
+ set rr [$var(frame) get wcs]
+ set var(system) [lindex $rr 0]
+ set var(sky) [lindex $rr 1]
+ set var(skyformat) [lindex $rr 2]
+ }
+ AdjustCoordSystem $varname system
+
+ # init
+ MarkerBaseTextCB $varname
+ MarkerBaseColorCB $varname
+ MarkerBaseLineWidthCB $varname
+ MarkerBasePropertyCB $varname
+ MarkerBaseFontCB $varname
+ $var(proc,coordCB) $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback delete MarkerBaseDeleteCB $varname
+ $var(frame) marker $var(id) callback text MarkerBaseTextCB $varname
+ $var(frame) marker $var(id) callback color MarkerBaseColorCB $varname
+ $var(frame) marker $var(id) callback width MarkerBaseLineWidthCB $varname
+ $var(frame) marker $var(id) callback property MarkerBasePropertyCB $varname
+ $var(frame) marker $var(id) callback font MarkerBaseFontCB $varname
+
+ # window
+ Toplevel $var(top) $var(mb) 6 [msgcat::mc "$type"] \
+ "$var(proc,close) $varname"
+
+ # menus
+ MarkerBaseMenu $varname
+ MarkerBaseFileMenu $varname
+ EditMenu $var(mb) $varname
+ ColorMenu $var(mb).color $varname color [list MarkerBaseColor $varname]
+ WidthDashMenu $var(mb).width $varname linewidth dash \
+ [list MarkerBaseLineWidth $varname] \
+ [list MarkerBaseProperty $varname dash]
+ MarkerBasePropertyMenu $varname
+ FontMenu $var(mb).font $varname font font,size font,weight \
+ font,slant [list MarkerBaseFont $varname]
+
+ # Param
+ set f [ttk::frame $var(top).param]
+ ttk::label $f.tid -text [msgcat::mc {Number}]
+ ttk::label $f.id -text "$var(id)"
+ ttk::label $f.ttext -text [msgcat::mc {Text}]
+ ttk::entry $f.text -textvariable ${varname}(text) -width 45
+ grid $f.tid $f.id -padx 2 -pady 2 -sticky w
+ grid $f.ttext $f.text - - - -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $var(top).buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] \
+ -command "$var(proc,apply) $varname"
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command "$var(proc,close) $varname"
+ pack $f.apply $f.close -side left -expand true -padx 2 -pady 4
+
+ bind $var(top) <Return> "$var(proc,apply) $varname"
+
+ # Fini
+ ttk::separator $var(top).sep -orient horizontal
+ pack $var(top).buttons $var(top).sep -side bottom -fill x
+ pack $var(top).param -side top -fill both -expand true
+
+ # some window managers need a hint
+ raise $var(top)
+}
+
+# actions
+
+proc MarkerBaseClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback delete MarkerBaseDeleteCB
+ $var(frame) marker $var(id) delete callback text MarkerBaseTextCB
+ $var(frame) marker $var(id) delete callback color MarkerBaseColorCB
+ $var(frame) marker $var(id) delete callback width MarkerBaseLineWidthCB
+ $var(frame) marker $var(id) delete callback property MarkerBasePropertyCB
+ $var(frame) marker $var(id) delete callback font MarkerBaseFontCB
+
+ MarkerBaseDeleteCB $varname
+
+ unset $varname
+}
+
+proc MarkerBaseApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) text \{$var(text)\}
+
+ UpdateRegionMenu
+}
+
+proc MarkerBaseColor {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) color $var(color)
+}
+
+proc MarkerBaseLineWidth {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) width $var(linewidth)
+}
+
+proc MarkerBaseProperty {varname prop} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) property $prop $var($prop)
+}
+
+proc MarkerBaseFont {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) font \
+ \"$var(font) $var(font,size) $var(font,weight) $var(font,slant)\"
+}
+
+# callbacks
+
+proc MarkerBaseDeleteCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseDeleteCB"
+ }
+
+ # variables
+ foreach m [array names marker] {
+ set mm [split $m ,]
+ if {[lindex $mm 0] == $var(frame) && [lindex $mm 1] == $var(id)} {
+ unset marker($m)
+ }
+ }
+
+ # destroy the window and menubar
+ if {[winfo exists $var(top)]} {
+ destroy $var(top)
+ destroy $var(mb)
+ }
+}
+
+proc MarkerBaseTextCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseTextCB"
+ }
+
+ set var(text) [$var(frame) get marker $var(id) text]
+}
+
+proc MarkerBaseColorCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseColorCB"
+ }
+
+ set var(color) [$var(frame) get marker $var(id) color]
+}
+
+proc MarkerBaseLineWidthCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseLineWidthCB"
+ }
+
+ set var(linewidth) [$var(frame) get marker $var(id) width]
+}
+
+proc MarkerBasePropertyCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBasePropertyCB"
+ }
+
+ set var(dash) [$var(frame) get marker $var(id) property dash]
+ set var(fixed) [$var(frame) get marker $var(id) property fixed]
+ set var(edit) [$var(frame) get marker $var(id) property edit]
+ set var(move) [$var(frame) get marker $var(id) property move]
+ set var(rotate) [$var(frame) get marker $var(id) property rotate]
+ set var(delete) [$var(frame) get marker $var(id) property delete]
+ set var(include) [$var(frame) get marker $var(id) property include]
+ set var(source) [$var(frame) get marker $var(id) property source]
+}
+
+proc MarkerBaseFontCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseFontCB"
+ }
+
+ set f [$var(frame) get marker $var(id) font]
+
+ set var(font) [lindex $f 0]
+ set var(font,size) [lindex $f 1]
+ set var(font,weight) [lindex $f 2]
+ set var(font,slant) [lindex $f 3]
+}
+
+proc MarkerBaseCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseCoordCB"
+ }
+
+ AdjustCoordSystem $varname system
+}
+
+# menus
+
+proc MarkerBaseMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(mb) add cascade -label [msgcat::mc {File}] -menu $var(mb).file
+ $var(mb) add cascade -label [msgcat::mc {Edit}] -menu $var(mb).edit
+ $var(mb) add cascade -label [msgcat::mc {Color}] -menu $var(mb).color
+ $var(mb) add cascade -label [msgcat::mc {Width}] -menu $var(mb).width
+ $var(mb) add cascade -label [msgcat::mc {Property}] -menu $var(mb).properties
+ $var(mb) add cascade -label [msgcat::mc {Font}] -menu $var(mb).font
+}
+
+proc MarkerBaseFileMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $var(mb).file
+ $var(mb).file add command -label [msgcat::mc {Apply}] \
+ -command "$var(proc,apply) $varname"
+ $var(mb).file add separator
+ $var(mb).file add command -label [msgcat::mc {Close}] \
+ -command "$var(proc,close) $varname"
+}
+
+proc MarkerBasePropertyMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $var(mb).properties
+ $var(mb).properties add checkbutton -label [msgcat::mc {Fixed in Size}] \
+ -variable ${varname}(fixed) \
+ -command "MarkerBaseProperty $varname fixed"
+ $var(mb).properties add separator
+ $var(mb).properties add checkbutton -label [msgcat::mc {Can Edit}] \
+ -variable ${varname}(edit) \
+ -command "MarkerBaseProperty $varname edit"
+ $var(mb).properties add checkbutton -label [msgcat::mc {Can Move}] \
+ -variable ${varname}(move) \
+ -command "MarkerBaseProperty $varname move"
+ $var(mb).properties add checkbutton -label [msgcat::mc {Can Rotate}] \
+ -variable ${varname}(rotate) \
+ -command "MarkerBaseProperty $varname rotate"
+ $var(mb).properties add checkbutton -label [msgcat::mc {Can Delete}] \
+ -variable ${varname}(delete) \
+ -command "MarkerBaseProperty $varname delete"
+ $var(mb).properties add separator
+ $var(mb).properties add radiobutton -label [msgcat::mc {Include}] \
+ -variable ${varname}(include) -value 1 \
+ -command "MarkerBaseProperty $varname include"
+ $var(mb).properties add radiobutton -label [msgcat::mc {Exclude}] \
+ -variable ${varname}(include) -value 0 \
+ -command "MarkerBaseProperty $varname include"
+ $var(mb).properties add separator
+ $var(mb).properties add radiobutton -label [msgcat::mc {Source}] \
+ -variable ${varname}(source) -value 1 \
+ -command "MarkerBaseProperty $varname source"
+ $var(mb).properties add radiobutton -label [msgcat::mc {Background}] \
+ -variable ${varname}(source) -value 0 \
+ -command "MarkerBaseProperty $varname source"
+}
diff --git a/ds9/library/markerbaseannulus.tcl b/ds9/library/markerbaseannulus.tcl
new file mode 100644
index 0000000..6253f8b
--- /dev/null
+++ b/ds9/library/markerbaseannulus.tcl
@@ -0,0 +1,274 @@
+# 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 MarkerBaseAnnulusDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set t [$var(frame) get marker $var(id) type]
+ switch -- $t {
+ ellipseannulus {set type "Ellipse Annulus"}
+ boxannulus {set type "Box Annulus"}
+ default {set type [string totitle $t]}
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(system) [lindex $rr 0]
+ set var(sky) [lindex $rr 1]
+ set var(skyformat) [lindex $rr 2]
+ AdjustCoordSystem $varname system
+
+ set var(x) 0
+ set var(y) 0
+
+ # init
+ MarkerBaseTextCB $varname
+ MarkerBaseColorCB $varname
+ MarkerBaseLineWidthCB $varname
+ MarkerBasePropertyCB $varname
+ MarkerBaseFontCB $varname
+ $var(proc,coordCB) $varname
+
+ MarkerBaseCenterMoveCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback delete MarkerBaseDeleteCB $varname
+ $var(frame) marker $var(id) callback text MarkerBaseTextCB $varname
+ $var(frame) marker $var(id) callback color MarkerBaseColorCB $varname
+ $var(frame) marker $var(id) callback width MarkerBaseLineWidthCB $varname
+ $var(frame) marker $var(id) callback property MarkerBasePropertyCB $varname
+ $var(frame) marker $var(id) callback font MarkerBaseFontCB $varname
+
+ $var(frame) marker $var(id) callback move MarkerBaseCenterMoveCB $varname
+
+ # window
+ Toplevel $var(top) $var(mb) 6 [msgcat::mc "$type"] \
+ "$var(proc,close) $varname"
+
+ # menus
+ MarkerBaseMenu $varname
+ MarkerBaseAnnulusFileMenu $varname
+ EditMenu $var(mb) $varname
+ ColorMenu $var(mb).color $varname color [list MarkerBaseColor $varname]
+ WidthDashMenu $var(mb).width $varname linewidth dash \
+ [list MarkerBaseLineWidth $varname] \
+ [list MarkerBaseProperty $varname dash]
+ MarkerBasePropertyMenu $varname
+ FontMenu $var(mb).font $varname font font,size font,weight \
+ font,slant [list MarkerBaseFont $varname]
+
+ # Param
+ set f [ttk::labelframe $var(top).param -text [msgcat::mc "Parameters"] \
+ -padding 2]
+
+ ttk::label $f.tid -text [msgcat::mc {Number}]
+ ttk::label $f.id -text "$var(id)"
+ ttk::label $f.ttext -text [msgcat::mc {Text}]
+ ttk::entry $f.text -textvariable ${varname}(text) -width 45
+ ttk::label $f.tcenter -text [msgcat::mc {Center}]
+ ttk::entry $f.centerx -textvariable ${varname}(x) -width 13
+ ttk::entry $f.centery -textvariable ${varname}(y) -width 13
+ CoordMenuButton $f.ucenter $varname system 1 sky skyformat \
+ [list $var(proc,coordCB) $varname]
+ CoordMenuEnable $f.ucenter.menu $varname system 1 sky skyformat
+
+ grid $f.tid $f.id -padx 2 -pady 2 -sticky w
+ grid $f.ttext $f.text - - - -padx 2 -pady 2 -sticky w
+ grid $f.tcenter $f.centerx $f.centery $f.ucenter \
+ -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $var(top).buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] \
+ -command "$var(proc,apply) $varname"
+ ttk::button $f.generate -text [msgcat::mc {Generate}] \
+ -command "$var(proc,generate) $varname"
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command "$var(proc,close) $varname"
+ pack $f.apply $f.generate $f.close -side left -expand true -padx 2 -pady 4
+
+ bind $var(top) <Return> "$var(proc,apply) $varname"
+
+ # Fini
+ grid $var(top).param -sticky news
+ grid $var(top).buttons - - -sticky ew
+
+ # some window managers need a hint
+ raise $var(top)
+}
+
+proc MarkerBaseAnnulusFileMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $var(mb).file
+ $var(mb).file add command -label [msgcat::mc {Apply}] \
+ -command "$var(proc,apply) $varname"
+ $var(mb).file add command -label [msgcat::mc {Generate}] \
+ -command "$var(proc,generate) $varname"
+ $var(mb).file add separator
+ $var(mb).file add command -label [msgcat::mc {Close}] \
+ -command "$var(proc,close) $varname"
+}
+
+proc MarkerBaseAnnulusMethodMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(mb) add cascade -label [msgcat::mc {Method}] -menu $var(mb).method
+ menu $var(mb).method
+ $var(mb).method add radiobutton -label [msgcat::mc {Equal Distance}] \
+ -variable ${varname}(method) -value dist
+ $var(mb).method add radiobutton -label [msgcat::mc {Equal Area}] \
+ -variable ${varname}(method) -value area
+}
+
+proc MarkerBaseAnnulusGenerateCircle {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(annulitxt) delete 1.0 end
+
+ if {$var(annuli) < 1} {
+ set var(annuli) 1
+ }
+
+ set inner $var(inner)
+ set outer $var(outer)
+ set annuli $var(annuli)
+
+ if {($inner != {}) && ($outer != {}) && ($annuli != {})} {
+ switch -- $var(method) {
+ dist {
+ for {set i 0} {$i<=$annuli} {incr i} {
+ $var(annulitxt) insert end \
+ "[expr ((($outer-$inner)/double($annuli))*$i)+$inner]\n"
+ }
+ }
+
+ area {
+ set pi 3.14159265358979323846
+ set area [expr $pi*(($outer*$outer)-($inner*$inner))/$annuli]
+
+ set r0 $inner
+ $var(annulitxt) insert end "$r0\n"
+ for {set i 0} {$i<$annuli} {incr i} {
+ set r1 [expr sqrt(($area+($pi*$r0*$r0))/$pi)]
+ $var(annulitxt) insert end \
+ [format "%.4f\n" $r1]
+ set r0 $r1
+ }
+ }
+ }
+ }
+}
+
+proc MarkerBaseAnnulusGenerateEllipse {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(annulitxt) delete 1.0 end
+
+ if {$var(annuli) < 1} {
+ set var(annuli) 1
+ }
+
+ set radius1 $var(radius1)
+ set radius2 $var(radius2)
+ set radius3 $var(radius3)
+ set annuli $var(annuli)
+
+ if {($radius1 != {}) && ($radius2 != {}) && \
+ ($radius3 != {}) && ($annuli != {})} {
+
+ switch -- $var(method) {
+ dist {
+ for {set i 0} {$i<=$annuli} {incr i} {
+ set major [expr ((($radius1-$radius3)/double($annuli))*$i)\
+ +$radius3]
+ set minor [expr $major*$radius2/$radius1]
+ $var(annulitxt) insert end "$major $minor\n"
+ }
+ }
+
+ area {
+ set pi 3.14159265358979323846
+ set r [expr double($radius2)/$radius1]
+ set area [expr $pi*(($radius1*$radius2)-($radius3*$radius3*$r))\
+ /$annuli]
+
+ set major0 $radius3
+ set minor0 [expr $radius3*$r]
+ $var(annulitxt) insert end "$major0 $minor0\n"
+ for {set i 0} {$i<$annuli} {incr i} {
+ set major1 [expr sqrt(($area+($pi*$major0*$minor0)) / \
+ ($pi*$r))]
+ set minor1 [expr $major1*$r]
+ $var(annulitxt) insert end \
+ [format "%.4f %.4f\n" $major1 $minor1]
+ set major0 $major1
+ set minor0 $minor1
+ }
+ }
+ }
+ }
+}
+
+proc MarkerBaseAnnulusGenerateBox {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(annulitxt) delete 1.0 end
+
+ if {$var(annuli) < 1} {
+ set var(annuli) 1
+ }
+
+ set radius1 $var(radius1)
+ set radius2 $var(radius2)
+ set radius3 $var(radius3)
+ set annuli $var(annuli)
+
+ if {($radius1 != {}) && ($radius2 != {}) && \
+ ($radius3 != {}) && ($annuli != {})} {
+
+ if {$radius1<=0} {
+ set radius1 1
+ }
+ if {$radius2<=0} {
+ set radius2 1
+ }
+
+ switch -- $var(method) {
+ dist {
+ for {set i 0} {$i<=$annuli} {incr i} {
+ set major [expr ((($radius1-$radius3)/$annuli)*$i)+$radius3]
+ set minor [expr $major*$radius2/$radius1]
+ $var(annulitxt) insert end "$major $minor\n"
+ }
+ }
+
+ area {
+ set r [expr double($radius2)/$radius1]
+ set area [expr (($radius1*$radius2)-($radius3*$radius3*$r)) \
+ /$annuli]
+
+ set major0 $radius3
+ set minor0 [expr $radius3*$r]
+ $var(annulitxt) insert end "$major0 $minor0\n"
+ for {set i 0} {$i<$annuli} {incr i} {
+ set major1 [expr sqrt(($area+($major0*$minor0))/$r)]
+ set minor1 [expr $major1*$r]
+ $var(annulitxt) insert end \
+ [format "%.4f %.4f\n" $major1 $minor1]
+ set major0 $major1
+ set minor0 $minor1
+ }
+ }
+ }
+ }
+}
diff --git a/ds9/library/markerbaseannulusrect.tcl b/ds9/library/markerbaseannulusrect.tcl
new file mode 100644
index 0000000..3ec3274
--- /dev/null
+++ b/ds9/library/markerbaseannulusrect.tcl
@@ -0,0 +1,188 @@
+# 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 MarkerBaseAnnulusRectDialog {varname unit major minor} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ set unit2 [string totitle $unit]
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ set var(method) dist
+
+ # base
+ MarkerBaseAnnulusDialog $varname
+
+ # menus
+ MarkerBaseAnnulusMethodMenu $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisRadialDialog $varname
+
+ # callbacks
+# $var(frame) marker $var(id) callback move $var(proc,editCB) $varname
+ $var(frame) marker $var(id) callback edit $var(proc,editCB) $varname
+ $var(frame) marker $var(id) callback end edit $var(proc,editCB) $varname
+ $var(frame) marker $var(id) callback rotate MarkerBaseCenterRotateCB $varname
+
+ set f $var(top).param
+
+ # Radius
+ ttk::label $f.majorTitle -text $major
+ ttk::label $f.minorTitle -text $minor
+ ttk::label $f.outerTitle -text [msgcat::mc "Outer"]
+ ttk::entry $f.radius1 -textvariable ${varname}(radius1) -width 13
+ ttk::entry $f.radius2 -textvariable ${varname}(radius2) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list $var(proc,distCB) $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+ ttk::label $f.innerTitle -text [msgcat::mc "Inner"]
+ ttk::entry $f.radius3 -textvariable ${varname}(radius3) -width 13
+
+ # Annulus
+ ttk::label $f.tannuli -text [msgcat::mc {Annuli}]
+ ttk::entry $f.vannuli -textvariable ${varname}(annuli) -width 13
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.vangle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid x $f.majorTitle $f.minorTitle -padx 2 -pady 2 -sticky w
+ grid $f.outerTitle $f.radius1 $f.radius2 $f.uradius \
+ -padx 2 -pady 2 -sticky w
+ grid $f.innerTitle $f.radius3 -padx 2 -pady 2 -sticky w
+ grid $f.tannuli $f.vannuli -padx 2 -pady 2 -sticky w
+ grid $f.tangle $f.vangle $f.uangle -padx 2 -pady 2 -sticky w
+
+ # Annuli
+ set f [ttk::labelframe $var(top).annuli -text [msgcat::mc {Annuli}] \
+ -padding 2]
+
+ set var(annulitxt) [text $f.txt \
+ -height 10 \
+ -width 15 \
+ -wrap none \
+ -font [font actual TkDefaultFont] \
+ -yscrollcommand [list $f.yscroll set] \
+ ]
+ ttk::scrollbar $f.yscroll -command [list $var(annulitxt) yview] \
+ -orient vertical
+
+ grid $var(annulitxt) $f.yscroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ # Fini
+ grid $var(top).annuli -row 0 -column 1 -sticky news
+ grid rowconfigure $var(top) 0 -weight 1
+ grid columnconfigure $var(top) 1 -weight 1
+
+ # init - do this last
+ $var(proc,distCB) $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+# actions
+
+proc MarkerBaseAnnulusRectClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # $var(frame) marker $var(id) delete callback move $var(proc,editCB)
+ $var(frame) marker $var(id) delete callback edit $var(proc,editCB)
+ $var(frame) marker $var(id) delete callback end edit $var(proc,editCB)
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc MarkerBaseAnnulusRectApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set levels {}
+ regsub -all "\n" "[$var(annulitxt) get 1.0 end]" " " levels
+ # and trim any trailing spaces
+ set levels [string trimright $levels " "]
+
+ if {$levels != {}} {
+ $var(frame) marker $var(id) $var(which) radius "\{$levels\}" \
+ $var(dcoord) $var(dformat)
+ }
+
+ MarkerBaseCenterRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc MarkerBaseAnnulusRectCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseAnnulusRectCoordCB"
+ }
+
+ MarkerAnalysisRadialSystem $varname
+ MarkerAnalysisStatsSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+proc MarkerBaseAnnulusRectEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseAnnulusRectEditCB"
+ }
+
+ set t [$var(frame) get marker $var(id) $var(which) radius \
+ $var(dcoord) $var(dformat)]
+
+ set last [llength $t]
+ set var(annuli) [expr $last/2-1]
+ set var(radius1) [lindex $t [expr $last-2]]
+ set var(radius2) [lindex $t [expr $last-1]]
+ set var(radius3) [lindex $t 0]
+
+ $var(annulitxt) delete 1.0 end
+ $var(annulitxt) insert end "$t"
+}
+
+proc MarkerBaseAnnulusRectDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseAnnulusRectDistCB"
+ }
+
+ $var(proc,editCB) $varname
+}
diff --git a/ds9/library/markerbasecenter.tcl b/ds9/library/markerbasecenter.tcl
new file mode 100644
index 0000000..1207f41
--- /dev/null
+++ b/ds9/library/markerbasecenter.tcl
@@ -0,0 +1,91 @@
+# 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 MarkerBaseCenterDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # variables
+ set var(x) 0
+ set var(y) 0
+
+ # base
+ MarkerBaseDialog $varname
+
+ # init
+ MarkerBaseCenterMoveCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback move MarkerBaseCenterMoveCB $varname
+
+ set f $var(top).param
+
+ # Center
+ ttk::label $f.tcenter -text [msgcat::mc {Center}]
+ ttk::entry $f.centerx -textvariable ${varname}(x) -width 13
+ ttk::entry $f.centery -textvariable ${varname}(y) -width 13
+
+ CoordMenuButton $f.ucenter $varname system 1 sky skyformat \
+ [list $var(proc,coordCB) $varname]
+ CoordMenuEnable $f.ucenter.menu $varname system 1 sky skyformat
+
+ grid $f.tcenter $f.centerx $f.centery $f.ucenter -padx 2 -pady 2 -sticky w
+}
+
+proc MarkerBaseCenterClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback move MarkerBaseCenterMoveCB
+
+ MarkerBaseClose $varname
+}
+
+proc MarkerBaseCenterApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(x) != {} &&
+ $var(y) != {}} {
+ $var(frame) marker $var(id) move to $var(system) $var(sky) \
+ $var(x) $var(y)
+ }
+
+ MarkerBaseApply $varname
+}
+
+proc MarkerBaseCenterRotate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) angle $var(angle) $var(system) $var(sky)
+}
+
+# callbacks
+
+proc MarkerBaseCenterMoveCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseCenterMoveCB"
+ }
+
+ set center [$var(frame) get marker $var(id) center $var(system) $var(sky) \
+ $var(skyformat)]
+ set var(x) [lindex $center 0]
+ set var(y) [lindex $center 1]
+}
+
+proc MarkerBaseCenterRotateCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(angle) [$var(frame) get marker $var(id) angle \
+ $var(system) $var(sky)]
+}
+
diff --git a/ds9/library/markerbaseline.tcl b/ds9/library/markerbaseline.tcl
new file mode 100644
index 0000000..06832b4
--- /dev/null
+++ b/ds9/library/markerbaseline.tcl
@@ -0,0 +1,99 @@
+# 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 MarkerBaseLineDialog {varname width height} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # variables - some may already initialized (ruler)
+ if {![info exists ${varname}(dcoord)]} {
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ }
+ AdjustCoordSystem $varname dcoord
+
+ # procs
+ set var(proc,close) MarkerBaseLineClose
+
+ # base
+ MarkerBaseDialog $varname
+
+ # init
+ $var(proc,distCB) $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback move "$var(proc,editCB)" $varname
+ $var(frame) marker $var(id) callback edit "$var(proc,editCB)" $varname
+
+ set f $var(top).param
+
+ # Points
+ ttk::label $f.title -text [msgcat::mc {Points}]
+ ttk::entry $f.x -textvariable ${varname}(x) -width 13
+ ttk::entry $f.y -textvariable ${varname}(y) -width 13
+ CoordMenuButton $f.coord $varname system 1 sky skyformat \
+ [list $var(proc,coordCB) $varname]
+ CoordMenuEnable $f.coord.menu $varname system 1 sky skyformat
+ ttk::entry $f.x2 -textvariable ${varname}(x2) -width 13
+ ttk::entry $f.y2 -textvariable ${varname}(y2) -width 13
+
+ # Length
+ ttk::label $f.dtitle -text [msgcat::mc {Length}]
+ ttk::label $f.dist -textvariable ${varname}(dist) \
+ -relief groove -width 12
+ DistMenuButton $f.udist $varname dcoord 1 dformat \
+ [list $var(proc,distCB) $varname]
+ DistMenuEnable $f.udist.menu $varname dcoord 1 dformat
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::label $f.angle -textvariable ${varname}(angle) \
+ -relief groove -width 12
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid $f.title $f.x $f.y $f.coord -padx 2 -pady 2 -sticky w
+ grid x $f.x2 $f.y2 -padx 2 -pady 2 -sticky w
+ grid $f.dtitle $f.dist $f.udist -padx 2 -pady 2 -sticky w
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+}
+
+proc MarkerBaseLineClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback move "$var(proc,editCB)"
+ $var(frame) marker $var(id) delete callback edit "$var(proc,editCB)"
+
+ MarkerBaseClose $varname
+}
+
+proc MarkerBaseLineApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseApply $varname
+}
+
+proc MarkerBaseLineEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBaseLineEditCB"
+ }
+
+ set p [$var(frame) get marker $var(id) $var(which) point $var(system) \
+ $var(sky) $var(skyformat)]
+
+ set var(x) [lindex $p 0]
+ set var(y) [lindex $p 1]
+ set var(x2) [lindex $p 2]
+ set var(y2) [lindex $p 3]
+}
diff --git a/ds9/library/markerbasepanda.tcl b/ds9/library/markerbasepanda.tcl
new file mode 100644
index 0000000..8e31099
--- /dev/null
+++ b/ds9/library/markerbasepanda.tcl
@@ -0,0 +1,216 @@
+# 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 MarkerBasePandaDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ set var(method) dist
+ set var(init) 0
+
+ # base
+ MarkerBaseAnnulusDialog $varname
+
+ # menus
+ MarkerBaseAnnulusMethodMenu $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisPandaDialog $varname
+
+ # callbacks
+# $var(frame) marker $var(id) callback move $var(proc,editCB) $varname
+ $var(frame) marker $var(id) callback edit $var(proc,editCB) $varname
+ $var(frame) marker $var(id) callback end edit $var(proc,editCB) $varname
+
+ set f $var(top).param
+
+ # Angles
+ ttk::label $f.tang1 -text [msgcat::mc {Start}]
+ ttk::label $f.tang2 -text [msgcat::mc {End}]
+ ttk::label $f.tangles -text [msgcat::mc {Angles}]
+ ttk::entry $f.ang1 -textvariable ${varname}(ang1) -width 13
+ ttk::entry $f.ang2 -textvariable ${varname}(ang2) -width 13
+ ttk::label $f.uangles -text [msgcat::mc {Degrees}]
+ ttk::label $f.tangnum -text [msgcat::mc {Number}]
+ ttk::entry $f.angnum -textvariable ${varname}(angnum) -width 13
+
+ grid x $f.tang1 $f.tang2 -padx 2 -pady 2 -sticky w
+ grid $f.tangles $f.ang1 $f.ang2 $f.uangles -padx 2 -pady 2 -sticky w
+ grid $f.tangnum $f.angnum -padx 2 -pady 2 -sticky w
+
+ # Radius
+ set f [ttk::labelframe $var(top).radius -text [msgcat::mc {Radius}] \
+ -padding 2]
+ set var(annulitxt) [text $f.txt \
+ -height 15 \
+ -width 15 \
+ -wrap none \
+ -font [font actual TkDefaultFont] \
+ -yscrollcommand [list $f.yscroll set] \
+ ]
+ ttk::scrollbar $f.yscroll -command [list $var(annulitxt) yview] \
+ -orient vertical
+
+ grid $var(annulitxt) $f.yscroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ # Radius Fini
+ grid $var(top).radius -row 0 -column 1 -sticky news
+ grid rowconfigure $var(top) 0 -weight 1
+ grid columnconfigure $var(top) 1 -weight 1
+
+ # Angles
+ set f [ttk::labelframe $var(top).angles -text [msgcat::mc {Angles}] \
+ -padding 2]
+
+ set var(angtxt) [text $f.txt \
+ -height 15 \
+ -width 15 \
+ -wrap none \
+ -font [font actual TkDefaultFont] \
+ -yscrollcommand [list $f.yscroll set] \
+ ]
+ ttk::scrollbar $f.yscroll -command [list $var(angtxt) yview] \
+ -orient vertical
+
+ grid $var(angtxt) $f.yscroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ # Angles Fini
+ grid $var(top).angles -row 0 -column 2 -sticky news
+ grid rowconfigure $var(top) 0 -weight 1
+ grid columnconfigure $var(top) 2 -weight 1
+
+ set var(init) 1
+}
+
+# actions
+
+proc MarkerBasePandaClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+# $var(frame) marker $var(id) delete callback move $var(proc,editCB)
+ $var(frame) marker $var(id) delete callback edit $var(proc,editCB)
+ $var(frame) marker $var(id) delete callback end edit $var(proc,editCB)
+
+ MarkerBaseCenterClose $varname
+}
+
+proc MarkerBasePandaApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set levels {}
+ regsub -all "\n" "[$var(annulitxt) get 1.0 end]" " " levels
+ # and trim any trailing spaces
+ set levels [string trimright $levels " "]
+
+ set angles {}
+ regsub -all "\n" "[$var(angtxt) get 1.0 end]" " " angles
+ # and trim any trailing spaces
+ set angles [string trimright $angles " "]
+
+ if {($levels != {}) && ($angles != {})} {
+ $var(frame) marker $var(id) $var(which) edit \
+ "\{$angles\}" "\{$levels\}" $var(system) $var(sky) \
+ $var(dcoord) $var(dformat)
+ }
+
+ MarkerBaseCenterApply $varname
+}
+
+proc MarkerBasePandaGenerateAngles {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(angtxt) delete 1.0 end
+
+ set ang1 $var(ang1)
+ set ang2 $var(ang2)
+ set angnum $var(angnum)
+
+ if {($ang1 != {}) && ($ang2 != {}) && ($angnum != {})} {
+ # normalize between 0 <= ang < 360
+ if {[::math::fuzzy::tgt $ang1 0]} {
+ while {[::math::fuzzy::tge $ang1 360]} {
+ set ang1 [expr $ang1-360]
+ }
+ } else {
+ while {[::math::fuzzy::tlt $ang1 0]} {
+ set ang1 [expr $ang1+360]
+ }
+ }
+
+ if {[::math::fuzzy::tgt $ang2 0]} {
+ while {[::math::fuzzy::tge $ang2 360]} {
+ set ang2 [expr $ang2-360]
+ }
+ } else {
+ while {[::math::fuzzy::tlt $ang2 0]} {
+ set ang2 [expr $ang2+360]
+ }
+ }
+
+ # with ang2 > ang1
+ while {[::math::fuzzy::tge $ang1 $ang2]} {
+ set ang2 [expr $ang2+360]
+ }
+
+ for {set i 0} {$i<=$angnum} {incr i} {
+ set v [expr ((($ang2-$ang1)/double($angnum))*$i)+$ang1]
+ $var(angtxt) insert end "$v\n"
+ }
+ }
+}
+
+# callbacks
+
+
+proc MarkerBasePandaCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBasePandaCoordCB"
+ }
+
+ MarkerAnalysisPandaSystem $varname
+ MarkerAnalysisStatsSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ if {$var(init)} {
+ $var(proc,editCB) $varname
+ }
+}
+
+proc MarkerBasePandaDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBasePandaDistCB"
+ }
+
+ $var(proc,editCB) $varname
+}
+
diff --git a/ds9/library/markerbasepandarect.tcl b/ds9/library/markerbasepandarect.tcl
new file mode 100644
index 0000000..320cb73
--- /dev/null
+++ b/ds9/library/markerbasepandarect.tcl
@@ -0,0 +1,130 @@
+# 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 MarkerBasePandaRectDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # base panda dialog
+ MarkerBasePandaDialog $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback rotate \
+ MarkerBaseCenterRotateCB $varname
+
+ set f $var(top).param
+
+ # Radius
+ ttk::label $f.tmajor -text [msgcat::mc {Major}]
+ ttk::label $f.tminor -text [msgcat::mc {Minor}]
+ ttk::label $f.touter -text [msgcat::mc {Outer}]
+ ttk::entry $f.radius1 -textvariable ${varname}(radius1) -width 13
+ ttk::entry $f.radius2 -textvariable ${varname}(radius2) -width 13
+ DistMenuButton $f.uradius $varname dcoord 1 dformat \
+ [list $var(proc,distCB) $varname]
+ DistMenuEnable $f.uradius.menu $varname dcoord 1 dformat
+ ttk::label $f.tinner -text [msgcat::mc {Inner}]
+ ttk::entry $f.radius3 -textvariable ${varname}(radius3) -width 13
+
+ # Annuli
+ ttk::label $f.tannuli -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable ${varname}(annuli) -width 13
+
+ grid x $f.tmajor $f.tminor -padx 2 -pady 2 -sticky w
+ grid $f.touter $f.radius1 $f.radius2 $f.uradius -padx 2 -pady 2 -sticky w
+ grid $f.tinner $f.radius3 -padx 2 -pady 2 -sticky w
+ grid $f.tannuli $f.annuli -padx 2 -pady 2 -sticky w
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+
+ # init - do this last
+ $var(proc,distCB) $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+# actions
+
+proc MarkerBasePandaRectClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBasePandaClose $varname
+}
+
+proc MarkerBasePandaRectApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBasePandaApply $varname
+ MarkerBaseCenterRotate $varname
+}
+
+# callbacks
+
+proc MarkerBasePandaRectCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBasePandaRectCoordCB"
+ }
+
+ MarkerBasePandaCoordCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
+proc MarkerBasePandaRectEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBasePandaRectEditCB"
+ }
+
+ set t [$var(frame) get marker $var(id) $var(which) radius \
+ $var(dcoord) $var(dformat)]
+
+ set last [llength $t]
+ set var(annuli) [expr $last/2-1]
+ set var(radius1) [lindex $t [expr $last-2]]
+ set var(radius2) [lindex $t [expr $last-1]]
+ set var(radius3) [lindex $t 0]
+
+ $var(annulitxt) delete 1.0 end
+ $var(annulitxt) insert end "$t"
+
+ set a [$var(frame) get marker $var(id) $var(which) angle \
+ $var(system) $var(sky)]
+
+ set last [expr [llength $a]-1]
+ set var(ang1) [lindex $a 0]
+ set var(ang2) [lindex $a $last]
+ set var(angnum) $last
+
+ $var(angtxt) delete 1.0 end
+ $var(angtxt) insert end "$a"
+}
+
+proc MarkerBasePandaRectDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "MarkerBasePandaRectDistCB"
+ }
+
+ MarkerBasePandaDistCB $varname
+}
diff --git a/ds9/library/markerdialog.tcl b/ds9/library/markerdialog.tcl
new file mode 100644
index 0000000..3cee4b7
--- /dev/null
+++ b/ds9/library/markerdialog.tcl
@@ -0,0 +1,292 @@
+# 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 MarkerLoadDialog {} {
+ global marker
+ global ed
+ global current
+ global wcs
+
+ set w {.mkd}
+
+ set ed(ok) 0
+ set ed(format) $marker(format)
+ set ed(load) $marker(load)
+ set ed(frame) $current(frame)
+
+ set ed(system) $wcs(system)
+ set ed(sky) $wcs(sky)
+ set ed(skyformat) $wcs(skyformat)
+ AdjustCoordSystem ed system
+
+ DialogCreate $w [msgcat::mc {Load Regions}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.formattitle -text [msgcat::mc {Format}]
+ set m $f.formatbutton.menu
+ ttk::menubutton $f.formatbutton -textvariable ed(format) -menu $m
+ ttk::label $f.coordtitle -text [msgcat::mc {Coordinate System}]
+ set ed(cb) $f.coordbutton
+ CoordMenuButton $ed(cb) ed system 1 sky skyformat {}
+ ttk::radiobutton $f.current -text [msgcat::mc {Load into Current Frame}] \
+ -variable ed(load) -value current
+ ttk::radiobutton $f.all -text [msgcat::mc {Load into All Frames}] \
+ -variable ed(load) -value all
+
+ menu $m
+ $m add radiobutton -label {DS9/Funtools} -variable ed(format) -value ds9 \
+ -command UpdateMarkerLoadDialog
+ $m add radiobutton -label {XML} -variable ed(format) -value xml \
+ -command UpdateMarkerLoadDialog
+ $m add radiobutton -label {CIAO} -variable ed(format) -value ciao \
+ -command UpdateMarkerLoadDialog
+ $m add radiobutton -label {SAOtng} -variable ed(format) -value saotng \
+ -command UpdateMarkerLoadDialog
+ $m add radiobutton -label {SAOimage} -variable ed(format) -value saoimage \
+ -command UpdateMarkerLoadDialog
+ $m add radiobutton -label {IRAF PROS} -variable ed(format) -value pros \
+ -command UpdateMarkerLoadDialog
+ $m add radiobutton -label {X Y} -variable ed(format) -value xy \
+ -command UpdateMarkerLoadDialog
+
+ grid $f.formattitle $f.formatbutton -padx 2 -pady 2 -sticky w
+ grid $f.coordtitle $f.coordbutton -padx 2 -pady 2 -sticky w
+ grid $f.current - -padx 2 -pady 2 -sticky w
+ grid $f.all - -padx 2 -pady 2 -sticky w
+
+ # Button
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ UpdateMarkerLoadDialog
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set marker(format) $ed(format)
+ set marker(system) $ed(system)
+ set marker(sky) $ed(sky)
+ set marker(skyformat) $ed(skyformat)
+ set marker(load) $ed(load)
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc UpdateMarkerLoadDialog {} {
+ global ed
+ global current
+
+ set mm $ed(cb).menu
+ set ed(frame) $current(frame)
+ CoordMenuEnable $mm ed system 1 sky skyformat
+
+ switch -- $ed(format) {
+ xy {$ed(cb) configure -state normal}
+ default {$ed(cb) configure -state disabled}
+ }
+
+ AdjustCoordSystem ed system
+ CoordMenuButtonCmd ed system sky {}
+}
+
+proc MarkerSaveDialog {title} {
+ global marker
+ global ed
+ global current
+ global wcs
+
+ set w {.mkd}
+
+ set ed(ok) 0
+ set ed(format) $marker(format)
+ set ed(frame) $current(frame)
+
+ set ed(system) $wcs(system)
+ set ed(sky) $wcs(sky)
+ set ed(skyformat) $wcs(skyformat)
+ AdjustCoordSystem ed system
+
+ DialogCreate $w $title ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.formattitle -text [msgcat::mc {Format}]
+ set m $f.formatbutton.menu
+ ttk::menubutton $f.formatbutton -textvariable ed(format) -menu $m
+ ttk::label $f.coordtitle -text [msgcat::mc {Coordinate System}]
+ set ed(cb) $f.coordbutton
+
+ CoordMenuButton $ed(cb) ed system 1 sky skyformat UpdateMarkerSaveDialog
+
+ menu $m
+ $m add radiobutton -label {DS9/Funtools} -variable ed(format) -value ds9 \
+ -command UpdateMarkerSaveDialog
+ $m add radiobutton -label {XML} -variable ed(format) -value xml \
+ -command UpdateMarkerSaveDialog
+ $m add radiobutton -label {CIAO} -variable ed(format) -value ciao \
+ -command UpdateMarkerSaveDialog
+ $m add radiobutton -label {SAOtng} -variable ed(format) -value saotng \
+ -command UpdateMarkerSaveDialog
+ $m add radiobutton -label {SAOimage} -variable ed(format) -value saoimage \
+ -command UpdateMarkerSaveDialog
+ $m add radiobutton -label {IRAF PROS} -variable ed(format) -value pros \
+ -command UpdateMarkerSaveDialog
+ $m add radiobutton -label {X Y} -variable ed(format) -value xy \
+ -command UpdateMarkerSaveDialog
+
+ grid $f.formattitle $f.formatbutton -padx 2 -pady 2 -sticky w
+ grid $f.coordtitle $f.coordbutton -padx 2 -pady 2 -sticky w
+
+ # Button
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ UpdateMarkerSaveDialog
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set marker(format) $ed(format)
+ set marker(system) $ed(system)
+ set marker(sky) $ed(sky)
+ set marker(skyformat) $ed(skyformat)
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc UpdateMarkerSaveDialog {} {
+ global ed
+ global current
+
+ set mm $ed(cb).menu
+ set ed(frame) $current(frame)
+ CoordMenuEnable $mm ed system 1 sky skyformat
+
+ switch -- $ed(format) {
+ ds9 -
+ xml -
+ xy {}
+
+ ciao {
+ switch -- $ed(system) {
+ detector -
+ amplifier -
+ physical -
+ image {set ed(system) physical}
+ wcs -
+ default {set ed(system) wcs}
+ }
+
+ set ed(sky) fk5
+ set ed(skyformat) sexagesimal
+
+ $mm entryconfig [msgcat::mc {Multiple WCS}] -state disabled
+ $mm entryconfig [msgcat::mc {Image}] -state disabled
+ $mm entryconfig [msgcat::mc {Amplifier}] -state disabled
+ $mm entryconfig [msgcat::mc {Detector}] -state disabled
+
+ $mm entryconfig [msgcat::mc {FK4}] -state disabled
+ $mm entryconfig [msgcat::mc {ICRS}] -state disabled
+ $mm entryconfig [msgcat::mc {Galactic}] -state disabled
+ $mm entryconfig [msgcat::mc {Ecliptic}] -state disabled
+
+ $mm entryconfig [msgcat::mc {Degrees}] -state disabled
+ }
+
+ saotng {
+ switch -- $ed(system) {
+ detector -
+ amplifier -
+ image -
+ physical {set ed(system) image}
+ wcs -
+ default {set ed(system) wcs}
+ }
+
+ $mm entryconfig [msgcat::mc {Multiple WCS}] -state disabled
+ $mm entryconfig [msgcat::mc {Physical}] -state disabled
+ $mm entryconfig [msgcat::mc {Amplifier}] -state disabled
+ $mm entryconfig [msgcat::mc {Detector}] -state disabled
+ }
+
+ saoimage {
+ set ed(system) image
+
+ $mm entryconfig [msgcat::mc {WCS}] -state disabled
+ $mm entryconfig [msgcat::mc {Multiple WCS}] -state disabled
+ $mm entryconfig [msgcat::mc {Physical}] -state disabled
+ $mm entryconfig [msgcat::mc {Amplifier}] -state disabled
+ $mm entryconfig [msgcat::mc {Detector}] -state disabled
+
+ $mm entryconfig [msgcat::mc {FK4}] -state disabled
+ $mm entryconfig [msgcat::mc {FK5}] -state disabled
+ $mm entryconfig [msgcat::mc {ICRS}] -state disabled
+ $mm entryconfig [msgcat::mc {Galactic}] -state disabled
+ $mm entryconfig [msgcat::mc {Ecliptic}] -state disabled
+
+ $mm entryconfig [msgcat::mc {Degrees}] -state disabled
+ $mm entryconfig {Sexagesimal} -state disabled
+ }
+
+ pros {
+ switch -- $ed(system) {
+ detector -
+ physical -
+ amplifier {set ed(system) physical}
+ image {}
+ wcs -
+ default {set ed(system) wcs}
+ }
+ if {$ed(sky) == {icrs}} {
+ set ed(sky) fk5
+ }
+
+ $mm entryconfig [msgcat::mc {Multiple WCS}] -state disabled
+ $mm entryconfig [msgcat::mc {Amplifier}] -state disabled
+ $mm entryconfig [msgcat::mc {Detector}] -state disabled
+
+ $mm entryconfig [msgcat::mc {ICRS}] -state disabled
+ }
+ }
+
+ AdjustCoordSystem ed system
+ CoordMenuButtonCmd ed system sky {}
+}
+
+
diff --git a/ds9/library/mask.tcl b/ds9/library/mask.tcl
new file mode 100644
index 0000000..aa3de7c
--- /dev/null
+++ b/ds9/library/mask.tcl
@@ -0,0 +1,297 @@
+# 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 MaskDef {} {
+ global mask
+ global imask
+ global pmask
+
+ set imask(top) .msk
+ set imask(mb) .mskmb
+
+ set mask(color) red
+ set mask(mark) 1
+ set mask(transparency) 0
+
+ array set pmask [array get mask]
+}
+
+proc MaskTransparency {} {
+ global mask
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) mask transparency $mask(transparency)
+ }
+}
+
+proc MaskClear {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) mask clear
+ }
+}
+
+proc MaskDialog {} {
+ global mask
+ global imask
+ global current
+ global ds9
+
+ # see if we already have a ctr window visible
+ if {[winfo exists $imask(top)]} {
+ raise $imask(top)
+ return
+ }
+
+ # create the mask window
+ set w $imask(top)
+ set mb $imask(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Mask Parameters}] MaskDestroyDialog
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label "[msgcat::mc {Open}]..." \
+ -command [list OpenDialog fits mask]
+ $mb.file add cascade -label [msgcat::mc {Open as}] \
+ -menu $mb.file.open
+ $mb.file add separator
+ $mb.file add cascade -label [msgcat::mc {Import}] \
+ -menu $mb.file.import
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Apply}] -command MaskApplyDialog
+ $mb.file add command -label [msgcat::mc {Clear}] -command MaskClear
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command MaskDestroyDialog
+
+ menu $mb.file.open
+ $mb.file.open add command \
+ -label "[msgcat::mc {Mosaic WCS}]..." \
+ -command [list OpenDialog mosaicimagewcs mask]
+ $mb.file.open add command \
+ -label "[msgcat::mc {Mosaic WCS Segment}]..." \
+ -command [list OpenDialog mosaicwcs mask]
+ $mb.file.open add command \
+ -label "[msgcat::mc {Mosaic IRAF}]..." \
+ -command [list OpenDialog mosaicimageiraf mask]
+ $mb.file.open add command \
+ -label "[msgcat::mc {Mosaic IRAF Segment}]..." \
+ -command [list OpenDialog mosaiciraf mask]
+
+ menu $mb.file.import
+ $mb.file.import add command \
+ -label "[msgcat::mc {Array}]..." \
+ -command [list ImportDialog array mask]
+ $mb.file.import add command \
+ -label "[msgcat::mc {NRRD}]..." \
+ -command [list ImportDialog nrrd mask]
+
+ EditMenu $mb imask
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ slider $f.slider 0 100 [msgcat::mc {Transparency}] \
+ mask(transparency) [list MaskTransparency]
+
+ grid $f.slider -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command MaskApplyDialog
+ ttk::button $f.clear -text [msgcat::mc {Clear}] -command MaskClear
+ ttk::button $f.close -text [msgcat::mc {Close}] -command MaskDestroyDialog
+ pack $f.apply $f.clear $f.close -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
+}
+
+proc MaskApplyDialog {} {
+ global mask
+
+ MaskTransparency
+}
+
+proc MaskDestroyDialog {} {
+ global imask
+
+ if {[winfo exists $imask(top)]} {
+ destroy $imask(top)
+ destroy $imask(mb)
+ }
+}
+
+proc UpdateMaskMenu {} {
+ global mask
+ global current
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateMaskMenu"
+ }
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set mask(color) [$current(frame) get mask color]
+ set mask(mark) [$current(frame) get mask mark]
+ set mask(transparency) [$current(frame) get mask transparency]
+
+ switch -- [$current(frame) get type] {
+ base {
+ $ds9(mb).analysis entryconfig \
+ "[msgcat::mc {Mask Parameters}]..." -state normal
+ }
+ 3d -
+ rgb {
+ $ds9(mb).analysis entryconfig \
+ "[msgcat::mc {Mask Parameters}]..." -state disabled
+ }
+ }
+}
+
+proc MaskLoad {} {
+ global current
+ global mask
+
+ set rr [MaskParamsDialog]
+ if {$current(frame) != {}} {
+ if {$rr} {
+ $current(frame) mask color $mask(color)
+ $current(frame) mask mark $mask(mark)
+ }
+ }
+ return $rr
+}
+
+proc MaskParamsDialog {} {
+ global mask
+ global ed
+
+ set w {.mskd}
+
+ set ed(ok) 0
+ set ed(color) $mask(color)
+ set ed(mark) $mask(mark)
+
+ DialogCreate $w [msgcat::mc {Mask Parameters}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.colortitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.colorbutton ed color {}
+ ttk::label $f.marktitle -text [msgcat::mc {Block}]
+ ttk::radiobutton $f.markz -text [msgcat::mc {Zero}] \
+ -variable ed(mark) -value 0
+ ttk::radiobutton $f.marknz -text [msgcat::mc {Non-zero}] \
+ -variable ed(mark) -value 1
+ ttk::label $f.marktitle2 -text [msgcat::mc {Value}]
+
+ grid $f.colortitle $f.colorbutton - -padx 2 -pady 2 -sticky w
+ grid $f.marktitle $f.markz $f.marknz $f.marktitle2 -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set mask(color) [string tolower $ed(color)]
+ set mask(mark) $ed(mark)
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc MaskBackup {ch which} {
+ puts $ch "$which mask color [$which get mask color]"
+ puts $ch "$which mask mark [$which get mask mark]"
+ puts $ch "$which mask transparency [$which get mask transparency]"
+}
+
+proc ProcessMaskCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global mask
+ global current
+
+ set rr {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {MaskDialog}
+ close {MaskDestroyDialog}
+ color {
+ incr i
+ set mask(color) [lindex $var $i]
+ if {$current(frame) != {}} {
+ $current(frame) mask color $mask(color)
+ }
+ }
+ mark {
+ incr i
+ set mask(mark) [lindex $var $i]
+ if {$current(frame) != {}} {
+ $current(frame) mask mark $mask(mark)
+ }
+ }
+ transparency {
+ incr i
+ set mask(transparency) [lindex $var $i]
+ if {$current(frame) != {}} {
+ $current(frame) mask transparency $mask(transparency)
+ }
+ MaskTransparency
+ }
+ clear {
+ MaskClear
+ }
+
+ default {
+ set rr mask
+ incr i -1
+ }
+ }
+
+ return $rr
+}
+
+proc ProcessSendMaskCmd {proc id param} {
+ global mask
+
+ switch -- [string tolower $param] {
+ color {$proc $id "$mask(color)\n"}
+ mark {$proc $id "$mask(mark)\n"}
+ transparency {$proc $id "$mask(transparency)\n"}
+ }
+}
+
diff --git a/ds9/library/mbin.tcl b/ds9/library/mbin.tcl
new file mode 100644
index 0000000..cfdb21d
--- /dev/null
+++ b/ds9/library/mbin.tcl
@@ -0,0 +1,341 @@
+# 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
+
+# Menu
+
+proc BinMainMenu {} {
+ global ds9
+
+ menu $ds9(mb).bin
+ $ds9(mb).bin add radiobutton -label [msgcat::mc {Average}] \
+ -variable bin(function) -value average -command ChangeBinFunction
+ $ds9(mb).bin add radiobutton -label [msgcat::mc {Sum}] \
+ -variable bin(function) -value sum -command ChangeBinFunction
+ $ds9(mb).bin add separator
+ $ds9(mb).bin add command -label [msgcat::mc {Bin In}] \
+ -command {Bin .5 .5}
+ $ds9(mb).bin add command -label [msgcat::mc {Bin Out}] \
+ -command {Bin 2 2}
+ $ds9(mb).bin add command -label [msgcat::mc {Bin Fit}] \
+ -command BinToFit
+ $ds9(mb).bin add separator
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 1" \
+ -variable bin(factor) -value { 1 1 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 2" \
+ -variable bin(factor) -value { 2 2 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 4" \
+ -variable bin(factor) -value { 4 4 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 8" \
+ -variable bin(factor) -value { 8 8 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 16" \
+ -variable bin(factor) -value { 16 16 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 32" \
+ -variable bin(factor) -value { 32 32 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 64" \
+ -variable bin(factor) -value { 64 64 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 128" \
+ -variable bin(factor) -value { 128 128 } -command ChangeBinFactor
+ $ds9(mb).bin add radiobutton -label "[msgcat::mc {Bin}] 256" \
+ -variable bin(factor) -value { 256 256 } -command ChangeBinFactor
+ $ds9(mb).bin add separator
+ $ds9(mb).bin add radiobutton -label {128x128} \
+ -variable bin(buffersize) -value 128 -command ChangeBinBufferSize
+ $ds9(mb).bin add radiobutton -label {256x256} \
+ -variable bin(buffersize) -value 256 -command ChangeBinBufferSize
+ $ds9(mb).bin add radiobutton -label {512x512} \
+ -variable bin(buffersize) -value 512 -command ChangeBinBufferSize
+ $ds9(mb).bin add radiobutton -label {1024x1024} \
+ -variable bin(buffersize) -value 1024 -command ChangeBinBufferSize
+ $ds9(mb).bin add radiobutton -label {2048x2048} \
+ -variable bin(buffersize) -value 2048 -command ChangeBinBufferSize
+ $ds9(mb).bin add radiobutton -label {4096x4096} \
+ -variable bin(buffersize) -value 4096 -command ChangeBinBufferSize
+ $ds9(mb).bin add radiobutton -label {8192x8192} \
+ -variable bin(buffersize) -value 8192 -command ChangeBinBufferSize
+ $ds9(mb).bin add separator
+ $ds9(mb).bin add command -label "[msgcat::mc {Binning Parameters}]..." \
+ -command BinDialog
+}
+
+proc PrefsDialogBinMenu {w} {
+ set f [ttk::labelframe $w.mbin -text [msgcat::mc {Bin}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarBin $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {Average}] \
+ -variable pbin(function) -value average
+ $m add radiobutton -label [msgcat::mc {Sum}] \
+ -variable pbin(function) -value sum
+ $m add separator
+ $m add radiobutton -label "[msgcat::mc {Bin}] 1" \
+ -variable pbin(factor) -value { 1 1 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 2" \
+ -variable pbin(factor) -value { 2 2 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 4" \
+ -variable pbin(factor) -value { 4 4 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 8" \
+ -variable pbin(factor) -value { 8 8 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 16" \
+ -variable pbin(factor) -value { 16 16 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 32" \
+ -variable pbin(factor) -value { 32 32 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 64" \
+ -variable pbin(factor) -value { 64 64 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 128" \
+ -variable pbin(factor) -value { 128 128 }
+ $m add radiobutton -label "[msgcat::mc {Bin}] 256" \
+ -variable pbin(factor) -value { 256 256 }
+ $m add separator
+ $m add radiobutton -label {128x128} -variable pbin(buffersize) -value 128
+ $m add radiobutton -label {256x256} -variable pbin(buffersize) -value 256
+ $m add radiobutton -label {512x512} -variable pbin(buffersize) -value 512
+ $m add radiobutton -label {1024x1204} -variable pbin(buffersize) -value 1024
+ $m add radiobutton -label {2048x2048} -variable pbin(buffersize) -value 2048
+ $m add radiobutton -label {4096x4096} -variable pbin(buffersize) -value 4096
+ $m add radiobutton -label {8192x8192} -variable pbin(buffersize) -value 8192
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogBin {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Bin}]
+ lappend dprefs(tabs) [ttk::frame $w.bin]
+
+ # Mouse
+ set f [ttk::labelframe $w.bin.mouse -text [msgcat::mc {Mouse Wheel Bin}]]
+
+ ttk::checkbutton $f.click -text [msgcat::mc {Enable}] \
+ -variable pbin(wheel)
+ ttk::label $f.title2 -text [msgcat::mc {Factor}]
+ ttk::entry $f.factor -textvariable pbin(wheel,factor) -width 10
+
+ grid $f.click $f.title2 $f.factor -padx 2 -pady 2 -sticky w
+
+ pack $w.bin.mouse -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsBinDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ bin,average 0
+ bin,sum 0
+ bin,in 1
+ bin,out 1
+ bin,fit 1
+ bin,1 1
+ bin,2 1
+ bin,4 1
+ bin,8 1
+ bin,16 1
+ bin,32 1
+ bin,64 1
+ bin,128 0
+ bin,256 0
+ bin,128x 0
+ bin,256x 0
+ bin,512x 0
+ bin,1024x 0
+ bin,2048x 0
+ bin,4096x 0
+ bin,8192x 0
+ bin,params 0
+ }
+}
+
+proc CreateButtonsBin {} {
+ global buttons
+ global ds9
+
+ ttk::frame $ds9(buttons).bin
+
+ RadioButton $ds9(buttons).bin.average \
+ [string tolower [msgcat::mc {Average}]] \
+ bin(function) average ChangeBinFunction
+ RadioButton $ds9(buttons).bin.sum \
+ [string tolower [msgcat::mc {Sum}]] \
+ bin(function) sum ChangeBinFunction
+
+ ButtonButton $ds9(buttons).bin.in \
+ [string tolower [msgcat::mc {Bin In}]] {Bin .5 .5}
+ ButtonButton $ds9(buttons).bin.out \
+ [string tolower [msgcat::mc {Bin Out}]] {Bin 2 2}
+ ButtonButton $ds9(buttons).bin.fit \
+ [string tolower [msgcat::mc {Bin Fit}]] BinToFit
+
+ RadioButton $ds9(buttons).bin.1 \
+ "[string tolower [msgcat::mc {Bin}]] 1" \
+ bin(factor) { 1 1 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.2 \
+ "[string tolower [msgcat::mc {Bin}]] 2" \
+ bin(factor) { 2 2 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.4 \
+ "[string tolower [msgcat::mc {Bin}]] 4" \
+ bin(factor) { 4 4 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.8 \
+ "[string tolower [msgcat::mc {Bin}]] 8" \
+ bin(factor) { 8 8 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.16 \
+ "[string tolower [msgcat::mc {Bin}]] 16" \
+ bin(factor) { 16 16 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.32 \
+ "[string tolower [msgcat::mc {Bin}]] 32" \
+ bin(factor) { 32 32 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.64 \
+ "[string tolower [msgcat::mc {Bin}]] 64" \
+ bin(factor) { 64 64 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.128 \
+ "[string tolower [msgcat::mc {Bin}]] 128" \
+ bin(factor) { 128 128 } ChangeBinFactor
+ RadioButton $ds9(buttons).bin.256 \
+ "[string tolower [msgcat::mc {Bin}]] 256" \
+ bin(factor) { 256 256 } ChangeBinFactor
+
+ RadioButton $ds9(buttons).bin.128x {128x128} \
+ bin(buffersize) 128 ChangeBinBufferSize
+ RadioButton $ds9(buttons).bin.256x {256x256} \
+ bin(buffersize) 256 ChangeBinBufferSize
+ RadioButton $ds9(buttons).bin.512x {512x512} \
+ bin(buffersize) 512 ChangeBinBufferSize
+ RadioButton $ds9(buttons).bin.1024x {1024x1024} \
+ bin(buffersize) 1024 ChangeBinBufferSize
+ RadioButton $ds9(buttons).bin.2048x {2048x2048} \
+ bin(buffersize) 2048 ChangeBinBufferSize
+ RadioButton $ds9(buttons).bin.4096x {4096x4096} \
+ bin(buffersize) 4096 ChangeBinBufferSize
+ RadioButton $ds9(buttons).bin.8192x {8192x8192} \
+ bin(buffersize) 8192 ChangeBinBufferSize
+
+ ButtonButton $ds9(buttons).bin.params \
+ [string tolower [msgcat::mc {Parameters}]] BinDialog
+
+ set buttons(bin) "
+ $ds9(buttons).bin.average pbuttons(bin,average)
+ $ds9(buttons).bin.sum pbuttons(bin,sum)
+ $ds9(buttons).bin.in pbuttons(bin,in)
+ $ds9(buttons).bin.out pbuttons(bin,out)
+ $ds9(buttons).bin.fit pbuttons(bin,fit)
+ $ds9(buttons).bin.1 pbuttons(bin,1)
+ $ds9(buttons).bin.2 pbuttons(bin,2)
+ $ds9(buttons).bin.4 pbuttons(bin,4)
+ $ds9(buttons).bin.8 pbuttons(bin,8)
+ $ds9(buttons).bin.16 pbuttons(bin,16)
+ $ds9(buttons).bin.32 pbuttons(bin,32)
+ $ds9(buttons).bin.64 pbuttons(bin,64)
+ $ds9(buttons).bin.128 pbuttons(bin,128)
+ $ds9(buttons).bin.256 pbuttons(bin,256)
+ $ds9(buttons).bin.128x pbuttons(bin,128x)
+ $ds9(buttons).bin.256x pbuttons(bin,256x)
+ $ds9(buttons).bin.512x pbuttons(bin,512x)
+ $ds9(buttons).bin.1024x pbuttons(bin,1024x)
+ $ds9(buttons).bin.2048x pbuttons(bin,2048x)
+ $ds9(buttons).bin.4096x pbuttons(bin,4096x)
+ $ds9(buttons).bin.8192x pbuttons(bin,8192x)
+ $ds9(buttons).bin.params pbuttons(bin,params)
+ "
+}
+
+proc PrefsDialogButtonbarBin {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Average}] \
+ -variable pbuttons(bin,average) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label [msgcat::mc {Sum}] \
+ -variable pbuttons(bin,sum) -command {UpdateButtons buttons(bin)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Bin In}] \
+ -variable pbuttons(bin,in) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label [msgcat::mc {Bin Out}] \
+ -variable pbuttons(bin,out) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label [msgcat::mc {Bin Fit}] \
+ -variable pbuttons(bin,fit) -command {UpdateButtons buttons(bin)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Bin}] 1" \
+ -variable pbuttons(bin,1) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 2" \
+ -variable pbuttons(bin,2) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 4" \
+ -variable pbuttons(bin,4) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 8" \
+ -variable pbuttons(bin,8) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 16" \
+ -variable pbuttons(bin,16) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 32" \
+ -variable pbuttons(bin,32) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 64" \
+ -variable pbuttons(bin,64) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 128" \
+ -variable pbuttons(bin,128) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label "[msgcat::mc {Bin}] 256" \
+ -variable pbuttons(bin,256) -command {UpdateButtons buttons(bin)}
+ $m add separator
+ $m add checkbutton -label {128x128} \
+ -variable pbuttons(bin,128x) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label {256x256} \
+ -variable pbuttons(bin,256x) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label {512x512} \
+ -variable pbuttons(bin,512x) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label {1024x1204} \
+ -variable pbuttons(bin,1024x) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label {2048x2048} \
+ -variable pbuttons(bin,2048x) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label {4096x4096} \
+ -variable pbuttons(bin,4096x) -command {UpdateButtons buttons(bin)}
+ $m add checkbutton -label {8192x8192} \
+ -variable pbuttons(bin,8192x) -command {UpdateButtons buttons(bin)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Binning Parameters}]..." \
+ -variable pbuttons(bin,params) -command {UpdateButtons buttons(bin)}
+}
+
+# Support
+
+proc UpdateBinMenu {} {
+ global ds9
+ global current
+ global bin
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateBinMenu"
+ }
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ if {[$current(frame) has fits bin]} {
+ $ds9(mb) entryconfig [msgcat::mc {Bin}] -state normal
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Bin}] -state disabled
+ }
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Bin}] -state normal
+ }
+
+ set bin(function) [$current(frame) get bin function]
+ set bin(factor) "[$current(frame) get bin factor]"
+ set bin(depth) [$current(frame) get bin depth]
+ set bin(buffersize) [$current(frame) get bin buffer size]
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Bin}] -state disabled
+ }
+}
+
diff --git a/ds9/library/mcolor.tcl b/ds9/library/mcolor.tcl
new file mode 100644
index 0000000..782b451
--- /dev/null
+++ b/ds9/library/mcolor.tcl
@@ -0,0 +1,498 @@
+# 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
+
+# Menus
+
+# Default colormap names
+# [msgcat::mc {grey}]
+# [msgcat::mc {red}]
+# [msgcat::mc {green}]
+# [msgcat::mc {blue}]
+# [msgcat::mc {heat}]
+# [msgcat::mc {cool}]
+# [msgcat::mc {rainbow}]
+# [msgcat::mc {standard}]
+# [msgcat::mc {staircase}]
+# [msgcat::mc {color}]
+
+proc ColorMainMenu {} {
+ global colorbar
+ global icolorbar
+ global ds9
+
+ menu $ds9(mb).color
+
+ set id [colorbar list id]
+ # base
+ foreach jj $id {
+ set name [colorbar get name $jj]
+ $ds9(mb).color add radiobutton \
+ -label [msgcat::mc $name] \
+ -variable colorbar(map) -value $name \
+ -command "ChangeColormapID $jj"
+ incr icolorbar(count)
+ }
+
+ set icolorbar(end) $icolorbar(count)
+ set icolorbar(h5) $icolorbar(count)
+ set icolorbar(matplotlib) $icolorbar(count)
+ set icolorbar(cubehelix) $icolorbar(count)
+ set icolorbar(gist) $icolorbar(count)
+ set icolorbar(topo) $icolorbar(count)
+ set icolorbar(user) $icolorbar(count)
+
+ $ds9(mb).color add separator
+ $ds9(mb).color add cascade -label [msgcat::mc {h5utils}] \
+ -menu $ds9(mb).color.h5
+ $ds9(mb).color add cascade -label [msgcat::mc {Matplotlib}] \
+ -menu $ds9(mb).color.matplotlib
+ $ds9(mb).color add cascade -label [msgcat::mc {Cubehelix}] \
+ -menu $ds9(mb).color.cubehelix
+ $ds9(mb).color add cascade -label [msgcat::mc {Gist}] \
+ -menu $ds9(mb).color.gist
+ $ds9(mb).color add cascade -label [msgcat::mc {Topographic}] \
+ -menu $ds9(mb).color.topo
+ $ds9(mb).color add cascade -label [msgcat::mc {User}] \
+ -menu $ds9(mb).color.user
+ $ds9(mb).color add separator
+ $ds9(mb).color add checkbutton -label [msgcat::mc {Invert Colormap}] \
+ -variable colorbar(invert) -command InvertColorbar
+ $ds9(mb).color add command -label [msgcat::mc {Reset Colormap}] \
+ -command ResetColormap
+ $ds9(mb).color add separator
+ $ds9(mb).color add cascade -label [msgcat::mc {Colorbar}] \
+ -menu $ds9(mb).color.colorbar
+ $ds9(mb).color add separator
+ $ds9(mb).color add command -label "[msgcat::mc {Colormap Parameters}]..." \
+ -command ColormapDialog
+
+ menu $ds9(mb).color.h5
+ menu $ds9(mb).color.matplotlib
+ menu $ds9(mb).color.cubehelix
+ menu $ds9(mb).color.gist
+ menu $ds9(mb).color.topo
+ menu $ds9(mb).color.user
+
+ menu $ds9(mb).color.colorbar
+ $ds9(mb).color.colorbar add cascade -label [msgcat::mc {Orientation}] \
+ -menu $ds9(mb).color.colorbar.orient
+ $ds9(mb).color.colorbar add cascade -label [msgcat::mc {Numerics}] \
+ -menu $ds9(mb).color.colorbar.numerics
+ $ds9(mb).color.colorbar add cascade -label [msgcat::mc {Font}] \
+ -menu $ds9(mb).color.colorbar.cb
+ $ds9(mb).color.colorbar add separator
+ $ds9(mb).color.colorbar add command \
+ -label "[msgcat::mc {Size}]..." \
+ -command ColorbarSizeDialog
+ $ds9(mb).color.colorbar add command \
+ -label "[msgcat::mc {Number of Ticks}]..." \
+ -command TicksDialog
+
+ menu $ds9(mb).color.colorbar.orient
+ $ds9(mb).color.colorbar.orient add radiobutton \
+ -label [msgcat::mc {Horizontal}] -variable colorbar(orientation) \
+ -value horizontal -command UpdateView
+ $ds9(mb).color.colorbar.orient add radiobutton \
+ -label [msgcat::mc {Vertical}] -variable colorbar(orientation) \
+ -value vertical -command UpdateView
+
+ menu $ds9(mb).color.colorbar.numerics
+ $ds9(mb).color.colorbar.numerics add checkbutton \
+ -label [msgcat::mc {Show}] -variable colorbar(numerics) \
+ -command UpdateView
+ $ds9(mb).color.colorbar.numerics add separator
+ $ds9(mb).color.colorbar.numerics add radiobutton \
+ -label [msgcat::mc {Space Equal Value}] -variable colorbar(space) \
+ -value 1 -command UpdateView
+ $ds9(mb).color.colorbar.numerics add radiobutton \
+ -label [msgcat::mc {Space Equal Distance}] -variable colorbar(space) \
+ -value 0 -command UpdateView
+
+ FontMenu $ds9(mb).color.colorbar.cb colorbar font font,size font,weight \
+ font,slant UpdateView
+
+ CreateExColorMenu h5
+ CreateExColorMenu matplotlib
+ CreateExColorMenu cubehelix
+ CreateExColorMenu gist
+ CreateExColorMenu topo
+ CreateExColorMenu user
+}
+
+proc CreateExColorMenu {which} {
+ global ds9
+ global icolorbar
+
+ # save start location
+ set icolorbar($which) $icolorbar(count)
+
+ foreach fn $icolorbar($which,fn) {
+ if {[lindex $fn 0] == {-}} {
+ $ds9(mb).color.$which add separator
+ } else {
+ set ch [open "$ds9(root)/cmaps/$fn" r]
+ global vardata
+ set vardata [read $ch]
+ close $ch
+
+ colorbar load var "\{$fn\}" vardata
+ set id [colorbar get id]
+ set map [colorbar get name]
+ incr icolorbar(count)
+
+ $ds9(mb).color.$which add radiobutton \
+ -label "$map" \
+ -variable colorbar(map) \
+ -command [list ChangeColormapID $id]
+ }
+ }
+}
+
+proc PrefsDialogColorMenu {w} {
+ global colorbar
+ global icolorbar
+ global pcolorbar
+
+ set f [ttk::labelframe $w.mcolor -text [msgcat::mc {Color}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarColor $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2 -sticky w
+
+ set m $f.menu.menu
+ menu $m
+
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ $m add radiobutton -label [msgcat::mc $name] \
+ -variable pcolorbar(map) -value $name
+ }
+
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Invert Colormap}] \
+ -variable pcolorbar(invert)
+ $m add separator
+ $m add cascade -label [msgcat::mc {Colorbar}] -menu $m.colorbar
+
+ menu $m.colorbar
+ $m.colorbar add cascade -label [msgcat::mc {Orientation}] \
+ -menu $m.colorbar.orient
+ $m.colorbar add cascade -label [msgcat::mc {Numerics}] \
+ -menu $m.colorbar.numerics
+ $m.colorbar add cascade -label [msgcat::mc {Font}] \
+ -menu $m.colorbar.cb
+
+ menu $m.colorbar.orient
+ $m.colorbar.orient add radiobutton -label [msgcat::mc {Horizontal}] \
+ -variable pcolorbar(orientation) -value horizontal
+ $m.colorbar.orient add radiobutton -label [msgcat::mc {Vertical}] \
+ -variable pcolorbar(orientation) -value vertical
+
+ menu $m.colorbar.numerics
+ $m.colorbar.numerics add checkbutton -label [msgcat::mc {Show}] \
+ -variable pcolorbar(numerics)
+ $m.colorbar.numerics add separator
+ $m.colorbar.numerics add radiobutton \
+ -label [msgcat::mc {Space Equal Value}] \
+ -variable pcolorbar(space) -value 1
+ $m.colorbar.numerics add radiobutton \
+ -label [msgcat::mc {Space Equal Distance}] \
+ -variable pcolorbar(space) -value 0
+
+ FontMenu $m.colorbar.cb pcolorbar font font,size font,weight \
+ font,slant {}
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogColor {} {
+ global dprefs
+ global colorbar
+ global icolorbar
+ global pcolorbar
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Color}]
+ lappend dprefs(tabs) [ttk::frame $w.color]
+
+ set f [ttk::labelframe $w.color.colorbar -text [msgcat::mc {Colorbar}]]
+
+ ttk::label $f.tsize -text [msgcat::mc {Colorbar Size}]
+ ttk::entry $f.size -textvariable pcolorbar(size) -width 10
+
+ ttk::label $f.tticks -text [msgcat::mc {Number of Ticks}]
+ ttk::entry $f.ticks -textvariable pcolorbar(ticks) -width 10
+
+ ttk::label $f.tcolor -text [msgcat::mc {Tag Color}]
+ ColorMenuButton $f.color pcolorbar tag {}
+
+ grid $f.tsize $f.size -padx 2 -pady 2 -sticky w
+ grid $f.tticks $f.ticks -padx 2 -pady 2 -sticky w
+ grid $f.tcolor $f.color -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsColorDef {} {
+ global pbuttons
+
+ # we have a chicken or the egg problem
+ # the colorbar has not been defined yet, but we must define vars
+ # before prefs are processed, so hard code all default cmaps
+ array set pbuttons {
+ color,grey 1
+ color,red 0
+ color,green 0
+ color,blue 0
+ color,a 1
+ color,b 1
+ color,bb 1
+ color,he 1
+ color,i8 1
+ color,aips0 1
+ color,sls 0
+ color,hsv 0
+ color,heat 1
+ color,cool 1
+ color,rainbow 1
+ color,standard 0
+ color,staircase 0
+ color,color 0
+ color,invert 0
+ color,reset 0
+ color,horz 0
+ color,vert 0
+ color,numerics 0
+ color,numvalue 0
+ color,numspace 0
+ color,params 0
+ }
+}
+
+proc CreateButtonsColor {} {
+ global buttons
+ global ds9
+ global colorbar
+ global icolorbar
+
+ ttk::frame $ds9(buttons).color
+
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ RadioButton $ds9(buttons).color.$name [msgcat::mc $name] \
+ colorbar(map) $name "ChangeColormapID $jj"
+ }
+
+ CheckButton $ds9(buttons).color.invert \
+ [string tolower [msgcat::mc {Invert}]] colorbar(invert) InvertColorbar
+ ButtonButton $ds9(buttons).color.reset \
+ [string tolower [msgcat::mc {Reset}]] ResetColormap
+ RadioButton $ds9(buttons).color.horz \
+ [string tolower [msgcat::mc {Horizontal}]] \
+ colorbar(orientation) horizontal UpdateView
+ RadioButton $ds9(buttons).color.vert \
+ [string tolower [msgcat::mc {Vertical}]] \
+ colorbar(orientation) vertical UpdateView
+ CheckButton $ds9(buttons).color.numerics \
+ [string tolower [msgcat::mc {Numerics}]] \
+ colorbar(numerics) UpdateView
+ RadioButton $ds9(buttons).color.numvalue \
+ [string tolower [msgcat::mc {Value}]] \
+ colorbar(space) 1 UpdateView
+ RadioButton $ds9(buttons).color.numspace \
+ [string tolower [msgcat::mc {Distance}]] \
+ colorbar(space) 0 UpdateView
+
+ ButtonButton $ds9(buttons).color.params \
+ [string tolower [msgcat::mc {Parameters}]] ColormapDialog
+
+ set buttons(color) {}
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ append buttons(color) "$ds9(buttons).color.$name pbuttons(color,$name) "
+ }
+
+ append buttons(color) "$ds9(buttons).color.invert pbuttons(color,invert) "
+ append buttons(color) "$ds9(buttons).color.reset pbuttons(color,reset) "
+ append buttons(color) "$ds9(buttons).color.horz pbuttons(color,horz) "
+ append buttons(color) "$ds9(buttons).color.vert pbuttons(color,vert) "
+ append buttons(color) "$ds9(buttons).color.numerics pbuttons(color,numerics) "
+ append buttons(color) "$ds9(buttons).color.numvalue pbuttons(color,numvalue) "
+ append buttons(color) "$ds9(buttons).color.numspace pbuttons(color,numspace) "
+ append buttons(color) "$ds9(buttons).color.params pbuttons(color,params) "
+}
+
+proc PrefsDialogButtonbarColor {f} {
+ global icolorbar
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ $m add checkbutton -label [msgcat::mc $name] \
+ -variable pbuttons(color,$name) \
+ -command {UpdateButtons buttons(color)}
+ }
+
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Invert Colormap}] \
+ -variable pbuttons(color,invert) \
+ -command {UpdateButtons buttons(color)}
+ $m add checkbutton -label [msgcat::mc {Reset Colormap}] \
+ -variable pbuttons(color,reset) \
+ -command {UpdateButtons buttons(color)}
+ $m add separator
+ $m add cascade -label [msgcat::mc {Colorbar}] -menu $m.colorbar
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Colormap Parameters}]..." \
+ -variable pbuttons(color,params) \
+ -command {UpdateButtons buttons(color)}
+
+ menu $m.colorbar
+ $m.colorbar add cascade -label [msgcat::mc {Orientation}] \
+ -menu $m.colorbar.orient
+ $m.colorbar add cascade -label [msgcat::mc {Numerics}] \
+ -menu $m.colorbar.numerics
+
+ menu $m.colorbar.orient
+ $m.colorbar.orient add checkbutton -label [msgcat::mc {Horizontal}] \
+ -variable pbuttons(color,horz) \
+ -command {UpdateButtons buttons(color)}
+ $m.colorbar.orient add checkbutton -label [msgcat::mc {Vertical}] \
+ -variable pbuttons(color,vert) \
+ -command {UpdateButtons buttons(color)}
+
+ menu $m.colorbar.numerics
+ $m.colorbar.numerics add checkbutton -label [msgcat::mc {Show}] \
+ -variable pbuttons(color,numerics) \
+ -command {UpdateButtons buttons(color)}
+ $m.colorbar.numerics add separator
+ $m.colorbar.numerics add checkbutton -label [msgcat::mc {Equal Value}] \
+ -variable pbuttons(color,numvalue) \
+ -command {UpdateButtons buttons(color)}
+ $m.colorbar.numerics add checkbutton -label [msgcat::mc {Equal Spacing}] \
+ -variable pbuttons(color,numspace) \
+ -command {UpdateButtons buttons(color)}
+}
+
+# Support
+
+proc UpdateColorMenu {} {
+ global icolorbar
+ global ds9
+ global current
+ global buttons
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateColorMenu"
+ }
+
+ set end [expr $icolorbar(end)+$icolorbar(start)]
+ if {$current(frame) != {}} {
+ switch [$current(frame) get type] {
+ base -
+ 3d {
+ # menus
+ # base
+ for {set ii $icolorbar(start)} {$ii<$end} {incr ii} {
+ $ds9(mb).color entryconfig $ii -state normal
+ }
+ $ds9(mb).color entryconfig [msgcat::mc {h5utils}] \
+ -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Matplotlib}] \
+ -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Cubehelix}] \
+ -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Gist}] \
+ -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Topographic}] \
+ -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {User}] \
+ -state normal
+
+ # buttons
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ $ds9(buttons).color.$name configure -state normal
+ }
+ }
+ rgb {
+ # menus
+ # base
+ for {set ii $icolorbar(start)} {$ii<$end} {incr ii} {
+ $ds9(mb).color entryconfig $ii -state disabled
+ }
+ $ds9(mb).color entryconfig [msgcat::mc {h5utils}] \
+ -state disabled
+ $ds9(mb).color entryconfig [msgcat::mc {Matplotlib}] \
+ -state disabled
+ $ds9(mb).color entryconfig [msgcat::mc {Cubehelix}] \
+ -state disabled
+ $ds9(mb).color entryconfig [msgcat::mc {Gist}] \
+ -state disabled
+ $ds9(mb).color entryconfig [msgcat::mc {Topographic}] \
+ -state disabled
+ $ds9(mb).color entryconfig [msgcat::mc {User}] \
+ -state disable
+
+ # buttons
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ $ds9(buttons).color.$name configure -state disabled
+ }
+ }
+ }
+ } else {
+ # menus
+ # base
+ for {set ii $icolorbar(start)} {$ii<$end} {incr ii} {
+ $ds9(mb).color entryconfig $ii -state normal
+ }
+ $ds9(mb).color entryconfig [msgcat::mc {h5utils}] -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Matplotlib}] -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Cubehelix}] -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Gist}] -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {Topographic}] -state normal
+ $ds9(mb).color entryconfig [msgcat::mc {User}] -state normal
+
+ # buttons
+ set id [colorbar list id]
+ # base
+ for {set ii 0} {$ii<$icolorbar(end)} {incr ii} {
+ set jj [lindex $id $ii]
+ set name [colorbar get name $jj]
+ $ds9(buttons).color.$name configure -state normal
+ }
+ }
+}
diff --git a/ds9/library/mecube.tcl b/ds9/library/mecube.tcl
new file mode 100644
index 0000000..824497a
--- /dev/null
+++ b/ds9/library/mecube.tcl
@@ -0,0 +1,133 @@
+# 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 LoadMECubeFile {fn} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {ext cube}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadMECubeAlloc {path fn} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {ext cube}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc LoadMECubeSocket {sock fn} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {ext cube}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ return [ProcessLoad 0]
+}
+
+proc SaveMECubeFile {fn} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits ext cube file "\{$fn\}"
+}
+
+proc SaveMECubeSocket {sock} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits ext cube socket $sock
+}
+
+proc ProcessMECubeCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadMECubeSocket $sock $param]} {
+ InitError xpa
+ LoadMECubeFile $param
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMECubeAlloc $fn $param
+ } else {
+ LoadMECubeFile $param
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendMECubeCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {$sock != {}} {
+ # xpa
+ SaveMECubeSocket $sock
+ } elseif {$fn != {}} {
+ # comm
+ SaveMECubeFile $fn
+ $proc $id {} $fn
+ }
+}
diff --git a/ds9/library/medit.tcl b/ds9/library/medit.tcl
new file mode 100644
index 0000000..7177e17
--- /dev/null
+++ b/ds9/library/medit.tcl
@@ -0,0 +1,321 @@
+# 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
+
+# Menus
+
+proc EditMainMenu {} {
+ global ds9
+ global current
+
+ menu $ds9(mb).edit
+ $ds9(mb).edit add command -label [msgcat::mc {Undo}] -command UndoFrame \
+ -accelerator "${ds9(ctrl)}Z"
+ $ds9(mb).edit add separator
+ $ds9(mb).edit add command -label [msgcat::mc {Cut}] -command CutFrame \
+ -accelerator "${ds9(ctrl)}X"
+ $ds9(mb).edit add command -label [msgcat::mc {Copy}] -command CopyFrame \
+ -accelerator "${ds9(ctrl)}C"
+ $ds9(mb).edit add command -label [msgcat::mc {Paste}] -command PasteFrame \
+ -accelerator "${ds9(ctrl)}V"
+ $ds9(mb).edit add separator
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {None}] \
+ -variable current(mode) -value none -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Region}] \
+ -variable current(mode) -value region -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Crosshair}] \
+ -variable current(mode) -value crosshair -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Colorbar}] \
+ -variable current(mode) -value colorbar -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Pan}] \
+ -variable current(mode) -value pan -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Zoom}] \
+ -variable current(mode) -value zoom -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Rotate}] \
+ -variable current(mode) -value rotate -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Crop}] \
+ -variable current(mode) -value crop -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Catalog}] \
+ -variable current(mode) -value catalog -command ChangeMode
+# IME
+# $ds9(mb).edit add radiobutton -label [msgcat::mc {Analysis}]
+# -variable current(mode) -value analysis -command ChangeMode
+ $ds9(mb).edit add radiobutton -label [msgcat::mc {Examine}] \
+ -variable current(mode) -value examine -command ChangeMode
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(mb).edit add separator
+ $ds9(mb).edit add command -label "[msgcat::mc {Preferences}]..." \
+ -command PrefsDialog
+ }
+ aqua {}
+ }
+
+ # Bindings
+ bind $ds9(top) <<Undo>> UndoFrame
+ bind $ds9(top) <<Cut>> CutFrame
+ bind $ds9(top) <<Copy>> CopyFrame
+ bind $ds9(top) <<Paste>> PasteFrame
+}
+
+proc PrefsDialogEditMenu {w} {
+ global ds9
+
+ set f [ttk::labelframe $w.medit -text [msgcat::mc {Edit}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarEdit $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {None}] \
+ -variable pcurrent(mode) -value none
+ $m add radiobutton -label [msgcat::mc {Region}] \
+ -variable pcurrent(mode) -value region
+ $m add radiobutton -label [msgcat::mc {Crosshair}] \
+ -variable pcurrent(mode) -value crosshair
+ $m add radiobutton -label [msgcat::mc {Colorbar}] \
+ -variable pcurrent(mode) -value colorbar
+ $m add radiobutton -label [msgcat::mc {Pan}] \
+ -variable pcurrent(mode) -value pan
+ $m add radiobutton -label [msgcat::mc {Zoom}] \
+ -variable pcurrent(mode) -value zoom
+ $m add radiobutton -label [msgcat::mc {Rotate}] \
+ -variable pcurrent(mode) -value rotate
+ $m add radiobutton -label [msgcat::mc {Crop}] \
+ -variable pcurrent(mode) -value crop
+ $m add radiobutton -label [msgcat::mc {Catalog}] \
+ -variable pcurrent(mode) -value catalog
+# IME
+# $m add radiobutton -label [msgcat::mc {Analysis}]
+# -variable pcurrent(mode) -value analysis
+ $m add radiobutton -label [msgcat::mc {Examine}] \
+ -variable pcurrent(mode) -value examine
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsEditDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ edit,undo 0
+ edit,cut 0
+ edit,copy 0
+ edit,paste 0
+ edit,none 1
+ edit,region 1
+ edit,crosshair 1
+ edit,colorbar 1
+ edit,pan 1
+ edit,zoom 1
+ edit,rotate 1
+ edit,crop 1
+ edit,catalog 1
+ edit,examine 1
+ edit,prefs 0
+ }
+# IME
+# edit,analysis 1
+}
+
+proc CreateButtonsEdit {} {
+ global buttons
+ global ds9
+ global current
+
+ ttk::frame $ds9(buttons).edit
+
+ ButtonButton $ds9(buttons).edit.undo \
+ [string tolower [msgcat::mc {Undo}]] UndoFrame
+ ButtonButton $ds9(buttons).edit.cut \
+ [string tolower [msgcat::mc {Cut}]] CutFrame
+ ButtonButton $ds9(buttons).edit.copy \
+ [string tolower [msgcat::mc {Copy}]] CopyFrame
+ ButtonButton $ds9(buttons).edit.paste \
+ [string tolower [msgcat::mc {Paste}]] PasteFrame
+
+ RadioButton $ds9(buttons).edit.none \
+ [string tolower [msgcat::mc {None}]] \
+ current(mode) none ChangeMode
+ RadioButton $ds9(buttons).edit.region \
+ [string tolower [msgcat::mc {Region}]] \
+ current(mode) region ChangeMode
+ RadioButton $ds9(buttons).edit.crosshair \
+ [string tolower [msgcat::mc {Cross}]] \
+ current(mode) crosshair ChangeMode
+ RadioButton $ds9(buttons).edit.colorbar \
+ [string tolower [msgcat::mc {Colorbar}]] \
+ current(mode) colorbar ChangeMode
+ RadioButton $ds9(buttons).edit.pan \
+ [string tolower [msgcat::mc {Pan}]] \
+ current(mode) pan ChangeMode
+ RadioButton $ds9(buttons).edit.zoom \
+ [string tolower [msgcat::mc {Zoom}]] \
+ current(mode) zoom ChangeMode
+ RadioButton $ds9(buttons).edit.rotate \
+ [string tolower [msgcat::mc {Rotate}]] \
+ current(mode) rotate ChangeMode
+ RadioButton $ds9(buttons).edit.crop \
+ [string tolower [msgcat::mc {Crop}]] \
+ current(mode) crop ChangeMode
+ RadioButton $ds9(buttons).edit.catalog \
+ [string tolower [msgcat::mc {Cat}]] \
+ current(mode) catalog ChangeMode
+# IME
+# RadioButton $ds9(buttons).edit.analysis
+# [string tolower [msgcat::mc {Analysis}]]
+# current(mode) analysis ChangeMode
+ RadioButton $ds9(buttons).edit.examine \
+ [string tolower [msgcat::mc {Exam}]] \
+ current(mode) examine ChangeMode
+
+ ButtonButton $ds9(buttons).edit.prefs \
+ [string tolower [msgcat::mc {Preferences}]] PrefsDialog
+
+ set buttons(edit) "
+ $ds9(buttons).edit.undo pbuttons(edit,undo)
+ $ds9(buttons).edit.cut pbuttons(edit,cut)
+ $ds9(buttons).edit.copy pbuttons(edit,copy)
+ $ds9(buttons).edit.paste pbuttons(edit,paste)
+ $ds9(buttons).edit.none pbuttons(edit,none)
+ $ds9(buttons).edit.region pbuttons(edit,region)
+ $ds9(buttons).edit.crosshair pbuttons(edit,crosshair)
+ $ds9(buttons).edit.colorbar pbuttons(edit,colorbar)
+ $ds9(buttons).edit.pan pbuttons(edit,pan)
+ $ds9(buttons).edit.zoom pbuttons(edit,zoom)
+ $ds9(buttons).edit.rotate pbuttons(edit,rotate)
+ $ds9(buttons).edit.crop pbuttons(edit,crop)
+ $ds9(buttons).edit.catalog pbuttons(edit,catalog)
+ $ds9(buttons).edit.examine pbuttons(edit,examine)
+ $ds9(buttons).edit.prefs pbuttons(edit,prefs)
+ "
+# IME
+# $ds9(buttons).edit.analysis pbuttons(edit,analysis)
+}
+
+proc PrefsDialogButtonbarEdit {f} {
+ global ds9
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Undo}] \
+ -variable pbuttons(edit,undo) -command {UpdateButtons buttons(edit)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Cut}] \
+ -variable pbuttons(edit,cut) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Copy}] \
+ -variable pbuttons(edit,copy) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Paste}] \
+ -variable pbuttons(edit,paste) -command {UpdateButtons buttons(edit)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {None}] \
+ -variable pbuttons(edit,none) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Region}] \
+ -variable pbuttons(edit,region) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Crosshair}] \
+ -variable pbuttons(edit,crosshair) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Colorbar}] \
+ -variable pbuttons(edit,colorbar) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Pan}] \
+ -variable pbuttons(edit,pan) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Zoom}] \
+ -variable pbuttons(edit,zoom) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Rotate}] \
+ -variable pbuttons(edit,rotate) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Crop}] \
+ -variable pbuttons(edit,crop) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Catalog}] \
+ -variable pbuttons(edit,catalog) -command {UpdateButtons buttons(edit)}
+# IME
+# $m add checkbutton -label [msgcat::mc {Analysis}]
+# -variable pbuttons(edit,analysis) -command {UpdateButtons buttons(edit)}
+ $m add checkbutton -label [msgcat::mc {Examine}] \
+ -variable pbuttons(edit,examine) -command {UpdateButtons buttons(edit)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Preferences}] \
+ -variable pbuttons(edit,prefs) -command {UpdateButtons buttons(edit)}
+}
+
+# Support
+
+proc UpdateEditMenu {} {
+ global ds9
+ global current
+ global marker
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateEditMenu"
+ }
+
+ switch -- $current(mode) {
+ pointer -
+ region {
+ if {$current(frame) != {}} {
+ set l [$current(frame) has marker undo]
+ if {$l != {}} {
+ $ds9(mb).edit entryconfig [msgcat::mc {Undo}] \
+ -state normal
+ } else {
+ $ds9(mb).edit entryconfig [msgcat::mc {Undo}] \
+ -state disabled
+ }
+
+ if {[$current(frame) has marker select]} {
+ $ds9(mb).edit entryconfig [msgcat::mc {Cut}] \
+ -state normal
+ $ds9(mb).edit entryconfig [msgcat::mc {Copy}] \
+ -state normal
+ } else {
+ $ds9(mb).edit entryconfig [msgcat::mc {Cut}] \
+ -state disabled
+ $ds9(mb).edit entryconfig [msgcat::mc {Copy}] \
+ -state disabled
+ }
+
+ if {$marker(copy) != {} } {
+ if {[$marker(copy) has marker paste]} {
+ $ds9(mb).edit entryconfig [msgcat::mc {Paste}] \
+ -state normal
+ } else {
+ $ds9(mb).edit entryconfig [msgcat::mc {Paste}] \
+ -state disabled
+ }
+ } else {
+ $ds9(mb).edit entryconfig [msgcat::mc {Paste}] \
+ -state disabled
+ }
+ } else {
+ $ds9(mb).edit entryconfig [msgcat::mc {Undo}] -state disabled
+ $ds9(mb).edit entryconfig [msgcat::mc {Cut}] -state disabled
+ $ds9(mb).edit entryconfig [msgcat::mc {Copy}] -state disabled
+ $ds9(mb).edit entryconfig [msgcat::mc {Paste}] -state disabled
+ }
+ }
+ none -
+ crosshair -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ catalog -
+ analysis -
+ examine -
+ iexam {$ds9(mb).edit entryconfig [msgcat::mc {Undo}] -state disabled}
+ }
+}
+
diff --git a/ds9/library/menu.tcl b/ds9/library/menu.tcl
new file mode 100644
index 0000000..70997a5
--- /dev/null
+++ b/ds9/library/menu.tcl
@@ -0,0 +1,586 @@
+# 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 CreateMenuBar {} {
+ global ds9
+
+ # we need this first, before the configure command
+ menu $ds9(mb)
+ AppleMenu $ds9(mb)
+ $ds9(top) configure -menu $ds9(mb)
+
+ $ds9(mb) add cascade -label [msgcat::mc {File}] -menu $ds9(mb).file
+ $ds9(mb) add cascade -label [msgcat::mc {Edit}] -menu $ds9(mb).edit
+ $ds9(mb) add cascade -label [msgcat::mc {View}] -menu $ds9(mb).view
+ $ds9(mb) add cascade -label [msgcat::mc {Frame}] -menu $ds9(mb).frame
+ $ds9(mb) add cascade -label [msgcat::mc {Bin}] -menu $ds9(mb).bin
+ $ds9(mb) add cascade -label [msgcat::mc {Zoom}] -menu $ds9(mb).zoom
+ $ds9(mb) add cascade -label [msgcat::mc {Scale}] -menu $ds9(mb).scale
+ $ds9(mb) add cascade -label [msgcat::mc {Color}] -menu $ds9(mb).color
+ $ds9(mb) add cascade -label [msgcat::mc {Region}] -menu $ds9(mb).region
+ $ds9(mb) add cascade -label [msgcat::mc {WCS}] -menu $ds9(mb).wcs
+ $ds9(mb) add cascade -label [msgcat::mc {Analysis}] -menu $ds9(mb).analysis
+
+ FileMainMenu
+ EditMainMenu
+ ViewMainMenu
+ FrameMainMenu
+ BinMainMenu
+ ZoomMainMenu
+ ScaleMainMenu
+ ColorMainMenu
+ RegionMainMenu
+ WCSMainMenu
+ AnalysisMainMenu
+ HelpMainMenu
+}
+
+proc AppleMenu {mb} {
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ # apple menu
+ menu $mb.apple
+ $mb add cascade -menu $mb.apple
+ $mb.apple add command \
+ -label [msgcat::mc {About SAOImage DS9}] \
+ -command AboutBox
+# -command ::tk::mac::standardAboutPanel
+ }
+ }
+}
+
+# CoordMenu
+proc CoordMenu {w varname system other sky skyformat cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $w
+ $w add radiobutton -label [msgcat::mc {WCS}] \
+ -variable ${varname}($system) -value wcs -command $cmd
+ $w add cascade -label [msgcat::mc {Multiple WCS}] -menu $w.wcs
+ menu $w.wcs
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $w.wcs add radiobutton -label "[msgcat::mc {WCS}] $l" \
+ -variable ${varname}($system) -value "wcs$l" -command $cmd
+ }
+
+ switch -- $other {
+ 1 {
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Image}] \
+ -variable ${varname}($system) -value image -command $cmd
+ $w add radiobutton -label [msgcat::mc {Physical}] \
+ -variable ${varname}($system) -value physical -command $cmd
+ $w add radiobutton -label [msgcat::mc {Amplifier}] \
+ -variable ${varname}($system) -value amplifier -command $cmd
+ $w add radiobutton -label [msgcat::mc {Detector}] \
+ -variable ${varname}($system) -value detector -command $cmd
+ }
+ 2 {
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Image}] \
+ -variable ${varname}($system) -value image -command $cmd
+ }
+ }
+
+ if {$sky != {}} {
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {FK4}] \
+ -variable ${varname}($sky) -value fk4 -command $cmd
+ $w add radiobutton -label [msgcat::mc {FK5}] \
+ -variable ${varname}($sky) -value fk5 -command $cmd
+ $w add radiobutton -label [msgcat::mc {ICRS}] \
+ -variable ${varname}($sky) -value icrs -command $cmd
+ $w add radiobutton -label [msgcat::mc {Galactic}] \
+ -variable ${varname}($sky) -value galactic -command $cmd
+ $w add radiobutton -label [msgcat::mc {Ecliptic}] \
+ -variable ${varname}($sky) -value ecliptic -command $cmd
+ }
+
+ if {$skyformat != {}} {
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Degrees}] \
+ -variable ${varname}($skyformat) -value degrees -command $cmd
+ $w add radiobutton -label {Sexagesimal} \
+ -variable ${varname}($skyformat) -value sexagesimal -command $cmd
+ }
+}
+
+proc CoordMenuButton {w varname system other sky skyformat cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ CoordMenuButtonCmd $varname $system $sky {}
+ ttk::menubutton $w -textvariable ${varname}($system,msg) -menu $w.menu
+ CoordMenu $w.menu $varname $system $other $sky $skyformat \
+ [list CoordMenuButtonCmd $varname $system $sky $cmd]
+}
+
+proc CoordMenuButtonCmd {varname system sky cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}($system,msg) [msgcat::mc $var($system)]
+
+ if {$sky != {}} {
+ switch -- $var($system) {
+ image -
+ physical -
+ amplifier -
+ detector {}
+ default {
+ if {[info exists var(frame)]} {
+ if {$var(frame) != {}} {
+ if {[$var(frame) has wcs equatorial $var($system)]} {
+ set ${varname}($system,msg) [msgcat::mc $var($sky)]
+ }
+ }
+ }
+ }
+ }
+ }
+
+ if {$cmd != {}} {
+ eval $cmd
+ }
+}
+
+proc CoordMenuEnable {w varname system other sky skyformat} {
+ upvar #0 $varname var
+ global $varname
+
+ if {![info exists var(frame)]} {
+ return
+ }
+
+ if {$var(frame) == {}} {
+ return
+ }
+
+ if {[$var(frame) has wcs wcs]} {
+ $w entryconfig [msgcat::mc {WCS}] -state normal
+ } else {
+ $w entryconfig [msgcat::mc {WCS}] -state disabled
+ }
+
+ $w entryconfig [msgcat::mc {Multiple WCS}] -state normal
+
+ foreach ll {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ if {[$var(frame) has wcs "wcs${ll}"]} {
+ $w.wcs entryconfig "[msgcat::mc {WCS}] $ll" -state normal
+ } else {
+ $w.wcs entryconfig "[msgcat::mc {WCS}] $ll" -state disabled
+ }
+ }
+
+ switch -- $other {
+ 1 {
+ $w entryconfig [msgcat::mc {Image}] -state normal
+ $w entryconfig [msgcat::mc {Physical}] -state normal
+ $w entryconfig [msgcat::mc {Amplifier}] -state normal
+ $w entryconfig [msgcat::mc {Detector}] -state normal
+ }
+ 2 {
+ $w entryconfig [msgcat::mc {Image}] -state normal
+ }
+ }
+
+ if {$sky != {}} {
+ if {[$var(frame) has wcs equatorial $var($system)]} {
+ $w entryconfig [msgcat::mc {FK4}] -state normal
+ $w entryconfig [msgcat::mc {FK5}] -state normal
+ $w entryconfig [msgcat::mc {ICRS}] -state normal
+ $w entryconfig [msgcat::mc {Galactic}] -state normal
+ $w entryconfig [msgcat::mc {Ecliptic}] -state normal
+ } else {
+ $w entryconfig [msgcat::mc {FK4}] -state disabled
+ $w entryconfig [msgcat::mc {FK5}] -state disabled
+ $w entryconfig [msgcat::mc {ICRS}] -state disabled
+ $w entryconfig [msgcat::mc {Galactic}] -state disabled
+ $w entryconfig [msgcat::mc {Ecliptic}] -state disabled
+ }
+ }
+
+ if {$skyformat != {}} {
+ if {[$var(frame) has wcs celestrial $var($system)]} {
+ $w entryconfig [msgcat::mc {Degrees}] -state normal
+ $w entryconfig {Sexagesimal} -state normal
+ } else {
+ $w entryconfig [msgcat::mc {Degrees}] -state disabled
+ $w entryconfig {Sexagesimal} -state disabled
+ }
+ }
+}
+
+proc CoordMenuReset {w varname system other sky skyformat} {
+ upvar #0 $varname var
+ global $varname
+
+ $w entryconfig [msgcat::mc {WCS}] -state normal
+ $w entryconfig [msgcat::mc {Multiple WCS}] -state normal
+
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $w.wcs entryconfig "[msgcat::mc {WCS}] $l" -state normal
+ }
+
+ switch -- $other {
+ 1 {
+ $w entryconfig [msgcat::mc {Image}] -state normal
+ $w entryconfig [msgcat::mc {Physical}] -state normal
+ $w entryconfig [msgcat::mc {Amplifier}] -state normal
+ $w entryconfig [msgcat::mc {Detector}] -state normal
+ }
+ 2 {
+ $w entryconfig [msgcat::mc {Image}] -state normal
+ }
+ }
+
+ if {$sky != {}} {
+ $w entryconfig [msgcat::mc {FK4}] -state normal
+ $w entryconfig [msgcat::mc {FK5}] -state normal
+ $w entryconfig [msgcat::mc {ICRS}] -state normal
+ $w entryconfig [msgcat::mc {Galactic}] -state normal
+ $w entryconfig [msgcat::mc {Ecliptic}] -state normal
+ }
+
+ if {$skyformat != {}} {
+ $w entryconfig [msgcat::mc {Degrees}] -state normal
+ $w entryconfig {Sexagesimal} -state normal
+ }
+}
+
+# DistMenu
+proc DistMenu {w varname system other format cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $w
+ $w add radiobutton -label [msgcat::mc {WCS}] \
+ -variable ${varname}($system) -value wcs -command $cmd
+ $w add cascade -label [msgcat::mc {Multiple WCS}] \
+ -menu $w.wcs
+ menu $w.wcs
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $w.wcs add radiobutton -label "[msgcat::mc {WCS}] $l" \
+ -variable ${varname}($system) -value "wcs$l" -command $cmd
+ }
+
+ if {$other} {
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Image}] \
+ -variable ${varname}($system) -value image -command $cmd
+ $w add radiobutton -label [msgcat::mc {Physical}] \
+ -variable ${varname}($system) -value physical -command $cmd
+ $w add radiobutton -label [msgcat::mc {Amplifier}] \
+ -variable ${varname}($system) -value amplifier -command $cmd
+ $w add radiobutton -label [msgcat::mc {Detector}] \
+ -variable ${varname}($system) -value detector -command $cmd
+ }
+
+ if {$format != {}} {
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Degrees}] \
+ -variable ${varname}($format) -value degrees -command $cmd
+ $w add radiobutton -label [msgcat::mc {ArcMin}] \
+ -variable ${varname}($format) -value arcmin -command $cmd
+ $w add radiobutton -label [msgcat::mc {ArcSec}] \
+ -variable ${varname}($format) -value arcsec -command $cmd
+ }
+}
+
+proc DistMenuButton {w varname system other format cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ DistMenuButtonCmd $varname $system $format {}
+ ttk::menubutton $w -textvariable ${varname}($system,msg) -menu $w.menu
+ DistMenu $w.menu $varname $system $other $format \
+ [list DistMenuButtonCmd $varname $system $format $cmd]
+}
+
+proc DistMenuButtonCmd {varname system format cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ set ${varname}($system,msg) [msgcat::mc $var($system)]
+
+ if {$format != {}} {
+ switch -- $var($system) {
+ image -
+ physical -
+ amplifier -
+ detector {}
+ default {
+ if {[info exists var(frame)]} {
+ if {$var(frame) != {}} {
+ if {[$var(frame) has wcs equatorial $var($system)]} {
+ set ${varname}($system,msg) [msgcat::mc $var($format)]
+ }
+ }
+ }
+ }
+ }
+ }
+
+ if {$cmd != {}} {
+ eval $cmd
+ }
+}
+
+proc DistMenuEnable {w varname system other format} {
+ upvar #0 $varname var
+ global $varname
+
+ if {![info exists var(frame)]} {
+ return
+ }
+
+ if {$var(frame) == {}} {
+ return
+ }
+
+ if {[$var(frame) has wcs wcs]} {
+ $w entryconfig [msgcat::mc {WCS}] -state normal
+ } else {
+ $w entryconfig [msgcat::mc {WCS}] -state disabled
+ }
+
+ $w entryconfig [msgcat::mc {Multiple WCS}] -state normal
+
+ foreach ll {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ if {[$var(frame) has wcs "wcs${ll}"]} {
+ $w.wcs entryconfig "[msgcat::mc {WCS}] $ll" -state normal
+ } else {
+ $w.wcs entryconfig "[msgcat::mc {WCS}] $ll" -state disabled
+ }
+ }
+
+ if {$other} {
+ $w entryconfig [msgcat::mc {Image}] -state normal
+ $w entryconfig [msgcat::mc {Physical}] -state normal
+ $w entryconfig [msgcat::mc {Amplifier}] -state normal
+ $w entryconfig [msgcat::mc {Detector}] -state normal
+ }
+
+ if {$format != {}} {
+ if {[$var(frame) has wcs celestrial $var($system)]} {
+ $w entryconfig [msgcat::mc {Degrees}] -state normal
+ $w entryconfig [msgcat::mc {ArcMin}] -state normal
+ $w entryconfig [msgcat::mc {ArcSec}] -state normal
+ } else {
+ $w entryconfig [msgcat::mc {Degrees}] -state disabled
+ $w entryconfig [msgcat::mc {ArcMin}] -state disabled
+ $w entryconfig [msgcat::mc {ArcSec}] -state disabled
+ }
+ }
+}
+
+proc DistMenuReset {w varname system other format} {
+ upvar #0 $varname var
+ global $varname
+
+ $w entryconfig [msgcat::mc {WCS}] -state normal
+ $w entryconfig [msgcat::mc {Multiple WCS}] -state normal
+
+ foreach ll {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $w.wcs entryconfig "[msgcat::mc {WCS}] $ll" -state normal
+ }
+
+ if {$other} {
+ $w entryconfig [msgcat::mc {Image}] -state normal
+ $w entryconfig [msgcat::mc {Physical}] -state normal
+ $w entryconfig [msgcat::mc {Amplifier}] -state normal
+ $w entryconfig [msgcat::mc {Detector}] -state normal
+ }
+
+ if {$format != {}} {
+ $w entryconfig [msgcat::mc {Degrees}] -state normal
+ $w entryconfig [msgcat::mc {ArcMin}] -state normal
+ $w entryconfig [msgcat::mc {ArcSec}] -state normal
+ }
+}
+
+# EditMenu
+proc EditMenu {mb varname} {
+ upvar #0 $varname var
+ global $varname
+ global ds9
+
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -command "EntryCut $var(top)" -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command "EntryCopy $var(top)" -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -command "EntryPaste $var(top)" -accelerator "${ds9(ctrl)}V"
+}
+
+# ColorMenu
+proc ColorMenu {w varname color cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $w
+ $w add radiobutton -label [msgcat::mc {Black}] \
+ -variable ${varname}($color) -value black -command $cmd
+ $w add radiobutton -label [msgcat::mc {White}] \
+ -variable ${varname}($color) -value white -command $cmd
+ $w add radiobutton -label [msgcat::mc {Red}] \
+ -variable ${varname}($color) -value red -command $cmd
+ $w add radiobutton -label [msgcat::mc {Green}] \
+ -variable ${varname}($color) -value green -command $cmd
+ $w add radiobutton -label [msgcat::mc {Blue}] \
+ -variable ${varname}($color) -value blue -command $cmd
+ $w add radiobutton -label [msgcat::mc {Cyan}] \
+ -variable ${varname}($color) -value cyan -command $cmd
+ $w add radiobutton -label [msgcat::mc {Magenta}] \
+ -variable ${varname}($color) -value magenta -command $cmd
+ $w add radiobutton -label [msgcat::mc {Yellow}] \
+ -variable ${varname}($color) -value yellow -command $cmd
+ $w add separator
+ $w add command -label "[msgcat::mc {Other Color}]..." \
+ -command [list ColorMenuOther $varname $color $cmd]
+}
+
+proc ColorMenuOther {varname color cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[EntryDialog [msgcat::mc {Color}] [msgcat::mc {Enter Color}] 20 ${varname}($color)]} {
+ eval $cmd
+ }
+}
+
+proc ColorMenuButton {w varname color cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ ttk::menubutton $w -textvariable ${varname}($color) -menu $w.menu
+ ColorMenu $w.menu $varname $color $cmd
+}
+
+# FontMenu
+proc FontMenu {w varname font size weight slant cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $w
+ $w add radiobutton -label {Times} -variable ${varname}($font) \
+ -value times -command $cmd
+ $w add radiobutton -label {Helvetica} -variable ${varname}($font) \
+ -value helvetica -command $cmd
+ $w add radiobutton -label {Courier} -variable ${varname}($font) \
+ -value courier -command $cmd
+ $w add separator
+ $w add radiobutton -label {9} -variable ${varname}($size) \
+ -value 9 -command $cmd
+ $w add radiobutton -label {10} -variable ${varname}($size) \
+ -value 10 -command $cmd
+ $w add radiobutton -label {12} -variable ${varname}($size) \
+ -value 12 -command $cmd
+ $w add radiobutton -label {14} -variable ${varname}($size) \
+ -value 14 -command $cmd
+ $w add radiobutton -label {16} -variable ${varname}($size) \
+ -value 16 -command $cmd
+ $w add radiobutton -label {20} -variable ${varname}($size) \
+ -value 20 -command $cmd
+ $w add radiobutton -label {24} -variable ${varname}($size) \
+ -value 24 -command $cmd
+ $w add radiobutton -label {30} -variable ${varname}($size) \
+ -value 30 -command $cmd
+ $w add radiobutton -label {36} -variable ${varname}($size) \
+ -value 36 -command $cmd
+ $w add radiobutton -label {72} -variable ${varname}($size) \
+ -value 72 -command $cmd
+ $w add separator
+ $w add command -label "[msgcat::mc {Other Font Size}]..." \
+ -command [list FontMenuSize $varname $size $cmd]
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Normal}] \
+ -variable ${varname}($weight) -value normal -command $cmd
+ $w add radiobutton -label [msgcat::mc {Bold}] \
+ -variable ${varname}($weight) -value bold -command $cmd
+ $w add separator
+ $w add radiobutton -label [msgcat::mc {Roman}] \
+ -variable ${varname}($slant) -value roman -command $cmd
+ $w add radiobutton -label [msgcat::mc {Italic}] \
+ -variable ${varname}($slant) -value italic -command $cmd
+}
+
+proc FontMenuSize {varname size cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[EntryDialog [msgcat::mc {Font Size}] [msgcat::mc {Enter Font Size}] 20 ${varname}($size)]} {
+ eval $cmd
+ }
+}
+
+proc FontMenuButton {w varname font size weight slant cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ ttk::menubutton $w -textvariable ${varname}($font) -menu $w.menu
+ FontMenu $w.menu $varname $font $size $weight $slant $cmd
+}
+
+# WidthDashMenu
+proc WidthDashMenu {w varname width dash cmd1 cmd2} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $w
+ $w add radiobutton -label {1} -variable ${varname}($width) \
+ -value 1 -command $cmd1
+ $w add radiobutton -label {2} -variable ${varname}($width) \
+ -value 2 -command $cmd1
+ $w add radiobutton -label {3} -variable ${varname}($width) \
+ -value 3 -command $cmd1
+ $w add radiobutton -label {4} -variable ${varname}($width) \
+ -value 4 -command $cmd1
+
+ if {$dash != {}} {
+ $w add separator
+ $w add checkbutton -label [msgcat::mc {Dash}] \
+ -variable ${varname}($dash) -command $cmd2
+ }
+}
+
+proc WidthDashMenuButton {w varname width dash cmd1 cmd2} {
+ upvar #0 $varname var
+ global $varname
+
+ ttk::menubutton $w -textvariable ${varname}($width) -menu $w.menu
+ WidthDashMenu $w.menu $varname $width $dash $cmd1 $cmd2
+}
+
+# Prefs
+proc PrefsDialogMenu {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Menus and Buttons}]
+ lappend dprefs(tabs) [ttk::frame $w.menu]
+
+ PrefsDialogFileMenu $w.menu
+ PrefsDialogEditMenu $w.menu
+ PrefsDialogViewMenu $w.menu
+ PrefsDialogFrameMenu $w.menu
+ PrefsDialogBinMenu $w.menu
+ PrefsDialogZoomMenu $w.menu
+ PrefsDialogScaleMenu $w.menu
+ PrefsDialogColorMenu $w.menu
+ PrefsDialogRegionMenu $w.menu
+ PrefsDialogWCSMenu $w.menu
+ PrefsDialogAnalysisMenu $w.menu
+ PrefsDialogHelpMenu $w.menu
+}
+
diff --git a/ds9/library/mfile.tcl b/ds9/library/mfile.tcl
new file mode 100644
index 0000000..83f0629
--- /dev/null
+++ b/ds9/library/mfile.tcl
@@ -0,0 +1,688 @@
+# 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
+
+# Menus
+
+proc FileMainMenu {} {
+ global ds9
+
+ menu $ds9(mb).file
+ $ds9(mb).file add command -label "[msgcat::mc {Open}]..." \
+ -command [list OpenDialog fits] -accelerator "${ds9(ctrl)}O"
+ $ds9(mb).file add cascade -label [msgcat::mc {Open as}] \
+ -menu $ds9(mb).file.open
+ $ds9(mb).file add separator
+ $ds9(mb).file add command -label "[msgcat::mc {Save}]..." \
+ -command [list SaveDialog fits] -accelerator "${ds9(ctrl)}S"
+ $ds9(mb).file add cascade -label [msgcat::mc {Save as}] \
+ -menu $ds9(mb).file.save
+ $ds9(mb).file add separator
+ $ds9(mb).file add cascade -label [msgcat::mc {Import}] \
+ -menu $ds9(mb).file.import
+ $ds9(mb).file add cascade -label [msgcat::mc {Export}] \
+ -menu $ds9(mb).file.export
+ $ds9(mb).file add separator
+ $ds9(mb).file add cascade -label [msgcat::mc {Save Image}] \
+ -menu $ds9(mb).file.saveimage
+ $ds9(mb).file add command -label "[msgcat::mc {Create Movie}]..." \
+ -command MovieDialog
+ $ds9(mb).file add separator
+ $ds9(mb).file add command -label "[msgcat::mc {Backup}]..." \
+ -command BackupDialog
+ $ds9(mb).file add command -label "[msgcat::mc {Restore}]..." \
+ -command RestoreDialog
+ $ds9(mb).file add separator
+ $ds9(mb).file add command -label "[msgcat::mc {Display Header}]..." \
+ -command DisplayHeaderMenu
+ $ds9(mb).file add cascade -label [msgcat::mc {Preserve During Load}] \
+ -menu $ds9(mb).file.preserve
+ $ds9(mb).file add separator
+ $ds9(mb).file add cascade -label [msgcat::mc {XPA}] \
+ -menu $ds9(mb).file.xpa
+ $ds9(mb).file add cascade -label [msgcat::mc {SAMP}] \
+ -menu $ds9(mb).file.samp
+ $ds9(mb).file add separator
+ $ds9(mb).file add command -label "[msgcat::mc {Open TCL Console}]..." \
+ -command OpenConsole
+ $ds9(mb).file add command -label "[msgcat::mc {Source TCL}]..." \
+ -command OpenSource
+ $ds9(mb).file add separator
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(mb).file add command -label "[msgcat::mc {Page Setup}]..." \
+ -command PSPageSetup -accelerator "${ds9(shiftctrl)}P"
+ $ds9(mb).file add command -label "[msgcat::mc {Print}]..." \
+ -command PSPrint -accelerator "${ds9(ctrl)}P"
+ }
+ aqua {
+ # accelerators don't work with dialog box
+ $ds9(mb).file add command -label "[msgcat::mc {Page Setup}]..." \
+ -command PSPageSetup
+ $ds9(mb).file add command -label "[msgcat::mc {Print}]..." \
+ -command PSPrint
+# $ds9(mb).file add command -label "[msgcat::mc {Postscript Page Setup}]..." -command PSPageSetup
+# $ds9(mb).file add command -label "[msgcat::mc {Postscript Print}]..." -command PSPrint
+# $ds9(mb).file add separator
+# $ds9(mb).file add command -label "[msgcat::mc {Page Setup}]..." -command MacOSXPageSetup
+# $ds9(mb).file add command -label "[msgcat::mc {Print}]..." -command MacOSXPrint
+ }
+ }
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(mb).file add separator
+ $ds9(mb).file add command \
+ -label [msgcat::mc {Exit}] -command QuitDS9
+ }
+ aqua {}
+ }
+
+ # File Open Menu
+ menu $ds9(mb).file.open
+ $ds9(mb).file.open add command -label "[msgcat::mc {Slice}]..." \
+ -command [list OpenDialog fits {} slice]
+ $ds9(mb).file.open add separator
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {RGB Image}]..." \
+ -command [list OpenDialog rgbimage]
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {RGB Cube}]..."\
+ -command [list OpenDialog rgbcube]
+ $ds9(mb).file.open add separator
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Multiple Extension Cube}]..." \
+ -command [list OpenDialog mecube]
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Multiple Extension Frames}]..." \
+ -command [list OpenDialog multiframe]
+ $ds9(mb).file.open add separator
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Mosaic WCS}]..." \
+ -command [list OpenDialog mosaicimagewcs]
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Mosaic WCS Segment}]..." \
+ -command [list OpenDialog mosaicwcs]
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Mosaic IRAF}]..." \
+ -command [list OpenDialog mosaicimageiraf]
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Mosaic IRAF Segment}]..." \
+ -command [list OpenDialog mosaiciraf]
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {Mosaic WFPC2}]..." \
+ -command [list OpenDialog mosaicimagewfpc2]
+ $ds9(mb).file.open add separator
+ $ds9(mb).file.open add command \
+ -label "[msgcat::mc {URL}]..." \
+ -command [list OpenURLFits]
+
+ # File Save Menu
+ menu $ds9(mb).file.save
+ $ds9(mb).file.save add command -label "[msgcat::mc {Slice}]..." \
+ -command [list SaveDialog slice]
+ $ds9(mb).file.save add separator
+ $ds9(mb).file.save add command \
+ -label "[msgcat::mc {RGB Image}]..." \
+ -command [list SaveDialog rgbimage]
+ $ds9(mb).file.save add command \
+ -label "[msgcat::mc {RGB Cube}]..."\
+ -command [list SaveDialog rgbcube]
+ $ds9(mb).file.save add separator
+ $ds9(mb).file.save add command \
+ -label "[msgcat::mc {Multiple Extension Cube}]..." \
+ -command [list SaveDialog mecube]
+ $ds9(mb).file.save add separator
+ $ds9(mb).file.save add command \
+ -label "[msgcat::mc {Mosaic WCS}]..." \
+ -command [list SaveDialog mosaicimagewcs]
+ $ds9(mb).file.save add command \
+ -label "[msgcat::mc {Mosaic WCS Segment}]..." \
+ -command [list SaveDialog mosaicwcs]
+
+ # File Import Menu
+ menu $ds9(mb).file.import
+ $ds9(mb).file.import add cascade -label [msgcat::mc {Slice}] \
+ -menu $ds9(mb).file.import.slice
+ $ds9(mb).file.import add separator
+ $ds9(mb).file.import add command -label "[msgcat::mc {Array}]..." \
+ -command [list ImportDialog array]
+ $ds9(mb).file.import add command -label {NRRD...} \
+ -command [list ImportDialog nrrd]
+ $ds9(mb).file.import add command -label {ENVI...} \
+ -command [list ImportDialog envi]
+ $ds9(mb).file.import add separator
+ $ds9(mb).file.import add command -label "[msgcat::mc {RGB Array}]..." \
+ -command [list ImportDialog rgbarray]
+ $ds9(mb).file.import add separator
+ $ds9(mb).file.import add command -label {GIF...} \
+ -command [list ImportDialog gif]
+ $ds9(mb).file.import add command -label {TIFF...} \
+ -command [list ImportDialog tiff]
+ $ds9(mb).file.import add command -label {JPEG...} \
+ -command [list ImportDialog jpeg]
+ $ds9(mb).file.import add command -label {PNG...} \
+ -command [list ImportDialog png]
+
+ # File Import Slice Menu
+ menu $ds9(mb).file.import.slice
+ $ds9(mb).file.import.slice add command -label {GIF...} \
+ -command [list ImportDialog gif {} slice]
+ $ds9(mb).file.import.slice add command -label {TIFF...} \
+ -command [list ImportDialog tiff {} slice]
+ $ds9(mb).file.import.slice add command -label {JPEG...} \
+ -command [list ImportDialog jpeg {} slice]
+ $ds9(mb).file.import.slice add command -label {PNG...} \
+ -command [list ImportDialog png {} slice]
+
+ # File Export Menu
+ menu $ds9(mb).file.export
+ $ds9(mb).file.export add command -label "[msgcat::mc {Array}]..." \
+ -command [list ExportDialog array]
+ $ds9(mb).file.export add command -label {NRRD...} \
+ -command [list ExportDialog nrrd]
+ $ds9(mb).file.export add command -label {ENVI...} \
+ -command [list ExportDialog envi]
+ $ds9(mb).file.export add separator
+ $ds9(mb).file.export add command -label "[msgcat::mc {RGB Array}]..." \
+ -command [list ExportDialog rgbarray]
+ $ds9(mb).file.export add separator
+ $ds9(mb).file.export add command -label {GIF...} \
+ -command [list ExportDialog gif]
+ $ds9(mb).file.export add command -label {TIFF...} \
+ -command [list ExportDialog tiff]
+ $ds9(mb).file.export add command -label {JPEG...} \
+ -command [list ExportDialog jpeg]
+ $ds9(mb).file.export add command -label {PNG...} \
+ -command [list ExportDialog png]
+
+ # File Saveimage Menu
+ menu $ds9(mb).file.saveimage
+ $ds9(mb).file.saveimage add command -label {FITS...} \
+ -command [list SaveImageDialog fits]
+ $ds9(mb).file.saveimage add command -label {EPS...} \
+ -command [list SaveImageDialog eps]
+ $ds9(mb).file.saveimage add command -label {GIF...} \
+ -command [list SaveImageDialog gif]
+ $ds9(mb).file.saveimage add command -label {TIFF...} \
+ -command [list SaveImageDialog tiff]
+ $ds9(mb).file.saveimage add command -label {JPEG...} \
+ -command [list SaveImageDialog jpeg]
+ $ds9(mb).file.saveimage add command -label {PNG...} \
+ -command [list SaveImageDialog png]
+
+ # File Preserve Menu
+ menu $ds9(mb).file.preserve
+ $ds9(mb).file.preserve add checkbutton -label [msgcat::mc {Pan}] \
+ -variable panzoom(preserve) -command PreservePan
+ $ds9(mb).file.preserve add checkbutton -label [msgcat::mc {Region}] \
+ -variable marker(preserve) -command MarkerPreserve
+
+ menu $ds9(mb).file.samp
+ $ds9(mb).file.samp add command -label [msgcat::mc {Connect}] \
+ -command SAMPConnect
+ $ds9(mb).file.samp add command -label [msgcat::mc {Disconnect}] \
+ -command SAMPDisconnect
+ $ds9(mb).file.samp add separator
+ $ds9(mb).file.samp add cascade -label [msgcat::mc {Image}] \
+ -menu $ds9(mb).file.samp.image
+ $ds9(mb).file.samp add cascade -label [msgcat::mc {Table}] \
+ -menu $ds9(mb).file.samp.table
+
+ menu $ds9(mb).file.samp.image
+ $ds9(mb).file.samp.image add command -label [msgcat::mc {Broadcast}] \
+ -command "SAMPSendImageLoadFits {}"
+ $ds9(mb).file.samp.image add separator
+
+ menu $ds9(mb).file.samp.table
+ $ds9(mb).file.samp.table add command -label [msgcat::mc {Broadcast}] \
+ -command "SAMPSendTableLoadFits {}"
+ $ds9(mb).file.samp.table add separator
+
+ menu $ds9(mb).file.xpa
+ $ds9(mb).file.xpa add command -label "[msgcat::mc {Information}]..." \
+ -command XPAInfo
+ $ds9(mb).file.xpa add separator
+ $ds9(mb).file.xpa add command -label [msgcat::mc {Connect}] \
+ -command XPAConnect
+ $ds9(mb).file.xpa add command -label [msgcat::mc {Disconnect}] \
+ -command XPADisconnect
+
+ # Bindings
+ bind $ds9(top) <<Open>> [list OpenDialog fits]
+ bind $ds9(top) <<Save>> [list SaveDialog fits]
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ bind $ds9(top) <<PageSetup>> PSPageSetup
+ bind $ds9(top) <<Print>> PSPrint
+ }
+ aqua {
+ # Known bug in Tk, can't have dialogs invoked by accelerator
+ }
+ }
+}
+
+proc PrefsDialogFileMenu {w} {
+ set f [ttk::labelframe $w.mfile -text [msgcat::mc {File}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarFile $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+ $m add cascade -label [msgcat::mc {Preserve During Load}] \
+ -menu $m.preserve
+
+ global pscale
+ global ppanzoom
+ global pmarker
+ menu $m.preserve
+ $m.preserve add checkbutton -label [msgcat::mc {Pan}] \
+ -variable ppanzoom(preserve)
+ $m.preserve add checkbutton -label [msgcat::mc {Region}] \
+ -variable pmarker(preserve)
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsFileDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ file,open 1
+ file,save 1
+ file,movie 0
+ file,backup 0
+ file,restore 0
+ file,header 1
+ file,xpa,info 0
+ file,samp,image 0
+ file,samp,table 0
+ file,console 0
+ file,tcl 0
+ file,pspage 0
+ file,psprint 0
+ file,page 1
+ file,print 1
+ file,exit 1
+ }
+}
+
+proc CreateButtonsFile {} {
+ global ds9
+ global buttons
+
+ ttk::frame $ds9(buttons).file
+
+ ButtonButton $ds9(buttons).file.open \
+ [string tolower [msgcat::mc {Open}]] \
+ [list OpenDialog fits]
+ ButtonButton $ds9(buttons).file.save \
+ [string tolower [msgcat::mc {Save}]] \
+ [list SaveDialog fits]
+
+ ButtonButton $ds9(buttons).file.movie \
+ [string tolower [msgcat::mc {Create Movie}]] MovieDialog
+
+ ButtonButton $ds9(buttons).file.backup \
+ [string tolower [msgcat::mc {Backup}]] BackupDialog
+ ButtonButton $ds9(buttons).file.restore \
+ [string tolower [msgcat::mc {Restore}]] RestoreDialog
+
+ ButtonButton $ds9(buttons).file.header \
+ [string tolower [msgcat::mc {Header}]] DisplayHeaderMenu
+
+ ButtonButton $ds9(buttons).file.xpainfo \
+ [string tolower {XPA Info}] XPAInfo
+ ButtonButton $ds9(buttons).file.sampimage \
+ [string tolower [msgcat::mc {SAMP Image}]] "SAMPSendImageLoadFits {}"
+ ButtonButton $ds9(buttons).file.samptable \
+ [string tolower [msgcat::mc {SAMP Table}]] "SAMPSendTableLoadFits {}"
+
+ ButtonButton $ds9(buttons).file.console \
+ [string tolower [msgcat::mc {Console}]] OpenConsole
+ ButtonButton $ds9(buttons).file.tcl \
+ [string tolower {TCL}] OpenSource
+
+ ButtonButton $ds9(buttons).file.pspage \
+ [string tolower [msgcat::mc {PS Page Setup}]] PSPageSetup
+ ButtonButton $ds9(buttons).file.psprint \
+ [string tolower [msgcat::mc {PS Print}]] PSPrint
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ ButtonButton $ds9(buttons).file.page \
+ [string tolower [msgcat::mc {Page Setup}]] PSPageSetup
+ ButtonButton $ds9(buttons).file.print \
+ [string tolower [msgcat::mc {Print}]] PSPrint
+ }
+ aqua {
+ ButtonButton $ds9(buttons).file.page \
+ [string tolower [msgcat::mc {Page Setup}]] PSPageSetup
+ ButtonButton $ds9(buttons).file.print \
+ [string tolower [msgcat::mc {Print}]] PSPrint
+# ButtonButton $ds9(buttons).file.page [string tolower [msgcat::mc {Page Setup}]] MacOSXPageSetup
+# ButtonButton $ds9(buttons).file.print [string tolower [msgcat::mc {Print}]] MacOSXPrint
+ }
+ }
+
+ ButtonButton $ds9(buttons).file.exit \
+ [string tolower [msgcat::mc {Exit}]] QuitDS9
+
+ set buttons(file) "
+ $ds9(buttons).file.open pbuttons(file,open)
+ $ds9(buttons).file.save pbuttons(file,save)
+ $ds9(buttons).file.movie pbuttons(file,movie)
+ $ds9(buttons).file.backup pbuttons(file,backup)
+ $ds9(buttons).file.restore pbuttons(file,restore)
+ $ds9(buttons).file.header pbuttons(file,header)
+ $ds9(buttons).file.xpainfo pbuttons(file,xpa,info)
+ $ds9(buttons).file.sampimage pbuttons(file,samp,image)
+ $ds9(buttons).file.samptable pbuttons(file,samp,table)
+ $ds9(buttons).file.console pbuttons(file,console)
+ $ds9(buttons).file.tcl pbuttons(file,tcl)
+ $ds9(buttons).file.pspage pbuttons(file,pspage)
+ $ds9(buttons).file.psprint pbuttons(file,psprint)
+ $ds9(buttons).file.page pbuttons(file,page)
+ $ds9(buttons).file.print pbuttons(file,print)
+ $ds9(buttons).file.exit pbuttons(file,exit)
+ "
+}
+
+proc PrefsDialogButtonbarFile {f} {
+ global buttons
+ global pbuttons
+ global ds9
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label "[msgcat::mc {Open}]..." \
+ -variable pbuttons(file,open) -command {UpdateButtons buttons(file)}
+ $m add checkbutton -label "[msgcat::mc {Save}]..." \
+ -variable pbuttons(file,save) -command {UpdateButtons buttons(file)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Create Movie}]..." \
+ -variable pbuttons(file,movie) -command {UpdateButtons buttons(file)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Backup}]..." \
+ -variable pbuttons(file,backup) -command {UpdateButtons buttons(file)}
+ $m add checkbutton -label "[msgcat::mc {Restore}]..." \
+ -variable pbuttons(file,restore) -command {UpdateButtons buttons(file)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Display Header}]..." \
+ -variable pbuttons(file,header) -command {UpdateButtons buttons(file)}
+ $m add separator
+ $m add cascade -label [msgcat::mc {XPA}] -menu $m.xpa
+ $m add cascade -label [msgcat::mc {SAMP}] -menu $m.samp
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Open TCL Console}]..." \
+ -variable pbuttons(file,console) -command {UpdateButtons buttons(file)}
+ $m add checkbutton -label "[msgcat::mc {Source TCL}]..." \
+ -variable pbuttons(file,tcl) -command {UpdateButtons buttons(file)}
+ $m add separator
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $m add checkbutton \
+ -label "[msgcat::mc {Page Setup}]..." \
+ -variable pbuttons(file,page) \
+ -command {UpdateButtons buttons(file)}
+ $m add checkbutton \
+ -label "[msgcat::mc {Print}]..." \
+ -variable pbuttons(file,print) \
+ -command {UpdateButtons buttons(file)}
+ }
+ aqua {
+ $m add checkbutton \
+ -label "[msgcat::mc {Page Setup}]..." \
+ -variable pbuttons(file,page) \
+ -command {UpdateButtons buttons(file)}
+ $m add checkbutton \
+ -label "[msgcat::mc {Print}]..." \
+ -variable pbuttons(file,print) \
+ -command {UpdateButtons buttons(file)}
+# $m add checkbutton -label "[msgcat::mc {Postscript Page Setup}]..." -variable pbuttons(file,pspage) -command {UpdateButtons buttons(file)}
+# $m add checkbutton -label "[msgcat::mc {Postscript Print}]..." -variable pbuttons(file,psprint) -command {UpdateButtons buttons(file)}
+# $m add separator
+# $m add checkbutton -label "[msgcat::mc {Page Setup}]..." -variable pbuttons(file,page) -command {UpdateButtons buttons(file)}
+# $m add checkbutton -label "[msgcat::mc {Print}]..." -variable pbuttons(file,print) -command {UpdateButtons buttons(file)}
+ }
+ }
+
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Exit}] \
+ -variable pbuttons(file,exit) -command {UpdateButtons buttons(filew)}
+
+ menu $m.xpa
+ $m.xpa add checkbutton -label "[msgcat::mc {Information}]..." \
+ -variable pbuttons(file,xpa,info) \
+ -command {UpdateButtons buttons(file)}
+
+ menu $m.samp
+ $m.samp add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(file,samp,image) \
+ -command {UpdateButtons buttons(file)}
+ $m.samp add checkbutton -label [msgcat::mc {Table}] \
+ -variable pbuttons(file,samp,table) \
+ -command {UpdateButtons buttons(file)}
+}
+
+# Support
+
+proc UpdateFileMenuStatic {} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateFileMenuStatic"
+ }
+
+ if {$ds9(active,num) > 0} {
+ $ds9(mb).file entryconfig "[msgcat::mc {Open}]..." \
+ -state normal
+ $ds9(mb).file entryconfig [msgcat::mc {Open as}] \
+ -state normal
+ $ds9(mb).file entryconfig [msgcat::mc {Import}] \
+ -state normal
+
+ $ds9(buttons).file.open configure -state normal
+ } else {
+ $ds9(mb).file entryconfig "[msgcat::mc {Open}]..." \
+ -state disabled
+ $ds9(mb).file entryconfig [msgcat::mc {Open as}] \
+ -state disabled
+ $ds9(mb).file entryconfig [msgcat::mc {Import}] \
+ -state disabled
+
+ $ds9(buttons).file.open configure -state disabled
+ }
+}
+
+proc UpdateFileMenu {} {
+ global ds9
+ global current
+ global samp
+ global xpa
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateFileMenu"
+ }
+
+ set mm $ds9(mb).file
+ set bb $ds9(buttons).file
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ $mm entryconfig "[msgcat::mc {Save}]..." -state normal
+ $mm entryconfig [msgcat::mc {Save as}] -state normal
+ $mm entryconfig [msgcat::mc {Export}] -state normal
+ $mm entryconfig [msgcat::mc {Save Image}] -state normal
+ $mm entryconfig "[msgcat::mc {Create Movie}]..." -state normal
+ $mm entryconfig "[msgcat::mc {Display Header}]..." -state normal
+
+ if {[$current(frame) has fits mosaic]} {
+ $mm.save entryconfig "[msgcat::mc {Mosaic WCS}]..." -state normal
+ $mm.save entryconfig "[msgcat::mc {Mosaic WCS Segment}]..." -state normal
+ } else {
+ $mm.save entryconfig "[msgcat::mc {Mosaic WCS}]..." -state disabled
+ $mm.save entryconfig "[msgcat::mc {Mosaic WCS Segment}]..." -state disabled
+ }
+
+ $bb.save configure -state normal
+ $bb.movie configure -state normal
+ $bb.header configure -state normal
+ } else {
+ $mm entryconfig "[msgcat::mc {Save}]..." -state disabled
+ $mm entryconfig [msgcat::mc {Save as}] -state disabled
+ $mm entryconfig [msgcat::mc {Export}] -state disabled
+ $mm entryconfig [msgcat::mc {Save Image}] -state disabled
+ $mm entryconfig "[msgcat::mc {Create Movie}]..." -state disabled
+ $mm entryconfig "[msgcat::mc {Display Header}]..." -state disabled
+
+ $bb.save configure -state disabled
+ $bb.movie configure -state disabled
+ $bb.header configure -state disabled
+ }
+
+ switch -- [$current(frame) get type] {
+ base {
+ $mm.open entryconfig \
+ "[msgcat::mc {RGB Image}]..." -state disabled
+ $mm.open entryconfig \
+ "[msgcat::mc {RGB Cube}]..." -state disabled
+ $mm.save entryconfig \
+ "[msgcat::mc {RGB Image}]..." -state disabled
+ $mm.save entryconfig \
+ "[msgcat::mc {RGB Cube}]..." -state disabled
+ $mm.import entryconfig \
+ "[msgcat::mc {RGB Array}]..." -state disabled
+ $mm.export entryconfig \
+ "[msgcat::mc {RGB Array}]..." -state disabled
+ }
+ rgb {
+ $mm.open entryconfig \
+ "[msgcat::mc {RGB Image}]..." -state normal
+ $mm.open entryconfig \
+ "[msgcat::mc {RGB Cube}]..." -state normal
+ $mm.save entryconfig \
+ "[msgcat::mc {RGB Image}]..." -state normal
+ $mm.save entryconfig \
+ "[msgcat::mc {RGB Cube}]..." -state normal
+ $mm.import entryconfig \
+ "[msgcat::mc {RGB Array}]..." -state normal
+ $mm.export entryconfig \
+ "[msgcat::mc {RGB Array}]..." -state normal
+ }
+ 3d {
+ $mm.open entryconfig \
+ "[msgcat::mc {RGB Image}]..." -state disabled
+ $mm.open entryconfig \
+ "[msgcat::mc {RGB Cube}]..." -state disabled
+ $mm.save entryconfig \
+ "[msgcat::mc {RGB Image}]..." -state disabled
+ $mm.save entryconfig \
+ "[msgcat::mc {RGB Cube}]..." -state disabled
+ $mm.import entryconfig \
+ "[msgcat::mc {RGB Array}]..." -state disabled
+ $mm.export entryconfig \
+ "[msgcat::mc {RGB Array}]..." -state disabled
+ }
+ }
+
+ if {[info exists samp]} {
+ set ss [expr $ds9(menu,start)+2]
+
+ if {[$current(frame) has fits]} {
+
+ $mm.samp entryconfig [msgcat::mc {Image}] \
+ -state normal
+ if {[$mm.samp.image index end] >= $ss} {
+ $mm.samp.image delete $ss end
+ }
+ foreach args $samp(apps,image) {
+ foreach {id name} $args {
+ $mm.samp.image add command -label $name \
+ -command "SAMPSendImageLoadFits $id"
+ }
+ }
+ $bb.sampimage configure -state normal
+
+ if {[$current(frame) has fits bin]} {
+ $mm.samp entryconfig [msgcat::mc {Table}] -state normal
+ if {[$mm.samp.table index end] >= $ss} {
+ $mm.samp.table delete $ss end
+ }
+ foreach args $samp(apps,table) {
+ foreach {id name} $args {
+ $mm.samp.table add command -label $name \
+ -command "SAMPSendTableLoadFits $id"
+ }
+ }
+ $bb.samptable configure -state normal
+
+ } else {
+ $mm.samp entryconfig [msgcat::mc {Table}] -state disabled
+ $bb.samptable configure -state disabled
+ }
+ } else {
+ $mm.samp entryconfig [msgcat::mc {Image}] -state disabled
+ $mm.samp entryconfig [msgcat::mc {Table}] -state disabled
+ $bb.sampimage configure -state disabled
+ $bb.samptable configure -state disabled
+ }
+ } else {
+ $mm.samp entryconfig [msgcat::mc {Image}] -state disabled
+ $mm.samp entryconfig [msgcat::mc {Table}] -state disabled
+ $bb.sampimage configure -state disabled
+ $bb.samptable configure -state disabled
+ }
+ } else {
+ $mm entryconfig "[msgcat::mc {Save}]..." -state disabled
+ $mm entryconfig [msgcat::mc {Save as}] -state disabled
+ $mm entryconfig [msgcat::mc {Export}] -state disabled
+ $mm entryconfig [msgcat::mc {Save Image}] -state disabled
+ $mm entryconfig "[msgcat::mc {Create Movie}]..." -state disabled
+ $mm entryconfig "[msgcat::mc {Display Header}]..." -state disabled
+
+ $bb.save configure -state disabled
+ $bb.movie configure -state disabled
+ $bb.header configure -state disabled
+
+ $mm.samp entryconfig [msgcat::mc {Image}] -state disabled
+ $mm.samp entryconfig [msgcat::mc {Table}] -state disabled
+ $bb.sampimage configure -state disabled
+ $bb.samptable configure -state disabled
+ }
+
+ # XPA
+ if {[info exists xpa]} {
+ $mm.xpa entryconfig "[msgcat::mc {Information}]..." -state normal
+ $mm.xpa entryconfig [msgcat::mc {Disconnect}] -state normal
+ } else {
+ $mm.xpa entryconfig "[msgcat::mc {Information}]..." -state disabled
+ $mm.xpa entryconfig [msgcat::mc {Disconnect}] -state disabled
+ }
+
+ # SAMP
+ if {[info exists samp]} {
+ $mm.samp entryconfig [msgcat::mc {Connect}] -state disabled
+ $mm.samp entryconfig [msgcat::mc {Disconnect}] -state normal
+ } else {
+ $mm.samp entryconfig [msgcat::mc {Connect}] -state normal
+ $mm.samp entryconfig [msgcat::mc {Disconnect}] -state disabled
+ }
+}
+
diff --git a/ds9/library/mframe.tcl b/ds9/library/mframe.tcl
new file mode 100644
index 0000000..878ecf4
--- /dev/null
+++ b/ds9/library/mframe.tcl
@@ -0,0 +1,1226 @@
+# 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
+
+# Menus
+
+proc FrameMainMenu {} {
+ global ds9
+ global current
+
+ menu $ds9(mb).frame
+ $ds9(mb).frame add command -label [msgcat::mc {New Frame}] \
+ -command CreateFrame
+ $ds9(mb).frame add command -label [msgcat::mc {New Frame RGB}] \
+ -command CreateRGBFrame
+ $ds9(mb).frame add command -label [msgcat::mc {New Frame 3D}] \
+ -command Create3DFrame
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add command -label [msgcat::mc {Delete Frame}] \
+ -command DeleteCurrentFrame
+ $ds9(mb).frame add command -label [msgcat::mc {Delete All Frames}] \
+ -command DeleteAllFramesMenu
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add command -label [msgcat::mc {Clear Frame}] \
+ -command ClearCurrentFrame
+ $ds9(mb).frame add command -label [msgcat::mc {Reset Frame}] \
+ -command ResetCurrentFrame
+ $ds9(mb).frame add command -label [msgcat::mc {Refresh Frame}] \
+ -command UpdateCurrentFrame
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add radiobutton -label [msgcat::mc {Single Frame}] \
+ -variable current(display) -value single -command DisplayMode
+ $ds9(mb).frame add radiobutton -label [msgcat::mc {Tile Frames}] \
+ -variable current(display) -value tile -command DisplayMode
+ $ds9(mb).frame add radiobutton -label [msgcat::mc {Blink Frames}] \
+ -variable current(display) -value blink -command DisplayMode
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add cascade -label [msgcat::mc {Match}] \
+ -menu $ds9(mb).frame.match
+ $ds9(mb).frame add cascade -label [msgcat::mc {Lock}] \
+ -menu $ds9(mb).frame.lock
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add cascade -label [msgcat::mc {Goto Frame}] \
+ -menu $ds9(mb).frame.goto
+ $ds9(mb).frame add cascade -label [msgcat::mc {Show/Hide Frames}] \
+ -menu $ds9(mb).frame.active
+ $ds9(mb).frame add cascade -label [msgcat::mc {Move Frame}] \
+ -menu $ds9(mb).frame.move
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add command -label [msgcat::mc {First Frame}] \
+ -command FirstFrame
+ $ds9(mb).frame add command -label [msgcat::mc {Previous Frame}] \
+ -command PrevFrame
+ $ds9(mb).frame add command -label [msgcat::mc {Next Frame}] \
+ -command NextFrame
+ $ds9(mb).frame add command -label [msgcat::mc {Last Frame}] \
+ -command LastFrame
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add command -label "[msgcat::mc {Cube}]..." \
+ -command CubeDialog
+ $ds9(mb).frame add command -label "[msgcat::mc {RGB}]..." \
+ -command RGBDialog
+ $ds9(mb).frame add command -label "[msgcat::mc {3D}]..." \
+ -command 3DDialog
+ $ds9(mb).frame add separator
+ $ds9(mb).frame add cascade -label [msgcat::mc {Frame Parameters}] \
+ -menu $ds9(mb).frame.params
+
+ # match
+ menu $ds9(mb).frame.match
+ $ds9(mb).frame.match add cascade -label [msgcat::mc {Frame}] \
+ -menu $ds9(mb).frame.match.frame
+ $ds9(mb).frame.match add cascade -label [msgcat::mc {Crosshair}] \
+ -menu $ds9(mb).frame.match.crosshair
+ $ds9(mb).frame.match add cascade -label [msgcat::mc {Crop}] \
+ -menu $ds9(mb).frame.match.crop
+ $ds9(mb).frame.match add cascade -label [msgcat::mc {Slice}] \
+ -menu $ds9(mb).frame.match.cube
+ $ds9(mb).frame.match add command -label [msgcat::mc {Bin}] \
+ -command MatchBinCurrent
+ $ds9(mb).frame.match add command -label [msgcat::mc {Axes Order}] \
+ -command MatchAxesCurrent
+ $ds9(mb).frame.match add command -label [msgcat::mc {Scale}] \
+ -command MatchScaleCurrent
+ $ds9(mb).frame.match add command -label [msgcat::mc {Scale and Limits}] \
+ -command MatchScaleLimitsCurrent
+ $ds9(mb).frame.match add command -label [msgcat::mc {Colorbar}] \
+ -command MatchColorCurrent
+ $ds9(mb).frame.match add command -label [msgcat::mc {Block}] \
+ -command MatchBlockCurrent
+ $ds9(mb).frame.match add command -label [msgcat::mc {Smooth}] \
+ -command MatchSmoothCurrent
+
+ menu $ds9(mb).frame.match.frame
+ $ds9(mb).frame.match.frame add command -label [msgcat::mc {WCS}] \
+ -command {MatchFrameCurrent wcs}
+ $ds9(mb).frame.match.frame add separator
+ $ds9(mb).frame.match.frame add command -label [msgcat::mc {Image}] \
+ -command {MatchFrameCurrent image}
+ $ds9(mb).frame.match.frame add command -label [msgcat::mc {Physical}] \
+ -command {MatchFrameCurrent physical}
+ $ds9(mb).frame.match.frame add command -label [msgcat::mc {Amplifier}] \
+ -command {MatchFrameCurrent amplifier}
+ $ds9(mb).frame.match.frame add command -label [msgcat::mc {Detector}] \
+ -command {MatchFrameCurrent detector}
+
+ menu $ds9(mb).frame.match.crosshair
+ $ds9(mb).frame.match.crosshair add command -label [msgcat::mc {WCS}] \
+ -command {MatchCrosshairCurrent wcs}
+ $ds9(mb).frame.match.crosshair add separator
+ $ds9(mb).frame.match.crosshair add command -label [msgcat::mc {Image}] \
+ -command {MatchCrosshairCurrent image}
+ $ds9(mb).frame.match.crosshair add command -label [msgcat::mc {Physical}] \
+ -command {MatchCrosshairCurrent physical}
+ $ds9(mb).frame.match.crosshair add command -label [msgcat::mc {Amplifier}] \
+ -command {MatchCrosshairCurrent amplifier}
+ $ds9(mb).frame.match.crosshair add command -label [msgcat::mc {Detector}] \
+ -command {MatchCrosshairCurrent detector}
+
+ menu $ds9(mb).frame.match.crop
+ $ds9(mb).frame.match.crop add command -label [msgcat::mc {WCS}] \
+ -command {MatchCropCurrent wcs}
+ $ds9(mb).frame.match.crop add separator
+ $ds9(mb).frame.match.crop add command -label [msgcat::mc {Image}] \
+ -command {MatchCropCurrent image}
+ $ds9(mb).frame.match.crop add command -label [msgcat::mc {Physical}] \
+ -command {MatchCropCurrent physical}
+ $ds9(mb).frame.match.crop add command -label [msgcat::mc {Amplifier}] \
+ -command {MatchCropCurrent amplifier}
+ $ds9(mb).frame.match.crop add command -label [msgcat::mc {Detector}] \
+ -command {MatchCropCurrent detector}
+
+ menu $ds9(mb).frame.match.cube
+ $ds9(mb).frame.match.cube add command -label [msgcat::mc {WCS}] \
+ -command {MatchCubeCurrent wcs}
+ $ds9(mb).frame.match.cube add separator
+ $ds9(mb).frame.match.cube add command -label [msgcat::mc {Image}] \
+ -command {MatchCubeCurrent image}
+
+ # lock
+ menu $ds9(mb).frame.lock
+ $ds9(mb).frame.lock add cascade -label [msgcat::mc {Frame}] \
+ -menu $ds9(mb).frame.lock.frame
+ $ds9(mb).frame.lock add cascade -label [msgcat::mc {Crosshair}] \
+ -menu $ds9(mb).frame.lock.crosshair
+ $ds9(mb).frame.lock add cascade -label [msgcat::mc {Crop}] \
+ -menu $ds9(mb).frame.lock.crop
+ $ds9(mb).frame.lock add cascade -label [msgcat::mc {Slice}] \
+ -menu $ds9(mb).frame.lock.cube
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Bin}] \
+ -variable bin(lock) -command {LockBinCurrent}
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Axes Order}] \
+ -variable cube(lock,axes) -command {LockAxesCurrent}
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Scale}] \
+ -variable scale(lock) -command {LockScaleCurrent}
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Scale and Limits}] \
+ -variable scale(lock,limits) -command {LockScaleLimitsCurrent}
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Colorbar}] \
+ -variable colorbar(lock) -command {LockColorCurrent}
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Block}] \
+ -variable block(lock) -command {LockBlockCurrent}
+ $ds9(mb).frame.lock add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable smooth(lock) -command {LockSmoothCurrent}
+
+ menu $ds9(mb).frame.lock.frame
+ $ds9(mb).frame.lock.frame add radiobutton -label [msgcat::mc {None}] \
+ -variable panzoom(lock) -value none -command LockFrameCurrent
+ $ds9(mb).frame.lock.frame add separator
+ $ds9(mb).frame.lock.frame add radiobutton -label [msgcat::mc {WCS}] \
+ -variable panzoom(lock) -value wcs -command LockFrameCurrent
+ $ds9(mb).frame.lock.frame add separator
+ $ds9(mb).frame.lock.frame add radiobutton -label [msgcat::mc {Image}] \
+ -variable panzoom(lock) -value image -command LockFrameCurrent
+ $ds9(mb).frame.lock.frame add radiobutton -label [msgcat::mc {Physical}] \
+ -variable panzoom(lock) -value physical -command LockFrameCurrent
+ $ds9(mb).frame.lock.frame add radiobutton -label [msgcat::mc {Amplifier}] \
+ -variable panzoom(lock) -value amplifier -command LockFrameCurrent
+ $ds9(mb).frame.lock.frame add radiobutton -label [msgcat::mc {Detector}] \
+ -variable panzoom(lock) -value detector -command LockFrameCurrent
+
+ menu $ds9(mb).frame.lock.crosshair
+ $ds9(mb).frame.lock.crosshair add radiobutton \
+ -label [msgcat::mc {None}] -variable crosshair(lock) \
+ -value none -command LockCrosshairCurrent
+ $ds9(mb).frame.lock.crosshair add separator
+ $ds9(mb).frame.lock.crosshair add radiobutton \
+ -label [msgcat::mc {WCS}] -variable crosshair(lock) \
+ -value wcs -command LockCrosshairCurrent
+ $ds9(mb).frame.lock.crosshair add separator
+ $ds9(mb).frame.lock.crosshair add radiobutton \
+ -label [msgcat::mc {Image}] -variable crosshair(lock) \
+ -value image -command LockCrosshairCurrent
+ $ds9(mb).frame.lock.crosshair add radiobutton \
+ -label [msgcat::mc {Physical}] -variable crosshair(lock) \
+ -value physical -command LockCrosshairCurrent
+ $ds9(mb).frame.lock.crosshair add radiobutton \
+ -label [msgcat::mc {Amplifier}] -variable crosshair(lock) \
+ -value amplifier -command LockCrosshairCurrent
+ $ds9(mb).frame.lock.crosshair add radiobutton \
+ -label [msgcat::mc {Detector}] -variable crosshair(lock) \
+ -value detector -command LockCrosshairCurrent
+
+ menu $ds9(mb).frame.lock.crop
+ $ds9(mb).frame.lock.crop add radiobutton -label [msgcat::mc {None}] \
+ -variable crop(lock) -value none -command LockCropCurrent
+ $ds9(mb).frame.lock.crop add separator
+ $ds9(mb).frame.lock.crop add radiobutton -label [msgcat::mc {WCS}] \
+ -variable crop(lock) -value wcs -command LockCropCurrent
+ $ds9(mb).frame.lock.crop add separator
+ $ds9(mb).frame.lock.crop add radiobutton -label [msgcat::mc {Image}] \
+ -variable crop(lock) -value image -command LockCropCurrent
+ $ds9(mb).frame.lock.crop add radiobutton -label [msgcat::mc {Physical}] \
+ -variable crop(lock) -value physical -command LockCropCurrent
+ $ds9(mb).frame.lock.crop add radiobutton -label [msgcat::mc {Amplifier}] \
+ -variable crop(lock) -value amplifier -command LockCropCurrent
+ $ds9(mb).frame.lock.crop add radiobutton -label [msgcat::mc {Detector}] \
+ -variable crop(lock) -value detector -command LockCropCurrent
+
+ menu $ds9(mb).frame.lock.cube
+ $ds9(mb).frame.lock.cube add radiobutton -label [msgcat::mc {None}] \
+ -variable cube(lock) -value none -command LockCubeCurrent
+ $ds9(mb).frame.lock.cube add separator
+ $ds9(mb).frame.lock.cube add radiobutton -label [msgcat::mc {WCS}] \
+ -variable cube(lock) -value wcs -command LockCubeCurrent
+ $ds9(mb).frame.lock.cube add separator
+ $ds9(mb).frame.lock.cube add radiobutton -label [msgcat::mc {Image}] \
+ -variable cube(lock) -value image -command LockCubeCurrent
+
+ # active
+ menu $ds9(mb).frame.active
+ $ds9(mb).frame.active add command -label [msgcat::mc {Show All}] \
+ -command ActiveFrameAll
+ $ds9(mb).frame.active add command -label [msgcat::mc {Hide All}] \
+ -command ActiveFrameNone
+ $ds9(mb).frame.active add separator
+
+ # move
+ menu $ds9(mb).frame.move
+ $ds9(mb).frame.move add command -label [msgcat::mc {First}] \
+ -command MoveFirstFrame
+ $ds9(mb).frame.move add command -label [msgcat::mc {Back}] \
+ -command MovePrevFrame
+ $ds9(mb).frame.move add command -label [msgcat::mc {Forward}] \
+ -command MoveNextFrame
+ $ds9(mb).frame.move add command -label [msgcat::mc {Last}] \
+ -command MoveLastFrame
+
+ menu $ds9(mb).frame.goto
+
+ # params
+ menu $ds9(mb).frame.params
+ $ds9(mb).frame.params add cascade -label [msgcat::mc {Tile}] \
+ -menu $ds9(mb).frame.params.tile
+ $ds9(mb).frame.params add cascade -label [msgcat::mc {Blink Interval}] \
+ -menu $ds9(mb).frame.params.blink
+ $ds9(mb).frame.params add command -label [msgcat::mc {Display Size}] \
+ -command DisplayDefaultDialog
+
+ menu $ds9(mb).frame.params.tile
+ $ds9(mb).frame.params.tile add radiobutton -label [msgcat::mc {Grid}] \
+ -variable tile(mode) -value grid -command DisplayMode
+ $ds9(mb).frame.params.tile add radiobutton -label [msgcat::mc {Columns}] \
+ -variable tile(mode) -value column -command DisplayMode
+ $ds9(mb).frame.params.tile add radiobutton -label [msgcat::mc {Rows}] \
+ -variable tile(mode) -value row -command DisplayMode
+ $ds9(mb).frame.params.tile add separator
+ $ds9(mb).frame.params.tile add command \
+ -label "[msgcat::mc {Tile Parameters}]..." -command TileDialog
+
+ menu $ds9(mb).frame.params.blink
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label ".125 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 125
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label ".25 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 250
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label ".5 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 500
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label "1 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 1000
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label "2 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 2000
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label "4 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 4000
+ $ds9(mb).frame.params.blink add radiobutton \
+ -label "8 [msgcat::mc {Seconds}]" \
+ -variable blink(interval) -value 8000
+}
+
+proc PrefsDialogFrameMenu {w} {
+ set f [ttk::labelframe $w.mframe -text [msgcat::mc {Frame}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarFrame $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {Single Frame}] \
+ -variable pcurrent(display) -value single
+ $m add radiobutton -label [msgcat::mc {Tile Frames}] \
+ -variable pcurrent(display) -value tile
+ $m add radiobutton -label [msgcat::mc {Blink Frames}] \
+ -variable pcurrent(display) -value blink
+ $m add separator
+ $m add cascade -label [msgcat::mc {Frame Parameters}] \
+ -menu $m.params
+
+ menu $m.params
+ $m.params add cascade -label [msgcat::mc {Tile}] \
+ -menu $m.params.tile
+ $m.params add cascade -label [msgcat::mc {Blink Interval}] \
+ -menu $m.params.blink
+
+ menu $m.params.tile
+ $m.params.tile add radiobutton -label [msgcat::mc {Grid}] \
+ -variable ptile(mode) -value grid
+ $m.params.tile add radiobutton -label [msgcat::mc {Columns}] \
+ -variable ptile(mode) -value column
+ $m.params.tile add radiobutton -label [msgcat::mc {Rows}] \
+ -variable ptile(mode) -value row
+
+ menu $m.params.blink
+ $m.params.blink add radiobutton -label ".125 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 125
+ $m.params.blink add radiobutton -label ".25 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 250
+ $m.params.blink add radiobutton -label ".5 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 500
+ $m.params.blink add radiobutton -label "1 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 1000
+ $m.params.blink add radiobutton -label "2 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 2000
+ $m.params.blink add radiobutton -label "4 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 4000
+ $m.params.blink add radiobutton -label "8 [msgcat::mc {Seconds}]" \
+ -variable pblink(interval) -value 8000
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsFrameDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ frame,new 1
+ frame,newrgb 1
+ frame,new3d 1
+ frame,delete 1
+ frame,deleteall 0
+ frame,clear 1
+ frame,reset 0
+ frame,refresh 0
+ frame,single 1
+ frame,tile 1
+ frame,blink 1
+
+ frame,match,bin 0
+ frame,match,axes 0
+ frame,match,scale 0
+ frame,match,scalelimits 0
+ frame,match,color 0
+ frame,match,smooth 0
+
+ frame,match,frame,wcs 0
+ frame,match,frame,image 0
+ frame,match,frame,physical 0
+ frame,match,frame,detector 0
+ frame,match,frame,amplifier 0
+
+ frame,match,crosshair,wcs 0
+ frame,match,crosshair,image 0
+ frame,match,crosshair,physical 0
+ frame,match,crosshair,detector 0
+ frame,match,crosshair,amplifier 0
+
+ frame,match,crop,wcs 0
+ frame,match,crop,image 0
+ frame,match,crop,physical 0
+ frame,match,crop,detector 0
+ frame,match,crop,amplifier 0
+
+ frame,match,cube,wcs 0
+ frame,match,cube,image 0
+
+ frame,lock,bin 0
+ frame,lock,axes 0
+ frame,lock,scale 0
+ frame,lock,scalelimits 0
+ frame,lock,color 0
+ frame,lock,smooth 0
+
+ frame,lock,frame,none 0
+ frame,lock,frame,wcs 0
+ frame,lock,frame,image 0
+ frame,lock,frame,physical 0
+ frame,lock,frame,detector 0
+ frame,lock,frame,amplifier 0
+
+ frame,lock,crosshair,none 0
+ frame,lock,crosshair,wcs 0
+ frame,lock,crosshair,image 0
+ frame,lock,crosshair,physical 0
+ frame,lock,crosshair,detector 0
+ frame,lock,crosshair,amplifier 0
+
+ frame,lock,crop,none 0
+ frame,lock,crop,wcs 0
+ frame,lock,crop,image 0
+ frame,lock,crop,physical 0
+ frame,lock,crop,detector 0
+ frame,lock,crop,amplifier 0
+
+ frame,lock,cube,none 0
+ frame,lock,cube,wcs 0
+ frame,lock,cube,image 0
+
+ frame,movefirst 0
+ frame,moveprev 0
+ frame,movenext 0
+ frame,movelast 0
+ frame,first 1
+ frame,prev 1
+ frame,next 1
+ frame,last 1
+ frame,cube 0
+ frame,rgb 0
+ frame,3d 0
+ frame,size 0
+ }
+}
+
+proc CreateButtonsFrame {} {
+ global buttons
+ global ds9
+ global current
+
+ ttk::frame $ds9(buttons).frame
+
+ ButtonButton $ds9(buttons).frame.new \
+ [string tolower [msgcat::mc {New}]] CreateFrame
+ ButtonButton $ds9(buttons).frame.newrgb \
+ [string tolower [msgcat::mc {RGB}]] CreateRGBFrame
+ ButtonButton $ds9(buttons).frame.new3d \
+ [string tolower [msgcat::mc {3D}]] Create3DFrame
+
+ ButtonButton $ds9(buttons).frame.delete \
+ [string tolower [msgcat::mc {Delete}]] DeleteCurrentFrame
+ ButtonButton $ds9(buttons).frame.deleteall \
+ [string tolower [msgcat::mc {Delete All}]] DeleteAllFramesMenu
+
+ ButtonButton $ds9(buttons).frame.clear \
+ [string tolower [msgcat::mc {Clear}]] ClearCurrentFrame
+ ButtonButton $ds9(buttons).frame.reset \
+ [string tolower [msgcat::mc {Reset}]] ResetCurrentFrame
+ ButtonButton $ds9(buttons).frame.refresh \
+ [string tolower [msgcat::mc {Refresh}]] UpdateCurrentFrame
+
+ RadioButton $ds9(buttons).frame.single \
+ [string tolower [msgcat::mc {Single}]] \
+ current(display) single DisplayMode
+ RadioButton $ds9(buttons).frame.tile \
+ [string tolower [msgcat::mc {Tile}]] \
+ current(display) tile DisplayMode
+ RadioButton $ds9(buttons).frame.blink \
+ [string tolower [msgcat::mc {Blink}]] \
+ current(display) blink DisplayMode
+
+ ButtonButton $ds9(buttons).frame.matchbin \
+ [string tolower [msgcat::mc {Match Bin}]] MatchBinCurrent
+ ButtonButton $ds9(buttons).frame.matchaxes \
+ [string tolower [msgcat::mc {Match Axes}]] MatchAxesCurrent
+ ButtonButton $ds9(buttons).frame.matchscale \
+ [string tolower [msgcat::mc {Match Scale}]] MatchScaleCurrent
+ ButtonButton $ds9(buttons).frame.matchscalelimits \
+ [string tolower [msgcat::mc {Match Limits}]] \
+ MatchScaleLimitsCurrent
+ ButtonButton $ds9(buttons).frame.matchcolor \
+ [string tolower [msgcat::mc {Match Color}]] MatchColorCurrent
+ ButtonButton $ds9(buttons).frame.matchsmooth \
+ [string tolower [msgcat::mc {Match Smooth}]] MatchSmoothCurrent
+
+ ButtonButton $ds9(buttons).frame.matchframewcs \
+ [string tolower [msgcat::mc {Match Frame WCS}]] \
+ {MatchFrameCurrent wcs}
+ ButtonButton $ds9(buttons).frame.matchframeimage \
+ [string tolower [msgcat::mc {Match Frame Image}]] \
+ {MatchFrameCurrent image}
+ ButtonButton $ds9(buttons).frame.matchframephysical \
+ [string tolower [msgcat::mc {Match Frame Physical}]] \
+ {MatchFrameCurrent physical}
+ ButtonButton $ds9(buttons).frame.matchframedetector \
+ [string tolower [msgcat::mc {Match Frame Detector}]] \
+ {MatchFrameCurrent detector}
+ ButtonButton $ds9(buttons).frame.matchframeamplifier \
+ [string tolower [msgcat::mc {Match Frame Amplifier}]] \
+ {MatchFrameCurrent amplifier}
+
+ ButtonButton $ds9(buttons).frame.matchcrosshairwcs \
+ [string tolower [msgcat::mc {Match Crosshair WCS}]] \
+ {MatchCrosshairCurrent wcs}
+ ButtonButton $ds9(buttons).frame.matchcrosshairimage \
+ [string tolower [msgcat::mc {Match Crosshair Image}]] \
+ {MatchCrosshairCurrent image}
+ ButtonButton $ds9(buttons).frame.matchcrosshairphysical \
+ [string tolower [msgcat::mc {Match Crosshair Physical}]] \
+ {MatchCrosshairCurrent physical}
+ ButtonButton $ds9(buttons).frame.matchcrosshairdetector \
+ [string tolower [msgcat::mc {Match Crosshair Detector}]] \
+ {MatchCrosshairCurrent detector}
+ ButtonButton $ds9(buttons).frame.matchcrosshairamplifier \
+ [string tolower [msgcat::mc {Match Crosshair Amplifier}]] \
+ {MatchCrosshairCurrent amplifier}
+
+ ButtonButton $ds9(buttons).frame.matchcropwcs \
+ [string tolower [msgcat::mc {Match Crop WCS}]] \
+ {MatchCropCurrent wcs}
+ ButtonButton $ds9(buttons).frame.matchcropimage \
+ [string tolower [msgcat::mc {Match Crop Image}]] \
+ {MatchCropCurrent image}
+ ButtonButton $ds9(buttons).frame.matchcropphysical \
+ [string tolower [msgcat::mc {Match Crop Physical}]] \
+ {MatchCropCurrent physical}
+ ButtonButton $ds9(buttons).frame.matchcropdetector \
+ [string tolower [msgcat::mc {Match Crop Detector}]] \
+ {MatchCropCurrent detector}
+ ButtonButton $ds9(buttons).frame.matchcropamplifier \
+ [string tolower [msgcat::mc {Match Crop Amplifier}]] \
+ {MatchCropCurrent amplifier}
+
+ ButtonButton $ds9(buttons).frame.matchcubewcs \
+ [string tolower [msgcat::mc {Match Slice WCS}]] \
+ {MatchCubeCurrent wcs}
+ ButtonButton $ds9(buttons).frame.matchcubeimage \
+ [string tolower [msgcat::mc {Match Slice Image}]] \
+ {MatchCubeCurrent image}
+
+ CheckButton $ds9(buttons).frame.lockbin \
+ [string tolower [msgcat::mc {Lock Bin}]] bin(lock) LockBinCurrent
+ CheckButton $ds9(buttons).frame.lockaxes \
+ [string tolower [msgcat::mc {Lock Axes}]] \
+ cube(lock,axes) LockAxesCurrent
+ CheckButton $ds9(buttons).frame.lockscale \
+ [string tolower [msgcat::mc {Lock Scale}]] scale(lock) LockScaleCurrent
+ CheckButton $ds9(buttons).frame.lockscalelimits \
+ [string tolower [msgcat::mc {Lock Limits}]] \
+ scale(lock,limits) LockScaleLimitsCurrent
+ CheckButton $ds9(buttons).frame.lockcolor \
+ [string tolower [msgcat::mc {Lock Color}]] color(lock) LockColorCurrent
+ CheckButton $ds9(buttons).frame.locksmooth \
+ [string tolower [msgcat::mc {Lock Smooth}]] \
+ smooth(lock) LockSmoothCurrent
+
+ RadioButton $ds9(buttons).frame.lockframenone \
+ [string tolower [msgcat::mc {Lock Frame None}]] \
+ panzoom(lock) none LockFrameCurrent
+ RadioButton $ds9(buttons).frame.lockframewcs \
+ [string tolower [msgcat::mc {Lock Frame WCS}]] \
+ panzoom(lock) wcs LockFrameCurrent
+ RadioButton $ds9(buttons).frame.lockframeimage \
+ [string tolower [msgcat::mc {Lock Frame Image}]] \
+ panzoom(lock) image LockFrameCurrent
+ RadioButton $ds9(buttons).frame.lockframephysical \
+ [string tolower [msgcat::mc {Lock Frame Physical}]] \
+ panzoom(lock) physical LockFrameCurrent
+ RadioButton $ds9(buttons).frame.lockframedetector \
+ [string tolower [msgcat::mc {Lock Frame Detector}]] \
+ panzoom(lock) detector LockFrameCurrent
+ RadioButton $ds9(buttons).frame.lockframeamplifier \
+ [string tolower [msgcat::mc {Lock Frame Amplifier}]] \
+ panzoom(lock) amplifier LockFrameCurrent
+
+ RadioButton $ds9(buttons).frame.lockcrosshairnone \
+ [string tolower [msgcat::mc {Lock Crosshair None}]] \
+ crosshair(lock) none LockCrosshairCurrent
+ RadioButton $ds9(buttons).frame.lockcrosshairwcs \
+ [string tolower [msgcat::mc {Lock Crosshair WCS}]] \
+ crosshair(lock) wcs LockCrosshairCurrent
+ RadioButton $ds9(buttons).frame.lockcrosshairimage \
+ [string tolower [msgcat::mc {Lock Crosshair Image}]] \
+ crosshair(lock) image LockCrosshairCurrent
+ RadioButton $ds9(buttons).frame.lockcrosshairphysical \
+ [string tolower [msgcat::mc {Lock Crosshair Physical}]] \
+ crosshair(lock) physical LockCrosshairCurrent
+ RadioButton $ds9(buttons).frame.lockcrosshairdetector \
+ [string tolower [msgcat::mc {Lock Crosshair Detector}]] \
+ crosshair(lock) detector LockCrosshairCurrent
+ RadioButton $ds9(buttons).frame.lockcrosshairamplifier \
+ [string tolower [msgcat::mc {Lock Crosshair Amplifier}]] \
+ crosshair(lock) amplifier LockCrosshairCurrent
+
+ RadioButton $ds9(buttons).frame.lockcropnone \
+ [string tolower [msgcat::mc {Lock Crop None}]] \
+ crop(lock) none LockCropCurrent
+ RadioButton $ds9(buttons).frame.lockcropwcs \
+ [string tolower [msgcat::mc {Lock Crop WCS}]] \
+ crop(lock) wcs LockCropCurrent
+ RadioButton $ds9(buttons).frame.lockcropimage \
+ [string tolower [msgcat::mc {Lock Crop Image}]] \
+ crop(lock) image LockCropCurrent
+ RadioButton $ds9(buttons).frame.lockcropphysical \
+ [string tolower [msgcat::mc {Lock Crop Physical}]] \
+ crop(lock) physical LockCropCurrent
+ RadioButton $ds9(buttons).frame.lockcropdetector \
+ [string tolower [msgcat::mc {Lock Crop Detector}]] \
+ crop(lock) detector LockCropCurrent
+ RadioButton $ds9(buttons).frame.lockcropamplifier \
+ [string tolower [msgcat::mc {Lock Crop Amplifier}]] \
+ crop(lock) amplifier LockCropCurrent
+
+ RadioButton $ds9(buttons).frame.lockcubenone \
+ [string tolower [msgcat::mc {Lock Slice None}]] \
+ cube(lock) none LockCubeCurrent
+ RadioButton $ds9(buttons).frame.lockcubewcs \
+ [string tolower [msgcat::mc {Lock Slice WCS}]] \
+ cube(lock) wcs LockCubeCurrent
+ RadioButton $ds9(buttons).frame.lockcubeimage \
+ [string tolower [msgcat::mc {Lock Slice Image}]] \
+ cube(lock) image LockCubeCurrent
+
+ ButtonButton $ds9(buttons).frame.movefirst \
+ [string tolower [msgcat::mc {Move First}]] MoveFirstFrame
+ ButtonButton $ds9(buttons).frame.moveprev \
+ [string tolower [msgcat::mc {Move Back}]] MovePrevFrame
+ ButtonButton $ds9(buttons).frame.movenext \
+ [string tolower [msgcat::mc {Move Forward}]] MoveNextFrame
+ ButtonButton $ds9(buttons).frame.movelast \
+ [string tolower [msgcat::mc {Move Last}]] MoveLastFrame
+
+ ButtonButton $ds9(buttons).frame.first \
+ [string tolower [msgcat::mc {First}]] FirstFrame
+ ButtonButton $ds9(buttons).frame.prev \
+ [string tolower [msgcat::mc {Prev}]] PrevFrame
+ ButtonButton $ds9(buttons).frame.next \
+ [string tolower [msgcat::mc {Next}]] NextFrame
+ ButtonButton $ds9(buttons).frame.last \
+ [string tolower [msgcat::mc {Last}]] LastFrame
+
+ ButtonButton $ds9(buttons).frame.cube \
+ [string tolower "[msgcat::mc {Cube}]..."] CubeDialog
+ ButtonButton $ds9(buttons).frame.rgb \
+ [string tolower "[msgcat::mc {RGB}]..."] RGBDialog
+ ButtonButton $ds9(buttons).frame.3d \
+ [string tolower "[msgcat::mc {3D}]..."] 3DDialog
+
+ ButtonButton $ds9(buttons).frame.size \
+ [string tolower [msgcat::mc {Size}]] DisplayDefaultDialog
+
+ set buttons(frame) "
+ $ds9(buttons).frame.new pbuttons(frame,new)
+ $ds9(buttons).frame.newrgb pbuttons(frame,newrgb)
+ $ds9(buttons).frame.new3d pbuttons(frame,new3d)
+ $ds9(buttons).frame.delete pbuttons(frame,delete)
+ $ds9(buttons).frame.deleteall pbuttons(frame,deleteall)
+ $ds9(buttons).frame.clear pbuttons(frame,clear)
+ $ds9(buttons).frame.reset pbuttons(frame,reset)
+ $ds9(buttons).frame.refresh pbuttons(frame,refresh)
+ $ds9(buttons).frame.single pbuttons(frame,single)
+ $ds9(buttons).frame.tile pbuttons(frame,tile)
+ $ds9(buttons).frame.blink pbuttons(frame,blink)
+
+ $ds9(buttons).frame.matchbin pbuttons(frame,match,bin)
+ $ds9(buttons).frame.matchaxes pbuttons(frame,match,axes)
+ $ds9(buttons).frame.matchscale pbuttons(frame,match,scale)
+ $ds9(buttons).frame.matchscalelimits pbuttons(frame,match,scalelimits)
+ $ds9(buttons).frame.matchcolor pbuttons(frame,match,color)
+ $ds9(buttons).frame.matchsmooth pbuttons(frame,match,smooth)
+
+ $ds9(buttons).frame.matchframewcs pbuttons(frame,match,frame,wcs)
+ $ds9(buttons).frame.matchframeimage pbuttons(frame,match,frame,image)
+ $ds9(buttons).frame.matchframephysical pbuttons(frame,match,frame,physical)
+ $ds9(buttons).frame.matchframedetector pbuttons(frame,match,frame,detector)
+ $ds9(buttons).frame.matchframeamplifier pbuttons(frame,match,frame,amplifier)
+
+ $ds9(buttons).frame.matchcrosshairwcs pbuttons(frame,match,crosshair,wcs)
+ $ds9(buttons).frame.matchcrosshairimage pbuttons(frame,match,crosshair,image)
+ $ds9(buttons).frame.matchcrosshairphysical pbuttons(frame,match,crosshair,physical)
+ $ds9(buttons).frame.matchcrosshairdetector pbuttons(frame,match,crosshair,detector)
+ $ds9(buttons).frame.matchcrosshairamplifier pbuttons(frame,match,crosshair,amplifier)
+
+ $ds9(buttons).frame.matchcropwcs pbuttons(frame,match,crop,wcs)
+ $ds9(buttons).frame.matchcropimage pbuttons(frame,match,crop,image)
+ $ds9(buttons).frame.matchcropphysical pbuttons(frame,match,crop,physical)
+ $ds9(buttons).frame.matchcropdetector pbuttons(frame,match,crop,detector)
+ $ds9(buttons).frame.matchcropamplifier pbuttons(frame,match,crop,amplifier)
+
+ $ds9(buttons).frame.matchcubewcs pbuttons(frame,match,cube,wcs)
+ $ds9(buttons).frame.matchcubeimage pbuttons(frame,match,cube,image)
+
+ $ds9(buttons).frame.lockbin pbuttons(frame,lock,bin)
+ $ds9(buttons).frame.lockaxes pbuttons(frame,lock,axes)
+ $ds9(buttons).frame.lockscale pbuttons(frame,lock,scale)
+ $ds9(buttons).frame.lockscalelimits pbuttons(frame,lock,scalelimits)
+ $ds9(buttons).frame.lockcolor pbuttons(frame,lock,color)
+ $ds9(buttons).frame.locksmooth pbuttons(frame,lock,smooth)
+
+ $ds9(buttons).frame.lockframenone pbuttons(frame,lock,frame,none)
+ $ds9(buttons).frame.lockframewcs pbuttons(frame,lock,frame,wcs)
+ $ds9(buttons).frame.lockframeimage pbuttons(frame,lock,frame,image)
+ $ds9(buttons).frame.lockframephysical pbuttons(frame,lock,frame,physical)
+ $ds9(buttons).frame.lockframedetector pbuttons(frame,lock,frame,detector)
+ $ds9(buttons).frame.lockframeamplifier pbuttons(frame,lock,frame,amplifier)
+
+ $ds9(buttons).frame.lockcrosshairnone pbuttons(frame,lock,crosshair,none)
+ $ds9(buttons).frame.lockcrosshairwcs pbuttons(frame,lock,crosshair,wcs)
+ $ds9(buttons).frame.lockcrosshairimage pbuttons(frame,lock,crosshair,image)
+ $ds9(buttons).frame.lockcrosshairphysical pbuttons(frame,lock,crosshair,physical)
+ $ds9(buttons).frame.lockcrosshairdetector pbuttons(frame,lock,crosshair,detector)
+ $ds9(buttons).frame.lockcrosshairamplifier pbuttons(frame,lock,crosshair,amplifier)
+
+ $ds9(buttons).frame.lockcropnone pbuttons(frame,lock,crop,none)
+ $ds9(buttons).frame.lockcropwcs pbuttons(frame,lock,crop,wcs)
+ $ds9(buttons).frame.lockcropimage pbuttons(frame,lock,crop,image)
+ $ds9(buttons).frame.lockcropphysical pbuttons(frame,lock,crop,physical)
+ $ds9(buttons).frame.lockcropdetector pbuttons(frame,lock,crop,detector)
+ $ds9(buttons).frame.lockcropamplifier pbuttons(frame,lock,crop,amplifier)
+
+ $ds9(buttons).frame.lockcubenone pbuttons(frame,lock,cube,none)
+ $ds9(buttons).frame.lockcubewcs pbuttons(frame,lock,cube,wcs)
+ $ds9(buttons).frame.lockcubeimage pbuttons(frame,lock,cube,image)
+
+ $ds9(buttons).frame.movefirst pbuttons(frame,movefirst)
+ $ds9(buttons).frame.moveprev pbuttons(frame,moveprev)
+ $ds9(buttons).frame.movenext pbuttons(frame,movenext)
+ $ds9(buttons).frame.movelast pbuttons(frame,movelast)
+ $ds9(buttons).frame.first pbuttons(frame,first)
+ $ds9(buttons).frame.prev pbuttons(frame,prev)
+ $ds9(buttons).frame.next pbuttons(frame,next)
+ $ds9(buttons).frame.last pbuttons(frame,last)
+ $ds9(buttons).frame.cube pbuttons(frame,cube)
+ $ds9(buttons).frame.rgb pbuttons(frame,rgb)
+ $ds9(buttons).frame.3d pbuttons(frame,3d)
+ $ds9(buttons).frame.size pbuttons(frame,size)
+ "
+}
+
+proc PrefsDialogButtonbarFrame {f} {
+ global buttons
+ global pbuttons
+ global ds9
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {New Frame}] \
+ -variable pbuttons(frame,new) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {New Frame RGB}] \
+ -variable pbuttons(frame,newrgb) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {New Frame 3D}] \
+ -variable pbuttons(frame,new3d) -command {UpdateButtons buttons(frame)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Delete Frame}] \
+ -variable pbuttons(frame,delete) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Delete All Frames}] \
+ -variable pbuttons(frame,deleteall) -command {UpdateButtons buttons(frame)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Clear Frame}] \
+ -variable pbuttons(frame,clear) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Reset Frame}] \
+ -variable pbuttons(frame,reset) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Refresh Frame}] \
+ -variable pbuttons(frame,refresh) -command {UpdateButtons buttons(frame)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Single Frame}] \
+ -variable pbuttons(frame,single) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Tile Frames}] \
+ -variable pbuttons(frame,tile) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Blink Frames}] \
+ -variable pbuttons(frame,blink) -command {UpdateButtons buttons(frame)}
+ $m add separator
+ $m add cascade -label [msgcat::mc {Match}] -menu $m.match
+ $m add cascade -label [msgcat::mc {Lock}] -menu $m.lock
+ $m add separator
+ $m add cascade -label [msgcat::mc {Move Frame}] -menu $m.move
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {First Frame}] \
+ -variable pbuttons(frame,first) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Previous Frame}] \
+ -variable pbuttons(frame,prev) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Next Frame}] \
+ -variable pbuttons(frame,next) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label [msgcat::mc {Last Frame}] \
+ -variable pbuttons(frame,last) -command {UpdateButtons buttons(frame)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Cube}]..." \
+ -variable pbuttons(frame,cube) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label "[msgcat::mc {RGB}]..." \
+ -variable pbuttons(frame,rgb) -command {UpdateButtons buttons(frame)}
+ $m add checkbutton -label "[msgcat::mc {3D}]..." \
+ -variable pbuttons(frame,3d) -command {UpdateButtons buttons(frame)}
+ $m add separator
+ $m add cascade -label [msgcat::mc {Frame Parameters}] -menu $m.params
+
+ # match
+ menu $m.match
+ $m.match add cascade -label [msgcat::mc {Frame}] \
+ -menu $m.match.frame
+ $m.match add cascade -label [msgcat::mc {Crosshair}] \
+ -menu $m.match.crosshair
+ $m.match add cascade -label [msgcat::mc {Crop}] \
+ -menu $m.match.crop
+ $m.match add cascade -label [msgcat::mc {Slice}] \
+ -menu $m.match.cube
+ $m.match add checkbutton -label [msgcat::mc {Bin}] \
+ -variable pbuttons(frame,match,bin) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match add checkbutton -label [msgcat::mc {Axes Order}] \
+ -variable pbuttons(frame,match,axes) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match add checkbutton -label [msgcat::mc {Scale}] \
+ -variable pbuttons(frame,match,scale) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match add checkbutton -label [msgcat::mc {Scale and Limits}] \
+ -variable pbuttons(frame,match,scalelimits) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match add checkbutton -label [msgcat::mc {Color}] \
+ -variable pbuttons(frame,match,color) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable pbuttons(frame,match,smooth) \
+ -command {UpdateButtons buttons(frame)}
+
+ menu $m.match.frame
+ $m.match.frame add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,match,frame,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.frame add separator
+ $m.match.frame add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,match,frame,image) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.frame add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(frame,match,frame,physical) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.frame add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(frame,match,frame,detector) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.frame add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(frame,match,frame,amplifier) \
+ -command {UpdateButtons buttons(frame)}
+
+ menu $m.match.crosshair
+ $m.match.crosshair add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,match,crosshair,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crosshair add separator
+ $m.match.crosshair add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,match,crosshair,image) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crosshair add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(frame,match,crosshair,physical) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crosshair add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(frame,match,crosshair,detector) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crosshair add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(frame,match,crosshair,amplifier) \
+ -command {UpdateButtons buttons(frame)}
+
+ menu $m.match.crop
+ $m.match.crop add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,match,crop,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crop add separator
+ $m.match.crop add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,match,crop,image) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crop add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(frame,match,crop,physical) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crop add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(frame,match,crop,detector) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.crop add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(frame,match,crop,amplifier) \
+ -command {UpdateButtons buttons(frame)}
+
+
+ menu $m.match.cube
+ $m.match.cube add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,match,cube,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.match.cube add separator
+ $m.match.cube add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,match,cube,image) \
+ -command {UpdateButtons buttons(frame)}
+
+ # lock
+ menu $m.lock
+ $m.lock add cascade -label [msgcat::mc {Frame}] \
+ -menu $m.lock.frame
+ $m.lock add cascade -label [msgcat::mc {Crosshair}] \
+ -menu $m.lock.crosshair
+ $m.lock add cascade -label [msgcat::mc {Crop}] \
+ -menu $m.lock.crop
+ $m.lock add cascade -label [msgcat::mc {Slice}] \
+ -menu $m.lock.cube
+ $m.lock add checkbutton -label [msgcat::mc {Bin}] \
+ -variable pbuttons(frame,lock,bin) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock add checkbutton -label [msgcat::mc {Axes Order}] \
+ -variable pbuttons(frame,lock,axes) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock add checkbutton -label [msgcat::mc {Scale}] \
+ -variable pbuttons(frame,lock,scale) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock add checkbutton -label [msgcat::mc {Scale and Limits}] \
+ -variable pbuttons(frame,lock,scalelimits) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock add checkbutton -label [msgcat::mc {Color}] \
+ -variable pbuttons(frame,lock,color) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable pbuttons(frame,lock,smooth) \
+ -command {UpdateButtons buttons(frame)}
+
+ menu $m.lock.frame
+ $m.lock.frame add checkbutton -label [msgcat::mc {None}] \
+ -variable pbuttons(frame,lock,frame,none) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.frame add separator
+ $m.lock.frame add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,lock,frame,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.frame add separator
+ $m.lock.frame add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,lock,frame,image) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.frame add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(frame,lock,frame,physical) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.frame add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(frame,lock,frame,detector) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.frame add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(frame,lock,frame,amplifier) \
+ -command {UpdateButtons buttons(frame)}
+
+ menu $m.lock.crosshair
+ $m.lock.crosshair add checkbutton -label [msgcat::mc {None}] \
+ -variable pbuttons(frame,lock,crosshair,none) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crosshair add separator
+ $m.lock.crosshair add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,lock,crosshair,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crosshair add separator
+ $m.lock.crosshair add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,lock,crosshair,image) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crosshair add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(frame,lock,crosshair,physical) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crosshair add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(frame,lock,crosshair,detector) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crosshair add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(frame,lock,crosshair,amplifier) \
+ -command {UpdateButtons buttons(frame)}
+
+ menu $m.lock.crop
+ $m.lock.crop add checkbutton -label [msgcat::mc {None}] \
+ -variable pbuttons(frame,lock,crop,none) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crop add separator
+ $m.lock.crop add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,lock,crop,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crop add separator
+ $m.lock.crop add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,lock,crop,image) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crop add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(frame,lock,crop,physical) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crop add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(frame,lock,crop,detector) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.crop add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(frame,lock,crop,amplifier) \
+ -command {UpdateButtons buttons(frame)}
+
+
+ menu $m.lock.cube
+ $m.lock.cube add checkbutton -label [msgcat::mc {None}] \
+ -variable pbuttons(frame,lock,cube,none) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.cube add separator
+ $m.lock.cube add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(frame,lock,cube,wcs) \
+ -command {UpdateButtons buttons(frame)}
+ $m.lock.cube add separator
+ $m.lock.cube add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(frame,lock,cube,image) \
+ -command {UpdateButtons buttons(frame)}
+
+ # move
+ menu $m.move
+ $m.move add checkbutton -label [msgcat::mc {First}] \
+ -variable pbuttons(frame,movefirst) \
+ -command {UpdateButtons buttons(frame)}
+ $m.move add checkbutton -label [msgcat::mc {Back}] \
+ -variable pbuttons(frame,moveprev) \
+ -command {UpdateButtons buttons(frame)}
+ $m.move add checkbutton -label [msgcat::mc {Forward}] \
+ -variable pbuttons(frame,movenext) \
+ -command {UpdateButtons buttons(frame)}
+ $m.move add checkbutton -label [msgcat::mc {Last}] \
+ -variable pbuttons(frame,movelast) \
+ -command {UpdateButtons buttons(frame)}
+
+ # params
+ menu $m.params
+ $m.params add checkbutton -label [msgcat::mc {Display Size}] \
+ -variable pbuttons(frame,size) -command {UpdateButtons buttons(frame)}
+}
+
+# Support
+
+proc UpdateFrameMenuStatic {} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateFrameMenuStatic"
+ }
+
+ $ds9(mb).frame entryconfig [msgcat::mc {New Frame RGB}] -state normal
+ $ds9(buttons).frame.newrgb configure -state normal
+
+ if {$ds9(active,num) > 0} {
+ $ds9(mb).frame entryconfig [msgcat::mc {Delete Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Delete All Frames}] -state normal
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Clear Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Reset Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Refresh Frame}] -state normal
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Single Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Tile Frames}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Blink Frames}] -state normal
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Match}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Lock}] -state normal
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Move Frame}] -state normal
+
+ $ds9(mb).frame entryconfig [msgcat::mc {First Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Previous Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Next Frame}] -state normal
+ $ds9(mb).frame entryconfig [msgcat::mc {Last Frame}] -state normal
+
+ $ds9(buttons).frame.delete configure -state normal
+ $ds9(buttons).frame.deleteall configure -state normal
+
+ $ds9(buttons).frame.clear configure -state normal
+ $ds9(buttons).frame.reset configure -state normal
+ $ds9(buttons).frame.refresh configure -state normal
+
+ $ds9(buttons).frame.single configure -state normal
+ $ds9(buttons).frame.tile configure -state normal
+ $ds9(buttons).frame.blink configure -state normal
+
+ $ds9(buttons).frame.movefirst configure -state normal
+ $ds9(buttons).frame.moveprev configure -state normal
+ $ds9(buttons).frame.movenext configure -state normal
+ $ds9(buttons).frame.movelast configure -state normal
+
+ $ds9(buttons).frame.first configure -state normal
+ $ds9(buttons).frame.prev configure -state normal
+ $ds9(buttons).frame.next configure -state normal
+ $ds9(buttons).frame.last configure -state normal
+ } else {
+ $ds9(mb).frame entryconfig [msgcat::mc {Delete Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Delete All Frames}] -state disabled
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Clear Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Reset Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Refresh Frame}] -state disabled
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Single Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Tile Frames}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Blink Frames}] -state disabled
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Match}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Lock}] -state disabled
+
+ $ds9(mb).frame entryconfig [msgcat::mc {Move Frame}] -state disabled
+
+ $ds9(mb).frame entryconfig [msgcat::mc {First Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Previous Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Next Frame}] -state disabled
+ $ds9(mb).frame entryconfig [msgcat::mc {Last Frame}] -state disabled
+
+ $ds9(buttons).frame.delete configure -state disabled
+ $ds9(buttons).frame.deleteall configure -state disabled
+
+ $ds9(buttons).frame.clear configure -state disabled
+ $ds9(buttons).frame.reset configure -state disabled
+ $ds9(buttons).frame.refresh configure -state disabled
+
+ $ds9(buttons).frame.single configure -state disabled
+ $ds9(buttons).frame.tile configure -state disabled
+ $ds9(buttons).frame.blink configure -state disabled
+
+ $ds9(buttons).frame.movefirst configure -state disabled
+ $ds9(buttons).frame.moveprev configure -state disabled
+ $ds9(buttons).frame.movenext configure -state disabled
+ $ds9(buttons).frame.movelast configure -state disabled
+
+ $ds9(buttons).frame.first configure -state disabled
+ $ds9(buttons).frame.prev configure -state disabled
+ $ds9(buttons).frame.next configure -state disabled
+ $ds9(buttons).frame.last configure -state disabled
+ }
+}
+
+proc UpdateFrameMenu {} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateFrameMenu"
+ }
+
+ if {$current(frame) != {}} {
+ $ds9(mb).frame entryconfig "[msgcat::mc {Cube}]..." \
+ -state normal
+ $ds9(buttons).frame.cube configure -state normal
+
+ switch -- [$current(frame) get type] {
+ base {
+ $ds9(mb).frame entryconfig "[msgcat::mc {RGB}]..." \
+ -state disabled
+ $ds9(mb).frame entryconfig "[msgcat::mc {3D}]..." \
+ -state normal
+ $ds9(buttons).frame.rgb configure -state disabled
+ $ds9(buttons).frame.3d configure -state normal
+ }
+ rgb {
+ $ds9(mb).frame entryconfig "[msgcat::mc {RGB}]..." \
+ -state normal
+ $ds9(mb).frame entryconfig "[msgcat::mc {3D}]..." \
+ -state disabled
+ $ds9(buttons).frame.rgb configure -state normal
+ $ds9(buttons).frame.3d configure -state disabled
+ }
+ 3d {
+ $ds9(mb).frame entryconfig "[msgcat::mc {RGB}]..." \
+ -state disabled
+ $ds9(mb).frame entryconfig "[msgcat::mc {3D}]..." \
+ -state normal
+ $ds9(buttons).frame.rgb configure -state disabled
+ $ds9(buttons).frame.3d configure -state normal
+ }
+ }
+ } else {
+ $ds9(mb).frame entryconfig "[msgcat::mc {Cube}]..." \
+ -state disabled
+ $ds9(mb).frame entryconfig "[msgcat::mc {RGB}]..." \
+ -state disabled
+ $ds9(mb).frame entryconfig "[msgcat::mc {3D}]..." \
+ -state disabled
+ $ds9(buttons).frame.cube configure -state disabled
+ $ds9(buttons).frame.rgb configure -state disabled
+ $ds9(buttons).frame.3d configure -state disabled
+ }
+}
+
+proc UpdateFrameMenuItems {} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateFrameMenuItems"
+ }
+
+ # Goto Frame Menu
+ if {[$ds9(mb).frame.goto index end] >= $ds9(menu,size,frame,goto)} {
+ $ds9(mb).frame.goto delete $ds9(menu,size,frame,goto) end
+ }
+
+ set cnt $ds9(menu,size,frame,goto)
+ foreach f $ds9(frames) {
+ set which "[msgcat::mc {Frame}] [string range $f 5 end]"
+ $ds9(mb).frame.goto add radiobutton -label $which \
+ -variable ds9(next) -value $f -command GotoFrame
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 1
+ $ds9(mb).frame.goto entryconfig $which -columnbreak 1
+ }
+ }
+
+ # Active Frame Menu
+ if {[$ds9(mb).frame.active index end] >= $ds9(menu,size,frame,active)} {
+ $ds9(mb).frame.active delete $ds9(menu,size,frame,active) end
+ }
+
+ set cnt $ds9(menu,size,frame,active)
+ foreach f $ds9(frames) {
+ set which "[msgcat::mc {Frame}] [string range $f 5 end]"
+ $ds9(mb).frame.active add checkbutton -label $which \
+ -variable active($f) -command UpdateActiveFrames
+
+ # wrap if needed
+ incr cnt
+ if {$cnt>=$ds9(menu,size,wrap)} {
+ set cnt 1
+ $ds9(mb).frame.active entryconfig $which -columnbreak 1
+ }
+ }
+}
+
diff --git a/ds9/library/mhelp.tcl b/ds9/library/mhelp.tcl
new file mode 100644
index 0000000..a44c3d5
--- /dev/null
+++ b/ds9/library/mhelp.tcl
@@ -0,0 +1,165 @@
+# 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
+
+# Menu
+
+proc HelpMainMenu {} {
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {
+ # window menu
+ menu $ds9(mb).window
+ $ds9(mb) add cascade -label [msgcat::mc {Window}] \
+ -menu $ds9(mb).window
+ }
+ }
+
+ $ds9(mb) add cascade -label [msgcat::mc {Help}] -menu $ds9(mb).help
+ menu $ds9(mb).help
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(mb).help add command -label [msgcat::mc {Reference Manual}]\
+ -command HelpRef
+ }
+ aqua {}
+ }
+ $ds9(mb).help add command -label [msgcat::mc {User Manual}]\
+ -command HelpUser
+ $ds9(mb).help add command -label [msgcat::mc {Mouse and Keyboard}] \
+ -command HelpKeyboard
+ $ds9(mb).help add separator
+ $ds9(mb).help add command -label [msgcat::mc {FAQ}] \
+ -command HelpFAQ
+ $ds9(mb).help add command -label [msgcat::mc {New Features}] \
+ -command HelpNew
+ $ds9(mb).help add command -label [msgcat::mc {Release Notes}] \
+ -command HelpRelease
+ $ds9(mb).help add command -label [msgcat::mc {Help Desk}] \
+ -command HelpDesk
+ $ds9(mb).help add separator
+ $ds9(mb).help add command -label [msgcat::mc {Story of SAOImage DS9}] \
+ -command HelpStory
+ $ds9(mb).help add command -label [msgcat::mc {Acknowledgment}] \
+ -command HelpAck
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(mb).help add separator
+ $ds9(mb).help add command \
+ -label "[msgcat::mc {About SAOImage DS9}]..." \
+ -command AboutBox
+ }
+ aqua {}
+ }
+}
+
+proc PrefsDialogHelpMenu {w} {
+ set f [ttk::labelframe $w.mhelp -text [msgcat::mc {Help}]]
+
+ PrefsDialogButtonbarHelp $f.buttonbar
+
+ grid $f.buttonbar -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsHelpDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ help,ref 1
+ help,user 1
+ help,keyboard 1
+ help,faq 0
+ help,new 0
+ help,release 1
+ help,desk 1
+ help,story 0
+ help,ack 1
+ help,about 1
+ }
+}
+
+proc CreateButtonsHelp {} {
+ global buttons
+ global ds9
+
+ ttk::frame $ds9(buttons).help
+
+ ButtonButton $ds9(buttons).help.ref \
+ [string tolower [msgcat::mc {Reference}]] HelpRef
+ ButtonButton $ds9(buttons).help.user \
+ [string tolower [msgcat::mc {User}]] HelpUser
+ ButtonButton $ds9(buttons).help.keyboard \
+ [string tolower [msgcat::mc {Keyboard}]] HelpKeyboard
+ ButtonButton $ds9(buttons).help.faq \
+ [string tolower [msgcat::mc {FAQ}]] HelpFAQ
+ ButtonButton $ds9(buttons).help.new \
+ [string tolower [msgcat::mc {New Features}]] HelpNew
+ ButtonButton $ds9(buttons).help.release \
+ [string tolower [msgcat::mc {Release}]] HelpRelease
+ ButtonButton $ds9(buttons).help.desk \
+ [string tolower [msgcat::mc {Help Desk}]] HelpDesk
+ ButtonButton $ds9(buttons).help.story \
+ [string tolower [msgcat::mc {Story}]] HelpStory
+ ButtonButton $ds9(buttons).help.ack \
+ [string tolower [msgcat::mc {Acknowledgment}]] HelpAck
+ ButtonButton $ds9(buttons).help.about \
+ [string tolower [msgcat::mc {About}]] AboutBox
+
+ set buttons(help) "
+ $ds9(buttons).help.ref pbuttons(help,ref)
+ $ds9(buttons).help.user pbuttons(help,user)
+ $ds9(buttons).help.keyboard pbuttons(help,keyboard)
+ $ds9(buttons).help.faq pbuttons(help,faq)
+ $ds9(buttons).help.new pbuttons(help,new)
+ $ds9(buttons).help.release pbuttons(help,release)
+ $ds9(buttons).help.desk pbuttons(help,desk)
+ $ds9(buttons).help.story pbuttons(help,story)
+ $ds9(buttons).help.ack pbuttons(help,ack)
+ $ds9(buttons).help.about pbuttons(help,about)
+ "
+}
+
+proc PrefsDialogButtonbarHelp {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Reference Manual}]\
+ -variable pbuttons(help,ref) -command {UpdateButtons buttons(help)}
+ $m add checkbutton -label [msgcat::mc {User Manual}]\
+ -variable pbuttons(help,user) -command {UpdateButtons buttons(help)}
+ $m add checkbutton -label [msgcat::mc {Mouse and Keyboard}] \
+ -variable pbuttons(help,keyboard) -command {UpdateButtons buttons(help)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {FAQ}] \
+ -variable pbuttons(help,faq) -command {UpdateButtons buttons(help)}
+ $m add checkbutton -label [msgcat::mc {New Features}] \
+ -variable pbuttons(help,new) -command {UpdateButtons buttons(help)}
+ $m add checkbutton -label [msgcat::mc {Release Notes}] \
+ -variable pbuttons(help,release) -command {UpdateButtons buttons(help)}
+ $m add checkbutton -label [msgcat::mc {Help Desk}] \
+ -variable pbuttons(help,desk) -command {UpdateButtons buttons(help)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Story of SAOImage DS9}] \
+ -variable pbuttons(help,story) -command {UpdateButtons buttons(help)}
+ $m add checkbutton -label [msgcat::mc {Acknowledgment}] \
+ -variable pbuttons(help,ack) -command {UpdateButtons buttons(help)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {About SAOImage DS9}]..." \
+ -variable pbuttons(help,about) -command {UpdateButtons buttons(help)}
+}
diff --git a/ds9/library/mosaic.tcl b/ds9/library/mosaic.tcl
new file mode 100644
index 0000000..cd9f57e
--- /dev/null
+++ b/ds9/library/mosaic.tcl
@@ -0,0 +1,34 @@
+# 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 ProcessMosaicCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ set vvar $var
+ set ii $i
+
+ switch -- [string tolower [lindex $var $i]] {
+ iraf {
+ incr ii
+ ProcessMosaicIRAFCmd vvar ii $sock $fn
+ }
+ wfpc2 {}
+ default {ProcessMosaicWCSCmd vvar ii $sock $fn}
+ }
+}
+
+proc ProcessSendMosaicCmd {proc id param sock fn} {
+ switch -- [string tolower [lindex $param 0]] {
+ iraf {}
+ wfpc2 {}
+ wcs {
+ set param [lindex $param 1 end]
+ ProcessSendMosaicWCSCmd $proc $id $param $sock $fn
+ }
+ default {ProcessSendMosaicWCSCmd $proc $id $param $sock $fn}
+ }
+}
diff --git a/ds9/library/mosaicimage.tcl b/ds9/library/mosaicimage.tcl
new file mode 100644
index 0000000..38ee35f
--- /dev/null
+++ b/ds9/library/mosaicimage.tcl
@@ -0,0 +1,37 @@
+# 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 ProcessMosaicImageCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ set vvar $var
+ set ii $i
+
+ switch -- [string tolower [lindex $var $i]] {
+ iraf {
+ incr ii
+ ProcessMosaicImageIRAFCmd vvar ii $sock $fn
+ }
+ wfpc2 {
+ incr ii
+ ProcessMosaicImageWFPC2Cmd vvar ii $sock $fn
+ }
+ default {ProcessMosaicImageWCSCmd vvar ii $sock $fn}
+ }
+}
+
+proc ProcessSendMosaicImageCmd {proc id param sock fn} {
+ switch -- [string tolower [lindex $param 0]] {
+ iraf {}
+ wfpc2 {}
+ wcs {
+ set param [lindex $param 1 end]
+ ProcessSendMosaicImageWCSCmd $proc $id $param $sock $fn
+ }
+ default {ProcessSendMosaicImageWCSCmd $proc $id $param $sock $fn}
+ }
+}
diff --git a/ds9/library/mosaicimageiraf.tcl b/ds9/library/mosaicimageiraf.tcl
new file mode 100644
index 0000000..436a7f4
--- /dev/null
+++ b/ds9/library/mosaicimageiraf.tcl
@@ -0,0 +1,87 @@
+# 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 LoadMosaicImageIRAFFile {fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic image iraf}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+ set loadParam(load,layer) $layer
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadMosaicImageIRAFAlloc {path fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic image iraf}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc LoadMosaicImageIRAFSocket {sock fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic image iraf}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc ProcessMosaicImageIRAFCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadMosaicImageIRAFSocket $sock $param $layer]} {
+ InitError xpa
+ LoadMosaicImageIRAFFile $param $layer
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMosaicImageIRAFAlloc $fn $param $layer
+ } else {
+ LoadMosaicImageIRAFFile $param $layer
+ }
+ }
+ FinishLoad
+}
diff --git a/ds9/library/mosaicimagewcs.tcl b/ds9/library/mosaicimagewcs.tcl
new file mode 100644
index 0000000..1c6f9a7
--- /dev/null
+++ b/ds9/library/mosaicimagewcs.tcl
@@ -0,0 +1,141 @@
+# 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 LoadMosaicImageWCSFile {fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic image $sys]
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+ set loadParam(load,layer) $layer
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadMosaicImageWCSAlloc {path fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic image $sys]
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc LoadMosaicImageWCSSocket {sock fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic image $sys]
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc SaveMosaicImageWCSFile {fn} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits mosaic image file "\{$fn\}"
+}
+
+proc SaveMosaicImageWCSSocket {sock} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits mosaic image socket $sock
+}
+
+proc ProcessMosaicImageWCSCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+
+ if {[string range [lindex $var $i] 0 2] == {wcs}} {
+ set opt [lindex $var $i]
+ incr i
+ } else {
+ set opt wcs
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadMosaicImageWCSSocket $sock $param $layer $opt]} {
+ InitError xpa
+ LoadMosaicImageWCSFile $param $layer $opt
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMosaicImageWCSAlloc $fn $param $layer $opt
+ } else {
+ LoadMosaicImageWCSFile $param $layer $opt
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendMosaicImageWCSCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {$sock != {}} {
+ # xpa
+ SaveMosaicImageWCSSocket $sock
+ } elseif {$fn != {}} {
+ # comm
+ SaveMosaicImageWCSFile $fn
+ $proc $id {} $fn
+ }
+}
+
+
diff --git a/ds9/library/mosaicimagewfpc2.tcl b/ds9/library/mosaicimagewfpc2.tcl
new file mode 100644
index 0000000..ed2d8a8
--- /dev/null
+++ b/ds9/library/mosaicimagewfpc2.tcl
@@ -0,0 +1,93 @@
+# 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 LoadMosaicImageWFPC2File {fn} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic image wfpc2}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadMosaicImageWFPC2Alloc {path fn} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic image wfpc2}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc LoadMosaicImageWFPC2Socket {sock fn} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic image wfpc2}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ return [ProcessLoad 0]
+}
+
+proc ProcessMosaicImageWFPC2Cmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadMosaicImageWFPC2Socket $sock $param]} {
+ InitError xpa
+ LoadMosaicImageWFPC2File $param
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMosaicImageWFPC2Alloc $fn $param
+ } else {
+ LoadMosaicImageWFPC2File $param
+ }
+ }
+ FinishLoad
+}
+
+
diff --git a/ds9/library/mosaiciraf.tcl b/ds9/library/mosaiciraf.tcl
new file mode 100644
index 0000000..8f719bb
--- /dev/null
+++ b/ds9/library/mosaiciraf.tcl
@@ -0,0 +1,87 @@
+# 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 LoadMosaicIRAFFile {fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic iraf}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+ set loadParam(load,layer) $layer
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadMosaicIRAFAlloc {path fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic iraf}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc LoadMosaicIRAFSocket {sock fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic iraf}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc ProcessMosaicIRAFCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadMosaicIRAFSocket $sock $param $layer]} {
+ InitError xpa
+ LoadMosaicIRAFFile $param $layer
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMosaicIRAFAlloc $fn $param $layer
+ } else {
+ LoadMosaicIRAFFile $param $layer
+ }
+ }
+ FinishLoad
+}
diff --git a/ds9/library/mosaicwcs.tcl b/ds9/library/mosaicwcs.tcl
new file mode 100644
index 0000000..5485813
--- /dev/null
+++ b/ds9/library/mosaicwcs.tcl
@@ -0,0 +1,148 @@
+# 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 LoadMosaicWCSFile {fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic $sys]
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+ set loadParam(load,layer) $layer
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadMosaicWCSAlloc {path fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic $sys]
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc LoadMosaicWCSSocket {sock fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic $sys]
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc SaveMosaicWCSFile {fn opt} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {$opt == {}} {
+ set opt 1
+ }
+
+ $current(frame) save fits mosaic file "\{$fn\}" $opt
+}
+
+proc SaveMosaicWCSSocket {sock opt} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {$opt == {}} {
+ set opt 1
+ }
+
+ $current(frame) save fits mosaic socket $sock $opt
+}
+
+proc ProcessMosaicWCSCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+
+ if {[string range [lindex $var $i] 0 2] == {wcs}} {
+ set opt [lindex $var $i]
+ incr i
+ } else {
+ set opt wcs
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadMosaicWCSSocket $sock $param $layer $opt]} {
+ InitError xpa
+ LoadMosaicWCSFile $param $layer $opt
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMosaicWCSAlloc $fn $param $layer $opt
+ } else {
+ LoadMosaicWCSFile $param $layer $opt
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendMosaicWCSCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set opt [lindex $param 0]
+ if {$sock != {}} {
+ # xpa
+ SaveMosaicWCSSocket $sock $opt
+ } elseif {$fn != {}} {
+ # comm
+ SaveMosaicWCSFile $fn $opt
+ $proc $id {} $fn
+ }
+}
diff --git a/ds9/library/movie.tcl b/ds9/library/movie.tcl
new file mode 100644
index 0000000..36a0047
--- /dev/null
+++ b/ds9/library/movie.tcl
@@ -0,0 +1,534 @@
+# 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 MovieDef {} {
+ global imovie
+ global movie
+
+ global tcl_platform
+
+ set imovie(top) .moviestatus
+ set imovie(mb) .moviestatusmb
+
+ set movie(action) slice
+ # must be >=5, or sometimes will generate bad data
+ set movie(quality) 5
+ set movie(num) 24
+ set movie(az,from) 45
+ set movie(az,to) -45
+ set movie(el,from) 30
+ set movie(el,to) 30
+ set movie(sl,from) 1
+ set movie(sl,to) 1
+ set movie(repeat) oscillate
+ set movie(repeat,num) 0
+
+ set movie(status) 0
+ set movie(abort) 0
+
+ set aa [msgcat::mc {An error has occurred while creating the image. Please be sure that the entire image window is visible on the screen.}]
+ set bb [msgcat::mc {An error has occurred while creating the image. Please be sure that the ds9 window is in the upper left corner of the default screen and the entire window is visible.}]
+ switch $tcl_platform(os) {
+ Darwin {
+ switch [lindex [split $tcl_platform(osVersion) {.}] 0] {
+ 10 -
+ 11 {set movie(error) $bb}
+ 8 -
+ 9 -
+ default {set movie(error) $aa}
+ }
+ }
+ default {set movie(error) $aa}
+ }
+}
+
+proc MovieDialog {} {
+ global movie
+ global mpegfbox
+ global ed
+ global current
+
+ set w {.movie}
+
+ set ed(ok) 0
+ set ed(action) $movie(action)
+
+ DialogCreate $w [msgcat::mc {Create Movie}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.title -text [msgcat::mc {Format}]
+ ttk::radiobutton $f.slice -text {Slice Movie} \
+ -variable ed(action) -value slice
+ ttk::radiobutton $f.frame -text {Frames Movie} \
+ -variable ed(action) -value frame
+ ttk::radiobutton $f.3d -text {3D Movie} \
+ -variable ed(action) -value 3d
+
+ grid $f.slice -padx 2 -pady 2 -sticky w
+ grid $f.frame -padx 2 -pady 2 -sticky w
+ grid $f.3d -padx 2 -pady 2 -sticky w
+
+ switch [$current(frame) get type] {
+ base -
+ rgb {$f.3d configure -state disabled}
+ 3d {$f.3d configure -state normal}
+ }
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set movie(action) $ed(action)
+ set fn [SaveFileDialog mpegfbox]
+
+ if {$fn != {}} {
+ set ok 1
+ switch $movie(action) {
+ slice -
+ frame {}
+ 3d {set ok [Movie3dDialog]}
+ }
+
+ if {$ok} {
+ Movie $fn
+ }
+ }
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc Movie {fn} {
+ global ds9
+ global movie
+ global current
+ global saveimage
+
+ if {$fn == {} || ![$current(frame) has fits]} {
+ return
+ }
+
+ switch $ds9(wm) {
+ x11 {}
+ aqua -
+ win32 {
+ Error $saveimage(error)
+ return
+ }
+ }
+
+ # besure we are on top
+ raise $ds9(top)
+
+ # we need single mode
+ if {$ds9(display) != {single}} {
+ set modesav $ds9(display)
+ set current(display) single
+ DisplayMode
+ }
+
+ switch $movie(action) {
+ slice {MovieSlice $fn}
+ frame {MovieFrame $fn}
+ 3d {Movie3d $fn}
+ }
+
+ if {[info exists modesav]} {
+ set current(display) $modesav
+ DisplayMode
+ }
+}
+
+proc MovieSlice {fn} {
+ global current
+ global movie
+ global cube
+
+ set depth [$current(frame) get fits depth $cube(axis)]
+ set slice [$current(frame) get fits slice $cube(axis)]
+
+ if {$cube(axis)==2} {
+ set ss [$current(frame) get crop 3d image]
+ set from [lindex $ss 0]
+ set to [lindex $ss 1]
+ } else {
+ set from 1
+ set to [$current(frame) get fits depth $cube(axis)]
+ }
+
+ # loop thru cube
+ set movie(first) 1
+ for {set ii $from} {$ii <= $to} {incr ii} {
+ $current(frame) update fits slice $cube(axis) $ii
+ if {[MoviePhoto $fn]} {
+ break
+ }
+ }
+ mpeg close
+
+ # reset current slice
+ $current(frame) update fits slice $cube(axis) $slice
+}
+
+proc MovieFrame {fn} {
+ global ds9
+ global current
+ global movie
+
+ # loop thru all active frames
+ set movie(first) 1
+ set framesav $current(frame)
+
+ foreach ff $ds9(active) {
+ set ds9(next) $ff
+ GotoFrame
+ if {[MoviePhoto $fn]} {
+ break
+ }
+ }
+ mpeg close
+
+ set ds9(next) $framesav
+ GotoFrame
+}
+
+proc Movie3d {fn} {
+ global movie
+ global current
+ global cube
+
+ set slice [$current(frame) get fits slice $cube(axis)]
+ set vp [$current(frame) get 3d view]
+
+ set azincr [expr 1.*($movie(az,to)-$movie(az,from))/$movie(num)]
+ set elincr [expr 1.*($movie(el,to)-$movie(el,from))/$movie(num)]
+ set slincr [expr 1.*($movie(sl,to)-$movie(sl,from))/$movie(num)]
+
+ # loop over az/el/slice
+ set movie(status) 0
+ set movie(abort) 0
+ set movie(first) 1
+
+ set az $movie(az,from)
+ set el $movie(el,from)
+ set sl $movie(sl,from)
+
+ for {set rr 0} {$rr<=$movie(repeat,num)} {incr rr} {
+ for {set nn 0} {$nn<=$movie(num)} {incr nn} {
+ MovieStatusDialog
+
+ if {$movie(abort)} {
+ break
+ }
+ set movie(status) [expr 1.*$nn/$movie(num)*100]
+ update idletasks
+
+ $current(frame) 3d view $az $el
+ $current(frame) update fits slice $cube(axis) [expr int($sl)]
+ if {[MoviePhoto $fn]} {
+ break
+ }
+ set az [expr $az+$azincr]
+ set el [expr $el+$elincr]
+ set sl [expr $sl+$slincr]
+ }
+ switch $movie(repeat) {
+ repeat {
+ set az $movie(az,from)
+ set el $movie(el,from)
+ set sl $movie(sl,from)
+ }
+ oscillate {
+ set azincr [expr -$azincr]
+ set elincr [expr -$elincr]
+ set slincr [expr -$slincr]
+ }
+ }
+ }
+ mpeg close
+
+ MovieStatusDestroyDialog
+
+ # reset
+ $current(frame) 3d view $vp
+ $current(frame) update fits slice $cube(axis) $slice
+ Update3DDialog
+ UpdateCubeDialog
+}
+
+# Support
+
+proc MoviePhoto {fn} {
+ global ds9
+ global movie
+ global current
+
+ # yes, we need this
+ UpdateDS9
+ RealizeDS9 1
+
+ set rr [catch {image create photo -format window -data $ds9(canvas)} ph]
+ if {$rr} {
+ Error $movie(error)
+ return $rr
+ }
+
+ if {$movie(first)} {
+ set w [image width $ph]
+ set h [image height $ph]
+ mpeg create "$fn" $w $h 25 1 $movie(quality)
+ set movie(first) 0
+ }
+ mpeg add $ph
+
+ image delete $ph
+ return 0
+}
+
+proc Movie3dDialog {} {
+ global movie
+ global ed2
+ global current
+ global cube
+
+ set w {.movie3d}
+
+ set ed2(ok) 0
+ set ed2(num) $movie(num)
+ set ed2(az,from) $movie(az,from)
+ set ed2(az,to) $movie(az,to)
+ set ed2(el,from) $movie(el,from)
+ set ed2(el,to) $movie(el,to)
+ set ed2(sl,from) [$current(frame) get fits slice $cube(axis)]
+ set ed2(sl,to) $ed2(sl,from)
+ set ed2(repeat) $movie(repeat)
+ set ed2(repeat,num) $movie(repeat,num)
+
+ DialogCreate $w [msgcat::mc {Save 3D Movie}] ed2(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.tnum -text [msgcat::mc {Number}]
+ ttk::entry $f.num -textvariable ed2(num) -width 7
+ ttk::label $f.tframes -text [msgcat::mc {Frames}]
+
+ ttk::label $f.taz -text [msgcat::mc {Azimuth}]
+ ttk::label $f.tazfrom -text [msgcat::mc {From}]
+ ttk::entry $f.azfrom -textvariable ed2(az,from) -width 7
+ ttk::label $f.tazto -text [msgcat::mc {To}]
+ ttk::entry $f.azto -textvariable ed2(az,to) -width 7
+
+ ttk::label $f.tel -text [msgcat::mc {Elevation}]
+ ttk::label $f.telfrom -text [msgcat::mc {From}]
+ ttk::entry $f.elfrom -textvariable ed2(el,from) -width 7
+ ttk::label $f.telto -text [msgcat::mc {To}]
+ ttk::entry $f.elto -textvariable ed2(el,to) -width 7
+
+ ttk::label $f.tsl -text [msgcat::mc {Slice}]
+ ttk::label $f.tslfrom -text [msgcat::mc {From}]
+ ttk::entry $f.slfrom -textvariable ed2(sl,from) -width 7
+ ttk::label $f.tslto -text [msgcat::mc {To}]
+ ttk::entry $f.slto -textvariable ed2(sl,to) -width 7
+
+ ttk::radiobutton $f.repeat -text [msgcat::mc {Repeat}] \
+ -variable ed2(repeat) -value repeat
+ ttk::radiobutton $f.oscillate -text [msgcat::mc {Oscillate}] \
+ -variable ed2(repeat) -value oscillate
+ ttk::entry $f.repeatnum -textvariable ed2(repeat,num) -width 7
+ ttk::label $f.ttimes -text [msgcat::mc {Times}]
+
+ grid $f.tnum x $f.num $f.tframes -padx 2 -pady 2 -sticky w
+ grid $f.taz $f.tazfrom $f.azfrom $f.tazto $f.azto -padx 2 -pady 2 -sticky w
+ grid $f.tel $f.telfrom $f.elfrom $f.telto $f.elto -padx 2 -pady 2 -sticky w
+ grid $f.tsl $f.tslfrom $f.slfrom $f.tslto $f.slto -padx 2 -pady 2 -sticky w
+ grid $f.oscillate x $f.repeatnum $f.ttimes -padx 2 -pady 2 -sticky w
+ grid $f.repeat -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ set movie(num) $ed2(num)
+ set movie(az,from) $ed2(az,from)
+ set movie(az,to) $ed2(az,to)
+ set movie(el,from) $ed2(el,from)
+ set movie(el,to) $ed2(el,to)
+ set movie(sl,from) $ed2(sl,from)
+ set movie(sl,to) $ed2(sl,to)
+ set movie(repeat) $ed2(repeat)
+ set movie(repeat,num) $ed2(repeat,num)
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
+proc MovieStatusDialog {} {
+ global imovie
+ global movie
+
+ # see if we already have a window visible
+ if {[winfo exists $imovie(top)]} {
+ raise $imovie(top)
+ return
+ }
+
+ # create the 3d window
+ set w $imovie(top)
+ set mb $imovie(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Movie}] MovieStatusDestroyDialog
+ raise $imovie(top)
+
+ # Status
+ set f [ttk::frame $w.param]
+ ttk::label $f.tstatus -text [msgcat::mc {Status}]
+ ttk::progressbar $f.status -variable movie(status) -length 350
+ grid $f.tstatus $f.status -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.abort -text [msgcat::mc {Abort}] \
+ -command MovieStatusAbortDialog
+ pack $f.abort -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 x
+}
+
+proc MovieStatusDestroyDialog {} {
+ global movie
+ global imovie
+
+ if {[winfo exists $imovie(top)]} {
+ destroy $imovie(top)
+ destroy $imovie(mb)
+ }
+}
+
+proc MovieStatusAbortDialog {} {
+ global movie
+ set movie(abort) 1
+}
+
+# Process Cmds
+
+proc ProcessMovieCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global movie
+
+ # we need to be realized
+ # already implemented
+ # ProcessRealizeDS9
+
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ slice -
+ frame -
+ 3d {
+ set movie(action) $item
+ incr i
+ }
+ default {
+ # backward compatibility
+ set movie(action) frame
+ }
+ }
+
+ set fn [lindex $var $i]
+
+ set go 1
+ while {$go} {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ number {
+ incr i
+ set movie(num) [lindex $var $i]
+ }
+ azfrom {
+ incr i
+ set movie(az,from) [lindex $var $i]
+ }
+ azto {
+ incr i
+ set movie(az,to) [lindex $var $i]
+ }
+ elfrom {
+ incr i
+ set movie(el,from) [lindex $var $i]
+ }
+ elto {
+ incr i
+ set movie(el,to) [lindex $var $i]
+ }
+ slfrom {
+ incr i
+ set movie(sl,from) [lindex $var $i]
+ }
+ slto {
+ incr i
+ set movie(sl,to) [lindex $var $i]
+ }
+ oscillate {
+ incr i
+ set movie(repeat) oscillate
+ set movie(repeat,num) [lindex $var $i]
+ }
+ repeat {
+ incr i
+ set movie(repeat) repeat
+ set movie(repeat,num) [lindex $var $i]
+ }
+ default {
+ incr i -1
+ set go 0
+ }
+ }
+ }
+
+ Movie $fn
+}
+
+
diff --git a/ds9/library/mregion.tcl b/ds9/library/mregion.tcl
new file mode 100644
index 0000000..12ea847
--- /dev/null
+++ b/ds9/library/mregion.tcl
@@ -0,0 +1,1103 @@
+# 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
+
+# Menus
+
+proc RegionMainMenu {} {
+ global ds9
+ global marker
+
+ menu $ds9(mb).region
+ $ds9(mb).region add command -label "[msgcat::mc {Get Information}]..." \
+ -command MarkerInfo
+ $ds9(mb).region add separator
+ $ds9(mb).region add cascade -label [msgcat::mc {Shape}] \
+ -menu $ds9(mb).region.shape
+ $ds9(mb).region add cascade -label [msgcat::mc {Composite Region}] \
+ -menu $ds9(mb).region.composite
+ $ds9(mb).region add cascade -label [msgcat::mc {Instrument FOV}] \
+ -menu $ds9(mb).region.fov
+ $ds9(mb).region add cascade -label [msgcat::mc {Template}] \
+ -menu $ds9(mb).region.template
+ $ds9(mb).region add separator
+ $ds9(mb).region add cascade -label [msgcat::mc {Color}] \
+ -menu $ds9(mb).region.color
+ $ds9(mb).region add cascade -label [msgcat::mc {Width}] \
+ -menu $ds9(mb).region.width
+ $ds9(mb).region add cascade -label [msgcat::mc {Properties}] \
+ -menu $ds9(mb).region.properties
+ $ds9(mb).region add cascade -label [msgcat::mc {Font}] \
+ -menu $ds9(mb).region.font
+ $ds9(mb).region add separator
+ $ds9(mb).region add command -label [msgcat::mc {Centroid}] \
+ -command MarkerCentroid
+ $ds9(mb).region add command -label [msgcat::mc {Move to Front}] \
+ -command MarkerFront
+ $ds9(mb).region add command -label [msgcat::mc {Move to Back}] \
+ -command MarkerBack
+ $ds9(mb).region add separator
+ $ds9(mb).region add command -label [msgcat::mc {Select All}] \
+ -command MarkerSelectAll -accelerator "${ds9(ctrl)}A"
+ $ds9(mb).region add command -label [msgcat::mc {Select None}] \
+ -command MarkerUnselectAll
+ $ds9(mb).region add command -label [msgcat::mc {Invert Selection}] \
+ -command MarkerSelectInvert
+ $ds9(mb).region add separator
+ $ds9(mb).region add command -label [msgcat::mc {Delete Selected Regions}] \
+ -command MarkerDeleteSelect
+ $ds9(mb).region add command -label [msgcat::mc {Delete All Regions}] \
+ -command MarkerDeleteAllMenu
+ $ds9(mb).region add separator
+ $ds9(mb).region add command -label [msgcat::mc {New Group}] \
+ -command GroupCreate
+ $ds9(mb).region add command -label "[msgcat::mc {Groups}]..." \
+ -command GroupDialog
+ $ds9(mb).region add separator
+ $ds9(mb).region add command -label "[msgcat::mc {List Regions}]..." \
+ -command MarkerList
+ $ds9(mb).region add command -label "[msgcat::mc {Load Regions}]..." \
+ -command MarkerLoad
+ $ds9(mb).region add command -label "[msgcat::mc {Save Regions}]..." \
+ -command MarkerSave
+ $ds9(mb).region add separator
+ $ds9(mb).region add cascade -label [msgcat::mc {Region Parameters}] \
+ -menu $ds9(mb).region.params
+
+ menu $ds9(mb).region.shape
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Circle}] \
+ -variable marker(shape) -value circle
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Ellipse}] \
+ -variable marker(shape) -value ellipse
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Box}] \
+ -variable marker(shape) -value box
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Polygon}] \
+ -variable marker(shape) -value polygon
+ $ds9(mb).region.shape add separator
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Line}] \
+ -variable marker(shape) -value line
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Vector}] \
+ -variable marker(shape) -value vector
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Projection}] \
+ -variable marker(shape) -value projection
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Segment}] \
+ -variable marker(shape) -value segment
+ $ds9(mb).region.shape add separator
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Text}] \
+ -variable marker(shape) -value text
+ $ds9(mb).region.shape add cascade -label [msgcat::mc {Point}] \
+ -menu $ds9(mb).region.shape.point
+ $ds9(mb).region.shape add separator
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Ruler}] \
+ -variable marker(shape) -value ruler
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Compass}] \
+ -variable marker(shape) -value compass
+ $ds9(mb).region.shape add separator
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Annulus}] \
+ -variable marker(shape) -value annulus
+ $ds9(mb).region.shape add radiobutton \
+ -label [msgcat::mc {Elliptical Annulus}] \
+ -variable marker(shape) -value ellipseannulus
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Box Annulus}] \
+ -variable marker(shape) -value boxannulus
+ $ds9(mb).region.shape add separator
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Panda}] \
+ -variable marker(shape) -value panda
+ $ds9(mb).region.shape add radiobutton \
+ -label [msgcat::mc {Elliptical Panda}]\
+ -variable marker(shape) -value epanda
+ $ds9(mb).region.shape add radiobutton -label [msgcat::mc {Box Panda}] \
+ -variable marker(shape) -value bpanda
+
+ menu $ds9(mb).region.shape.point
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {Circle}] \
+ -variable marker(shape) -value {circle point}
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {Box}] \
+ -variable marker(shape) -value {box point}
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {Diamond}] \
+ -variable marker(shape) -value {diamond point}
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {Cross}] \
+ -variable marker(shape) -value {cross point}
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {X}] \
+ -variable marker(shape) -value {x point}
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {Arrow}] \
+ -variable marker(shape) -value {arrow point}
+ $ds9(mb).region.shape.point add radiobutton -label [msgcat::mc {BoxCircle}]\
+ -variable marker(shape) -value {boxcircle point}
+
+ menu $ds9(mb).region.composite
+ $ds9(mb).region.composite add command -label [msgcat::mc {Create}] \
+ -command CompositeCreate
+ $ds9(mb).region.composite add command -label [msgcat::mc {Dissolve}] \
+ -command CompositeDelete
+
+ CreateFOVMenu
+
+ menu $ds9(mb).region.template
+ $ds9(mb).region.template add command -label "[msgcat::mc {Load}]..." \
+ -command OpenTemplateMarker
+ $ds9(mb).region.template add command -label "[msgcat::mc {Save}]..." \
+ -command SaveAsTemplateMarker
+
+ ColorMenu $ds9(mb).region.color marker color MarkerColor
+ WidthDashMenu $ds9(mb).region.width marker width dash \
+ MarkerWidth [list MarkerProp dash]
+
+ menu $ds9(mb).region.properties
+ $ds9(mb).region.properties add checkbutton \
+ -label [msgcat::mc {Fixed in Size}] \
+ -variable marker(fixed) -command {MarkerProp fixed}
+ $ds9(mb).region.properties add separator
+ $ds9(mb).region.properties add checkbutton \
+ -label [msgcat::mc {Can Edit}] \
+ -variable marker(edit) -command {MarkerProp edit}
+ $ds9(mb).region.properties add checkbutton \
+ -label [msgcat::mc {Can Move}] \
+ -variable marker(move) -command {MarkerProp move}
+ $ds9(mb).region.properties add checkbutton \
+ -label [msgcat::mc {Can Rotate}] \
+ -variable marker(rotate) -command {MarkerProp rotate}
+ $ds9(mb).region.properties add checkbutton \
+ -label [msgcat::mc {Can Delete}] \
+ -variable marker(delete) -command {MarkerProp delete}
+ $ds9(mb).region.properties add separator
+ $ds9(mb).region.properties add radiobutton \
+ -label [msgcat::mc {Include}] \
+ -variable marker(include) -value 1 -command {MarkerProp include}
+ $ds9(mb).region.properties add radiobutton \
+ -label [msgcat::mc {Exclude}] \
+ -variable marker(include) -value 0 -command {MarkerProp include}
+ $ds9(mb).region.properties add separator
+ $ds9(mb).region.properties add radiobutton \
+ -label [msgcat::mc {Source}] \
+ -variable marker(source) -value 1 -command {MarkerProp source}
+ $ds9(mb).region.properties add radiobutton \
+ -label [msgcat::mc {Background}] \
+ -variable marker(source) -value 0 -command {MarkerProp source}
+
+ FontMenu $ds9(mb).region.font marker font font,size font,weight \
+ font,slant MarkerFont
+
+ menu $ds9(mb).region.params
+ $ds9(mb).region.params add checkbutton \
+ -label [msgcat::mc {Show}] \
+ -variable marker(show) -command MarkerShow
+ $ds9(mb).region.params add checkbutton \
+ -label [msgcat::mc {Show Text}] \
+ -variable marker(show,text) -command MarkerShowText
+ $ds9(mb).region.params add separator
+ $ds9(mb).region.params add checkbutton \
+ -label [msgcat::mc {Auto Plot 2D}] -variable marker(plot2d)
+ $ds9(mb).region.params add checkbutton \
+ -label [msgcat::mc {Auto Plot 3D}] -variable marker(plot3d)
+ $ds9(mb).region.params add checkbutton \
+ -label [msgcat::mc {Auto Plot Statistics}] -variable marker(stats)
+ $ds9(mb).region.params add separator
+ $ds9(mb).region.params add checkbutton \
+ -label [msgcat::mc {Auto Centroid}] \
+ -variable marker(centroid,auto) -command MarkerCentroidAuto
+ $ds9(mb).region.params add command \
+ -label "[msgcat::mc {Centroid Parameters}]..." \
+ -command CentroidDialog
+
+ # Bindings
+ bind $ds9(top) <<SelectAll>> MarkerSelectAll
+}
+
+proc PrefsDialogRegionMenu {w} {
+ set f [ttk::labelframe $w.mregion -text [msgcat::mc {Region}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarRegion $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2 -sticky w
+
+ set m $f.menu.menu
+ menu $m
+ $m add cascade -label [msgcat::mc {Shape}] -menu $m.shape
+ $m add separator
+ $m add cascade -label [msgcat::mc {Color}] -menu $m.color
+ $m add cascade -label [msgcat::mc {Width}] -menu $m.width
+ $m add cascade -label [msgcat::mc {Properties}] -menu $m.properties
+ $m add cascade -label [msgcat::mc {Font}] -menu $m.font
+ $m add separator
+ $m add cascade -label [msgcat::mc {Region Parameters}] -menu $m.params
+
+ menu $m.shape
+ $m.shape add radiobutton -label [msgcat::mc {Circle}] \
+ -variable pmarker(shape) -value circle
+ $m.shape add radiobutton -label [msgcat::mc {Ellipse}] \
+ -variable pmarker(shape) -value ellipse
+ $m.shape add radiobutton -label [msgcat::mc {Box}] \
+ -variable pmarker(shape) -value box
+ $m.shape add radiobutton -label [msgcat::mc {Polygon}] \
+ -variable pmarker(shape) -value polygon
+ $m.shape add separator
+ $m.shape add radiobutton -label [msgcat::mc {Line}] \
+ -variable pmarker(shape) -value line
+ $m.shape add radiobutton -label [msgcat::mc {Vector}] \
+ -variable pmarker(shape) -value vector
+ $m.shape add radiobutton -label [msgcat::mc {Projection}] \
+ -variable pmarker(shape) -value projection
+ $m.shape add radiobutton -label [msgcat::mc {Segment}] \
+ -variable pmarker(shape) -value segment
+ $m.shape add separator
+ $m.shape add radiobutton -label [msgcat::mc {Text}] \
+ -variable pmarker(shape) -value text
+ $m.shape add cascade -label [msgcat::mc {Point}] \
+ -menu $m.shape.point
+ $m.shape add separator
+ $m.shape add radiobutton -label [msgcat::mc {Ruler}] \
+ -variable pmarker(shape) -value ruler
+ $m.shape add radiobutton -label [msgcat::mc {Compass}] \
+ -variable pmarker(shape) -value compass
+ $m.shape add separator
+ $m.shape add radiobutton -label [msgcat::mc {Annulus}] \
+ -variable pmarker(shape) -value annulus
+ $m.shape add radiobutton -label [msgcat::mc {Elliptical Annulus}] \
+ -variable pmarker(shape) -value ellipseannulus
+ $m.shape add radiobutton -label [msgcat::mc {Box Annulus}] \
+ -variable pmarker(shape) -value boxannulus
+ $m.shape add separator
+ $m.shape add radiobutton -label [msgcat::mc {Panda}] \
+ -variable pmarker(shape) -value panda
+ $m.shape add radiobutton -label [msgcat::mc {Elliptical Panda}] \
+ -variable pmarker(shape) -value epanda
+ $m.shape add radiobutton -label [msgcat::mc {Box Panda}] \
+ -variable pmarker(shape) -value bpanda
+
+ menu $m.shape.point
+ $m.shape.point add radiobutton -label [msgcat::mc {Circle}] \
+ -variable pmarker(shape) -value {circle point}
+ $m.shape.point add radiobutton -label [msgcat::mc {Box}] \
+ -variable pmarker(shape) -value {box point}
+ $m.shape.point add radiobutton -label [msgcat::mc {Diamond}] \
+ -variable pmarker(shape) -value {diamond point}
+ $m.shape.point add radiobutton -label [msgcat::mc {Cross}] \
+ -variable pmarker(shape) -value {cross point}
+ $m.shape.point add radiobutton -label [msgcat::mc {X}] \
+ -variable pmarker(shape) -value {x point}
+ $m.shape.point add radiobutton -label [msgcat::mc {Arrow}] \
+ -variable pmarker(shape) -value {arrow point}
+ $m.shape.point add radiobutton -label [msgcat::mc {BoxCircle}]\
+ -variable pmarker(shape) -value {boxcircle point}
+
+ ColorMenu $m.color pmarker color {}
+ WidthDashMenu $m.width pmarker width dash {} {}
+
+ menu $m.properties
+ $m.properties add checkbutton -label [msgcat::mc {Fixed in Size}] \
+ -variable pmarker(fixed)
+ $m.properties add separator
+ $m.properties add checkbutton -label [msgcat::mc {Can Edit}] \
+ -variable pmarker(edit)
+ $m.properties add checkbutton -label [msgcat::mc {Can Move}] \
+ -variable pmarker(move)
+ $m.properties add checkbutton -label [msgcat::mc {Can Rotate}] \
+ -variable pmarker(rotate)
+ $m.properties add checkbutton -label [msgcat::mc {Can Delete}] \
+ -variable pmarker(delete)
+ $m.properties add separator
+ $m.properties add radiobutton -label [msgcat::mc {Include}] \
+ -variable pmarker(include) -value 1
+ $m.properties add radiobutton -label [msgcat::mc {Exclude}] \
+ -variable pmarker(include) -value 0
+ $m.properties add separator
+ $m.properties add radiobutton -label [msgcat::mc {Source}] \
+ -variable pmarker(source) -value 1
+ $m.properties add radiobutton -label [msgcat::mc {Background}] \
+ -variable pmarker(source) -value 0
+
+ FontMenu $m.font pmarker font font,size font,weight font,slant {}
+
+ menu $m.params
+ $m.params add checkbutton -label [msgcat::mc {Show}] \
+ -variable pmarker(show)
+ $m.params add checkbutton -label [msgcat::mc {Show Text}] \
+ -variable pmarker(show,text)
+ $m.params add separator
+ $m.params add checkbutton -label [msgcat::mc {Auto Centroid}] \
+ -variable pmarker(centroid,auto)
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogRegion {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Region}]
+ lappend dprefs(tabs) [ttk::frame $w.region]
+
+ # Format
+ set f [ttk::labelframe $w.region.format -text [msgcat::mc {Default Format}]]
+
+ ttk::menubutton $f.format -textvariable pmarker(format) \
+ -menu $f.format.menu
+
+ grid $f.format -padx 2 -pady 2 -sticky w
+
+ menu $f.format.menu
+ $f.format.menu add radiobutton -label {DS9/Funtools} \
+ -variable pmarker(format) -value ds9
+ $f.format.menu add radiobutton -label {XML} \
+ -variable pmarker(format) -value xml
+ $f.format.menu add radiobutton -label {CIAO} \
+ -variable pmarker(format) -value ciao
+ $f.format.menu add radiobutton -label {SAOtng} \
+ -variable pmarker(format) -value saotng
+ $f.format.menu add radiobutton -label {SAOimage} \
+ -variable pmarker(format) -value saoimage
+ $f.format.menu add radiobutton -label {IRAF PROS} \
+ -variable pmarker(format) -value pros
+ $f.format.menu add radiobutton -label {X Y} \
+ -variable pmarker(format) -value xy
+
+ # Length
+ set f [ttk::labelframe $w.region.dformat \
+ -text [msgcat::mc {Default Length}]]
+
+ ttk::menubutton $f.dformat -textvariable pmarker(dformat) \
+ -menu $f.dformat.menu
+
+ grid $f.dformat -padx 2 -pady 2 -sticky w
+
+ menu $f.dformat.menu
+ $f.dformat.menu add radiobutton -label {Degrees} \
+ -variable pmarker(dformat) -value degrees
+ $f.dformat.menu add radiobutton -label {ArcMin} \
+ -variable pmarker(dformat) -value arcmin
+ $f.dformat.menu add radiobutton -label {ArcSec} \
+ -variable pmarker(dformat) -value arcsec
+
+ # Epsilon
+ set f [ttk::labelframe $w.region.epsilon \
+ -text [msgcat::mc {Mouse Click Epsilon}]]
+
+ ttk::label $f.title -text [msgcat::mc {Pixels}]
+ ttk::menubutton $f.epsilon -textvariable pmarker(epsilon) \
+ -menu $f.epsilon.menu
+
+ grid $f.title $f.epsilon -padx 2 -pady 2 -sticky w
+
+ menu $f.epsilon.menu
+ $f.epsilon.menu add radiobutton -label {2} -variable pmarker(epsilon) \
+ -value 2 -command MarkerEpsilon
+ $f.epsilon.menu add radiobutton -label {3} -variable pmarker(epsilon) \
+ -value 3 -command MarkerEpsilon
+ $f.epsilon.menu add radiobutton -label {4} -variable pmarker(epsilon) \
+ -value 4 -command MarkerEpsilon
+ $f.epsilon.menu add radiobutton -label {5} -variable pmarker(epsilon) \
+ -value 5 -command MarkerEpsilon
+ $f.epsilon.menu add radiobutton -label {6} -variable pmarker(epsilon) \
+ -value 6 -command MarkerEpsilon
+ $f.epsilon.menu add radiobutton -label {8} -variable pmarker(epsilon) \
+ -value 8 -command MarkerEpsilon
+ $f.epsilon.menu add radiobutton -label {10} -variable pmarker(epsilon) \
+ -value 10 -command MarkerEpsilon
+
+ grid $f.title $f.epsilon -padx 2 -pady 2 -sticky w
+
+ # Centroid
+ set f [ttk::labelframe $w.region.centroid -text [msgcat::mc {Centroid}]]
+
+ ttk::label $f.ititle -text [msgcat::mc {Iteration}]
+ ttk::entry $f.iteration -textvariable pmarker(centroid,iteration) -width 10
+ ttk::label $f.rtitle -text [msgcat::mc {Radius}]
+ ttk::entry $f.radius -textvariable pmarker(centroid,radius) -width 10
+
+ grid $f.ititle $f.iteration $f.rtitle $f.radius -padx 2 -pady 2 -sticky w
+ # Plots
+ set f [ttk::labelframe $w.region.plot -text [msgcat::mc {Auto Plot}]]
+ ttk::checkbutton $f.2d -text [msgcat::mc {2D}] -variable pmarker(plot2d)
+ ttk::checkbutton $f.3d -text [msgcat::mc {3D}] -variable pmarker(plot3d)
+ ttk::checkbutton $f.stats -text [msgcat::mc {Statistics}] \
+ -variable pmarker(stats)
+
+ grid $f.2d $f.3d -padx 2 -pady 2 -sticky w
+ grid $f.stats -padx 2 -pady 2 -sticky w
+
+ # Circle
+ set f [ttk::labelframe $w.region.circle -text [msgcat::mc {Circle}]]
+
+ ttk::label $f.title -text [msgcat::mc {Radius}]
+ ttk::entry $f.radius -textvariable pmarker(circle,radius) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ grid $f.title $f.radius $f.unit -padx 2 -pady 2 -sticky w
+
+ # Ellipse
+ set f [ttk::labelframe $w.region.ellipse -text [msgcat::mc {Ellipse}]]
+
+ ttk::label $f.title -text "Radius 1"
+ ttk::entry $f.radius1 -textvariable pmarker(ellipse,radius1) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ ttk::label $f.title2 -text "Radius 2"
+ ttk::entry $f.radius2 -textvariable pmarker(ellipse,radius2) -width 10
+ ttk::label $f.unit2 -text [msgcat::mc {Image}]
+
+ grid $f.title $f.radius1 $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.title2 $f.radius2 $f.unit2 -padx 2 -pady 2 -sticky w
+
+ # Box
+ set f [ttk::labelframe $w.region.box -text [msgcat::mc {Box}]]
+
+ ttk::label $f.title -text "Size 1"
+ ttk::entry $f.radius1 -textvariable pmarker(box,radius1) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ ttk::label $f.title2 -text "Size 2"
+ ttk::entry $f.radius2 -textvariable pmarker(box,radius2) -width 10
+ ttk::label $f.unit2 -text [msgcat::mc {Image}]
+
+ grid $f.title $f.radius1 $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.title2 $f.radius2 $f.unit2 -padx 2 -pady 2 -sticky w
+
+ # Projection
+ set f [ttk::labelframe $w.region.projection -text [msgcat::mc {Projection}]]
+
+ ttk::label $f.title -text [msgcat::mc {Thickness}]
+ ttk::entry $f.thick -textvariable pmarker(projection,thick) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ grid $f.title $f.thick $f.unit -padx 2 -pady 2 -sticky w
+
+ # Point
+ set f [ttk::labelframe $w.region.point -text [msgcat::mc {Point}]]
+
+ ttk::label $f.title -text [msgcat::mc {Size}]
+ ttk::entry $f.size -textvariable pmarker(point,size) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Pixels}]
+
+ grid $f.title $f.size $f.unit -padx 2 -pady 2 -sticky w
+
+ pack $w.region.format $w.region.dformat $w.region.epsilon \
+ $w.region.centroid $w.region.plot \
+ $w.region.circle $w.region.ellipse \
+ $w.region.box $w.region.projection $w.region.point \
+ -side top -fill both -expand true
+}
+
+proc PrefsDialogAnnulus {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Annulus}]
+ lappend dprefs(tabs) [ttk::frame $w.annulus]
+
+ # Annulus
+ set f [ttk::labelframe $w.annulus.annulus -text [msgcat::mc {Annulus}]]
+
+ ttk::label $f.innerTitle -text [msgcat::mc {Inner}]
+ ttk::label $f.outerTitle -text [msgcat::mc {Outer}]
+ ttk::label $f.radiusTitle -text [msgcat::mc {Radius}]
+ ttk::entry $f.inner -textvariable pmarker(annulus,inner) -width 10
+ ttk::entry $f.outer -textvariable pmarker(annulus,outer) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+ ttk::label $f.annuliTitle -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable pmarker(annulus,annuli) -width 10
+
+ grid x $f.innerTitle $f.outerTitle -padx 2 -pady 2 -sticky w
+ grid $f.radiusTitle $f.inner $f.outer $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.annuliTitle $f.annuli -padx 2 -pady 2 -sticky w
+
+ # Ellipse Annulus
+ set f [ttk::labelframe $w.annulus.ellipseannulus \
+ -text [msgcat::mc {Elliptical Annulus}]]
+
+ ttk::label $f.majorTitle -text [msgcat::mc {Major}]
+ ttk::label $f.minorTitle -text [msgcat::mc {Minor}]
+
+ ttk::label $f.innerTitle -text [msgcat::mc {Inner}]
+ ttk::entry $f.radius1 -textvariable pmarker(ellipseannulus,radius1) \
+ -width 10
+ ttk::entry $f.radius2 -textvariable pmarker(ellipseannulus,radius2) \
+ -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ ttk::label $f.outerTitle -text [msgcat::mc {Outer}]
+ ttk::entry $f.radius3 -textvariable pmarker(ellipseannulus,radius3) \
+ -width 10
+
+ ttk::label $f.annuliTitle -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable pmarker(ellipseannulus,annuli) -width 10
+
+ grid x $f.majorTitle $f.minorTitle -padx 2 -pady 2 -sticky w
+ grid $f.innerTitle $f.radius1 $f.radius2 $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.outerTitle $f.radius3 -padx 2 -pady 2 -sticky w
+ grid $f.annuliTitle $f.annuli -padx 2 -pady 2 -sticky w
+
+ # Box Annulus
+ set f [ttk::labelframe $w.annulus.boxannulus \
+ -text [msgcat::mc {Box Annulus}]]
+
+ ttk::label $f.majorTitle -text [msgcat::mc {Width}]
+ ttk::label $f.minorTitle -text [msgcat::mc {Height}]
+
+ ttk::label $f.innerTitle -text [msgcat::mc {Inner}]
+ ttk::entry $f.radius1 -textvariable pmarker(boxannulus,radius1) -width 10
+ ttk::entry $f.radius2 -textvariable pmarker(boxannulus,radius2) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ ttk::label $f.outerTitle -text [msgcat::mc {Outer}]
+ ttk::entry $f.radius3 -textvariable pmarker(boxannulus,radius3) -width 10
+
+ ttk::label $f.annuliTitle -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable pmarker(boxannulus,annuli) -width 10
+
+ grid x $f.majorTitle $f.minorTitle -padx 2 -pady 2 -sticky w
+ grid $f.innerTitle $f.radius1 $f.radius2 $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.outerTitle $f.radius3 -padx 2 -pady 2 -sticky w
+ grid $f.annuliTitle $f.annuli -padx 2 -pady 2 -sticky w
+
+ pack $w.annulus.annulus $w.annulus.ellipseannulus $w.annulus.boxannulus \
+ -side top -fill both -expand true
+}
+
+proc PrefsDialogPanda {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Panda}]
+ lappend dprefs(tabs) [ttk::frame $w.panda]
+
+ # Panda
+ set f [ttk::labelframe $w.panda.panda -text [msgcat::mc {Panda}]]
+
+ ttk::label $f.innerTitle -text [msgcat::mc {Inner}]
+ ttk::label $f.outerTitle -text [msgcat::mc {Outer}]
+ ttk::label $f.radiusTitle -text [msgcat::mc {Radius}]
+ ttk::entry $f.inner -textvariable pmarker(panda,inner) -width 10
+ ttk::entry $f.outer -textvariable pmarker(panda,outer) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+ ttk::label $f.annuliTitle -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable pmarker(panda,annuli) -width 10
+
+ grid x $f.innerTitle $f.outerTitle -padx 2 -pady 2 -sticky w
+ grid $f.radiusTitle $f.inner $f.outer $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.annuliTitle $f.annuli -padx 2 -pady 2 -sticky w
+
+ ttk::label $f.ang1Title -text [msgcat::mc {Start}]
+ ttk::label $f.ang2Title -text [msgcat::mc {Stop}]
+ ttk::label $f.angTitle -text [msgcat::mc {Angles}]
+ ttk::entry $f.ang1 -textvariable pmarker(panda,ang1) -width 10
+ ttk::entry $f.ang2 -textvariable pmarker(panda,ang2) -width 10
+ ttk::label $f.angunit -text [msgcat::mc {Degrees}]
+ ttk::label $f.angnumTitle -text [msgcat::mc {Number}]
+ ttk::entry $f.angnum -textvariable pmarker(panda,angnum) -width 10
+
+ grid x $f.ang1Title $f.ang2Title -padx 2 -pady 2 -sticky w
+ grid $f.angTitle $f.ang1 $f.ang2 $f.angunit -padx 2 -pady 2 -sticky w
+ grid $f.angnumTitle $f.angnum -padx 2 -pady 2 -sticky w
+
+ # Elliptical Panda
+ set f [ttk::labelframe $w.panda.epanda \
+ -text [msgcat::mc {Elliptical Panda}]]
+
+ ttk::label $f.majorTitle -text [msgcat::mc {Major}]
+ ttk::label $f.minorTitle -text [msgcat::mc {Minor}]
+
+ ttk::label $f.innerTitle -text [msgcat::mc {Inner}]
+ ttk::entry $f.radius1 -textvariable pmarker(epanda,radius1) -width 10
+ ttk::entry $f.radius2 -textvariable pmarker(epanda,radius2) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ ttk::label $f.outerTitle -text [msgcat::mc {Outer}]
+ ttk::entry $f.radius3 -textvariable pmarker(epanda,radius3) -width 10
+
+ ttk::label $f.annuliTitle -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable pmarker(epanda,annuli) -width 10
+
+ grid x $f.majorTitle $f.minorTitle -padx 2 -pady 2 -sticky w
+ grid $f.innerTitle $f.radius1 $f.radius2 $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.outerTitle $f.radius3 -padx 2 -pady 2 -sticky w
+ grid $f.annuliTitle $f.annuli -padx 2 -pady 2 -sticky w
+
+ ttk::label $f.ang1Title -text [msgcat::mc {Start}]
+ ttk::label $f.ang2Title -text [msgcat::mc {Stop}]
+ ttk::label $f.angTitle -text [msgcat::mc {Angles}]
+ ttk::entry $f.ang1 -textvariable pmarker(epanda,ang1) -width 10
+ ttk::entry $f.ang2 -textvariable pmarker(epanda,ang2) -width 10
+ ttk::label $f.angunit -text [msgcat::mc {Degrees}]
+ ttk::label $f.angnumTitle -text [msgcat::mc {Number}]
+ ttk::entry $f.angnum -textvariable pmarker(epanda,angnum) -width 10
+
+ grid x $f.ang1Title $f.ang2Title -padx 2 -pady 2 -sticky w
+ grid $f.angTitle $f.ang1 $f.ang2 $f.angunit -padx 2 -pady 2 -sticky w
+ grid $f.angnumTitle $f.angnum -padx 2 -pady 2 -sticky w
+
+ # Default Box Panda
+ set f [ttk::labelframe $w.panda.bpanda -text [msgcat::mc {Box Panda}]]
+
+ ttk::label $f.majorTitle -text [msgcat::mc {Major}]
+ ttk::label $f.minorTitle -text [msgcat::mc {Minor}]
+
+ ttk::label $f.innerTitle -text [msgcat::mc {Inner}]
+ ttk::entry $f.radius1 -textvariable pmarker(bpanda,radius1) -width 10
+ ttk::entry $f.radius2 -textvariable pmarker(bpanda,radius2) -width 10
+ ttk::label $f.unit -text [msgcat::mc {Image}]
+
+ ttk::label $f.outerTitle -text [msgcat::mc {Outer}]
+ ttk::entry $f.radius3 -textvariable pmarker(bpanda,radius3) -width 10
+
+ ttk::label $f.annuliTitle -text [msgcat::mc {Annuli}]
+ ttk::entry $f.annuli -textvariable pmarker(bpanda,annuli) -width 10
+
+ grid x $f.majorTitle $f.minorTitle -padx 2 -pady 2 -sticky w
+ grid $f.innerTitle $f.radius1 $f.radius2 $f.unit -padx 2 -pady 2 -sticky w
+ grid $f.outerTitle $f.radius3 -padx 2 -pady 2 -sticky w
+ grid $f.annuliTitle $f.annuli -padx 2 -pady 2 -sticky w
+
+ ttk::label $f.ang1Title -text [msgcat::mc {Start}]
+ ttk::label $f.ang2Title -text [msgcat::mc {Stop}]
+ ttk::label $f.angTitle -text [msgcat::mc {Angles}]
+ ttk::entry $f.ang1 -textvariable pmarker(bpanda,ang1) -width 10
+ ttk::entry $f.ang2 -textvariable pmarker(bpanda,ang2) -width 10
+ ttk::label $f.angunit -text [msgcat::mc {Degrees}]
+ ttk::label $f.angnumTitle -text [msgcat::mc {Number}]
+ ttk::entry $f.angnum -textvariable pmarker(bpanda,angnum) -width 10
+
+ grid x $f.ang1Title $f.ang2Title -padx 2 -pady 2 -sticky w
+ grid $f.angTitle $f.ang1 $f.ang2 $f.angunit -padx 2 -pady 2 -sticky w
+ grid $f.angnumTitle $f.angnum -padx 2 -pady 2 -sticky w
+
+ pack $w.panda.panda $w.panda.epanda $w.panda.bpanda \
+ -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsRegionDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ region,info 1
+ region,circle 0
+ region,ellipse 0
+ region,box 0
+ region,polygon 0
+ region,line 0
+ region,vector 0
+ region,projection 0
+ region,segment 0
+ region,text 0
+ region,point 0
+ region,ruler 0
+ region,compass 0
+ region,annulus 0
+ region,ellipseannulus 0
+ region,boxannulus 0
+ region,panda 0
+ region,epanda 0
+ region,bpanda 0
+ region,create 0
+ region,dissolve 0
+ region,loadtemplate 0
+ region,savetemplate 0
+ region,centroid 0
+ region,front 1
+ region,back 1
+ region,all 1
+ region,none 1
+ region,invert 0
+ region,delete 1
+ region,deleteall 0
+ region,newgroup 0
+ region,group 0
+ region,list 1
+ region,load 1
+ region,save 1
+ region,show 0
+ region,showtext 0
+ region,autocentroid 0
+ }
+}
+
+proc CreateButtonsRegion {} {
+ global buttons
+ global ds9
+
+ ttk::frame $ds9(buttons).region
+
+ ButtonButton $ds9(buttons).region.info \
+ [string tolower [msgcat::mc {Information}]] MarkerInfo
+
+ RadioButton $ds9(buttons).region.circle \
+ [string tolower [msgcat::mc {Circle}]] \
+ marker(shape) circle {}
+ RadioButton $ds9(buttons).region.ellipse \
+ [string tolower [msgcat::mc {Ellipse}]] \
+ marker(shape) ellipse {}
+ RadioButton $ds9(buttons).region.box \
+ [string tolower [msgcat::mc {Box}]] \
+ marker(shape) box {}
+ RadioButton $ds9(buttons).region.polygon \
+ [string tolower [msgcat::mc {Polygon}]] \
+ marker(shape) polygon {}
+ RadioButton $ds9(buttons).region.line \
+ [string tolower [msgcat::mc {Line}]] \
+ marker(shape) line {}
+ RadioButton $ds9(buttons).region.vector \
+ [string tolower [msgcat::mc {Vector}]] \
+ marker(shape) vector {}
+ RadioButton $ds9(buttons).region.projection \
+ [string tolower [msgcat::mc {Projection}]] \
+ marker(shape) projection {}
+ RadioButton $ds9(buttons).region.segment \
+ [string tolower [msgcat::mc {Segment}]] \
+ marker(shape) segment {}
+ RadioButton $ds9(buttons).region.text \
+ [string tolower [msgcat::mc {Text}]] \
+ marker(shape) text {}
+ RadioButton $ds9(buttons).region.point \
+ [string tolower [msgcat::mc {Point}]] \
+ marker(shape) {circle point} {}
+ RadioButton $ds9(buttons).region.ruler \
+ [string tolower [msgcat::mc {Ruler}]] \
+ marker(shape) ruler {}
+ RadioButton $ds9(buttons).region.compass \
+ [string tolower [msgcat::mc {Compass}]] \
+ marker(shape) compass {}
+ RadioButton $ds9(buttons).region.annulus \
+ [string tolower [msgcat::mc {Annulus}]] \
+ marker(shape) annulus {}
+ RadioButton $ds9(buttons).region.ellipseannulus \
+ [string tolower [msgcat::mc {Elliptical Annulus}]] \
+ marker(shape) ellipseannulus {}
+ RadioButton $ds9(buttons).region.boxannulus \
+ [string tolower [msgcat::mc {Box Annulus}]] \
+ marker(shape) boxannulus {}
+ RadioButton $ds9(buttons).region.panda \
+ [string tolower [msgcat::mc {Panda}]] \
+ marker(shape) panda {}
+ RadioButton $ds9(buttons).region.epanda \
+ [string tolower [msgcat::mc {Ellipse Panda}]] \
+ marker(shape) epanda {}
+ RadioButton $ds9(buttons).region.bpanda \
+ [string tolower [msgcat::mc {Box Panda}]] \
+ marker(shape) bpanda {}
+
+ ButtonButton $ds9(buttons).region.create \
+ [string tolower [msgcat::mc {Composite}]] CompositeCreate
+ ButtonButton $ds9(buttons).region.dissolve \
+ [string tolower [msgcat::mc {Dissolve}]] CompositeDelete
+
+ ButtonButton $ds9(buttons).region.loadtemplate \
+ [string tolower [msgcat::mc {Load Template}]] OpenTemplateMarker
+ ButtonButton $ds9(buttons).region.savetemplate \
+ [string tolower [msgcat::mc {Save Template}]] SaveAsTemplateMarker
+
+ ButtonButton $ds9(buttons).region.centroid \
+ [string tolower [msgcat::mc {Centroid}]] MarkerCentroid
+ ButtonButton $ds9(buttons).region.front \
+ [string tolower [msgcat::mc {Front}]] MarkerFront
+ ButtonButton $ds9(buttons).region.back \
+ [string tolower [msgcat::mc {Back}]] MarkerBack
+
+ ButtonButton $ds9(buttons).region.all \
+ [string tolower [msgcat::mc {All}]] MarkerSelectAll
+ ButtonButton $ds9(buttons).region.none \
+ [string tolower [msgcat::mc {None}]] MarkerUnselectAll
+ ButtonButton $ds9(buttons).region.invert \
+ [string tolower [msgcat::mc {Invert}]] MarkerSelectInvert
+ ButtonButton $ds9(buttons).region.delete \
+ [string tolower [msgcat::mc {Delete}]] MarkerDeleteSelect
+ ButtonButton $ds9(buttons).region.deleteall \
+ [string tolower [msgcat::mc {Delete All}]] MarkerDeleteAllMenu
+
+ ButtonButton $ds9(buttons).region.newgroup \
+ [string tolower [msgcat::mc {New Group}]] GroupCreate
+ ButtonButton $ds9(buttons).region.group \
+ [string tolower [msgcat::mc {Groups}]] GroupDialog
+
+ ButtonButton $ds9(buttons).region.list \
+ [string tolower [msgcat::mc {List}]] MarkerList
+ ButtonButton $ds9(buttons).region.load \
+ [string tolower [msgcat::mc {Load}]] MarkerLoad
+ ButtonButton $ds9(buttons).region.save \
+ [string tolower [msgcat::mc {Save}]] MarkerSave
+
+ CheckButton $ds9(buttons).region.show \
+ [string tolower [msgcat::mc {Show}]] \
+ marker(show) MarkerShow
+ CheckButton $ds9(buttons).region.showtext \
+ [string tolower [msgcat::mc {Show Text}]] \
+ marker(show,text) MarkerShowText
+ CheckButton $ds9(buttons).region.autocentroid \
+ [string tolower [msgcat::mc {Auto Centroid}]] \
+ marker(centroid,auto) MarkerCentroidAuto
+
+ set buttons(region) "
+ $ds9(buttons).region.info pbuttons(region,info)
+ $ds9(buttons).region.circle pbuttons(region,circle)
+ $ds9(buttons).region.ellipse pbuttons(region,ellipse)
+ $ds9(buttons).region.box pbuttons(region,box)
+ $ds9(buttons).region.polygon pbuttons(region,polygon)
+ $ds9(buttons).region.line pbuttons(region,line)
+ $ds9(buttons).region.vector pbuttons(region,vector)
+ $ds9(buttons).region.projection pbuttons(region,projection)
+ $ds9(buttons).region.segment pbuttons(region,segment)
+ $ds9(buttons).region.text pbuttons(region,text)
+ $ds9(buttons).region.point pbuttons(region,point)
+ $ds9(buttons).region.ruler pbuttons(region,ruler)
+ $ds9(buttons).region.compass pbuttons(region,compass)
+ $ds9(buttons).region.annulus pbuttons(region,annulus)
+ $ds9(buttons).region.ellipseannulus pbuttons(region,ellipseannulus)
+ $ds9(buttons).region.boxannulus pbuttons(region,boxannulus)
+ $ds9(buttons).region.panda pbuttons(region,panda)
+ $ds9(buttons).region.epanda pbuttons(region,epanda)
+ $ds9(buttons).region.bpanda pbuttons(region,bpanda)
+ $ds9(buttons).region.create pbuttons(region,create)
+ $ds9(buttons).region.dissolve pbuttons(region,dissolve)
+ $ds9(buttons).region.loadtemplate pbuttons(region,loadtemplate)
+ $ds9(buttons).region.savetemplate pbuttons(region,savetemplate)
+ $ds9(buttons).region.centroid pbuttons(region,centroid)
+ $ds9(buttons).region.front pbuttons(region,front)
+ $ds9(buttons).region.back pbuttons(region,back)
+ $ds9(buttons).region.all pbuttons(region,all)
+ $ds9(buttons).region.none pbuttons(region,none)
+ $ds9(buttons).region.invert pbuttons(region,invert)
+ $ds9(buttons).region.delete pbuttons(region,delete)
+ $ds9(buttons).region.deleteall pbuttons(region,deleteall)
+ $ds9(buttons).region.newgroup pbuttons(region,newgroup)
+ $ds9(buttons).region.group pbuttons(region,group)
+ $ds9(buttons).region.list pbuttons(region,list)
+ $ds9(buttons).region.load pbuttons(region,load)
+ $ds9(buttons).region.save pbuttons(region,save)
+ $ds9(buttons).region.show pbuttons(region,show)
+ $ds9(buttons).region.showtext pbuttons(region,showtext)
+ $ds9(buttons).region.autocentroid pbuttons(region,autocentroid)
+ "
+}
+
+proc PrefsDialogButtonbarRegion {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label "[msgcat::mc {Get Information}]..." \
+ -variable pbuttons(region,info) \
+ -command {UpdateButtons buttons(region)}
+ $m add separator
+ $m add cascade -label [msgcat::mc {Shape}] -menu $m.shape
+ $m add cascade -label [msgcat::mc {Composite Region}] -menu $m.composite
+ $m add cascade -label [msgcat::mc {Template}] -menu $m.template
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Centroid}] \
+ -variable pbuttons(region,centroid) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label [msgcat::mc {Move to Front}] \
+ -variable pbuttons(region,front) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label [msgcat::mc {Move to Back}] \
+ -variable pbuttons(region,back) \
+ -command {UpdateButtons buttons(region)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Select All}] \
+ -variable pbuttons(region,all) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label [msgcat::mc {Select None}] \
+ -variable pbuttons(region,none) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label [msgcat::mc {Invert Selection}] \
+ -variable pbuttons(region,invert) \
+ -command {UpdateButtons buttons(region)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Delete Selected Regions}] \
+ -variable pbuttons(region,delete) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label [msgcat::mc {Delete All Regions}] \
+ -variable pbuttons(region,deleteall) \
+ -command {UpdateButtons buttons(region)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {New Group}] \
+ -variable pbuttons(region,newgroup) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label "[msgcat::mc {Groups}]..." \
+ -variable pbuttons(region,group) \
+ -command {UpdateButtons buttons(region)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {List Regions}]..." \
+ -variable pbuttons(region,list) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label "[msgcat::mc {Load Regions}]..." \
+ -variable pbuttons(region,load) \
+ -command {UpdateButtons buttons(region)}
+ $m add checkbutton -label "[msgcat::mc {Save Regions}]..." \
+ -variable pbuttons(region,save) \
+ -command {UpdateButtons buttons(region)}
+ $m add separator
+ $m add cascade -label [msgcat::mc {Region Parameters}] -menu $m.params
+
+ menu $m.shape
+ $m.shape add checkbutton -label [msgcat::mc {Circle}] \
+ -variable pbuttons(region,circle) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Ellipse}] \
+ -variable pbuttons(region,ellipse) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Box}] \
+ -variable pbuttons(region,box) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Polygon}] \
+ -variable pbuttons(region,polygon) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add separator
+ $m.shape add checkbutton -label [msgcat::mc {Line}] \
+ -variable pbuttons(region,line) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Vector}] \
+ -variable pbuttons(region,vector) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Projection}] \
+ -variable pbuttons(region,projection) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Segment}] \
+ -variable pbuttons(region,segment) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add separator
+ $m.shape add checkbutton -label [msgcat::mc {Text}] \
+ -variable pbuttons(region,text) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Point}] \
+ -variable pbuttons(region,point) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add separator
+ $m.shape add checkbutton -label [msgcat::mc {Ruler}] \
+ -variable pbuttons(region,ruler) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Compass}] \
+ -variable pbuttons(region,compass) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add separator
+ $m.shape add checkbutton -label [msgcat::mc {Annulus}] \
+ -variable pbuttons(region,annulus) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Elliptical Annulus}] \
+ -variable pbuttons(region,ellipseannulus) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Box Annulus}] \
+ -variable pbuttons(region,boxannulus) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Panda}] \
+ -variable pbuttons(region,panda) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Elliptical Panda}]\
+ -variable pbuttons(region,epanda) \
+ -command {UpdateButtons buttons(region)}
+ $m.shape add checkbutton -label [msgcat::mc {Box Panda}] \
+ -variable pbuttons(region,bpanda) \
+ -command {UpdateButtons buttons(region)}
+
+ menu $m.composite
+ $m.composite add checkbutton -label [msgcat::mc {Create}] \
+ -variable pbuttons(region,create) \
+ -command {UpdateButtons buttons(region)}
+ $m.composite add checkbutton -label [msgcat::mc {Dissolve}] \
+ -variable pbuttons(region,dissolve) \
+ -command {UpdateButtons buttons(region)}
+
+ menu $m.template
+ $m.template add checkbutton -label "[msgcat::mc {Load}]..." \
+ -variable pbuttons(region,loadtemplate) \
+ -command {UpdateButtons buttons(region)}
+ $m.template add checkbutton -label "[msgcat::mc {Save}]..." \
+ -variable pbuttons(region,savetemplate) \
+ -command {UpdateButtons buttons(region)}
+
+ menu $m.params
+ $m.params add checkbutton -label [msgcat::mc {Show}] \
+ -variable pbuttons(region,show) \
+ -command {UpdateButtons buttons(region)}
+ $m.params add checkbutton -label [msgcat::mc {Show Text}] \
+ -variable pbuttons(region,showtext) \
+ -command {UpdateButtons buttons(region)}
+ $m.params add separator
+ $m.params add checkbutton -label [msgcat::mc {Auto Centroid}] \
+ -variable pbuttons(region,autocentroid) \
+ -command {UpdateButtons buttons(region)}
+}
+
+# Support
+
+proc UpdateRegionMenu {} {
+ global current
+ global marker
+ global pmarker
+ global ds9
+
+ if {$current(frame) != {}} {
+ $ds9(mb) entryconfig [msgcat::mc {Region}] -state normal
+
+ set marker(show) [$current(frame) get marker show]
+ set marker(show,text) [$current(frame) get marker show text]
+ set marker(centroid,auto) [$current(frame) get marker centroid auto]
+ set marker(centroid,radius) [$current(frame) get marker centroid radius]
+ set marker(centroid,iteration) \
+ [$current(frame) get marker centroid iteration]
+ set marker(preserve) [$current(frame) get marker preserve]
+
+ switch -- $current(mode) {
+ pointer -
+ region {
+ if {[$current(frame) get marker select number] == 1} {
+ set marker(color) \
+ [$current(frame) get marker color]
+ set marker(width) \
+ [$current(frame) get marker width]
+ set marker(dash) \
+ [$current(frame) get marker property dash]
+ set marker(fixed) \
+ [$current(frame) get marker property fixed]
+ set marker(edit) \
+ [$current(frame) get marker property edit]
+ set marker(move) \
+ [$current(frame) get marker property move]
+ set marker(rotate) \
+ [$current(frame) get marker property rotate]
+ set marker(delete) \
+ [$current(frame) get marker property delete]
+ set marker(include) \
+ [$current(frame) get marker property include]
+ set marker(source) \
+ [$current(frame) get marker property source]
+
+ set f [$current(frame) get marker font]
+
+ set marker(font) [lindex $f 0]
+ set marker(font,size) [lindex $f 1]
+ set marker(font,weight) [lindex $f 2]
+ set marker(font,slant) [lindex $f 3]
+ } else {
+ # defaults
+ set marker(color) $pmarker(color)
+ set marker(width) $pmarker(width)
+ set marker(dash) $pmarker(dash)
+ set marker(fixed) $pmarker(fixed)
+ set marker(edit) $pmarker(edit)
+ set marker(move) $pmarker(move)
+ set marker(rotate) $pmarker(rotate)
+ set marker(delete) $pmarker(delete)
+ set marker(include) $pmarker(include)
+ set marker(source) $pmarker(source)
+
+ set marker(font) $pmarker(font)
+ set marker(font,size) $pmarker(font,size)
+ set marker(font,weight) $pmarker(font,weight)
+ set marker(font,slant) $pmarker(font,slant)
+ }
+ }
+ }
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Region}] -state disabled
+ }
+}
diff --git a/ds9/library/mscale.tcl b/ds9/library/mscale.tcl
new file mode 100644
index 0000000..df6b248
--- /dev/null
+++ b/ds9/library/mscale.tcl
@@ -0,0 +1,441 @@
+# 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
+
+# Menu
+
+proc ScaleMainMenu {} {
+ global ds9
+
+ menu $ds9(mb).scale
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Linear}] \
+ -variable scale(type) -command ChangeScale -value linear
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Log}] \
+ -variable scale(type) -command ChangeScale -value log
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Power}] \
+ -variable scale(type) -command ChangeScale -value pow
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Square Root}] \
+ -variable scale(type) -command ChangeScale -value sqrt
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Squared}] \
+ -variable scale(type) -command ChangeScale -value squared
+ $ds9(mb).scale add radiobutton -label {ASINH} \
+ -variable scale(type) -command ChangeScale -value asinh
+ $ds9(mb).scale add radiobutton -label {SINH} \
+ -variable scale(type) -command ChangeScale -value sinh
+ $ds9(mb).scale add radiobutton \
+ -label [msgcat::mc {Histogram Equalization}] \
+ -variable scale(type) -command ChangeScale -value histequ
+ $ds9(mb).scale add separator
+ $ds9(mb).scale add command -label "[msgcat::mc {Log Exponent}]..." \
+ -command ScaleLogDialog
+ $ds9(mb).scale add separator
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Min Max}] \
+ -variable scale(mode) -command ChangeScaleMode -value minmax
+ $ds9(mb).scale add radiobutton -label {99.5%} \
+ -variable scale(mode) -command ChangeScaleMode -value 99.5
+ $ds9(mb).scale add radiobutton -label {99%} \
+ -variable scale(mode) -command ChangeScaleMode -value 99
+ $ds9(mb).scale add radiobutton -label {98%} \
+ -variable scale(mode) -command ChangeScaleMode -value 98
+ $ds9(mb).scale add radiobutton -label {97%} \
+ -variable scale(mode) -command ChangeScaleMode -value 97
+ $ds9(mb).scale add radiobutton -label {96%} \
+ -variable scale(mode) -command ChangeScaleMode -value 96
+ $ds9(mb).scale add radiobutton -label {95%} \
+ -variable scale(mode) -command ChangeScaleMode -value 95
+ $ds9(mb).scale add radiobutton -label {92.5%} \
+ -variable scale(mode) -command ChangeScaleMode -value 92.5
+ $ds9(mb).scale add radiobutton -label {90%} \
+ -variable scale(mode) -command ChangeScaleMode -value 90
+ $ds9(mb).scale add radiobutton -label {ZScale} \
+ -variable scale(mode) -command ChangeScaleMode -value zscale
+ $ds9(mb).scale add radiobutton -label {ZMax} \
+ -variable scale(mode) -command ChangeScaleMode -value zmax
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {User}] \
+ -variable scale(mode) -command ChangeScaleMode -value user
+ $ds9(mb).scale add separator
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Global}] \
+ -variable scale(scope) -command ChangeScaleScope -value global
+ $ds9(mb).scale add radiobutton -label [msgcat::mc {Local}] \
+ -variable scale(scope) -command ChangeScaleScope -value local
+ $ds9(mb).scale add separator
+ $ds9(mb).scale add cascade -label [msgcat::mc {Min Max}] \
+ -menu $ds9(mb).scale.minmax
+ $ds9(mb).scale add command -label {ZScale...} -command ZScaleDialog
+ $ds9(mb).scale add separator
+ $ds9(mb).scale add checkbutton -label "[msgcat::mc {Use}] DATASEC" \
+ -variable scale(datasec) -command ChangeDATASEC
+ $ds9(mb).scale add separator
+ $ds9(mb).scale add command -label "[msgcat::mc {Scale Parameters}]..." \
+ -command ScaleDialog
+
+ menu $ds9(mb).scale.minmax
+ $ds9(mb).scale.minmax add radiobutton -label [msgcat::mc {Scan}] \
+ -variable minmax(mode) -value scan -command ChangeMinMax
+ $ds9(mb).scale.minmax add radiobutton -label [msgcat::mc {Sample}] \
+ -variable minmax(mode) -value sample -command ChangeMinMax
+ $ds9(mb).scale.minmax add radiobutton -label {DATAMIN DATAMAX} \
+ -variable minmax(mode) -value datamin -command ChangeMinMax
+ $ds9(mb).scale.minmax add radiobutton -label {IRAF-MIN IRAF-MAX} \
+ -variable minmax(mode) -value irafmin -command ChangeMinMax
+ $ds9(mb).scale.minmax add separator
+ $ds9(mb).scale.minmax add command \
+ -label "[msgcat::mc {Sample Parameters}]..." -command MinMaxDialog
+}
+
+proc PrefsDialogScaleMenu {w} {
+ set f [ttk::labelframe $w.mscale -text [msgcat::mc {Scale}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarScale $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2 -sticky w
+
+ set m $f.menu.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {Linear}] \
+ -variable pscale(type) -value linear
+ $m add radiobutton -label [msgcat::mc {Log}] \
+ -variable pscale(type) -value log
+ $m add radiobutton -label [msgcat::mc {Power}] \
+ -variable pscale(type) -value pow
+ $m add radiobutton -label [msgcat::mc {Square Root}]\
+ -variable pscale(type) -value sqrt
+ $m add radiobutton -label [msgcat::mc {Squared}] \
+ -variable pscale(type) -value squared
+ $m add radiobutton -label {ASINH} \
+ -variable pscale(type) -value asinh
+ $m add radiobutton -label {SINH} \
+ -variable pscale(type) -value sinh
+ $m add radiobutton -label [msgcat::mc {Histogram Equalization}] \
+ -variable pscale(type) -value histequ
+ $m add separator
+ $m add radiobutton -label [msgcat::mc {Min Max}] \
+ -variable pscale(mode) -value minmax
+ $m add radiobutton -label {99.5%} -variable pscale(mode) -value 99.5
+ $m add radiobutton -label {99%} -variable pscale(mode) -value 99
+ $m add radiobutton -label {98%} -variable pscale(mode) -value 98
+ $m add radiobutton -label {97%} -variable pscale(mode) -value 97
+ $m add radiobutton -label {96%} -variable pscale(mode) -value 96
+ $m add radiobutton -label {95%} -variable pscale(mode) -value 95
+ $m add radiobutton -label {92.5%} -variable pscale(mode) -value 92.5
+ $m add radiobutton -label {90%} -variable pscale(mode) -value 90
+ $m add radiobutton -label {ZScale} -variable pscale(mode) -value zscale
+ $m add radiobutton -label {ZMax} -variable pscale(mode) -value zmax
+ $m add radiobutton -label [msgcat::mc {User}] \
+ -variable pscale(mode) -value user
+ $m add separator
+ $m add radiobutton -label [msgcat::mc {Global}] \
+ -variable pscale(scope) -value global
+ $m add radiobutton -label [msgcat::mc {Local}] \
+ -variable pscale(scope) -value local
+ $m add separator
+ $m add cascade -label [msgcat::mc {Min Max}] -menu $m.minmax
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Use}] DATASEC" \
+ -variable pscale(datasec)
+
+ menu $m.minmax
+ $m.minmax add radiobutton -label [msgcat::mc {Scan}] \
+ -variable pminmax(mode) -value scan
+ $m.minmax add radiobutton -label [msgcat::mc {Sample}] \
+ -variable pminmax(mode) -value sample
+ $m.minmax add radiobutton -label {DATAMIN DATAMAX} \
+ -variable pminmax(mode) -value datamin
+ $m.minmax add radiobutton -label {IRAF-MIN IRAF-MAX} \
+ -variable pminmax(mode) -value irafmin
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogScale {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Scale}]
+ lappend dprefs(tabs) [ttk::frame $w.scale]
+
+ # Log
+ set f [ttk::labelframe $w.scale.log -text [msgcat::mc {Log Exponent}]]
+
+ ttk::entry $f.log -textvariable pscale(log) -width 10
+
+ grid $f.log -padx 2 -pady 2 -sticky w
+
+ # MinMax
+ set f [ttk::labelframe $w.scale.minmax \
+ -text [msgcat::mc {Min Max Parameters}]]
+
+ slider $f.ssample 0 1000 [msgcat::mc {Sample Increment}] \
+ pminmax(sample) {}
+
+ grid $f.ssample -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Zscale
+ set f [ttk::labelframe $w.scale.zscale \
+ -text [msgcat::mc {ZScale Parameters}]]
+
+ slider $f.scontrast 0. 1. [msgcat::mc {Contrast}] \
+ pzscale(contrast) {}
+ slider $f.ssize 0 1000 [msgcat::mc {Number of Samples}] \
+ pzscale(sample) {}
+ slider $f.sline 0 500 [msgcat::mc {Samples per Line}] \
+ pzscale(line) {}
+
+ grid $f.scontrast -padx 2 -pady 2 -sticky ew
+ grid $f.ssize -padx 2 -pady 2 -sticky ew
+ grid $f.sline -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ pack $w.scale.log $w.scale.minmax $w.scale.zscale -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsScaleDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ scale,linear 1
+ scale,log 1
+ scale,pow 1
+ scale,sqrt 1
+ scale,squared 1
+ scale,asinh 1
+ scale,sinh 1
+ scale,hist 1
+ scale,minmax 1
+ scale,995 0
+ scale,99 0
+ scale,98 0
+ scale,97 0
+ scale,96 0
+ scale,95 0
+ scale,925 0
+ scale,90 0
+ scale,zscale 1
+ scale,zmax 0
+ scale,user 0
+ scale,global 0
+ scale,local 0
+ scale,datasec 0
+ scale,params 0
+ }
+}
+
+proc CreateButtonsScale {} {
+ global buttons
+ global ds9
+ global scale
+
+ ttk::frame $ds9(buttons).scale
+ RadioButton $ds9(buttons).scale.linear \
+ [string tolower [msgcat::mc {Linear}]] \
+ scale(type) linear ChangeScale
+ RadioButton $ds9(buttons).scale.log \
+ [string tolower [msgcat::mc {Log}]] \
+ scale(type) log ChangeScale
+ RadioButton $ds9(buttons).scale.pow \
+ [string tolower [msgcat::mc {Power}]] \
+ scale(type) pow ChangeScale
+ RadioButton $ds9(buttons).scale.sqrt \
+ [string tolower [msgcat::mc {Sqrt}]] \
+ scale(type) sqrt ChangeScale
+ RadioButton $ds9(buttons).scale.squared \
+ [string tolower [msgcat::mc {Squared}]] \
+ scale(type) squared ChangeScale
+ RadioButton $ds9(buttons).scale.asinh \
+ [string tolower {ASINH}] \
+ scale(type) asinh ChangeScale
+ RadioButton $ds9(buttons).scale.sinh \
+ [string tolower {SINH}] \
+ scale(type) sinh ChangeScale
+ RadioButton $ds9(buttons).scale.hist \
+ [string tolower [msgcat::mc {Histogram}]] \
+ scale(type) histequ ChangeScale
+
+ RadioButton $ds9(buttons).scale.minmax \
+ [string tolower [msgcat::mc {Min Max}]] \
+ scale(mode) minmax ChangeScaleMode
+ RadioButton $ds9(buttons).scale.995 {99.5%} scale(mode) 99.5 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.99 {99%} scale(mode) 99 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.98 {98%} scale(mode) 98 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.97 {97%} scale(mode) 97 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.96 {96%} scale(mode) 96 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.95 {95%} scale(mode) 95 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.925 {92.5%} scale(mode) 92.5 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.90 {90%} scale(mode) 90 ChangeScaleMode
+ RadioButton $ds9(buttons).scale.zscale {zscale} \
+ scale(mode) zscale ChangeScaleMode
+ RadioButton $ds9(buttons).scale.zmax {zmax} \
+ scale(mode) zmax ChangeScaleMode
+ RadioButton $ds9(buttons).scale.user \
+ [string tolower [msgcat::mc {User}]] \
+ scale(mode) user ChangeScaleMode
+
+ RadioButton $ds9(buttons).scale.global \
+ [string tolower [msgcat::mc {Global}]] \
+ scale(scope) global ChangeScaleScope
+ RadioButton $ds9(buttons).scale.local \
+ [string tolower [msgcat::mc {Local}]] \
+ scale(scope) local ChangeScaleScope
+
+ CheckButton $ds9(buttons).scale.datasec {datasec} \
+ scale(datasec) ChangeDATASEC
+
+ ButtonButton $ds9(buttons).scale.params \
+ [string tolower [msgcat::mc {Parameters}]] ScaleDialog
+
+ set buttons(scale) "
+ $ds9(buttons).scale.linear pbuttons(scale,linear)
+ $ds9(buttons).scale.log pbuttons(scale,log)
+ $ds9(buttons).scale.pow pbuttons(scale,pow)
+ $ds9(buttons).scale.sqrt pbuttons(scale,sqrt)
+ $ds9(buttons).scale.squared pbuttons(scale,squared)
+ $ds9(buttons).scale.asinh pbuttons(scale,asinh)
+ $ds9(buttons).scale.sinh pbuttons(scale,sinh)
+ $ds9(buttons).scale.hist pbuttons(scale,hist)
+ $ds9(buttons).scale.minmax pbuttons(scale,minmax)
+ $ds9(buttons).scale.995 pbuttons(scale,995)
+ $ds9(buttons).scale.99 pbuttons(scale,99)
+ $ds9(buttons).scale.98 pbuttons(scale,98)
+ $ds9(buttons).scale.97 pbuttons(scale,97)
+ $ds9(buttons).scale.96 pbuttons(scale,96)
+ $ds9(buttons).scale.95 pbuttons(scale,95)
+ $ds9(buttons).scale.925 pbuttons(scale,925)
+ $ds9(buttons).scale.90 pbuttons(scale,90)
+ $ds9(buttons).scale.zscale pbuttons(scale,zscale)
+ $ds9(buttons).scale.zmax pbuttons(scale,zmax)
+ $ds9(buttons).scale.user pbuttons(scale,user)
+ $ds9(buttons).scale.global pbuttons(scale,global)
+ $ds9(buttons).scale.local pbuttons(scale,local)
+ $ds9(buttons).scale.datasec pbuttons(scale,datasec)
+ $ds9(buttons).scale.params pbuttons(scale,params)
+ "
+}
+
+proc PrefsDialogButtonbarScale {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Linear}] \
+ -variable pbuttons(scale,linear) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {Log}] \
+ -variable pbuttons(scale,log) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {Power}] \
+ -variable pbuttons(scale,pow) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {Square Root}] \
+ -variable pbuttons(scale,sqrt) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {Squared}] \
+ -variable pbuttons(scale,squared) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {ASINH} \
+ -variable pbuttons(scale,asinh) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {SINH} \
+ -variable pbuttons(scale,sinh) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {Histogram Equalization}] \
+ -variable pbuttons(scale,hist) -command {UpdateButtons buttons(scale)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Min Max}] \
+ -variable pbuttons(scale,minmax) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {99.5%} \
+ -variable pbuttons(scale,995) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {99%} \
+ -variable pbuttons(scale,99) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {98%} \
+ -variable pbuttons(scale,98) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {97%} \
+ -variable pbuttons(scale,97) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {96%} \
+ -variable pbuttons(scale,96) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {95%} \
+ -variable pbuttons(scale,95) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {92.5%} \
+ -variable pbuttons(scale,925) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {90%} \
+ -variable pbuttons(scale,90) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {ZScale} \
+ -variable pbuttons(scale,zscale) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label {ZMax} \
+ -variable pbuttons(scale,zmax) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {User}] \
+ -variable pbuttons(scale,user) -command {UpdateButtons buttons(scale)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Global}] \
+ -variable pbuttons(scale,global) -command {UpdateButtons buttons(scale)}
+ $m add checkbutton -label [msgcat::mc {Local}] \
+ -variable pbuttons(scale,local) -command {UpdateButtons buttons(scale)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Use}] DATASEC" \
+ -variable pbuttons(scale,datasec) -command {UpdateButtons buttons(scale)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Scale Parameters}]..." \
+ -variable pbuttons(scale,params) -command {UpdateButtons buttons(scale)}
+}
+
+# Support
+
+proc UpdateScaleMenu {} {
+ global ds9
+ global current
+ global scale
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateScaleMenu"
+ }
+
+ if {$current(frame) != {}} {
+ if {![$current(frame) has iis]} {
+ $ds9(mb) entryconfig [msgcat::mc {Scale}] -state normal
+
+ set scale(type) [$current(frame) get colorscale]
+ set scale(log) [$current(frame) get colorscale log]
+ set scale(scope) [$current(frame) get clip scope]
+ set scale(mode) [$current(frame) get clip mode]
+ set scale(datasec) [$current(frame) get datasec]
+ set minmax(sample) [$current(frame) get clip minmax sample]
+ set minmax(mode) [$current(frame) get clip minmax mode]
+ set zscale(contrast) [$current(frame) get clip zscale contrast]
+ set zscale(sample) [$current(frame) get clip zscale sample]
+ set zscale(line) [$current(frame) get clip zscale line]
+
+ # DATAMIN/MAX IRAFMIN/MAX
+ if {[$current(frame) has fits]} {
+ if {[$current(frame) has datamin]} {
+ $ds9(mb).scale.minmax entryconfig {DATAMIN DATAMAX} \
+ -state normal
+ } else {
+ $ds9(mb).scale.minmax entryconfig {DATAMIN DATAMAX} \
+ -state disabled
+ }
+
+ if {[$current(frame) has irafmin]} {
+ $ds9(mb).scale.minmax entryconfig {IRAF-MIN IRAF-MAX} \
+ -state normal
+ } else {
+ $ds9(mb).scale.minmax entryconfig {IRAF-MIN IRAF-MAX} \
+ -state disabled
+ }
+ } else {
+ $ds9(mb).scale.minmax entryconfig {DATAMIN DATAMAX} \
+ -state normal
+ $ds9(mb).scale.minmax entryconfig {IRAF-MIN IRAF-MAX} \
+ -state normal
+ }
+
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Scale}] -state disabled
+ }
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Scale}] -state disabled
+ }
+}
+
diff --git a/ds9/library/multiframe.tcl b/ds9/library/multiframe.tcl
new file mode 100644
index 0000000..3fad8e7
--- /dev/null
+++ b/ds9/library/multiframe.tcl
@@ -0,0 +1,179 @@
+# 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 LoadMultiFrameFile {fn} {
+ set path {}
+ if {[string range $fn 0 4] == "stdin" ||
+ [string range $fn 0 4] == "STDIN" ||
+ [string range $fn 0 0] == "-"} {
+ set path [tmpnam {.fits}]
+ catch {
+ set ch [open "$path" w]
+ fconfigure stdin -translation binary -encoding binary
+ fconfigure $ch -translation binary -encoding binary
+ puts -nonewline $ch [read stdin]
+ close $ch
+ }
+ }
+
+ LoadMultiFrameAlloc $path $fn
+}
+
+proc LoadMultiFrameSocket {sock fn} {
+ set path [tmpnam {.fits}]
+ catch {
+ set ch [open "$path" w]
+ fconfigure $ch -translation binary -encoding binary
+ fconfigure $sock -translation binary -encoding binary
+ puts -nonewline $ch [read $sock]
+ close $ch
+ }
+
+ set rr [LoadMultiFrameAlloc $path $fn]
+ if {!$rr} {
+ if {$path != {}} {
+ catch {file delete -force $path}
+ }
+ }
+ return $rr
+}
+
+proc LoadMultiFrameAlloc {path fn} {
+ global loadParam
+ global current
+ global ds9
+
+ set ext 0
+ set cnt 0
+ set did 0
+ set need 0
+
+ # start with new frame?
+ if {$current(frame) != {}} {
+ switch -- [$current(frame) get type] {
+ base {
+ if {[$current(frame) has fits]} {
+ CreateFrame
+ set did 1
+ }
+ }
+ rgb -
+ 3d {
+ CreateFrame
+ set did 1
+ }
+ }
+ } else {
+ CreateFrame
+ }
+
+ while {1} {
+
+ # create a new frame
+ if {$need} {
+ CreateFrame
+ set did 1
+ }
+
+ # ProcessLoad will clear loadParam each time
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {}
+ if {$path != {}} {
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) "stdin\[$ext\]"
+ set loadParam(file,fn) "$path\[$ext\]"
+ } else {
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) "$fn\[$ext\]"
+ }
+ set loadParam(load,layer) {}
+
+ if {![ProcessLoad 0]} {
+ if {$ext} {
+ InitError xpa
+
+ if {$did} {
+ DeleteCurrentFrame
+ incr ds9(next,num) -1
+ }
+ if {!$cnt} {
+ Error "[msgcat::mc {Unable to load}] $loadParam(file,type) $loadParam(file,mode) $loadParam(file,name)"
+ return 0
+ }
+ break;
+ }
+ } else {
+ # ignore any bin tables
+ if {![$current(frame) has fits bin]} {
+ incr cnt
+ set need 1
+ } else {
+ set need 0
+ }
+ }
+
+ incr ext
+ }
+
+ if {$path != {}} {
+ catch {file delete -force $path}
+ }
+
+ # go into tile mode if more than one
+ if {$cnt && $current(display) != "tile"} {
+ set current(display) tile
+ DisplayMode
+ }
+
+ return 1
+}
+
+proc ProcessMultiFrameCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ # not supported
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {
+ if {![LoadMultiFrameSocket $sock $param]} {
+ InitError xpa
+ LoadMultiFrameFile $param
+ }
+ }
+ {Windows NT} {LoadMultiFrameFile $param}
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadMultiFrameAlloc $fn $param
+ } else {
+ LoadMultiFrameFile $param
+ }
+ }
+ FinishLoad
+}
+
diff --git a/ds9/library/mview.tcl b/ds9/library/mview.tcl
new file mode 100644
index 0000000..401b887
--- /dev/null
+++ b/ds9/library/mview.tcl
@@ -0,0 +1,358 @@
+# 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
+
+# Menus
+
+proc ViewMainMenu {} {
+ global ds9
+
+ menu $ds9(mb).view
+ $ds9(mb).view add radiobutton -label [msgcat::mc {Horizontal Layout}] \
+ -variable view(layout) -value horizontal -command {ViewHorzCmd}
+ $ds9(mb).view add radiobutton -label [msgcat::mc {Vertical Layout}] \
+ -variable view(layout) -value vertical -command {ViewVertCmd}
+ $ds9(mb).view add separator
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Information Panel}] \
+ -variable view(info) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Panner}] \
+ -variable view(panner) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Magnifier}] \
+ -variable view(magnifier) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Buttons}] \
+ -variable view(buttons) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Colorbar}] \
+ -variable view(colorbar) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Horizontal Graph}] \
+ -variable view(graph,horz) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Vertical Graph}] \
+ -variable view(graph,vert) -command UpdateView
+ $ds9(mb).view add separator
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Filename}] \
+ -variable view(info,filename) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Object}] \
+ -variable view(info,object) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Keyword}] \
+ -variable view(info,keyword) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Min Max}] \
+ -variable view(info,minmax) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Low High}] \
+ -variable view(info,lowhigh) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Units}] \
+ -variable view(info,bunit) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {WCS}] \
+ -variable view(info,wcs) -command UpdateView
+ $ds9(mb).view add cascade -label [msgcat::mc {Multiple WCS}] \
+ -menu $ds9(mb).view.mwcs
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Image}] \
+ -variable view(info,image) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Physical}] \
+ -variable view(info,physical) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable view(info,amplifier) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Detector}] \
+ -variable view(info,detector) -command UpdateView
+ $ds9(mb).view add checkbutton -label [msgcat::mc {Frame Information}] \
+ -variable view(info,frame) -command UpdateView
+
+ # View Info Panel WCS
+ menu $ds9(mb).view.mwcs
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $ds9(mb).view.mwcs add checkbutton \
+ -label "[msgcat::mc {WCS}] $l" \
+ -variable "view(info,wcs$l)" \
+ -command UpdateView
+ }
+}
+
+proc PrefsDialogViewMenu {w} {
+ set f [ttk::labelframe $w.mview -text [msgcat::mc {View}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarView $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+ $m add radiobutton -label [msgcat::mc {Horizontal Layout}] \
+ -variable pview(layout) -value horizontal
+ $m add radiobutton -label [msgcat::mc {Vertical Layout}] \
+ -variable pview(layout) -value vertical
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Information Panel}] \
+ -variable pview(info)
+ $m add checkbutton -label [msgcat::mc {Panner}] \
+ -variable pview(panner)
+ $m add checkbutton -label [msgcat::mc {Magnifier}] \
+ -variable pview(magnifier)
+ $m add checkbutton -label [msgcat::mc {Buttons}] \
+ -variable pview(buttons)
+ $m add checkbutton -label [msgcat::mc {Colorbar}] \
+ -variable pview(colorbar)
+ $m add checkbutton -label [msgcat::mc {Horizontal Graph}] \
+ -variable pview(graph,horz)
+ $m add checkbutton -label [msgcat::mc {Vertical Graph}] \
+ -variable pview(graph,vert)
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Filename}] \
+ -variable pview(info,filename)
+ $m add checkbutton -label [msgcat::mc {Object}] \
+ -variable pview(info,object)
+ $m add checkbutton -label [msgcat::mc {Keyword}] \
+ -variable pview(info,keyword)
+ $m add checkbutton -label [msgcat::mc {Min Max}] \
+ -variable pview(info,minmax)
+ $m add checkbutton -label [msgcat::mc {Low High}] \
+ -variable pview(info,lowhigh)
+ $m add checkbutton -label [msgcat::mc {Units}] \
+ -variable pview(info,bunit)
+ $m add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pview(info,wcs)
+ $m add cascade -label [msgcat::mc {Multiple WCS}] -menu $m.wcs
+ $m add checkbutton -label [msgcat::mc {Image}] \
+ -variable pview(info,image)
+ $m add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pview(info,physical)
+ $m add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pview(info,amplifier)
+ $m add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pview(info,detector)
+ $m add checkbutton -label [msgcat::mc {Frame Information}]\
+ -variable pview(info,frame)
+
+ menu $m.wcs
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $m.wcs add checkbutton -label "[msgcat::mc {WCS}] $l" \
+ -variable "pview(info,wcs$l)"
+ }
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogGraph {} {
+ global dprefs
+ global ds9
+ global pds9
+ global pmagnifier
+ global current
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Graphs}]
+ lappend dprefs(tabs) [ttk::frame $w.graph]
+
+ set f [ttk::labelframe $w.graph.horz -text [msgcat::mc {Horizontal}]]
+
+ ttk::label $f.htitle -text [msgcat::mc {Default}]
+ ttk::checkbutton $f.hgrid -text [msgcat::mc {Grid}] \
+ -variable pgraph(horz,grid) -command UpdateGraphGrid
+ ttk::radiobutton $f.hlinear -text [msgcat::mc {Linear}] \
+ -variable pgraph(horz,log) -value false \
+ -command "UpdateGraphYAxis $current(frame)"
+ ttk::radiobutton $f.hlog -text [msgcat::mc {Log}] \
+ -variable pgraph(horz,log) -value true \
+ -command "UpdateGraphYAxis $current(frame)"
+
+ grid $f.htitle $f.hgrid $f.hlinear $f.hlog -padx 2 -pady 2 -sticky w
+
+ set f [ttk::labelframe $w.graph.vert -text [msgcat::mc {Vertical}]]
+
+ ttk::label $f.vtitle -text [msgcat::mc {Default}]
+ ttk::checkbutton $f.vgrid -text [msgcat::mc {Grid}] \
+ -variable pgraph(vert,grid) -command UpdateGraphGrid
+ ttk::radiobutton $f.vlinear -text [msgcat::mc {Linear}] \
+ -variable pgraph(vert,log) -value false \
+ -command "UpdateGraphYAxis $current(frame)"
+ ttk::radiobutton $f.vlog -text [msgcat::mc {Log}] \
+ -variable pgraph(vert,log) -value true \
+ -command "UpdateGraphYAxis $current(frame)"
+
+ grid $f.vtitle $f.vgrid $f.vlinear $f.vlog -padx 2 -pady 2 -sticky w
+
+ pack $w.graph.horz $w.graph.vert -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsViewDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ view,horizontal 0
+ view,vertical 0
+ view,info 1
+ view,panner 1
+ view,magnifier 1
+ view,buttons 1
+ view,colorbar 1
+ view,graphhorz 1
+ view,graphvert 1
+ view,filename 0
+ view,object 0
+ view,minmax 0
+ view,lowhigh 0
+ view,bunit 0
+ view,wcs 0
+ view,image 0
+ view,physical 0
+ view,amplifier 0
+ view,detector 0
+ view,frame 0
+ }
+}
+
+proc CreateButtonsView {} {
+ global buttons
+ global ds9
+ global view
+
+ ttk::frame $ds9(buttons).view
+
+ RadioButton $ds9(buttons).view.horizontal \
+ [string tolower [msgcat::mc {Layout Horz}]] \
+ view(layout) horizontal {ViewHorzCmd}
+ RadioButton $ds9(buttons).view.vertical \
+ [string tolower [msgcat::mc {Layout Vert}]] \
+ view(layout) vertical {ViewVertCmd}
+
+ CheckButton $ds9(buttons).view.info \
+ [string tolower [msgcat::mc {Information}]] \
+ view(info) UpdateView
+ CheckButton $ds9(buttons).view.panner \
+ [string tolower [msgcat::mc {Panner}]] \
+ view(panner) UpdateView
+ CheckButton $ds9(buttons).view.magnifier \
+ [string tolower [msgcat::mc {Magnifier}]] \
+ view(magnifier) UpdateView
+ CheckButton $ds9(buttons).view.buttons \
+ [string tolower [msgcat::mc {Buttons}]] \
+ view(buttons) UpdateView
+ CheckButton $ds9(buttons).view.colorbar \
+ [string tolower [msgcat::mc {Colorbar}]] \
+ view(colorbar) UpdateView
+ CheckButton $ds9(buttons).view.graphhorz \
+ [string tolower [msgcat::mc {Graph Horz}]] \
+ view(graph,horz) UpdateView
+ CheckButton $ds9(buttons).view.graphvert \
+ [string tolower [msgcat::mc {Graph Vert}]] \
+ view(graph,vert) UpdateView
+
+ CheckButton $ds9(buttons).view.filename \
+ [string tolower [msgcat::mc {Filename}]] \
+ view(info,filename) UpdateView
+ CheckButton $ds9(buttons).view.object \
+ [string tolower [msgcat::mc {Object}]] \
+ view(info,object) UpdateView
+ CheckButton $ds9(buttons).view.keyword \
+ [string tolower [msgcat::mc {Keyword}]] \
+ view(info,keyword) UpdateView
+ CheckButton $ds9(buttons).view.minmax \
+ [string tolower [msgcat::mc {Min Max}]] \
+ view(info,minmax) UpdateView
+ CheckButton $ds9(buttons).view.lowhigh \
+ [string tolower [msgcat::mc {Low High}]] \
+ view(info,lowhigh) UpdateView
+ CheckButton $ds9(buttons).view.bunit \
+ [string tolower [msgcat::mc {Units}]] \
+ view(info,bunit) UpdateView
+ CheckButton $ds9(buttons).view.wcs \
+ [string tolower [msgcat::mc {WCS}]] \
+ view(info,wcs) UpdateView
+ CheckButton $ds9(buttons).view.image \
+ [string tolower [msgcat::mc {Image}]] \
+ view(info,image) UpdateView
+ CheckButton $ds9(buttons).view.physical \
+ [string tolower [msgcat::mc {Physical}]] \
+ view(info,physical) UpdateView
+ CheckButton $ds9(buttons).view.amplifier \
+ [string tolower [msgcat::mc {Amplifier}]] \
+ view(info,amplifier) UpdateView
+ CheckButton $ds9(buttons).view.detector \
+ [string tolower [msgcat::mc {Detector}]] \
+ view(info,detector) UpdateView
+ CheckButton $ds9(buttons).view.frame \
+ [string tolower [msgcat::mc {Frame}]] \
+ view(info,frame) UpdateView
+
+ set buttons(view) "
+ $ds9(buttons).view.horizontal pbuttons(view,horizontal)
+ $ds9(buttons).view.vertical pbuttons(view,vertical)
+ $ds9(buttons).view.info pbuttons(view,info)
+ $ds9(buttons).view.panner pbuttons(view,panner)
+ $ds9(buttons).view.magnifier pbuttons(view,magnifier)
+ $ds9(buttons).view.buttons pbuttons(view,buttons)
+ $ds9(buttons).view.colorbar pbuttons(view,colorbar)
+ $ds9(buttons).view.graphhorz pbuttons(view,graphhorz)
+ $ds9(buttons).view.graphvert pbuttons(view,graphvert)
+ $ds9(buttons).view.filename pbuttons(view,filename)
+ $ds9(buttons).view.object pbuttons(view,object)
+ $ds9(buttons).view.minmax pbuttons(view,minmax)
+ $ds9(buttons).view.lowhigh pbuttons(view,lowhigh)
+ $ds9(buttons).view.bunit pbuttons(view,bunit)
+ $ds9(buttons).view.wcs pbuttons(view,wcs)
+ $ds9(buttons).view.image pbuttons(view,image)
+ $ds9(buttons).view.physical pbuttons(view,physical)
+ $ds9(buttons).view.amplifier pbuttons(view,amplifier)
+ $ds9(buttons).view.detector pbuttons(view,detector)
+ $ds9(buttons).view.frame pbuttons(view,frame)
+ "
+}
+
+proc PrefsDialogButtonbarView {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Horizontal Layout}] \
+ -variable pbuttons(view,horizontal) \
+ -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Vertical Layout}] \
+ -variable pbuttons(view,vertical) \
+ -command {UpdateButtons buttons(view)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Information Panel}] \
+ -variable pbuttons(view,info) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Panner}] \
+ -variable pbuttons(view,panner) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Magnifier}] \
+ -variable pbuttons(view,magnifier) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Buttons}] \
+ -variable pbuttons(view,buttons) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Colorbar}] \
+ -variable pbuttons(view,colorbar) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Horizontal Graph}] \
+ -variable pbuttons(view,graphhorz) \
+ -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Vertical Graph}] \
+ -variable pbuttons(view,graphvert) \
+ -command {UpdateButtons buttons(view)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Filename}] \
+ -variable pbuttons(view,filename) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Object}] \
+ -variable pbuttons(view,object) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Min Max}] \
+ -variable pbuttons(view,minmax) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Low High}] \
+ -variable pbuttons(view,lowhigh) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Unists}] \
+ -variable pbuttons(view,bunit) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {WCS}] \
+ -variable pbuttons(view,wcs) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Image}] \
+ -variable pbuttons(view,image) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Physical}] \
+ -variable pbuttons(view,physical) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Amplifier}] \
+ -variable pbuttons(view,amplifier) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Detector}] \
+ -variable pbuttons(view,detector) -command {UpdateButtons buttons(view)}
+ $m add checkbutton -label [msgcat::mc {Frame Information}] \
+ -variable pbuttons(view,frame) -command {UpdateButtons buttons(view)}
+}
diff --git a/ds9/library/mwcs.tcl b/ds9/library/mwcs.tcl
new file mode 100644
index 0000000..94b881f
--- /dev/null
+++ b/ds9/library/mwcs.tcl
@@ -0,0 +1,140 @@
+# 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
+
+# Menu
+
+proc WCSMainMenu {} {
+ global ds9
+ global wcs
+
+ CoordMenu $ds9(mb).wcs wcs system 0 sky skyformat UpdateWCS
+ $ds9(mb).wcs add separator
+ $ds9(mb).wcs add command -label "[msgcat::mc {WCS Parameters}]..." \
+ -command WCSDialog
+}
+
+proc UpdateWCSMenu {} {
+ global wcs
+ global ds9
+ global current
+ global bin
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateWCSMenu"
+ }
+
+ if {$current(frame) != {}} {
+ $ds9(mb) entryconfig [msgcat::mc {WCS}] -state normal
+
+ set ww [$current(frame) get wcs]
+ set wcs(system) [lindex $ww 0]
+ set wcs(sky) [lindex $ww 1]
+ set wcs(skyformat) [lindex $ww 2]
+
+ set wcs(frame) $current(frame)
+ if {[$current(frame) has fits]} {
+ CoordMenuEnable $ds9(mb).wcs wcs system 0 sky skyformat
+ } else {
+ CoordMenuReset $ds9(mb).wcs wcs system 0 sky skyformat
+ }
+ UpdateWCSInfoBox $current(frame)
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {WCS}] -state disabled
+ }
+}
+
+proc PrefsDialogWCSMenu {w} {
+ set f [ttk::labelframe $w.mwcs -text [msgcat::mc {WCS}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarWCS $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2 -sticky w
+
+ CoordMenu $f.menu.menu pwcs system 0 sky skyformat {}
+
+ pack $f -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsWCSDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ wcs,fk4 1
+ wcs,fk5 1
+ wcs,icrs 1
+ wcs,galactic 1
+ wcs,ecliptic 1
+ wcs,degrees 1
+ wcs,sexagesimal 1
+ }
+}
+
+proc CreateButtonsWCS {} {
+ global buttons
+ global ds9
+ global wcs
+
+ ttk::frame $ds9(buttons).wcs
+
+ RadioButton $ds9(buttons).wcs.fk4 {fk4} \
+ wcs(sky) fk4 UpdateWCS
+ RadioButton $ds9(buttons).wcs.fk5 {fk5} \
+ wcs(sky) fk5 UpdateWCS
+ RadioButton $ds9(buttons).wcs.icrs \
+ [string tolower [msgcat::mc {ICRS}]] \
+ wcs(sky) icrs UpdateWCS
+ RadioButton $ds9(buttons).wcs.galactic \
+ [string tolower [msgcat::mc {Galactic}]] \
+ wcs(sky) galactic UpdateWCS
+ RadioButton $ds9(buttons).wcs.ecliptic \
+ [string tolower [msgcat::mc {Ecliptic}]] \
+ wcs(sky) ecliptic UpdateWCS
+ RadioButton $ds9(buttons).wcs.degrees \
+ [string tolower [msgcat::mc {Degrees}]] \
+ wcs(skyformat) degrees UpdateWCS
+ RadioButton $ds9(buttons).wcs.sexagesimal {sexagesimal} \
+ wcs(skyformat) sexagesimal UpdateWCS
+
+ set buttons(wcs) "
+ $ds9(buttons).wcs.fk4 pbuttons(wcs,fk4)
+ $ds9(buttons).wcs.fk5 pbuttons(wcs,fk5)
+ $ds9(buttons).wcs.icrs pbuttons(wcs,icrs)
+ $ds9(buttons).wcs.galactic pbuttons(wcs,galactic)
+ $ds9(buttons).wcs.ecliptic pbuttons(wcs,ecliptic)
+ $ds9(buttons).wcs.degrees pbuttons(wcs,degrees)
+ $ds9(buttons).wcs.sexagesimal pbuttons(wcs,sexagesimal)
+ "
+}
+
+proc PrefsDialogButtonbarWCS {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {FK4}] \
+ -variable pbuttons(wcs,fk4) -command {UpdateButtons buttons(wcs)}
+ $m add checkbutton -label [msgcat::mc {FK5}] \
+ -variable pbuttons(wcs,fk5) -command {UpdateButtons buttons(wcs)}
+ $m add checkbutton -label [msgcat::mc {ICRS}] \
+ -variable pbuttons(wcs,icrs) -command {UpdateButtons buttons(wcs)}
+ $m add checkbutton -label [msgcat::mc {Galactic}] \
+ -variable pbuttons(wcs,galactic) -command {UpdateButtons buttons(wcs)}
+ $m add checkbutton -label [msgcat::mc {Ecliptic}] \
+ -variable pbuttons(wcs,ecliptic) -command {UpdateButtons buttons(wcs)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Degrees}] \
+ -variable pbuttons(wcs,degrees) -command {UpdateButtons buttons(wcs)}
+ $m add checkbutton -label [msgcat::mc {Sexagesimal}] \
+ -variable pbuttons(wcs,sexagesimal) -command {UpdateButtons buttons(wcs)}
+}
+
diff --git a/ds9/library/mzoom.tcl b/ds9/library/mzoom.tcl
new file mode 100644
index 0000000..de9959f
--- /dev/null
+++ b/ds9/library/mzoom.tcl
@@ -0,0 +1,412 @@
+# 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
+
+# Menus
+
+proc ZoomMainMenu {} {
+ global ds9
+
+ menu $ds9(mb).zoom
+ $ds9(mb).zoom add command -label [msgcat::mc {Center Image}] \
+ -command CenterCurrentFrame
+ $ds9(mb).zoom add checkbutton -label [msgcat::mc {Align}] \
+ -variable current(align) -command AlignWCSFrame
+ $ds9(mb).zoom add separator
+ $ds9(mb).zoom add command -label [msgcat::mc {Zoom In}] \
+ -command {Zoom 2 2}
+ $ds9(mb).zoom add command -label [msgcat::mc {Zoom Out}] \
+ -command {Zoom .5 .5}
+ $ds9(mb).zoom add command -label [msgcat::mc {Zoom Fit}] \
+ -command ZoomToFit
+ $ds9(mb).zoom add separator
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/32" \
+ -variable current(zoom) -value { 0.03125 0.03125 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/16" \
+ -variable current(zoom) -value { 0.0625 0.0625 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/8" \
+ -variable current(zoom) -value { 0.125 0.125 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/4" \
+ -variable current(zoom) -value { 0.25 0.25 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/2" \
+ -variable current(zoom) -value { 0.5 0.5 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 1" \
+ -variable current(zoom) -value { 1 1 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 2" \
+ -variable current(zoom) -value { 2 2 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 4" \
+ -variable current(zoom) -value { 4 4 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 8" \
+ -variable current(zoom) -value { 8 8 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 16" \
+ -variable current(zoom) -value { 16 16 } -command ChangeZoom
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Zoom}] 32" \
+ -variable current(zoom) -value { 32 32 } -command ChangeZoom
+ $ds9(mb).zoom add separator
+ $ds9(mb).zoom add radiobutton -label [msgcat::mc {None}] \
+ -variable current(orient) -value none -command ChangeOrient
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Invert}] X" \
+ -variable current(orient) -value x -command ChangeOrient
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Invert}] Y" \
+ -variable current(orient) -value y -command ChangeOrient
+ $ds9(mb).zoom add radiobutton -label "[msgcat::mc {Invert}] XY" \
+ -variable current(orient) -value xy -command ChangeOrient
+ $ds9(mb).zoom add separator
+ $ds9(mb).zoom add radiobutton -label "0 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 0 -command ChangeRotate
+ $ds9(mb).zoom add radiobutton -label "90 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 90 -command ChangeRotate
+ $ds9(mb).zoom add radiobutton -label "180 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 180 -command ChangeRotate
+ $ds9(mb).zoom add radiobutton -label "270 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 270 -command ChangeRotate
+ $ds9(mb).zoom add separator
+ $ds9(mb).zoom add command -label "[msgcat::mc {Crop Parameters}]..." \
+ -command CropDialog
+ $ds9(mb).zoom add separator
+ $ds9(mb).zoom add command \
+ -label "[msgcat::mc {Pan Zoom Rotate Parameters}]..." \
+ -command PanZoomDialog
+}
+
+proc PrefsDialogZoomMenu {w} {
+ set f [ttk::labelframe $w.mzoom -text [msgcat::mc {Zoom}]]
+
+ ttk::menubutton $f.menu -text [msgcat::mc {Menu}] -menu $f.menu.menu
+ PrefsDialogButtonbarZoom $f.buttonbar
+
+ grid $f.menu $f.buttonbar -padx 2 -pady 2
+
+ set m $f.menu.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Align}] \
+ -variable pcurrent(align)
+ $m add separator
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 1/32" \
+ -variable pcurrent(zoom) -value { 0.03125 0.03125 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 1/16" \
+ -variable pcurrent(zoom) -value { 0.0625 0.0625 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 1/8" \
+ -variable pcurrent(zoom) -value { 0.125 0.125 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 1/4" \
+ -variable pcurrent(zoom) -value { 0.25 0.25 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 1/2" \
+ -variable pcurrent(zoom) -value { 0.5 0.5 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 1" \
+ -variable pcurrent(zoom) -value { 1 1 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 2" \
+ -variable pcurrent(zoom) -value { 2 2 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 4" \
+ -variable pcurrent(zoom) -value { 4 4 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 8" \
+ -variable pcurrent(zoom) -value { 8 8 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 16" \
+ -variable pcurrent(zoom) -value { 16 16 }
+ $m add radiobutton -label "[msgcat::mc {Zoom}] 32" \
+ -variable pcurrent(zoom) -value { 32 32 }
+ $m add separator
+ $m add radiobutton -label [msgcat::mc {None}] \
+ -variable pcurrent(orient) -value none
+ $m add radiobutton -label "[msgcat::mc {Invert}] X" \
+ -variable pcurrent(orient) -value x
+ $m add radiobutton -label "[msgcat::mc {Invert}] Y" \
+ -variable pcurrent(orient) -value y
+ $m add radiobutton -label "[msgcat::mc {Invert}] XY" \
+ -variable pcurrent(orient) -value xy
+ $m add separator
+ $m add radiobutton -label "0 [msgcat::mc {Degrees}]" \
+ -variable pcurrent(rotate) -value 0
+ $m add radiobutton -label "90 [msgcat::mc {Degrees}]" \
+ -variable pcurrent(rotate) -value 90
+ $m add radiobutton -label "180 [msgcat::mc {Degrees}]" \
+ -variable pcurrent(rotate) -value 180
+ $m add radiobutton -label "270 [msgcat::mc {Degrees}]" \
+ -variable pcurrent(rotate) -value 270
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogZoom {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Zoom}]
+ lappend dprefs(tabs) [ttk::frame $w.zoom]
+
+ # PanZoom
+ set f [ttk::labelframe $w.zoom.panzoom -text [msgcat::mc {Pan Zoom}]]
+
+ ttk::radiobutton $f.click -text [msgcat::mc {Click to Center}] \
+ -variable ppanzoom(mode) -value click
+ ttk::radiobutton $f.drag -text [msgcat::mc {Drag to Center}] \
+ -variable ppanzoom(mode) -value drag
+ ttk::radiobutton $f.panzoom -text [msgcat::mc {Pan then Zoom}] \
+ -variable ppanzoom(mode) -value panzoom
+
+ grid $f.click $f.drag $f.panzoom -padx 2 -pady 2 -sticky w
+
+ # Mouse
+ set f [ttk::labelframe $w.zoom.mouse -text [msgcat::mc {Mouse Wheel Zoom}]]
+
+ ttk::checkbutton $f.click -text [msgcat::mc {Enable}] \
+ -variable ppanzoom(wheel)
+ ttk::label $f.title2 -text [msgcat::mc {Factor}]
+ ttk::entry $f.factor -textvariable ppanzoom(wheel,factor) -width 10
+
+ grid $f.click $f.title2 $f.factor -padx 2 -pady 2 -sticky w
+
+ pack $w.zoom.panzoom $w.zoom.mouse -side top -fill both -expand true
+}
+
+# Buttons
+
+proc ButtonsZoomDef {} {
+ global pbuttons
+
+ array set pbuttons {
+ zoom,center 0
+ zoom,align 0
+
+ zoom,in 1
+ zoom,out 1
+ zoom,fit 1
+ zoom,i32 0
+ zoom,i16 0
+ zoom,i8 0
+ zoom,i4 1
+ zoom,i2 1
+ zoom,1 1
+ zoom,2 1
+ zoom,4 1
+ zoom,8 0
+ zoom,16 0
+ zoom,32 0
+
+ zoom,none 0
+ zoom,x 0
+ zoom,y 0
+ zoom,xy 0
+
+ zoom,0 0
+ zoom,90 0
+ zoom,180 0
+ zoom,270 0
+
+ zoom,crop 0
+ zoom,params 0
+ }
+}
+
+proc CreateButtonsZoom {} {
+ global buttons
+ global ds9
+
+ ttk::frame $ds9(buttons).zoom
+
+ ButtonButton $ds9(buttons).zoom.center \
+ [string tolower [msgcat::mc {Center}]] CenterCurrentFrame
+ CheckButton $ds9(buttons).zoom.align \
+ [msgcat::mc {Align}] current(align) AlignWCSFrame
+
+ ButtonButton $ds9(buttons).zoom.in \
+ [string tolower [msgcat::mc {Zoom In}]] {Zoom 2 2}
+ ButtonButton $ds9(buttons).zoom.out \
+ [string tolower [msgcat::mc {Zoom Out}]] {Zoom .5 .5}
+ ButtonButton $ds9(buttons).zoom.fit \
+ [string tolower [msgcat::mc {Zoom Fit}]] ZoomToFit
+ RadioButton $ds9(buttons).zoom.i32 \
+ "[string tolower [msgcat::mc {Zoom}]] 1/32" \
+ current(zoom) { 0.03125 0.03125 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.i16 \
+ "[string tolower [msgcat::mc {Zoom}]] 1/16" \
+ current(zoom) { 0.0625 0.0625 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.i8 \
+ "[string tolower [msgcat::mc {Zoom}]] 1/8" \
+ current(zoom) { 0.125 0.125 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.i4 \
+ "[string tolower [msgcat::mc {Zoom}]] 1/4" \
+ current(zoom) { 0.25 0.25 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.i2 \
+ "[string tolower [msgcat::mc {Zoom}]] 1/2" \
+ current(zoom) { 0.5 0.5 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.1 \
+ "[string tolower [msgcat::mc {Zoom}]] 1" \
+ current(zoom) { 1 1 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.2 \
+ "[string tolower [msgcat::mc {Zoom}]] 2" \
+ current(zoom) { 2 2 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.4 \
+ "[string tolower [msgcat::mc {Zoom}]] 4" \
+ current(zoom) { 4 4 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.8 \
+ "[string tolower [msgcat::mc {Zoom}]] 8" \
+ current(zoom) { 8 8 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.16 \
+ "[string tolower [msgcat::mc {Zoom}]] 16" \
+ current(zoom) { 16 16 } ChangeZoom
+ RadioButton $ds9(buttons).zoom.32 \
+ "[string tolower [msgcat::mc {Zoom}]] 32" \
+ current(zoom) { 32 32 } ChangeZoom
+
+ RadioButton $ds9(buttons).zoom.none \
+ [string tolower [msgcat::mc {None}]] \
+ current(orient) none ChangeOrient
+ RadioButton $ds9(buttons).zoom.x {x} current(orient) x ChangeOrient
+ RadioButton $ds9(buttons).zoom.y {y} current(orient) y ChangeOrient
+ RadioButton $ds9(buttons).zoom.xy {xy} current(orient) xy ChangeOrient
+
+ RadioButton $ds9(buttons).zoom.0 {0} current(rotate) 0 ChangeRotate
+ RadioButton $ds9(buttons).zoom.90 {90} current(rotate) 90 ChangeRotate
+ RadioButton $ds9(buttons).zoom.180 {180} current(rotate) 180 ChangeRotate
+ RadioButton $ds9(buttons).zoom.270 {270} current(rotate) 270 ChangeRotate
+
+ ButtonButton $ds9(buttons).zoom.crop \
+ [string tolower [msgcat::mc {Crop}]] CropDialog
+ ButtonButton $ds9(buttons).zoom.params \
+ [string tolower [msgcat::mc {Parameters}]] PanZoomDialog
+
+ set buttons(zoom) "
+ $ds9(buttons).zoom.center pbuttons(zoom,center)
+ $ds9(buttons).zoom.align pbuttons(zoom,align)
+
+ $ds9(buttons).zoom.in pbuttons(zoom,in)
+ $ds9(buttons).zoom.out pbuttons(zoom,out)
+ $ds9(buttons).zoom.fit pbuttons(zoom,fit)
+ $ds9(buttons).zoom.i32 pbuttons(zoom,i32)
+ $ds9(buttons).zoom.i16 pbuttons(zoom,i16)
+ $ds9(buttons).zoom.i8 pbuttons(zoom,i8)
+ $ds9(buttons).zoom.i4 pbuttons(zoom,i4)
+ $ds9(buttons).zoom.i2 pbuttons(zoom,i2)
+ $ds9(buttons).zoom.1 pbuttons(zoom,1)
+ $ds9(buttons).zoom.2 pbuttons(zoom,2)
+ $ds9(buttons).zoom.4 pbuttons(zoom,4)
+ $ds9(buttons).zoom.8 pbuttons(zoom,8)
+ $ds9(buttons).zoom.16 pbuttons(zoom,16)
+ $ds9(buttons).zoom.32 pbuttons(zoom,32)
+
+ $ds9(buttons).zoom.none pbuttons(zoom,none)
+ $ds9(buttons).zoom.x pbuttons(zoom,x)
+ $ds9(buttons).zoom.y pbuttons(zoom,y)
+ $ds9(buttons).zoom.xy pbuttons(zoom,xy)
+
+ $ds9(buttons).zoom.0 pbuttons(zoom,0)
+ $ds9(buttons).zoom.90 pbuttons(zoom,90)
+ $ds9(buttons).zoom.180 pbuttons(zoom,180)
+ $ds9(buttons).zoom.270 pbuttons(zoom,270)
+
+ $ds9(buttons).zoom.crop pbuttons(zoom,crop)
+ $ds9(buttons).zoom.params pbuttons(zoom,params)
+ "
+}
+
+proc PrefsDialogButtonbarZoom {f} {
+ global buttons
+ global pbuttons
+
+ ttk::menubutton $f -text [msgcat::mc {Buttonbar}] -menu $f.menu
+
+ set m $f.menu
+ menu $m
+ $m add checkbutton -label [msgcat::mc {Center Image}] \
+ -variable pbuttons(zoom,center) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label [msgcat::mc {Align}] \
+ -variable pbuttons(zoom,align) -command {UpdateButtons buttons(zoom)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {Zoom In}] \
+ -variable pbuttons(zoom,in) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label [msgcat::mc {Zoom Out}] \
+ -variable pbuttons(zoom,out) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label [msgcat::mc {Zoom Fit}] \
+ -variable pbuttons(zoom,fit) -command {UpdateButtons buttons(zoom)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 1/32" \
+ -variable pbuttons(zoom,i32) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 1/16" \
+ -variable pbuttons(zoom,i16) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 1/8" \
+ -variable pbuttons(zoom,i8) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 1/4" \
+ -variable pbuttons(zoom,i4) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 1/2" \
+ -variable pbuttons(zoom,i2) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 1" \
+ -variable pbuttons(zoom,1) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 2" \
+ -variable pbuttons(zoom,2) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 4" \
+ -variable pbuttons(zoom,4) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 8" \
+ -variable pbuttons(zoom,8) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 16" \
+ -variable pbuttons(zoom,16) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Zoom}] 32" \
+ -variable pbuttons(zoom,32) -command {UpdateButtons buttons(zoom)}
+ $m add separator
+ $m add checkbutton -label [msgcat::mc {None}] \
+ -variable pbuttons(zoom,none) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Invert}] X" \
+ -variable pbuttons(zoom,x) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Invert}] Y" \
+ -variable pbuttons(zoom,y) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "[msgcat::mc {Invert}] XY" \
+ -variable pbuttons(zoom,xy) -command {UpdateButtons buttons(zoom)}
+ $m add separator
+ $m add checkbutton -label "0 [msgcat::mc {Degrees}]" \
+ -variable pbuttons(zoom,0) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "90 [msgcat::mc {Degrees}]" \
+ -variable pbuttons(zoom,90) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "180 [msgcat::mc {Degrees}]" \
+ -variable pbuttons(zoom,180) -command {UpdateButtons buttons(zoom)}
+ $m add checkbutton -label "270 [msgcat::mc {Degrees}]" \
+ -variable pbuttons(zoom,270) -command {UpdateButtons buttons(zoom)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Crop Parameters}]..." \
+ -variable pbuttons(zoom,crop) -command {UpdateButtons buttons(zoom)}
+ $m add separator
+ $m add checkbutton -label "[msgcat::mc {Pan Zoom Rotate Parameters}]..." \
+ -variable pbuttons(zoom,params) -command {UpdateButtons buttons(zoom)}
+}
+
+# Support
+
+proc UpdateZoomMenuStatic {} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateZoomMenuStatic"
+ }
+
+ if {$ds9(active,num) > 0} {
+ $ds9(mb) entryconfig [msgcat::mc {Zoom}] -state normal
+ } else {
+ $ds9(mb) entryconfig [msgcat::mc {Zoom}] -state disabled
+ }
+}
+
+proc UpdateZoomMenu {} {
+ global ds9
+ global current
+ global panzoom
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateZoomMenu"
+ }
+
+ if {$current(frame) == {}} {
+ $ds9(mb).zoom entryconfig [msgcat::mc {Align}] -state disabled
+ } else {
+ $ds9(mb).zoom entryconfig [msgcat::mc {Align}] -state normal
+
+ set panzoom(preserve) [$current(frame) get pan preserve]
+ set current(zoom) [$current(frame) get zoom]
+ set current(rotate) [$current(frame) get rotate]
+ set current(orient) [$current(frame) get orient]
+ set current(align) [$current(frame) get wcs align]
+ }
+}
+
diff --git a/ds9/library/nameres.tcl b/ds9/library/nameres.tcl
new file mode 100644
index 0000000..c4b32bb
--- /dev/null
+++ b/ds9/library/nameres.tcl
@@ -0,0 +1,254 @@
+# 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 NRESDef {} {
+ global nres
+ global inres
+ global pnres
+
+ set inres(top) .nres
+ set inres(mb) .nresmb
+
+ # set via wcs()
+ set nres(system) wcs
+ set nres(sky) fk5
+ set nres(skyformat) degrees
+
+ # prefs only
+ set pnres(server) simbad-cds
+}
+
+proc NRESApply {varname sync} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(sync) $sync
+ ARApply $varname
+ if {$var(name)!={}} {
+ NSVRServer $varname
+ } else {
+ ARError $varname "Please specify an Object Name"
+ }
+}
+
+proc NRESDialog {} {
+ global nres
+ global inres
+
+ global ds9
+ global pds9
+
+ if {[winfo exists $inres(top)]} {
+ raise $inres(top)
+ return
+ }
+
+ set varname dnres
+ upvar #0 $varname var
+ global $varname
+
+ # AR variables
+ ARInit $varname {}
+
+ # Variables
+ set var(top) $inres(top)
+ set var(mb) $inres(mb)
+ set var(system) $nres(system)
+ set var(sky) $nres(sky)
+ set var(skyformat) $nres(skyformat)
+
+ # create the window
+ set w $var(top)
+ set mb $var(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Name Resolution}] "ARDestroy $varname"
+
+ # file
+ $mb add cascade -label File -menu $mb.file
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Retrieve}] \
+ -command "NRESApply $varname 0"
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Pan To}] \
+ -command "NRESPan $varname"
+ $mb.file add command -label [msgcat::mc {Crosshair To}] \
+ -command "NRESCrosshair $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command "ARDestroy $varname"
+
+ # edit
+ AREditMenu $varname
+
+ # name server
+ NSVRServerMenu $varname
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.nametitle -text [msgcat::mc {Object}]
+ ttk::entry $f.name -textvariable ${varname}(name) -width 48
+ ttk::label $f.sky -textvariable ${varname}(sky) -anchor w
+ set var(xname) [ttk::label $f.xtitle -text {} -width 1]
+ ttk::label $f.x -textvariable ${varname}(x) -width 14 -relief groove
+ set var(yname) [ttk::label $f.ytitle -text {} -width 1]
+ ttk::label $f.y -textvariable ${varname}(y) -width 14 -relief groove
+ ARSkyFormat $f.skyformat $varname
+ grid $f.nametitle x $f.name - - - - -padx 2 -pady 2 -sticky w
+ grid $f.sky $f.xtitle $f.x $f.ytitle $f.y $f.skyformat \
+ -padx 2 -pady 2 -sticky w
+
+ # Status
+ set f [ttk::frame $w.status]
+ ttk::label $f.tstatus -text [msgcat::mc {Status}]
+ ttk::label $f.status -textvariable ${varname}(status)
+ grid $f.tstatus $f.status -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ set var(apply) [ttk::button $f.apply -text [msgcat::mc {Retrieve}] \
+ -command "NRESApply $varname 0"]
+ set var(cancel) [ttk::button $f.cancel -text [msgcat::mc {Cancel}] \
+ -command "ARCancel $varname" -state disabled]
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command "ARDestroy $varname"
+ pack $f.apply $f.cancel $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ ttk::separator $w.sep -orient horizontal
+ ttk::separator $w.sep2 -orient horizontal
+ pack $w.buttons $w.sep $w.status $w.sep2 -side bottom -fill x
+ pack $w.param -side top -fill both -expand true
+
+ ARCoord $varname
+ ARStatus $varname {}
+}
+
+proc NRESPan {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {($var(x) != {}) && ($var(y) != {})} {
+ PanTo $var(x) $var(y) $var(system) $var(sky)
+ }
+}
+
+proc NRESCrosshair {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global current
+
+ if {($current(frame) != {})} {
+ if {[$current(frame) has wcs equatorial $var(system)]} {
+ if {($var(x) != {}) && ($var(y) != {})} {
+ set current(mode) crosshair
+ ChangeMode
+ $current(frame) crosshair \
+ $var(system) $var(sky) $var(x) $var(y)
+ }
+ }
+ }
+}
+
+# Prefs
+
+proc PrefsDialogNRES {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Name Server}]
+ lappend dprefs(tabs) [ttk::frame $w.namesvr]
+
+ set f [ttk::labelframe $w.namesvr.params -text [msgcat::mc {Name Server}]]
+
+ ttk::label $f.tsvr -text [msgcat::mc {Default}]
+ ttk::menubutton $f.svr -textvariable pnres(server) -menu $f.svr.menu
+
+ menu $f.svr.menu
+ NSVRServerMenuItems $f.svr.menu
+
+ grid $f.tsvr $f.svr -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+# Process Cmds
+
+proc ProcessNRESCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ set vvarname dnres
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ global nres
+ global pnres
+
+ NRESDialog
+
+ switch -- [string tolower [lindex $var $i]] {
+ {} -
+ open {}
+ close {ARDestroy $vvarname}
+ server {
+ incr i
+ set pnres(server) [lindex $var $i]
+ }
+ pan {NRESPan $vvarname}
+ crosshair {NRESCrosshair $vvarname}
+ format -
+ skyformat {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ deg -
+ degree -
+ degrees {
+ set vvar(skyformat) degrees
+ set vvar(skyformat,msg) $vvar(skyformat)
+ }
+ default {
+ set vvar(skyformat) [string tolower [lindex $var $i]]
+ set vvar(skyformat,msg) $vvar(skyformat)
+ }
+ }
+ }
+ name {
+ incr i
+ set vvar(name) [lindex $var $i]
+ NRESApply $vvarname 1
+ }
+ default {
+ set vvar(name) [lindex $var $i]
+ NRESApply $vvarname 1
+ }
+ }
+}
+
+proc ProcessSendNRESCmd {proc id param} {
+ global nres
+ global pnres
+ global dnres
+
+ NRESDialog
+
+ switch -- [string tolower [lindex $param 0]] {
+ server {$proc $id "$pnres(server)\n"}
+ format -
+ skyformat {$proc $id "$dnres(skyformat)\n"}
+ name -
+ {} {$proc $id "$dnres(name)\n"}
+ default {
+ set dnres(name) [lindex $param 0]
+ NRESApply dnres 1
+ $proc $id "$dnres(x) $dnres(y)\n"
+ }
+ }
+}
+
diff --git a/ds9/library/nrrd.tcl b/ds9/library/nrrd.tcl
new file mode 100644
index 0000000..cae05bc
--- /dev/null
+++ b/ds9/library/nrrd.tcl
@@ -0,0 +1,142 @@
+# 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 ImportNRRDFile {fn layer} {
+ global loadParam
+
+ set loadParam(file,type) nrrd
+ set loadParam(file,mode) {}
+ set loadParam(load,layer) $layer
+
+ # find stdin
+ if {[string range $fn 0 4] == "stdin" ||
+ [string range $fn 0 4] == "STDIN" ||
+ [string range $fn 0 0] == "-"} {
+ set loadParam(load,type) alloc
+ set loadParam(file,name) stdin
+ set loadParam(file,fn) $loadParam(file,name)
+ } else {
+ set loadParam(load,type) mmap
+ set loadParam(file,name) $fn
+ }
+
+ ProcessLoad
+}
+
+proc ImportNRRDAlloc {path fn layer} {
+ global loadParam
+
+ set loadParam(file,type) nrrd
+ set loadParam(file,mode) {}
+ set loadParam(load,type) alloc
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc ImportNRRDSocket {sock fn layer} {
+ global loadParam
+
+ set loadParam(file,type) nrrd
+ set loadParam(file,mode) {}
+ set loadParam(load,type) socket
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+ set loadParam(load,layer) $layer
+
+ return [ProcessLoad 0]
+}
+
+proc ExportNRRDFile {fn opt} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save nrrd file "\{$fn\}" $opt
+}
+
+proc ExportNRRDSocket {sock opt} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save nrrd socket $sock $opt
+}
+
+proc ProcessNRRDCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![ImportNRRDSocket $sock $param $layer]} {
+ InitError xpa
+ ImportNRRDFile $param $layer
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ ImportNRRDAlloc $fn $param $layer
+ } else {
+ ImportNRRDFile $param $layer
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendNRRDCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set opt [string tolower [lindex $param 0]]
+ if {$sock != {}} {
+ # xpa
+ ExportNRRDSocket $sock $opt
+ } elseif {$fn != {}} {
+ # comm
+ ExportNRRDFile $fn $opt
+ $proc $id {} $fn
+ }
+}
diff --git a/ds9/library/nsvr.tcl b/ds9/library/nsvr.tcl
new file mode 100644
index 0000000..22f6699
--- /dev/null
+++ b/ds9/library/nsvr.tcl
@@ -0,0 +1,287 @@
+# 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 NSVRServer {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "NSVRServer $varname"
+ }
+
+ global nres
+ global pnres
+
+ ARStatus $varname "Looking up $var(name)"
+
+ set ss [split $pnres(server) {-}]
+ switch -- [lindex $ss 1] {
+ eso -
+ sao {set var(url) {http://vizier.cfa.harvard.edu/viz-bin/nph-sesame}}
+ cds {set var(url) {http://cdsweb.u-strasbg.fr/cgi-bin/nph-sesame}}
+ }
+ append ${varname}(url) {/-ox}
+ switch -- [lindex $ss 0] {
+ ned {append ${varname}(url) {/N}}
+ simbad {append ${varname}(url) {/S}}
+ vizier {append ${varname}(url) {/V}}
+ }
+
+ set var(query) [http::formatQuery $var(name)]
+
+ NSVRGetURL $varname $var(url)
+}
+
+proc NSVRGetURL {varname url} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "NSVRGetURL $varname $url $var(query)"
+ }
+
+ set var(ra) {}
+ set var(dec) {}
+ set var(pos) {}
+
+ global ihttp
+ # -query will not work, do it manually
+ if {$var(sync)} {
+ if {![catch {set var(token) [http::geturl $url?$var(query) \
+ -timeout $ihttp(timeout) \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ NSVRGetURLFinish $varname $var(token)
+ } else {
+ ARError $varname "[msgcat::mc {Unable to locate URL}] $url"
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $url?$var(query) \
+ -timeout $ihttp(timeout) \
+ -command \
+ [list NSVRGetURLFinish $varname] \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ } else {
+ ARError $varname "[msgcat::mc {Unable to locate URL}] $url"
+ }
+ }
+}
+
+proc NSVRGetURLFinish {varname token} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "NSVRGetURLFinish $varname"
+ }
+
+ if {!($var(active))} {
+ ARCancelled $varname
+ return
+ }
+
+ upvar #0 $token t
+
+ # Code
+ set code [http::ncode $token]
+
+ # Meta
+ set meta $t(meta)
+
+ # Log it
+ HTTPLog $token
+
+ # Result?
+ switch -- $code {
+ 200 -
+ 203 -
+ 404 -
+ 503 {NSVRSESAME $varname}
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $meta {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "NSVRGetURLFinish redirect $code to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset var(token)
+
+ # strip query from url
+ set value [lindex [split $value {?}] 0]
+
+ NSVRGetURL $varname $value
+ }
+ }
+ }
+
+ default {ARError $varname "[msgcat::mc {Error code was returned}] $code"}
+ }
+}
+
+proc NSVRSESAME {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "NSVRSESAME $varname"
+ }
+
+ set pp [xml::parser \
+ -characterdatacommand [list NSVRSESAMECharCB $varname]\
+ -elementstartcommand [list NSVRSESAMEElemStartCB $varname] \
+ -elementendcommand [list NSVRSESAMEElemEndCB $varname] \
+ -ignorewhitespace 1 \
+ ]
+
+ set var(parse) {}
+
+ if {[catch {$pp parse [http::data $var(token)]} err]} {
+ $pp free
+ NSVRParse $varname {} {}
+ return
+ }
+
+ switch -- $var(skyformat) {
+ degrees {
+ if {$var(ra) != {} && $var(dec) != {}} {
+ NSVRParse $varname $var(ra) $var(dec)
+ } else {
+ NSVRParse $varname {} {}
+ }
+ }
+ sexagesimal {
+ if {$var(pos) != {}} {
+ # can have extra space chars, must clean up
+ set ss [split [string trim $var(pos)]]
+ NSVRParse $varname [lindex $ss 0] [lindex $ss end]
+ } else {
+ NSVRParse $varname {} {}
+ }
+ }
+ }
+}
+
+proc NSVRSESAMECharCB {t data} {
+ upvar #0 $t T
+ global $t
+
+ set state [lindex $T(parse) end]
+ set prev [lindex $T(parse) end-1]
+
+ switch -- $state {
+ jpos {
+ set T(pos) $data
+ }
+ jradeg {
+ set T(ra) $data
+ }
+ jdedeg {
+ set T(dec) $data
+ }
+ }
+ return {}
+}
+
+proc NSVRSESAMEElemStartCB {t name attlist args} {
+ upvar #0 $t T
+ global $t
+
+ lappend ${t}(parse) $name
+ return {}
+}
+
+proc NSVRSESAMEElemEndCB {t name args} {
+ upvar #0 $t T
+ global $t
+
+ set ${t}(parse) [lreplace $T(parse) end end]
+ return {}
+}
+
+proc NSVRParse {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "NSVRParse $varname $x $y"
+ }
+
+ set var(x) $x
+ set var(y) $y
+
+ if {($var(x) == {}) || ($var(y) == {})} {
+ set var(x) {}
+ set var(y) {}
+
+ ARStatus $varname "$var(name) not found"
+ ARReset $varname
+ } else {
+ if {$var(proc,next) != {}} {
+ if {[info exists var(token)]} {
+ http::cleanup $var(token)
+ unset var(token)
+ }
+
+ eval $var(proc,next) $varname
+ } else {
+ ARDone $varname
+ }
+ }
+}
+
+proc NSVRServerMenu {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(mb) add cascade -label [msgcat::mc {Name Server}] -menu $var(mb).name
+ menu $var(mb).name
+
+ NSVRServerMenuItems $var(mb).name
+}
+
+proc NSVRServerMenuItems {mm} {
+ global nres
+
+ $mm add radiobutton -label {NED@SAO} -variable pnres(server) \
+ -value ned-sao
+ $mm add radiobutton -label {NED@CDS} -variable pnres(server) \
+ -value ned-cds
+ $mm add separator
+ $mm add radiobutton -label {SIMBAD@SAO} -variable pnres(server) \
+ -value simbad-sao
+ $mm add radiobutton -label {SIMBAD@CDS} -variable pnres(server) \
+ -value simbad-cds
+ $mm add separator
+ $mm add radiobutton -label {VIZIER@SAO} -variable pnres(server) \
+ -value vizier-sao
+ $mm add radiobutton -label {VIZIER@CDS} -variable pnres(server) \
+ -value vizier-cds
+}
diff --git a/ds9/library/nvss.tcl b/ds9/library/nvss.tcl
new file mode 100644
index 0000000..2f1aab1
--- /dev/null
+++ b/ds9/library/nvss.tcl
@@ -0,0 +1,162 @@
+# 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 NVSSDef {} {
+ global nvss
+ global invss
+
+ set invss(top) .nvss
+ set invss(mb) .nvssmb
+
+ set nvss(sky) fk5
+ set nvss(rformat) arcmin
+ set nvss(width) 15
+ set nvss(height) 15
+ set nvss(mode) new
+ set nvss(save) 0
+ set nvss(survey) nvss
+}
+
+proc NVSSDialog {} {
+ global nvss
+ global invss
+ global wcs
+
+ if {[winfo exists $invss(top)]} {
+ raise $invss(top)
+ return
+ }
+
+ set varname dnvss
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $invss(top)
+ set var(mb) $invss(mb)
+ set var(sky) $nvss(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $nvss(rformat)
+ set var(width) $nvss(width)
+ set var(height) $nvss(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(mode) $nvss(mode)
+ set var(save) $nvss(save)
+ set var(survey) $nvss(survey)
+
+ set w $var(top)
+ IMGSVRInit $varname "NVSS [msgcat::mc {Server}]" \
+ NVSSExec NVSSAck ARDone ARError
+
+ IMGSVRUpdate $varname
+}
+
+proc NVSSExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set var(fn) [tmpnam {.fits}]
+ }
+
+ # skyformat
+ switch -- $var(skyformat) {
+ degrees {
+ set xx [uformat d h: $var(x)]
+ set yy [uformat d d: $var(y)]
+ }
+ sexagesimal {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ }
+ regsub -all {:} $xx { } xx
+ regsub -all {:} $yy { } yy
+
+ # size - degrees
+ switch -- $var(rformat) {
+ degrees {
+ set ww [expr $var(width)]
+ set hh [expr $var(height)]
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+
+ set var(query) [http::formatQuery submit Submit! Equinox J2000 PolType I RA $xx Dec $yy Size "$ww $hh" Cells "15.0 15.0" MAPROJ SIN Type image/x-fits rotate "0.0"]
+
+# set var(query) [http::formatQuery .submit "Extract the Cutout" RA "$xx $yy" Equinox J2000 ImageSize $rr MaxInt 10 .cgifields ImageType ImageType "FITS Image"]
+ set url "http://www.cv.nrao.edu/cgi-bin/postage.pl"
+ IMGSVRGetURL $varname $url
+}
+
+proc NVSSAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the NRAO VLA Sky Survey
+
+This major undertaking has received the generous technical and
+scientific support of many individuals. The NRAO staff has provided
+extremely valuable assistance in many aspects of the observations
+themselves and in the area of software support; in particular, we are
+grateful to Rick Perley, Ken Sowinski, Barry Clark, and Bill Cotton in
+this regard. The support of the NRAO Director, Paul van den Bout, and
+the yeoman service provided by Frazer Owen as Chair of the Survey
+Oversight Committee are also greatly appreciated. We also thank the
+members of the Oversight Committee (Ken Chambers, Eric Feigelson,
+Jackie Hewitt, Gillian Knapp, and Rogier Windhorst) for their time and
+wise counsel in this enterprise.
+
+Acknowledgment is also due our colleagues who are involved in the
+ongoing NVSS effort, including Richard McMahon and Isobel Hook. This
+work is supported in part under the auspices of the Department of
+Energy by Lawrence Livermore National Laboratory under contract
+No. W-7405-ENG-48 and the Institute for Geophysics and Planetary
+Physics, whose director Charles Alcock has been particularly
+supportive. We also acknowledge a generous planning grant from the
+CalSpace Institute; support from the STScI archive group, STScI
+director Bob Williams, and the STScI Director's Discretionary Research
+Fund; computing resources from Columbia University; a grant from the
+National Science Foundation; a gift of computing equipment from Sun
+Microsystems; a NATO travel grant to support our collaboration with
+Richard McMahon; and an award from the National Geographic Society
+which, in the spirit of their support 40 years ago for the Palomar
+Observatory Sky Survey, will be providing funds to continue our
+charting of the Universe.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc ProcessNVSSCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ NVSSDialog
+ IMGSVRProcessCmd $varname $iname dnvss
+}
+
+proc ProcessSendNVSSCmd {proc id param} {
+ NVSSDialog
+ IMGSVRProcessSendCmd $proc $id $param dnvss
+}
diff --git a/ds9/library/open.tcl b/ds9/library/open.tcl
new file mode 100644
index 0000000..223bf87
--- /dev/null
+++ b/ds9/library/open.tcl
@@ -0,0 +1,119 @@
+# 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 Open {fn format layer mode sys} {
+ if {$fn == {}} {
+ return
+ }
+
+ StartLoad
+ switch -- $format {
+ fits {LoadFitsFile $fn $layer $mode}
+ mosaicimagewcs {LoadMosaicImageWCSFile $fn $layer $sys}
+ mosaicimageiraf {LoadMosaicImageIRAFFile $fn $layer}
+ mosaicimagewfpc2 {LoadMosaicImageWFPC2File $fn}
+ mosaicwcs {LoadMosaicWCSFile $fn $layer $sys}
+ mosaiciraf {LoadMosaicIRAFFile $fn $layer}
+ mecube {LoadMECubeFile $fn}
+ multiframe {LoadMultiFrameFile $fn}
+ rgbimage {LoadRGBImageFile $fn}
+ rgbcube {LoadRGBCubeFile $fn}
+ }
+ FinishLoad
+}
+
+# Support
+
+proc OpenDialog {format {layer {}} {mode {}}} {
+ global current
+ global fitsfbox
+
+ set fn [OpenFileDialog fitsfbox]
+
+ # just in case (could be invoked via a menu keyshortcut)
+ if {$current(frame) == {}} {
+ CreateFrame
+ }
+
+ set sys wcs
+ if {$fn != {}} {
+ set ok 1
+ switch -- $format {
+ mosaicimagewcs {set ok [MosaicWCSDialog sys]}
+ mosaicwcs {set ok [MosaicWCSDialog sys]}
+ }
+
+ if {$ok} {
+ switch -- $layer {
+ mask {set ok [MaskLoad]}
+ }
+ }
+
+ if {$ok} {
+ Open $fn $format $layer $mode $sys
+ }
+ }
+}
+
+proc MosaicWCSDialog {varname} {
+ upvar $varname var
+ global ed
+
+ set w {.wcs}
+
+ set ed(ok) 0
+ set ed(sys) wcs
+ set ed(label) WCS
+
+ DialogCreate $w [msgcat::mc {Load Mosaic}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.title -text [msgcat::mc {Select Coordinate System }]
+ ttk::menubutton $f.sys -textvariable ed(label) \
+ -menu $f.sys.m -width 10
+
+ menu $f.sys.m
+ $f.sys.m add radiobutton -label [msgcat::mc {WCS}] \
+ -variable ed(sys) -value "wcs" -command [list set ed(label) WCS]
+ $f.sys.m add separator
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $f.sys.m add radiobutton -variable ed(sys) \
+ -label "[msgcat::mc {WCS}] $l" \
+ -value "wcs$l" \
+ -command [list set ed(label) "[msgcat::mc {WCS}] $l"]
+ }
+
+ grid $f.title $f.sys
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set var $ed(sys)
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
diff --git a/ds9/library/pagesetup.tcl b/ds9/library/pagesetup.tcl
new file mode 100644
index 0000000..c24c58d
--- /dev/null
+++ b/ds9/library/pagesetup.tcl
@@ -0,0 +1,208 @@
+# 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 PSPageSetup {} {
+ global ps
+ global ed
+
+ set ed(ok) 0
+ array set ed [array get ps]
+
+ set w {.pagesetup}
+
+ DialogCreate $w [msgcat::mc {Page Setup}] ed(ok)
+
+ # Layout
+ set f [ttk::labelframe $w.layout -text {Layout}]
+
+ ttk::label $f.torient -text [msgcat::mc {Orientation}]
+ ttk::radiobutton $f.portrait -text [msgcat::mc {Portrait}] \
+ -variable ed(orient) -value portrait
+ ttk::radiobutton $f.landscape -text [msgcat::mc {Landscape}] \
+ -variable ed(orient) -value landscape
+ ttk::label $f.tscale -text [msgcat::mc {Scale}]
+ ttk::entry $f.scale -textvariable ed(scale) -width 7
+ ttk::label $f.uscale -text {%}
+
+ grid $f.torient $f.portrait $f.landscape -padx 2 -pady 2 -sticky w
+ grid $f.tscale $f.scale $f.uscale -padx 2 -pady 2 -sticky w
+
+ # Page Size
+ set f [ttk::labelframe $w.size -text {Page Size}]
+
+ ttk::radiobutton $f.letter -text "[msgcat::mc {Letter}](8.5 x 11 in)"\
+ -variable ed(size) -value letter
+ ttk::radiobutton $f.legal -text "[msgcat::mc {Legal}](8.5 x 14 in)"\
+ -variable ed(size) -value legal
+ ttk::radiobutton $f.tabloid -text "[msgcat::mc {Tabloid}](11 x 17 in)"\
+ -variable ed(size) -value tabloid
+ ttk::radiobutton $f.poster -text "[msgcat::mc {Poster}](36 x 48 in)"\
+ -variable ed(size) -value poster
+ ttk::radiobutton $f.a4 -text {A4(210 x 297 mm)} \
+ -variable ed(size) -value a4
+ ttk::radiobutton $f.other -text "[msgcat::mc {Other}] (inches)" \
+ -variable ed(size) -value other
+ ttk::radiobutton $f.othermm -text "[msgcat::mc {Other}] (mm)" \
+ -variable ed(size) -value othermm
+ ttk::label $f.title3 -text [msgcat::mc {Width}]
+ ttk::entry $f.width -textvariable ed(width) -width 10
+ ttk::label $f.title4 -text [msgcat::mc {Height}]
+ ttk::entry $f.height -textvariable ed(height) -width 10
+
+ grid $f.letter -padx 2 -pady 2 -sticky w
+ grid $f.legal -padx 2 -pady 2 -sticky w
+ grid $f.tabloid -padx 2 -pady 2 -sticky w
+ grid $f.poster -padx 2 -pady 2 -sticky w
+ grid $f.a4 -padx 2 -pady 2 -sticky w
+ grid $f.other $f.title3 $f.width -padx 2 -pady 2 -sticky w
+ grid $f.othermm $f.title4 $f.height -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ grid $w.layout -sticky news
+ grid $w.size -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ array set ps [array get ed]
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PrefsDialogPageSetup {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Page Setup}]
+ lappend dprefs(tabs) [ttk::frame $w.pagesetup]
+
+ # Layout
+ set f [ttk::labelframe $w.pagesetup.layout -text {Layout}]
+
+ ttk::label $f.torient -text [msgcat::mc {Orientation}]
+ ttk::radiobutton $f.portrait -text [msgcat::mc {Portrait}] \
+ -variable pps(orient) -value portrait
+ ttk::radiobutton $f.landscape -text [msgcat::mc {Landscape}] \
+ -variable pps(orient) -value landscape
+ ttk::label $f.tscale -text [msgcat::mc {Scale}]
+ ttk::entry $f.scale -textvariable pps(scale) -width 7
+ ttk::label $f.uscale -text {%}
+
+ grid $f.torient $f.portrait $f.landscape -padx 2 -pady 2 -sticky w
+ grid $f.tscale $f.scale $f.uscale -padx 2 -pady 2 -sticky w
+
+ # Page Size
+ set f [ttk::labelframe $w.pagesetup.size -text {Page Size}]
+
+ ttk::radiobutton $f.letter -text "[msgcat::mc {Letter}](8.5 x 11 in)"\
+ -variable pps(size) -value letter
+ ttk::radiobutton $f.legal -text "[msgcat::mc {Legal}](8.5 x 14 in)"\
+ -variable pps(size) -value legal
+ ttk::radiobutton $f.tabloid -text "[msgcat::mc {Tabloid}](11 x 17 in)"\
+ -variable pps(size) -value tabloid
+ ttk::radiobutton $f.poster -text "[msgcat::mc {Poster}](36 x 48 in)"\
+ -variable pps(size) -value poster
+ ttk::radiobutton $f.a4 -text {A4(210 x 297 mm)} \
+ -variable pps(size) -value a4
+ ttk::radiobutton $f.other -text "[msgcat::mc {Other}] (inches)" \
+ -variable pps(size) -value other
+ ttk::radiobutton $f.othermm -text "[msgcat::mc {Other}] (mm)" \
+ -variable pps(size) -value othermm
+
+ ttk::label $f.title3 -text [msgcat::mc {Width}]
+ ttk::entry $f.width -textvariable pps(width) -width 10
+
+ ttk::label $f.title4 -text [msgcat::mc {Height}]
+ ttk::entry $f.height -textvariable pps(height) -width 10
+
+ grid $f.letter -padx 2 -pady 2 -sticky w
+ grid $f.legal -padx 2 -pady 2 -sticky w
+ grid $f.tabloid -padx 2 -pady 2 -sticky w
+ grid $f.poster -padx 2 -pady 2 -sticky w
+ grid $f.a4 -padx 2 -pady 2 -sticky w
+ grid $f.other $f.title3 $f.width -padx 2 -pady 2 -sticky w
+ grid $f.othermm $f.title4 $f.height -padx 2 -pady 2 -sticky w
+
+ pack $w.pagesetup.layout $w.pagesetup.size \
+ -side top -fill both -expand true
+}
+
+# Process Cmds
+
+proc ProcessPageSetupCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {ProcessPSPageSetupCmd var i}
+ aqua {
+ ProcessPSPageSetupCmd var i
+# MacOSXPageSetup
+ }
+ wwin32 {Win32PageSetup}
+ }
+}
+
+proc ProcessSendPageSetupCmd {proc id param} {
+ global ds9
+
+ switch $ds9(wm) {
+ x11 {ProcessSendPSPageSetupCmd $proc $id $param}
+ aqua -
+ win32 {}
+ }
+}
+
+proc ProcessPSPageSetupCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ps
+
+ switch -- [string tolower [lindex $var $i]] {
+ orientation -
+ orient {incr i; set ps(orient) [string tolower [lindex $var $i]]}
+ pagescale -
+ scale {incr i; set ps(scale) [lindex $var $i]}
+ pagesize -
+ size {incr i; set ps(size) [string tolower [lindex $var $i]] }
+ }
+}
+
+proc ProcessSendPSPageSetupCmd {proc id param} {
+ global ps
+
+ switch -- [string tolower $param] {
+ orientation -
+ orient {$proc $id "$ps(orient)\n"}
+ pagescale -
+ scale {$proc $id "$ps(scale)\n"}
+ pagesize -
+ size {$proc $id "$ps(size)\n"}
+ }
+}
+
diff --git a/ds9/library/panner.tcl b/ds9/library/panner.tcl
new file mode 100644
index 0000000..5ff5e7a
--- /dev/null
+++ b/ds9/library/panner.tcl
@@ -0,0 +1,296 @@
+# 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 CreatePanner {} {
+ global ipanner
+ global ds9
+
+ set ds9(panner) [canvas $ds9(panel).pan -width $ipanner(size) \
+ -height $ipanner(size) \
+ -relief groove \
+ -borderwidth 2 \
+ -highlightthickness 0 \
+ -insertofftime 0 \
+ -takefocus 0]
+ $ds9(panner) create panner$ds9(visual) \
+ -width $ipanner(size) \
+ -height $ipanner(size) \
+ -command panner \
+ -tag panner \
+ -helvetica $ds9(helvetica) \
+ -courier $ds9(courier) \
+ -times $ds9(times)
+}
+
+proc PannerDef {} {
+ global ipanner
+ global ppanner
+
+ set ipanner(size) 128
+
+ # prefs only
+ set ppanner(compass) 1
+}
+
+proc InitPanner {} {
+ global ds9
+ global ppanner
+
+ # other bindings
+ BindEventsPanner
+
+ bind $ds9(panner) <Tab> [list NextFrame]
+ bind $ds9(panner) <Shift-Tab> [list PrevFrame]
+
+ switch $ds9(wm) {
+ x11 {bind $ds9(panner) <ISO_Left_Tab> [list PrevFrame]}
+ aqua -
+ win32 {}
+ }
+
+ switch $ds9(wm) {
+ x11 -
+ aqua {
+ bind $ds9(panner) <Enter> [list focus $ds9(panner)]
+ bind $ds9(panner) <Leave> [list focus {}]
+ }
+ win32 {}
+ }
+
+ # compass
+ panner compass $ppanner(compass)
+}
+
+proc BindEventsPanner {} {
+ global ds9
+
+ $ds9(panner) bind panner <Enter> [list EnterPanner %x %y]
+ $ds9(panner) bind panner <Leave> [list LeavePanner]
+ $ds9(panner) bind panner <Motion> [list MotionPanner %x %y]
+ $ds9(panner) bind panner <Button-1> [list Button1Panner %x %y]
+ $ds9(panner) bind panner <B1-Motion> [list Motion1Panner %x %y]
+ $ds9(panner) bind panner <ButtonRelease-1> [list Release1Panner %x %y]
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $ds9(panner) bind panner <ButtonRelease-2> \
+ [list Release2Panner %x %y]
+ }
+ aqua {
+ $ds9(panner) bind panner <ButtonRelease-3> \
+ [list Release2Panner %x %y]
+ }
+ }
+
+
+ $ds9(panner) bind panner <Up> [list ArrowKeyPanner 0 -1]
+ $ds9(panner) bind panner <Down> [list ArrowKeyPanner 0 1]
+ $ds9(panner) bind panner <Left> [list ArrowKeyPanner -1 0]
+ $ds9(panner) bind panner <Right> [list ArrowKeyPanner 1 0]
+}
+
+proc UnBindEventsPanner {} {
+ global ds9
+
+ $ds9(panner) bind panner <Enter> {}
+ $ds9(panner) bind panner <Leave> {}
+ $ds9(panner) bind panner <Motion> {}
+ $ds9(panner) bind panner <Button-1> {}
+ $ds9(panner) bind panner <B1-Motion> {}
+ $ds9(panner) bind panner <ButtonRelease-1> {}
+
+ switch $ds9(wm) {
+ x11 -
+ win32 {$ds9(panner) bind panner <ButtonRelease-2> {}}
+ aqua {$ds9(panner) bind panner <ButtonRelease-3> {}}
+ }
+
+ $ds9(panner) bind panner <Up> {}
+ $ds9(panner) bind panner <Down> {}
+ $ds9(panner) bind panner <Left> {}
+ $ds9(panner) bind panner <Right> {}
+}
+
+proc EnterPanner {x y} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "EnterPanner"
+ }
+
+ switch $ds9(wm) {
+ x11 -
+ aqua {
+ focus $ds9(panner)
+ $ds9(panner) focus panner
+ }
+ win32 {}
+ }
+
+ if {$current(frame) != {}} {
+ EnterInfoBox $current(frame)
+ UpdateInfoBox $current(frame) $x $y panner
+ UpdatePixelTableDialog $current(frame) $x $y panner
+ UpdateGraph $current(frame) $x $y panner
+ }
+}
+
+proc LeavePanner {} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "LeavePanner"
+ }
+
+ panner highlite off
+ switch $ds9(wm) {
+ x11 -
+ aqua {
+ $ds9(panner) focus {}
+ focus {}
+ }
+ win32 {}
+ }
+
+ LeaveInfoBox
+ PixelTableClearDialog
+ ClearGraphData
+}
+
+proc MotionPanner {x y} {
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "MotionPanner"
+ }
+
+ panner highlite $x $y
+ if {$current(frame) != {}} {
+ UpdateColormapLevelMosaic $current(frame) $x $y panner
+ UpdateInfoBox $current(frame) $x $y panner
+ UpdatePixelTableDialog $current(frame) $x $y panner
+ UpdateGraph $current(frame) $x $y panner
+ }
+}
+
+proc Button1Panner {x y} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Button1Panner"
+ }
+
+ panner pan begin $x $y
+}
+
+proc Motion1Panner {x y} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Motion1Panner"
+ }
+
+ panner pan motion $x $y
+ if {$current(frame) != {}} {
+ UpdateColormapLevelMosaic $current(frame) $x $y panner
+ UpdateInfoBox $current(frame) $x $y panner
+ UpdatePixelTableDialog $current(frame) $x $y panner
+ UpdateGraph $current(frame) $x $y panner
+ }
+}
+
+proc Release1Panner {x y} {
+ global ds9
+ global current
+
+ global debug
+ if {$debug(tcl,events)} {
+ puts stderr "Release1Panner"
+ }
+
+ if {$current(frame) != {}} {
+ panner pan end $x $y
+ $current(frame) pan bbox [panner get bbox]
+
+ UpdateColormapLevelMosaic $current(frame) $x $y panner
+ UpdateInfoBox $current(frame) $x $y panner
+ UpdatePixelTableDialog $current(frame) $x $y panner
+ UpdateGraph $current(frame) $x $y panner
+
+ LockFrameCurrent
+ UpdateGraphXAxis $current(frame)
+ UpdatePanZoomDialog
+ SAMPSendCoordPointAtSkyCmd $current(frame)
+ }
+}
+
+proc Release2Panner {x y} {
+ global ds9
+ global current
+
+ if {$current(frame) != {}} {
+ panner pan to $x $y
+ $current(frame) pan bbox [panner get bbox]
+
+ UpdateColormapLevelMosaic $current(frame) $x $y panner
+ UpdateInfoBox $current(frame) $x $y panner
+ UpdatePixelTableDialog $current(frame) $x $y panner
+ UpdateGraph $current(frame) $x $y panner
+
+ LockFrameCurrent
+ UpdateGraphXAxis $current(frame)
+ UpdatePanZoomDialog
+ SAMPSendCoordPointAtSkyCmd $current(frame)
+ }
+}
+
+proc ArrowKeyPanner {x y} {
+ global current
+
+ panner warp $x $y
+ SAMPSendCoordPointAtSkyCmd $current(frame)
+}
+
+proc PannerBackup {ch} {
+ global ppanner
+
+ puts $ch "panner compass $ppanner(compass)"
+}
+
+# Prefs
+
+proc PrefsDialogPanner {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Panner}]
+ lappend dprefs(tabs) [ttk::frame $w.panner]
+
+ set f [ttk::labelframe $w.panner.param -text [msgcat::mc {Panner}]]
+
+ ttk::checkbutton $f.compass \
+ -text [msgcat::mc {Show Compass}] \
+ -variable ppanner(compass) -command PrefsPannerCompass
+
+ grid $f.compass -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsPannerCompass {} {
+ global ppanner
+
+ panner compass $ppanner(compass)
+}
diff --git a/ds9/library/panzoom.tcl b/ds9/library/panzoom.tcl
new file mode 100644
index 0000000..7c843d7
--- /dev/null
+++ b/ds9/library/panzoom.tcl
@@ -0,0 +1,823 @@
+# 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 PanZoomDef {} {
+ global panzoom
+ global ipanzoom
+ global ppanzoom
+ global tcl_platform
+
+ set ipanzoom(top) .pz
+ set ipanzoom(mb) .pzmb
+ set ipanzoom(speed) 512
+ set ipanzoom(x) 0
+ set ipanzoom(last) {0 0}
+ set ipanzoom(state) 1
+
+ set panzoom(preserve) 0
+ set panzoom(lock) none
+
+ # set via wcs()
+ set panzoom(system) wcs
+ set panzoom(sky) fk5
+ set panzoom(skyformat) degrees
+
+ set ppanzoom(preserve) $panzoom(preserve)
+
+ # prefs only
+ set ppanzoom(mode) click
+ set ppanzoom(wheel) 1
+ set ppanzoom(wheel,factor) 1.2
+ # special case
+ switch -- $tcl_platform(os) {
+ Darwin {
+ switch [lindex [split $tcl_platform(osVersion) {.}] 0] {
+ 11 {set ppanzoom(wheel,factor) 1.01}
+ }
+ }
+ }
+}
+
+# Pan
+
+proc CenterCurrentFrame {} {
+ global current
+
+ CenterFrame $current(frame)
+}
+
+proc CenterAllFrame {} {
+ global ds9
+
+ foreach ff $ds9(frames) {
+ CenterFrame $ff
+ }
+}
+
+proc CenterFrame {which} {
+ if {$which != {}} {
+ $which center
+
+ UpdatePan $which
+ UpdateZoomMenu
+ }
+}
+
+proc Pan {x y sys {sky {}}} {
+ global current
+
+ if {$current(frame) != {}} {
+ switch -- $sys {
+ canvas {$current(frame) pan $x $y}
+ default {$current(frame) pan $sys $sky $x $y}
+ }
+
+ UpdatePan $current(frame)
+ }
+}
+
+proc PanTo {x y sys sky} {
+ global current
+
+ PanToFrame $current(frame) $x $y $sys $sky
+}
+
+proc PanToFrame {which x y sys sky} {
+ global current
+
+ if {$which != {}} {
+ $which pan to $sys $sky $x $y
+ UpdatePan $which
+ }
+}
+
+proc PanButton {which x y} {
+ global ppanzoom
+
+ switch -- $ppanzoom(mode) {
+ click {}
+ drag {$which pan motion begin $x $y}
+ panzoom {}
+ }
+}
+
+proc PanMotion {which x y} {
+ global ppanzoom
+
+ switch -- $ppanzoom(mode) {
+ click {}
+ drag {$which pan motion $x $y}
+ panzoom {}
+ }
+}
+
+proc PanRelease {which x y} {
+ global panzoom
+ global ipanzoom
+ global ppanzoom
+ global current
+
+ switch -- $ppanzoom(mode) {
+ click {$which pan to $x $y}
+ drag {$which pan motion end $x $y}
+ panzoom {
+ if {$ipanzoom(last) != "$x $y"} {
+ set ipanzoom(state) 1
+ }
+ switch -- $ipanzoom(state) {
+ 1 {
+ $which pan to $x $y
+ $which update now
+ set cc [$which get cursor canvas]
+ set xx [expr int([lindex $cc 0])]
+ set yy [expr int([lindex $cc 1])]
+ $which warp to $xx $yy
+ set ipanzoom(last) "$xx $yy"
+
+ set z [$current(frame) get zoom]
+ if {$z < 2} {
+ set ipanzoom(state) 2
+ } elseif {$z < 4} {
+ set ipanzoom(state) 3
+ } elseif {$z < 8} {
+ set ipanzoom(state) 4
+ } else {
+ set ipanzoom(state) 5
+ }
+ }
+ 2 {
+ $which zoom to 2 2 about $x $y
+ set ipanzoom(state) 3
+ }
+ 3 {
+ $which zoom to 4 4 about $x $y
+ set ipanzoom(state) 4
+ }
+ 4 {
+ $which zoom to 8 8 about $x $y
+ set ipanzoom(state) 5
+ }
+ 5 {
+ $which zoom to 1 1 about $x $y
+ set ipanzoom(state) 2
+ }
+ }
+ if {$which == $current(frame)} {
+ set current(zoom) [$current(frame) get zoom]
+ }
+ }
+ }
+
+ UpdatePan $which
+}
+
+proc PreservePan {} {
+ global current
+ global panzoom
+
+ if {$current(frame) != {}} {
+ $current(frame) pan preserve $panzoom(preserve)
+ }
+}
+
+proc UpdatePan {which} {
+ LockFrame $which
+ UpdateGraphXAxis $which
+ UpdatePanZoomDialog
+ SAMPSendCoordPointAtSkyCmd $which
+}
+
+# Zoom
+
+proc ZoomToFit {} {
+ global current
+ global grid
+
+ if {$current(frame) != {}} {
+ # we need to update the grid because titles are zoom dependant
+ if {$grid(view) && $grid(type) == "publication"} {
+ # recalculate to make room for labels
+ $current(frame) zoom to fit .8
+ set current(zoom) [$current(frame) get zoom]
+ } else {
+ $current(frame) zoom to fit
+ set current(zoom) [$current(frame) get zoom]
+ }
+ UpdateZoom $current(frame)
+ }
+}
+
+proc ChangeZoom {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) zoom to $current(zoom)
+ UpdateZoom $current(frame)
+ }
+}
+
+proc Zoom {zx zy} {
+ global current
+
+ if {$current(frame) != {}} {
+ ZoomFrame $current(frame) $zx $zy
+ }
+}
+
+proc ZoomFrame {which zx zy} {
+ global current
+
+ $which zoom $zx $zy
+ if {$which == $current(frame)} {
+ set current(zoom) [$current(frame) get zoom]
+ }
+ UpdateZoom $which
+}
+
+proc ZoomButton {which x y} {
+ global current
+
+ $which zoom 2 2 about $x $y
+ if {$current(frame) == $which} {
+ set current(zoom) [$current(frame) get zoom]
+ }
+ UpdateZoom $which
+}
+
+proc ZoomShift {which} {
+ global current
+
+ $which zoom .5 .5
+ if {$current(frame) == $which} {
+ set current(zoom) [$current(frame) get zoom]
+ }
+ UpdateZoom $which
+}
+
+proc UpdateZoom {which} {
+ LockFrame $which
+ UpdateGraphXAxis $which
+ UpdatePanZoomDialog
+ GridUpdateZoom
+ RefreshInfoBox $which
+}
+
+# Orient
+
+proc ChangeOrient {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) orient $current(orient)
+ UpdateRotate $current(frame)
+ }
+}
+
+# Rotate
+
+proc Rotate {value} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) rotate $value
+ set current(rotate) [$current(frame) get rotate]
+ UpdateRotate $current(frame)
+ }
+}
+
+proc ChangeRotate {} {
+ global current
+
+ if {$current(frame) != {}} {
+ $current(frame) rotate to $current(rotate)
+ UpdateRotate $current(frame)
+ }
+}
+
+proc RotateButton {which x y} {
+ global ipanzoom
+
+ $which rotate motion begin
+ set ipanzoom(x) $x
+}
+
+proc RotateMotion {which x y} {
+ global current
+ global ipanzoom
+ global icursor
+
+ $which rotate motion [expr double($ipanzoom(x)-$x)/$ipanzoom(speed) * 180.]
+ if {$current(frame) == $which} {
+ set current(rotate) [$which get rotate]
+ }
+ RefreshInfoBox $which
+}
+
+proc RotateRelease {which x y} {
+ global current
+
+ $which rotate motion end
+ if {$current(frame) == $which} {
+ set current(rotate) [$which get rotate]
+ }
+ UpdateRotate $which
+}
+
+proc UpdateRotate {which} {
+ LockFrame $which
+ UpdateGraphXAxis $which
+ UpdatePanZoomDialog
+ RefreshInfoBox $which
+}
+
+proc PanZoomDialog {} {
+ global panzoom
+ global ipanzoom
+ global dpanzoom
+ global ds9
+ global current
+
+ # see if we already have a window visible
+ if {[winfo exists $ipanzoom(top)]} {
+ raise $ipanzoom(top)
+ return
+ }
+
+ # create the window
+ set w $ipanzoom(top)
+ set mb $ipanzoom(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Pan Zoom Rotate Parameters}] \
+ PanZoomDestroyDialog
+
+ # for CoordMenuButton
+ set panzoom(frame) $current(frame)
+
+ $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 {Pan}] -menu $mb.pan
+ $mb add cascade -label [msgcat::mc {Zoom}] -menu $mb.zoom
+ $mb add cascade -label [msgcat::mc {Orientation}] -menu $mb.orient
+ $mb add cascade -label [msgcat::mc {Rotate}] -menu $mb.rotate
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command PanZoomApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command PanZoomDestroyDialog
+
+ EditMenu $mb ipanzoom
+
+ menu $mb.pan
+ $mb.pan add command -label [msgcat::mc {Center Image}] \
+ -command CenterCurrentFrame
+ $mb.pan add checkbutton -label [msgcat::mc {Align}] \
+ -variable current(align) -command AlignWCSFrame
+
+ menu $mb.zoom
+ $mb.zoom add command -label [msgcat::mc {Zoom In}] -command {Zoom 2 2}
+ $mb.zoom add command -label [msgcat::mc {Zoom Out}] -command {Zoom .5 .5}
+ $mb.zoom add command -label [msgcat::mc {Zoom Fit}] -command ZoomToFit
+ $mb.zoom add separator
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/32" \
+ -variable current(zoom) -value { 0.03125 0.03125 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/16" \
+ -variable current(zoom) -value { 0.0625 0.0625 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/8" \
+ -variable current(zoom) -value { 0.125 0.125 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/4" \
+ -variable current(zoom) -value { 0.25 0.25 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 1/2" \
+ -variable current(zoom) -value { 0.5 0.5 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 1" \
+ -variable current(zoom) -value { 1 1 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 2" \
+ -variable current(zoom) -value { 2 2 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 4" \
+ -variable current(zoom) -value { 4 4 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 8" \
+ -variable current(zoom) -value { 8 8 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 16" \
+ -variable current(zoom) -value { 16 16 } -command ChangeZoom
+ $mb.zoom add radiobutton -label "[msgcat::mc {Zoom}] 32" \
+ -variable current(zoom) -value { 32 32 } -command ChangeZoom
+
+ menu $mb.orient
+ $mb.orient add radiobutton -label [msgcat::mc {None}] \
+ -variable current(orient) -value none -command ChangeOrient
+ $mb.orient add radiobutton -label "[msgcat::mc {Invert}] X" \
+ -variable current(orient) -value x -command ChangeOrient
+ $mb.orient add radiobutton -label "[msgcat::mc {Invert}] Y" \
+ -variable current(orient) -value y -command ChangeOrient
+ $mb.orient add radiobutton -label "[msgcat::mc {Invert}] XY" \
+ -variable current(orient) -value xy -command ChangeOrient
+
+ menu $mb.rotate
+ $mb.rotate add radiobutton -label "0 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 0 -command ChangeRotate
+ $mb.rotate add radiobutton -label "90 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 90 -command ChangeRotate
+ $mb.rotate add radiobutton -label "180 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 180 -command ChangeRotate
+ $mb.rotate add radiobutton -label "270 [msgcat::mc {Degrees}]" \
+ -variable current(rotate) -value 270 -command ChangeRotate
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.zoomtitle -text [msgcat::mc {Zoom}]
+ ttk::entry $f.zoomx -textvariable dpanzoom(zoom,x) -width 14
+ ttk::entry $f.zoomy -textvariable dpanzoom(zoom,y) -width 14
+
+ ttk::label $f.rottitle -text [msgcat::mc {Rotate}]
+ ttk::entry $f.rotvalue -textvariable dpanzoom(rotate) -width 14
+ ttk::label $f.rottitle2 -text [msgcat::mc {Degrees}]
+
+ ttk::label $f.pantitle -text [msgcat::mc {Pan}]
+ ttk::entry $f.panx -textvariable dpanzoom(x) -width 14
+ ttk::entry $f.pany -textvariable dpanzoom(y) -width 14
+ set dpanzoom(cb) $f.pansystem
+ CoordMenuButton $dpanzoom(cb) panzoom system 1 sky skyformat \
+ UpdatePanZoomDialog
+
+ grid $f.zoomtitle $f.zoomx $f.zoomy -padx 2 -pady 2
+ grid $f.rottitle $f.rotvalue $f.rottitle2 -padx 2 -pady 2 -sticky w
+ grid $f.pantitle $f.panx $f.pany $f.pansystem -padx 2 -pady 2
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command PanZoomApplyDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command PanZoomDestroyDialog
+ pack $f.apply $f.close -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
+
+ $w.param.zoomx select range 0 end
+
+ UpdatePanZoomDialog
+}
+
+proc PanZoomApplyDialog {} {
+ global panzoom
+ global ipanzoom
+ global dpanzoom
+ global current
+
+ if {$current(frame) != {}} {
+ set current(zoom) "$dpanzoom(zoom,x) $dpanzoom(zoom,y)"
+ set current(rotate) $dpanzoom(rotate)
+
+ $current(frame) zoom to $current(zoom) about \
+ $panzoom(system) $panzoom(sky) $dpanzoom(x) $dpanzoom(y)
+ $current(frame) rotate to $current(rotate)
+
+ LockFrameCurrent
+ UpdateGraphXAxis $current(frame)
+ UpdatePanZoomDialog
+ GridUpdateZoom
+ RefreshInfoBox $current(frame)
+ UpdateZoomMenu
+ SAMPSendCoordPointAtSkyCmd $current(frame)
+ }
+}
+
+proc PanZoomDestroyDialog {} {
+ global ipanzoom
+ global dpanzoom
+
+ if {[winfo exists $ipanzoom(top)]} {
+ destroy $ipanzoom(top)
+ destroy $ipanzoom(mb)
+ }
+
+ unset dpanzoom
+}
+
+proc UpdatePanZoomMenu {} {
+ # can be changed by wcs
+ SetCoordSystem panzoom system sky skyformat
+}
+
+proc UpdatePanZoomDialog {} {
+ global panzoom
+ global ipanzoom
+ global dpanzoom
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdatePanZoomDialog"
+ }
+
+ if {![winfo exists $ipanzoom(top)]} {
+ return
+ }
+
+ if {$current(frame) != {}} {
+ set panzoom(frame) $current(frame)
+ if {[$current(frame) has fits]} {
+ # now make sure we have the coord systems
+ AdjustCoordSystem panzoom system
+ CoordMenuEnable $dpanzoom(cb).menu panzoom system 1 sky skyformat
+ CoordMenuButtonCmd panzoom system sky {}
+ } else {
+ CoordMenuReset $dpanzoom(cb).menu panzoom system 1 sky skyformat
+ }
+ }
+
+ if {$current(frame) != {}} {
+ set zz [$current(frame) get zoom]
+ set dpanzoom(zoom,x) [lindex $zz 0]
+ set dpanzoom(zoom,y) [lindex $zz 1]
+ set dpanzoom(rotate) [$current(frame) get rotate]
+
+ set coord [$current(frame) get cursor $panzoom(system) \
+ $panzoom(sky) $panzoom(skyformat)]
+ set dpanzoom(x) [lindex $coord 0]
+ set dpanzoom(y) [lindex $coord 1]
+ } else {
+ set dpanzoom(zoom,x) {}
+ set dpanzoom(zoom,y) {}
+ set dpanzoom(rotate) {}
+
+ set dpanzoom(x) {}
+ set dpanzoom(y) {}
+ }
+}
+
+# Other
+
+proc AlignWCSFrame {} {
+ global current
+ global ds9
+
+ if {$current(frame) != {}} {
+ $current(frame) wcs align $current(align)
+
+ LockFrameCurrent
+ UpdateGraphXAxis $current(frame)
+ UpdatePanZoomDialog
+ }
+}
+
+proc MatchFrameCurrent {sys} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchFrame $current(frame) $sys
+ }
+}
+
+proc MatchFrame {which sys} {
+ global ds9
+ global current
+
+ # NO-make sure matrices have been updated
+ # really messes up mousewheel events, just assume all is good
+ # RealizeDS9
+
+ switch -- $sys {
+ image -
+ physical -
+ amplifier -
+ detector {
+ set current(align) 0
+ $which wcs align 0
+
+ set pan [$which get cursor $sys]
+ set zoom [$which get zoom]
+ set rotate [$which get rotate]
+ set orient [$which get orient]
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ $ff pan to $sys $pan
+ $ff zoom to $zoom
+ $ff rotate to $rotate
+ $ff orient $orient
+
+ $ff wcs align 0
+ }
+ }
+ }
+ wcs {
+ set www [$which get wcs]
+ set sys [lindex $www 0]
+ set sky [lindex $www 1]
+ if {[$which has wcs $sys]} {
+ set current(align) 1
+ $which wcs align 1
+ set align [$which get wcs align pointer]
+ set pan [$which get cursor $sys FK5]
+ set zoom [$which get zoom]
+ set rotate [$which get rotate]
+ set orient [$which get orient]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ if {[$ff has wcs $sys]} {
+ $ff pan to $sys FK5 $pan
+ $ff zoom to $zoom
+ $ff rotate to $rotate
+ $ff orient $orient
+
+ $ff wcs align $align
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+proc LockFrameCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockFrame $current(frame)
+ }
+}
+
+proc LockFrame {which} {
+ global panzoom
+
+ switch -- $panzoom(lock) {
+ none {}
+ default {MatchFrame $which $panzoom(lock)}
+ }
+}
+
+# Backup
+
+proc PanZoomBackup {ch which} {
+ puts $ch "$which pan preserve [$which get pan preserve]"
+ puts $ch "$which pan to physical [$which get cursor physical]"
+ puts $ch "$which zoom to [$which get zoom]"
+ puts $ch "$which rotate to [$which get rotate]"
+ puts $ch "$which orient [$which get orient]"
+ puts $ch "$which wcs align [$which get wcs align]"
+}
+
+# Process Cmds
+
+proc ProcessPanCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {PanZoomDialog}
+ close {PanZoomDestroyDialog}
+ to {
+ set x [lindex $var [expr $i+1]]
+ set y [lindex $var [expr $i+2]]
+ set sys [lindex $var [expr $i+3]]
+ set sky [lindex $var [expr $i+4]]
+ set format {}
+
+ incr i 2
+ incr i [FixSpec sys sky format physical fk5 degrees]
+ PanTo $x $y $sys $sky
+ }
+ default {
+ set x [lindex $var [expr $i+0]]
+ set y [lindex $var [expr $i+1]]
+ set sys [lindex $var [expr $i+2]]
+ set sky [lindex $var [expr $i+3]]
+ set format {}
+
+ incr i 1
+ incr i [FixSpec sys sky format physical fk5 degrees]
+ Pan $x $y $sys $sky
+ }
+ }
+}
+
+proc ProcessSendPanCmd {proc id param} {
+ global current
+
+ set sys [lindex $param 0]
+ set sky [lindex $param 1]
+ set format [lindex $param 2]
+ FixSpec sys sky format physical fk5 degrees
+
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get cursor $sys $sky $format]\n"
+ }
+}
+
+proc ProcessZoomCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ global current
+ switch -- [string tolower [lindex $var $i]] {
+ open {PanZoomDialog}
+ close {PanZoomDestroyDialog}
+ in {Zoom 2 2}
+ out {Zoom .5 .5}
+ to {
+ switch -- [string tolower [lindex $var [expr $i+1]]] {
+ fit {
+ ZoomToFit
+ incr i
+ }
+ default {
+ set z1 [lindex $var [expr $i+1]]
+ set z2 [lindex $var [expr $i+2]]
+ if {[string is double $z2] && $z2 != {}} {
+ set current(zoom) " $z1 $z2 "
+ incr i 2
+ } else {
+ set current(zoom) " $z1 $z1 "
+ incr i
+ }
+ ChangeZoom
+ }
+ }
+ }
+ default {
+ set z1 [lindex $var $i]
+ set z2 [lindex $var [expr $i+1]]
+ if {[string is double $z2] && $z2 != {}} {
+ Zoom $z1 $z2
+ incr i
+ } else {
+ Zoom $z1 $z1
+ }
+ }
+ }
+}
+
+proc ProcessSendZoomCmd {proc id param} {
+ global current
+
+ set z1 [lindex $current(zoom) 0]
+ set z2 [lindex $current(zoom) 1]
+ if {$z1 != $z2} {
+ $proc $id "$current(zoom)\n"
+ } else {
+ $proc $id "$z1\n"
+ }
+}
+
+proc ProcessOrientCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ global current
+ switch -- [string tolower [lindex $var $i]] {
+ open {PanZoomDialog}
+ close {PanZoomDestroyDialog}
+ default {
+ set current(orient) [string tolower [lindex $var $i]]
+ ChangeOrient
+ }
+ }
+}
+
+proc ProcessSendOrientCmd {proc id param} {
+ global current
+ $proc $id "$current(orient)\n"
+}
+
+proc ProcessRotateCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ global current
+ switch -- [string tolower [lindex $var $i]] {
+ open {PanZoomDialog}
+ close {PanZoomDestroyDialog}
+ to {
+ set current(rotate) [lindex $var [expr $i+1]]
+ ChangeRotate
+ incr i
+ }
+ default {Rotate [lindex $var $i]}
+ }
+}
+
+proc ProcessSendRotateCmd {proc id param} {
+ global current
+ $proc $id "$current(rotate)\n"
+}
+
diff --git a/ds9/library/photo.tcl b/ds9/library/photo.tcl
new file mode 100644
index 0000000..fe70891
--- /dev/null
+++ b/ds9/library/photo.tcl
@@ -0,0 +1,300 @@
+# 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 ImportPhotoFile {fn mode} {
+ global loadParam
+
+ set loadParam(file,type) photo
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) photo
+
+ # find stdin
+ if {[string range $fn 0 4] == "stdin" ||
+ [string range $fn 0 4] == "STDIN" ||
+ [string range $fn 0 0] == "-"} {
+
+ fconfigure stdin -translation binary -encoding binary
+ if {[catch {image create photo -data [read -nonewline stdin]} ph]} {
+ Error [msgcat::mc {An error has occurred while reading image.}]
+ return
+ }
+ set loadParam(file,name) stdin
+ } else {
+ if {[catch {image create photo -file $fn} ph]} {
+ Error [msgcat::mc {An error has occurred while reading image.}]
+ return
+ }
+ set loadParam(file,name) $fn
+ }
+ set loadParam(var,name) $ph
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+
+ image delete $ph
+}
+
+proc ImportPhotoAlloc {path fn mode} {
+ global loadParam
+
+ set loadParam(file,type) photo
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) photo
+
+ if {[catch {image create photo -file $path} ph]} {
+ Error [msgcat::mc {An error has occurred while reading image.}]
+ return
+ }
+ set loadParam(file,name) $fn
+ set loadParam(var,name) $ph
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+
+ image delete $ph
+}
+
+proc ImportPhotoSocket {ch fn mode} {
+ global loadParam
+
+ set loadParam(file,type) photo
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) photo
+ set loadParam(file,name) $fn
+
+ fconfigure $ch -translation binary -encoding binary
+ if {[catch {image create photo -data [read $ch]} ph]} {
+ Error [msgcat::mc {An error has occurred while reading image.}]
+ return 0
+ }
+ set loadParam(var,name) $ph
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ set rr [ProcessLoad 0]
+
+ image delete $ph
+ return $rr
+}
+
+proc ExportPhotoFile {fn format opt} {
+ global export
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {[catch {image create photo} ph]} {
+ Error [msgcat::mc {An error has occurred while creating image.}]
+ return
+ }
+
+ $current(frame) save photo $ph
+ set ff $format
+ switch -- $format {
+ jpeg {
+ if {$opt == {}} {
+ set opt $export(jpeg,quality)
+ }
+ set ff [list $format -quality $opt]
+ }
+ tiff {
+ if {$opt == {}} {
+ set opt $export(tiff,compress)
+ }
+ set ff [list $format -compression $opt]
+ }
+ }
+ if {[catch {$ph write $fn -format $ff}]} {
+ Error [msgcat::mc {An error has occurred while writing image.}]
+ }
+
+ image delete $ph
+}
+
+proc ExportPhotoSocket {ch format opt} {
+ global export
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ if {[catch {image create photo} ph]} {
+ Error [msgcat::mc {An error has occurred while creating image.}]
+ return
+ }
+
+ $current(frame) save photo $ph
+
+ fconfigure $ch -translation binary -encoding binary
+ set ff $format
+ switch -- $format {
+ jpeg {
+ if {$opt == {}} {
+ set opt $export(jpeg,quality)
+ }
+ set ff [list $format -quality $opt]
+ }
+ tiff {
+ if {$opt == {}} {
+ set opt $export(tiff,compress)
+ }
+ set ff [list $format -compression $opt]
+ }
+ }
+ if {[catch {$ph data -format $ff} data]} {
+ Error [msgcat::mc {An error has occurred while writing image.}]
+ return
+ }
+ puts -nonewline $ch [base64::decode $data]
+
+ image delete $ph
+}
+
+# Process Cmds
+
+proc ProcessGIFCmd {varname iname ch fn} {
+ upvar $varname var
+ upvar $iname i
+
+ ProcessPhotoCmd $varname $iname $ch $fn
+}
+
+proc ProcessJPEGCmd {varname iname ch fn} {
+ upvar $varname var
+ upvar $iname i
+
+ ProcessPhotoCmd $varname $iname $ch $fn
+}
+
+proc ProcessPNGCmd {varname iname ch fn} {
+ upvar $varname var
+ upvar $iname i
+
+ ProcessPhotoCmd $varname $iname $ch $fn
+}
+
+proc ProcessTIFFCmd {varname iname ch fn} {
+ upvar $varname var
+ upvar $iname i
+
+ ProcessPhotoCmd $varname $iname $ch $fn
+}
+
+proc ProcessPhotoCmd {varname iname ch fn} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ global loadParam
+ global current
+
+ set mode {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ set mode slice
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$ch != {}} {
+ # xpa
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {
+ if {![ImportPhotoSocket $ch $param $mode]} {
+ InitError xpa
+ ImportPhotoFile $param $mode
+ }
+ }
+ {Windows NT} {ImportPhotoFile $param $mode}
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ ImportPhotoAlloc $fn $param $mode
+ } else {
+ ImportPhotoFile $param $mode
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendGIFCmd {proc id param ch fn} {
+ global current
+
+ ProcessSendPhotoCmd gif $proc $id $param $ch $fn
+}
+
+proc ProcessSendJPEGCmd {proc id param ch fn} {
+ global current
+
+ ProcessSendPhotoCmd jpeg $proc $id $param $ch $fn
+}
+
+proc ProcessSendPNGCmd {proc id param ch fn} {
+ global current
+
+ ProcessSendPhotoCmd png $proc $id $param $ch $fn
+}
+
+proc ProcessSendTIFFCmd {proc id param ch fn} {
+ global current
+
+ ProcessSendPhotoCmd tiff $proc $id $param $ch $fn
+}
+
+proc ProcessSendPhotoCmd {format proc id param ch fn} {
+ global current
+ global export
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set opt [string tolower [lindex $param 0]]
+ if {$ch != {}} {
+ # xpa
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ExportPhotoSocket $ch $format $opt}
+ {Windows NT} {}
+ }
+ } elseif {$fn != {}} {
+ # comm
+ ExportPhotoFile $fn $format $opt
+ $proc $id {} $fn
+ }
+}
diff --git a/ds9/library/pixel.tcl b/ds9/library/pixel.tcl
new file mode 100644
index 0000000..cbca655
--- /dev/null
+++ b/ds9/library/pixel.tcl
@@ -0,0 +1,295 @@
+# 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 PixelDef {} {
+ global pixel
+ global ipixel
+ global dpixel
+ global ppixel
+
+ set ipixel(top) .pixel
+ set ipixel(mb) .pixelmb
+ set ipixel(max) 13
+
+ set pixel(size) 5
+ array set ppixel [array get pixel]
+
+ set dpixel(copy) {}
+ set dpixel(tbl) {}
+}
+
+proc UpdatePixelTableDialog {which x y sys} {
+ global pixel
+ global ipixel
+ global dpixel
+
+ if {[winfo exists $ipixel(top)]} {
+ $which get pixel table $sys $x $y $pixel(size) $pixel(size) dpixel
+ }
+}
+
+proc PixelTableDialog {} {
+ global pixel
+ global ipixel
+ global dpixel
+
+ global ds9
+
+ if {[winfo exists $ipixel(top)]} {
+ raise $ipixel(top)
+ return
+ }
+
+ # create the pixel table window
+ set w $ipixel(top)
+ set mb $ipixel(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Pixel Table}] PixelTableDestroyDialog
+
+ $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 {Size}] -menu $mb.size
+
+ menu $mb.file
+ $mb.file add command -label "[msgcat::mc {Save}]..." \
+ -command PixelTableSaveDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command PixelTableDestroyDialog
+
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -state disabled -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command PixelTableCopyDialog -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -state disabled -accelerator "${ds9(ctrl)}V"
+
+ menu $mb.size
+ for {set ii 3} {$ii<=$ipixel(max)} {incr ii 2} {
+ $mb.size add radiobutton -label "${ii}x${ii}" -variable pixel(size) \
+ -value $ii -command PixelTableConfigure
+ }
+
+ set f [ttk::frame $w.tbl]
+ set dpixel(tbl) [table $f.t \
+ -state disabled \
+ -anchor w \
+ -font [font actual TkDefaultFont] \
+ -variable dpixel \
+ -usecommand 0 \
+ -maxwidth 1200 \
+ ]
+
+ $dpixel(tbl) tag col coord 0
+ $dpixel(tbl) tag row coord 0
+ $dpixel(tbl) tag configure coord -foreground blue
+ $dpixel(tbl) tag configure center -foreground red
+
+ grid $f.t -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 0 -weight 1
+
+ set f [ttk::frame $w.buttons]
+ ttk::button $w.buttons.close -text [msgcat::mc {Close}] \
+ -command PixelTableDestroyDialog
+ pack $w.buttons.close -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.tbl -side top -fill both -expand true
+
+ selection handle $w PixelTableExportSelection
+
+ PixelTableConfigure
+
+ # dummy info
+ for {set jj 0} {$jj<=$pixel(size)} {incr jj} {
+ for {set ii 0} {$ii<=$pixel(size)} {incr ii} {
+ set dpixel($ii,$jj) {}
+ }
+ }
+}
+
+proc PixelTableDestroyDialog {} {
+ global ipixel
+ global dpixel
+
+ if {[winfo exists $ipixel(top)]} {
+ destroy $ipixel(top)
+ destroy $ipixel(mb)
+ }
+
+ if {[info exists dpixel]} {
+ unset dpixel
+ }
+}
+
+proc PixelTableCopyDialog {} {
+ global ipixel
+ global dpixel
+
+ set dpixel(copy) [PixelTableRender]
+
+ selection own -command PixelTableLostSelection $ipixel(top)
+
+ clipboard clear
+ clipboard append $dpixel(copy)
+}
+
+proc PixelTableClearDialog {} {
+ global pixel
+ global ipixel
+ global dpixel
+ global dpixel
+
+ if {[winfo exists $ipixel(top)]} {
+ for {set jj 0} {$jj<=$pixel(size)} {incr jj} {
+ for {set ii 0} {$ii<=$pixel(size)} {incr ii} {
+ set dpixel($ii,$jj) {}
+ }
+ }
+ }
+}
+
+proc PixelTableSaveDialog {} {
+ set filename [SaveFileDialog pixelfbox]
+
+ if {$filename != {}} {
+ set file [open $filename w]
+ puts -nonewline $file [PixelTableRender]
+ close $file
+ }
+}
+
+# support
+
+proc PixelTableConfigure {} {
+ global pixel
+ global ipixel
+ global dpixel
+
+ set ss [expr $pixel(size)+1]
+ $dpixel(tbl) configure -rows $ss -cols $ss
+ for {set ii 1} {$ii<=$ipixel(max)} {incr ii} {
+ $dpixel(tbl) tag cell {} $ii,$ii
+ }
+ set hh [expr int($ss/2.)]
+ $dpixel(tbl) tag cell center $hh,$hh
+}
+
+proc PixelTableRender {} {
+ global pixel
+ global dpixel
+
+ set rr {}
+ # col header
+ append rr " "
+ for {set ii 1} {$ii<=$pixel(size)} {incr ii} {
+ set msg [format "%12s" $dpixel(0,${ii})]
+ append rr "$msg"
+ }
+ append rr "\n"
+
+ append rr " "
+ for {set ii 1} {$ii<=$pixel(size)} {incr ii} {
+ append rr " -----------"
+ }
+ append rr "\n"
+
+ # body
+ for {set jj 1} {$jj<=$pixel(size)} {incr jj} {
+ set msg [format "%10s" $dpixel(${jj},0)]
+ append rr "$msg |"
+ for {set ii 1} {$ii<=$pixel(size)} {incr ii} {
+ set msg [format "%12.11s" $dpixel($jj,$ii)]
+ append rr "$msg"
+ }
+ append rr "\n"
+ }
+
+ return $rr
+}
+
+proc PixelTableExportSelection {offset bytes} {
+ global dpixel
+
+ if {$dpixel(copy) != {}} {
+ return [string range $dpixel(copy) $offset [expr $offset+$bytes]]
+ }
+}
+
+proc PixelTableLostSelection {} {
+ global dpixel
+
+ set dpixel(copy) {}
+}
+
+proc PrefsDialogPixelTable {} {
+ global dprefs
+ global ppixel
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Pixel Table}]
+ lappend dprefs(tabs) [ttk::frame $w.pixel]
+
+ set f [ttk::labelframe $w.pixel.param -text [msgcat::mc {Pixel Table}]]
+
+ ttk::label $f.tsize -text [msgcat::mc {Size}]
+
+ PrefsDialogPixelTableButtonCmd $ppixel(size)
+ ttk::menubutton $f.size -textvariable dprefs(pixeltable,msg) \
+ -menu $f.size.menu
+
+ global ipixel
+ set m $f.size.menu
+ menu $m
+ for {set ii 3} {$ii<=$ipixel(max)} {incr ii 2} {
+ $m add radiobutton -label "${ii}x${ii}" -variable ppixel(size) \
+ -value $ii -command [list PrefsDialogPixelTableButtonCmd $ii]
+ }
+ grid $f.tsize $f.size -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+proc PrefsDialogPixelTableButtonCmd {ii} {
+ global dprefs
+ global pixel
+
+ set dprefs(pixeltable,msg) "${ii}x${ii}"
+}
+
+proc ProcessPixelTableCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ switch -- [string tolower [lindex $var $i]] {
+ open -
+ yes -
+ true -
+ on -
+ 1 {PixelTableDialog}
+
+ close -
+ no -
+ false -
+ off -
+ 0 {PixelTableDestroyDialog}
+
+ default {
+ PixelTableDialog
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendPixelTableCmd {proc id param sock fn} {
+ PixelTableDialog
+ ProcessSend $proc $id $sock $fn {.txt} [PixelTableRender]
+}
diff --git a/ds9/library/plot.tcl b/ds9/library/plot.tcl
new file mode 100644
index 0000000..fdd167d
--- /dev/null
+++ b/ds9/library/plot.tcl
@@ -0,0 +1,1360 @@
+# 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 PlotDef {} {
+ global pap
+ global iap
+
+ set iap(tt) {ap}
+ set iap(windows) {}
+ set iap(unique) 0
+
+ set pap(graph,title) {}
+ set pap(graph,title,family) helvetica
+ set pap(graph,title,size) 12
+ set pap(graph,title,weight) normal
+ set pap(graph,title,slant) roman
+
+ set pap(legend) 0
+ set pap(legend,title) Legend
+ set pap(legend,position) right
+ set pap(legend,title,family) helvetica
+ set pap(legend,title,size) 10
+ set pap(legend,title,weight) normal
+ set pap(legend,title,slant) roman
+ set pap(legend,font,family) helvetica
+ set pap(legend,font,size) 9
+ set pap(legend,font,weight) normal
+ set pap(legend,font,slant) roman
+
+ set pap(axis,x,title) {}
+ set pap(axis,x,grid) 1
+ set pap(axis,x,log) 0
+ set pap(axis,x,flip) 0
+ set pap(axis,x,auto) 1
+ set pap(axis,x,min) {}
+ set pap(axis,x,max) {}
+ set pap(axis,x,format) {}
+
+ set pap(axis,y,title) {}
+ set pap(axis,y,grid) 1
+ set pap(axis,y,log) 0
+ set pap(axis,y,flip) 0
+ set pap(axis,y,auto) 1
+ set pap(axis,y,min) {}
+ set pap(axis,y,max) {}
+ set pap(axis,y,format) {}
+
+ set pap(axis,title,family) helvetica
+ set pap(axis,title,size) 9
+ set pap(axis,title,weight) normal
+ set pap(axis,title,slant) roman
+
+ set pap(axis,font,family) helvetica
+ set pap(axis,font,size) 9
+ set pap(axis,font,weight) normal
+ set pap(axis,font,slant) roman
+
+ set pap(show) 1
+ set pap(shape,symbol) none
+ set pap(shape,fill) 1
+ set pap(shape,color) red
+ set pap(smooth) linear
+ set pap(color) black
+ set pap(fill) 0
+ set pap(fill,color) black
+ set pap(width) 1
+ set pap(dash) 0
+
+ set pap(error) 1
+ set pap(error,cap) 0
+ set pap(error,color) red
+ set pap(error,width) 1
+
+ set pap(bar,relief) raised
+ set pap(bar,mode) normal
+}
+
+proc PlotAxisFormat {varname axis w nn} {
+ upvar #0 $varname var
+ global $varname
+
+ return [format $var(axis,$axis,format) $nn]
+}
+
+proc PlotClearData {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ # first set can be external
+ set clear $var(1,manage)
+
+ for {set nn 1} {$nn<=$var(data,total)} {incr nn} {
+ if {$var($nn,manage)} {
+ # delete elements
+ foreach el [$var(graph) element names] {
+ set f [split $el -]
+ if {[lindex $f 1] == $nn} {
+ $var(graph) element delete $el
+ }
+ }
+
+ # destroy vectors
+ blt::vector destroy $var($nn,xdata) $var($nn,ydata)
+ switch $var($nn,dim) {
+ xy {}
+ xyex {blt::vector destroy $var($nn,xedata)}
+ xyey {blt::vector destroy $var($nn,yedata)}
+ xyexey {blt::vector destroy $var($nn,xedata) $var($nn,yedata)}
+ }
+
+ foreach x [array names $varname] {
+ set f [split $x ,]
+ if {([lindex $f 0] == $nn)} {
+ unset ${varname}($x)
+ }
+ }
+ }
+ }
+
+ if {$clear} {
+ set var(data,total) 0
+ set var(data,current) 0
+
+ set var(name) {}
+ set var(xdata) {}
+ set var(ydata) {}
+ set var(xedata) {}
+ set var(yedata) {}
+
+ # reset other variables
+ set var(axis,x,auto) 1
+ set var(axis,x,min) {}
+ set var(axis,x,max) {}
+ set var(axis,x,format) {}
+
+ set var(axis,y,auto) 1
+ set var(axis,y,min) {}
+ set var(axis,y,max) {}
+ set var(axis,y,format) {}
+
+ $var(mb).select delete $ds9(menu,start) end
+
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+ } else {
+ set var(data,total) 1
+ set var(data,current) 1
+
+ $var(mb).select delete [expr $ds9(menu,start)+1] end
+ PlotCurrentData $varname
+ $var(proc,updategraph) $varname
+ }
+}
+
+proc PlotCurrentData {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(data,total) > 0} {
+ set nn $var(data,current)
+
+ set var(manage) $var($nn,manage)
+ set var(dim) $var($nn,dim)
+
+ set var(xdata) $var($nn,xdata)
+ set var(ydata) $var($nn,ydata)
+ set var(xedata) $var($nn,xedata)
+ set var(yedata) $var($nn,yedata)
+
+ PlotSetVar $varname $nn
+ }
+
+ PlotStats $varname
+ PlotList $varname
+}
+
+proc PlotDataSet {varname dim data} {
+ upvar #0 $varname var
+ global $varname
+
+ switch -- $dim {
+ 4 {
+ # first data set
+ PlotDataSetOne $varname "4.1" $data
+
+ # set color
+ set cc $var(color)
+ set var(color) [PlotNextColor $var(color)]
+
+ # second data set
+ PlotDataSetOne $varname "4.2" $data
+ set var(color) $cc
+ }
+ 5 {
+ # first data set
+ PlotDataSetOne $varname "5.1" $data
+
+ # set color
+ set cc $var(color)
+ set var(color) [PlotNextColor $var(color)]
+
+ # second data set
+ PlotDataSetOne $varname "5.2" $data
+ set var(color) $cc
+ }
+ default {PlotDataSetOne $varname $dim $data}
+ }
+}
+
+proc PlotDataSetOne {varname dim data} {
+ upvar #0 $varname var
+ global $varname
+
+ # look for no data
+ if {[string length $data] == 0} {
+ return
+ }
+
+ # total length
+ set ll [llength $data]
+ set ii 0
+
+ while {$ii<$ll} {
+ # incr count
+ incr ${varname}(data,total)
+ set nn $var(data,total)
+ set var(data,current) $nn
+
+ # new vector names
+ set xdata ap${varname}xx${nn}
+ set ydata ap${varname}yy${nn}
+ set xedata ap${varname}xe${nn}
+ set yedata ap${varname}ye${nn}
+
+ # basics xy
+ set var(manage) 1
+ set var(name) "Dataset $nn"
+ set var(xdata) $xdata
+ set var(ydata) $ydata
+ global $var(xdata) $var(ydata)
+ blt::vector create $var(xdata) $var(ydata)
+
+ # substitute all separtors
+ regsub -all {[\n\r\t, ]+} $data { } data
+ # remove all non-numeric data
+ regsub -all {[^0-9.e\- ]+} $data {} data
+
+ set ox [lindex $data $ii]
+ set x {}
+ set y {}
+ set xe {}
+ set ye {}
+ switch -- $dim {
+ 2 -
+ xy {
+ set var(dim) xy
+ set var(xedata) {}
+ set var(yedata) {}
+
+ for {} {$ii<$ll} {incr ii 2} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ }
+
+ xyex {
+ set var(dim) xyex
+ set var(xedata) $xedata
+ set var(yedata) {}
+
+ global $var(xedata)
+ blt::vector create $var(xedata)
+
+ for {} {$ii<$ll} {incr ii 3} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend xe [lindex $data [expr $ii+2]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend xe [lindex $data [expr $ii+2]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ $var(xedata) set $xe
+ }
+
+ 3 -
+ xyey {
+ set var(dim) xyey
+ set var(xedata) {}
+ set var(yedata) $yedata
+
+ global $var(yedata)
+ blt::vector create $var(yedata)
+
+ for {} {$ii<$ll} {incr ii 3} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend ye [lindex $data [expr $ii+2]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend ye [lindex $data [expr $ii+2]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ $var(yedata) set $ye
+ }
+
+ xyexey {
+ set var(dim) xyexey
+ set var(xedata) $xedata
+ set var(yedata) $yedata
+
+ global $var(xedata) $var(yedata)
+ blt::vector create $var(xedata) $var(yedata)
+
+ for {} {$ii<$ll} {incr ii 4} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend xe [lindex $data [expr $ii+2]]
+ lappend ye [lindex $data [expr $ii+3]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend xe [lindex $data [expr $ii+2]]
+ lappend ye [lindex $data [expr $ii+3]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ $var(xedata) set $xe
+ $var(yedata) set $ye
+ }
+
+ 4.1 {
+ set var(dim) xyey
+ set var(xedata) {}
+ set var(yedata) $yedata
+
+ global $var(yedata)
+ blt::vector create $var(yedata)
+
+ for {} {$ii<$ll} {incr ii 4} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend ye [lindex $data [expr $ii+2]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend ye [lindex $data [expr $ii+2]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ $var(yedata) set $ye
+ }
+
+ 4.2 {
+ set var(dim) xy
+ set var(xedata) {}
+ set var(yedata) {}
+
+ for {} {$ii<$ll} {incr ii 4} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+3]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+3]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ }
+
+ 5.1 {
+ set var(dim) xyey
+ set var(xedata) {}
+ set var(yedata) $yedata
+
+ global $var(yedata)
+ blt::vector create $var(yedata)
+
+ for {} {$ii<$ll} {incr ii 5} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend ye [lindex $data [expr $ii+2]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+1]]
+ lappend ye [lindex $data [expr $ii+2]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ $var(yedata) set $ye
+ }
+
+ 5.2 {
+ set var(dim) xyey
+ set var(xedata) {}
+ set var(yedata) $yedata
+
+ global $var(yedata)
+ blt::vector create $var(yedata)
+
+ for {} {$ii<$ll} {incr ii 5} {
+ set tx [lindex $data $ii]
+ if {$var(seq)} {
+ if {$ox<=$tx} {
+ set ox $tx
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+3]]
+ lappend ye [lindex $data [expr $ii+4]]
+ } else {
+ break
+ }
+ } else {
+ lappend x $tx
+ lappend y [lindex $data [expr $ii+3]]
+ lappend ye [lindex $data [expr $ii+4]]
+ }
+ }
+ $var(xdata) set $x
+ $var(ydata) set $y
+ $var(yedata) set $ye
+ }
+ }
+
+ set var($nn,manage) 1
+ set var($nn,dim) $var(dim)
+
+ set var($nn,xdata) $var(xdata)
+ set var($nn,ydata) $var(ydata)
+ set var($nn,xedata) $var(xedata)
+ set var($nn,yedata) $var(yedata)
+
+ PlotGetVar $varname $nn
+
+ # update data set menu
+ $var(mb).select add radiobutton -label "$var(name)" \
+ -variable ${varname}(data,current) -value $nn \
+ -command [list PlotCurrentData $varname]
+
+ PlotCreateElement $varname
+ $var(proc,updateelement) $varname
+ }
+}
+
+proc PlotDupData {varname mm} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ # incr count
+ incr ${varname}(data,total)
+ set nn $var(data,total)
+ set pp [expr $nn-1]
+
+ # new vector names
+ set var($nn,name) "Dataset $nn"
+ set var($nn,xdata) ap${varname}xx${nn}
+ set var($nn,ydata) ap${varname}yy${nn}
+ set var($nn,xedata) ap${varname}xe${nn}
+ set var($nn,yedata) ap${varname}ye${nn}
+ global $var($mm,xdata) $var($mm,ydata) $var($mm,xedata) $var($mm,yedata)
+ global $var($nn,xdata) $var($nn,ydata) $var($nn,xedata) $var($nn,yedata)
+
+ $var($mm,xdata) dup $var($nn,xdata)
+ $var($mm,ydata) dup $var($nn,ydata)
+ if {$var($mm,xedata) != {}} {
+ $var($mm,xedata) dup $var($nn,xedata)
+ } else {
+ set var($nn,xedata) {}
+ }
+ if {$var($mm,yedata) != {}} {
+ $var($mm,yedata) dup $var($nn,yedata)
+ } else {
+ set var($nn,yedata) {}
+ }
+
+ set var($nn,manage) 1
+ set var($nn,dim) $var($mm,dim)
+
+ set var($nn,show) $var($mm,show)
+ set var($nn,shape,symbol) $var($mm,shape,symbol)
+ set var($nn,shape,fill) $var($mm,shape,fill)
+ set var($nn,shape,color) $var($mm,shape,color)
+ set var($nn,smooth) $var($mm,smooth)
+ set var($nn,color) [PlotNextColor $var($mm,color)]
+ set var($nn,fill) $var($mm,fill)
+ set var($nn,fill,color) [PlotNextColor $var($mm,fill,color)]
+ set var($nn,width) $var($mm,width)
+ set var($nn,dash) $var($mm,dash)
+ set var($nn,error) $var($mm,error)
+ set var($nn,error,cap) $var($mm,error,cap)
+ set var($nn,error,color) $var($mm,error,color)
+ set var($nn,error,width) $var($mm,error,width)
+ set var($nn,bar,relief) $var($mm,bar,relief)
+
+ # update data set menu
+ $var(mb).select add radiobutton -label "$var($nn,name)" \
+ -variable ${varname}(data,current) -value $nn \
+ -command [list PlotCurrentData $varname]
+
+ # make current
+ set var(data,current) $nn
+
+ set var(manage) $var($nn,manage)
+ set var(dim) $var($nn,dim)
+
+ set var(xdata) $var($nn,xdata)
+ set var(ydata) $var($nn,ydata)
+ set var(xedata) $var($nn,xedata)
+ set var(yedata) $var($nn,yedata)
+
+ PlotSetVar $varname $nn
+
+ PlotCreateElement $varname
+ $var(proc,updateelement) $varname
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+}
+
+proc PlotDestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global iap
+
+ # see if it still is around
+ if {![PlotPing $varname]} {
+ return
+ }
+
+ for {set nn 1} {$nn<=$var(data,total)} {incr nn} {
+ switch $var($nn,dim) {
+ xy {
+ blt::vector destroy $var($nn,xdata) $var($nn,ydata)
+ }
+ xyex {
+ blt::vector destroy $var($nn,xdata) $var($nn,ydata) \
+ $var($nn,xedata)
+ }
+ xyey {
+ blt::vector destroy $var($nn,xdata) $var($nn,ydata) \
+ $var($nn,yedata)
+ }
+ xyexey {
+ blt::vector destroy $var($nn,xdata) $var($nn,ydata) \
+ $var($nn,xedata) $var($nn,yedata)
+ }
+ }
+ }
+
+ destroy $var(top)
+ destroy $var(mb)
+
+ # stats window?
+ if {$var(stats)} {
+ SimpleTextDestroy "${varname}stats"
+ }
+
+ # list window?
+ if {$var(list)} {
+ SimpleTextDestroy "${varname}list"
+ }
+
+ # delete it from the xpa list
+ set ii [lsearch $iap(windows) $varname]
+ if {$ii>=0} {
+ set iap(windows) [lreplace $iap(windows) $ii $ii]
+ }
+
+ unset $varname
+}
+
+proc PlotExternal {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # incr count
+ incr ${varname}(data,total)
+ set nn $var(data,total)
+ set var(data,current) $nn
+
+ set var(name) "Dataset $nn"
+
+ set var($nn,manage) $var(manage)
+ set var($nn,dim) $var(dim)
+
+ set var($nn,xdata) $var(xdata)
+ set var($nn,ydata) $var(ydata)
+ set var($nn,xedata) $var(xedata)
+ set var($nn,yedata) $var(yedata)
+
+ PlotGetVar $varname $nn
+
+ # update data set menu
+ $var(mb).select add radiobutton -label "[msgcat::mc {Dataset}] $nn" \
+ -variable ${varname}(data,current) -value $nn \
+ -command "PlotCurrentData $varname"
+
+ PlotCreateElement $varname
+}
+
+proc PlotList {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {!$var(list)} {
+ return
+ }
+
+ set rr [PlotListGenerate $varname]
+ SimpleTextDialog "${varname}list" [msgcat::mc {Data}] \
+ 40 20 insert top $rr PlotListDestroyCB $varname
+}
+
+proc PlotListGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set rr {}
+ if {$var(xdata) != {}} {
+ global $var(xdata) $var(ydata) $var(xedata) $var(yedata)
+ set ll [$var(xdata) length]
+ set xx [$var(xdata) range]
+ set yy [$var(ydata) range]
+
+ switch $var(dim) {
+ xy {
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ append rr "[lindex $xx $ii] [lindex $yy $ii]\n"
+ }
+ }
+ xyex {
+ set xe [$var(xedata) range]
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ append rr "[lindex $xx $ii] [lindex $yy $ii] [lindex $xe $ii]\n"
+ }
+ }
+ xyey {
+ set ye [$var(yedata) range]
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ append rr "[lindex $xx $ii] [lindex $yy $ii] [lindex $ye $ii]\n"
+ }
+ }
+ xyexey {
+ set xe [$var(xedata) range]
+ set ye [$var(yedata) range]
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ append rr "[lindex $xx $ii] [lindex $yy $ii] [lindex $xe $ii] [lindex $ye $ii]\n"
+ }
+ }
+ }
+ }
+
+ return $rr
+}
+
+proc PlotListDestroyCB {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(list) 0
+}
+
+proc PlotLoadConfig {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ PlotLoadConfigFile $varname [OpenFileDialog apconfigfbox]
+}
+
+# used by backup
+proc PlotLoadConfigFile {varname filename} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$filename != {}} {
+ source $filename
+ array set $varname [array get analysisplot]
+ unset analysisplot
+
+ # backward compatibility
+ FixVar ${varname}(axis,x,grid) ${varname}(graph,x,grid)
+ FixVar ${varname}(axis,x,log) ${varname}(graph,x,log)
+ FixVar ${varname}(axis,x,flip) ${varname}(graph,x,flip)
+ FixVar ${varname}(axis,y,grid) ${varname}(graph,y,grid)
+ FixVar ${varname}(axis,y,log) ${varname}(graph,y,log)
+ FixVar ${varname}(axis,y,flip) ${varname}(graph,y,flip)
+
+ FixVar ${varname}(graph,title,family) ${varname}(titleFont)
+ FixVar ${varname}(graph,title,size) ${varname}(titleSize)
+ FixVar ${varname}(graph,title,weight) ${varname}(titleWeight)
+ FixVar ${varname}(graph,title,slant) ${varname}(titleSlant)
+
+ FixVar ${varname}(axis,title,family) ${varname}(textlabFont)
+ FixVar ${varname}(axis,title,size) ${varname}(textlabSize)
+ FixVar ${varname}(axis,title,weight) ${varname}(textlabWeight)
+ FixVar ${varname}(axis,title,slant) ${varname}(textlabSlant)
+
+ FixVar ${varname}(axis,font,family) ${varname}(numlabFont)
+ FixVar ${varname}(axis,font,size) ${varname}(numlabSize)
+ FixVar ${varname}(axis,font,weight) ${varname}(numlabWeight)
+ FixVar ${varname}(axis,font,slant) ${varname}(numlabSlant)
+
+ FixVar ${varname}(show) ${varname}(linear)
+ FixVar ${varname}(shape,color) ${varname}(discrete,color)
+ FixVar ${varname}(shape,fill) ${varname}(discrete,fill)
+ FixVar ${varname}(width) ${varname}(linear,width)
+ FixVar ${varname}(color) ${varname}(linear,color)
+ if {[info exists ${varname}(linear,dash)]} {
+ set var(linear,dash) [FromYesNo $var(linear,dash)]
+ }
+ FixVar ${varname}(dash) ${varname}(linear,dash)
+
+ if {[info exists ${varname}(discrete)]} {
+ if {$var(discrete)} {
+ FixVar ${varname}(shape,symbol) ${varname}(discrete,symbol)
+ } else {
+ FixVarRm ${varname}(discrete,symbol)
+ }
+ }
+
+ FixVarRm ${varname}(bar)
+ FixVarRm ${varname}(bar,color)
+
+ FixVarRm ${varname}(discrete)
+
+ FixVarRm ${varname}(quadratic)
+ FixVarRm ${varname}(quadratic,width)
+ FixVarRm ${varname}(quadratic,color)
+ FixVarRm ${varname}(quadratic,dash)
+
+ FixVarRm ${varname}(step)
+ FixVarRm ${varname}(step,color)
+ FixVarRm ${varname}(step,dash)
+ FixVarRm ${varname}(step,width)
+
+ if {[info exists var(grid)]} {
+ set var(axis,x,grid) $var(grid)
+ set var(axis,y,grid) $var(grid)
+ unset var(grid)
+ }
+ if {[info exists var(format)]} {
+ set var(graph,format) $var(format)
+ set var(axis,x,format) $var(format,x)
+ set var(axis,y,format) $var(format,y)
+ unset var(format)
+ unset var(format,x)
+ unset var(format,y)
+ }
+
+ if {[info exists var(grid,log)]} {
+ switch $var(grid,log) {
+ linearlinear {
+ set var(axis,x,log) 0
+ set var(axis,y,log) 0
+ }
+ linearlog {
+ set var(axis,x,log) 0
+ set var(axis,y,log) 1
+ }
+ loglinear {
+ set var(axis,x,log) 1
+ set var(axis,y,log) 0
+ }
+ loglog {
+ set var(axis,x,log) 1
+ set var(axis,y,log) 1
+ }
+ }
+ unset var(grid,log)
+ }
+
+ $var(proc,updategraph) $varname
+ $var(proc,updateelement) $varname
+ }
+}
+
+proc PlotLoadData {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set filename [OpenFileDialog apdatafbox]
+ if {$filename != {}} {
+ set dim xy
+ if {[PlotDataFormatDialog dim]} {
+ PlotLoadDataFile $varname $filename $dim
+ }
+ }
+}
+
+# used by backup
+proc PlotLoadDataFile {varname filename dim} {
+ upvar #0 $varname var
+ global $varname
+
+ set ch [open $filename]
+ set data [read $ch]
+ close $ch
+
+ PlotRaise $varname
+
+ PlotDataSet $varname $dim $data
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+}
+
+proc PlotNextColor {which} {
+ switch -- $which {
+ black {return red}
+ red {return green}
+ green {return blue}
+ blue {return cyan}
+ cyan {return magenta}
+ magenta {return yellow}
+ yellow {return black}
+ white {return white}
+ default {return red}
+ }
+}
+
+proc PlotPing {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[info exists var(top)]} {
+ if {[winfo exists $var(top)]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc PlotRaise {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[PlotPing $varname]} {
+ raise $var(top)
+ return 1
+ }
+ return 0
+}
+
+proc PlotSaveConfig {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ PlotSaveConfigFile $varname [SaveFileDialog apconfigfbox]
+}
+
+proc PlotSaveConfigFile {varname filename} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$filename == {}} {
+ return
+ }
+
+ set ch [open $filename w]
+
+ set analysisplot(graph,title) $var(graph,title)
+ set analysisplot(graph,title,family) $var(graph,title,family)
+ set analysisplot(graph,title,size) $var(graph,title,size)
+ set analysisplot(graph,title,weight) $var(graph,title,weight)
+ set analysisplot(graph,title,slant) $var(graph,title,slant)
+
+ set analysisplot(legend) $var(legend)
+ set analysisplot(legend,title) $var(legend,title)
+ set analysisplot(legend,position) $var(legend,position)
+ set analysisplot(legend,title,family) $var(legend,title,family)
+ set analysisplot(legend,title,size) $var(legend,title,size)
+ set analysisplot(legend,title,weight) $var(legend,title,weight)
+ set analysisplot(legend,title,slant) $var(legend,title,slant)
+ set analysisplot(legend,font,family) $var(legend,font,family)
+ set analysisplot(legend,font,size) $var(legend,font,size)
+ set analysisplot(legend,font,weight) $var(legend,font,weight)
+ set analysisplot(legend,font,slant) $var(legend,font,slant)
+
+ set analysisplot(axis,x,title) $var(axis,x,title)
+ set analysisplot(axis,x,grid) $var(axis,x,grid)
+ set analysisplot(axis,x,log) $var(axis,x,log)
+ set analysisplot(axis,x,flip) $var(axis,x,flip)
+ set analysisplot(axis,x,auto) $var(axis,x,auto)
+ set analysisplot(axis,x,min) $var(axis,x,min)
+ set analysisplot(axis,x,max) $var(axis,x,max)
+ set analysisplot(axis,x,format) $var(axis,x,format)
+
+ set analysisplot(axis,y,title) $var(axis,y,title)
+ set analysisplot(axis,y,grid) $var(axis,y,grid)
+ set analysisplot(axis,y,log) $var(axis,y,log)
+ set analysisplot(axis,y,flip) $var(axis,y,flip)
+ set analysisplot(axis,y,auto) $var(axis,y,auto)
+ set analysisplot(axis,y,min) $var(axis,y,min)
+ set analysisplot(axis,y,max) $var(axis,y,max)
+ set analysisplot(axis,y,format) $var(axis,y,format)
+
+ set analysisplot(axis,title,family) $var(axis,title,family)
+ set analysisplot(axis,title,size) $var(axis,title,size)
+ set analysisplot(axis,title,weight) $var(axis,title,weight)
+ set analysisplot(axis,title,slant) $var(axis,title,slant)
+
+ set analysisplot(axis,font,family) $var(axis,font,family)
+ set analysisplot(axis,font,size) $var(axis,font,size)
+ set analysisplot(axis,font,weight) $var(axis,font,weight)
+ set analysisplot(axis,font,slant) $var(axis,font,slant)
+
+ set analysisplot(show) $var(show)
+ set analysisplot(shape,symbol) $var(shape,symbol)
+ set analysisplot(shape,fill) $var(shape,fill)
+ set analysisplot(shape,color) $var(shape,color)
+ set analysisplot(smooth) $var(smooth)
+ set analysisplot(color) $var(color)
+ set analysisplot(fill) $var(fill)
+ set analysisplot(fill,color) $var(fill,color)
+ set analysisplot(width) $var(width)
+ set analysisplot(dash) $var(dash)
+
+ set analysisplot(error) $var(error)
+ set analysisplot(error,cap) $var(error,cap)
+ set analysisplot(error,color) $var(error,color)
+ set analysisplot(error,width) $var(error,width)
+
+ set analysisplot(bar,relief) $var(bar,relief)
+ set analysisplot(bar,mode) $var(bar,mode)
+
+ puts $ch "array set analysisplot \{ [array get analysisplot] \}"
+ close $ch
+}
+
+proc PlotSaveData {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(xdata) == {}} {
+ return
+ }
+
+ PlotSaveDataFile $varname [SaveFileDialog apdatafbox]
+}
+
+proc PlotSaveDataFile {varname filename} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(xdata) == {}} {
+ return
+ }
+
+ if {$filename == {}} {
+ return
+ }
+
+ global $var(xdata) $var(ydata) $var(xedata) $var(yedata)
+ set ll [$var(xdata) length]
+ set xx [$var(xdata) range]
+ set yy [$var(ydata) range]
+
+ set ch [open $filename w]
+ switch $var(dim) {
+ xy {
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ puts $ch "[lindex $xx $ii] [lindex $yy $ii]"
+ }
+ }
+ xyex {
+ set xe [$var(xedata) range]
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ puts $ch "[lindex $xx $ii] [lindex $yy $ii] [lindex $xe $ii]"
+ }
+ }
+ xyey {
+ set ye [$var(yedata) range]
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ puts $ch "[lindex $xx $ii] [lindex $yy $ii] [lindex $ye $ii]"
+ }
+ }
+ xyexey {
+ set xe [$var(xedata) range]
+ set ye [$var(yedata) range]
+ for {set ii 0} {$ii<$ll} {incr ii} {
+ puts $ch "[lindex $xx $ii] [lindex $yy $ii] [lindex $xe $ii] [lindex $ye $ii]"
+ }
+ }
+ }
+ close $ch
+
+ PlotRaise $varname
+}
+
+proc PlotStats {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {!$var(stats)} {
+ return
+ }
+
+ set rr [PlotStatsGenerate $varname]
+ SimpleTextDialog "${varname}stats" [msgcat::mc {Statistics}] \
+ 40 20 insert top $rr PlotStatsDestroyCB $varname
+}
+
+proc PlotStatsGenerate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set min {}
+ set max {}
+ set mean {}
+ set median {}
+ set varr {}
+ set sdev {}
+
+ if {$var(ydata) != {}} {
+ if {[$var(ydata) length] > 0} {
+ set min [format "%6.3f" [blt::vector expr min($var(ydata))]]
+ set max [format "%6.3f" [blt::vector expr max($var(ydata))]]
+ set mean [format "%6.3f" [blt::vector expr mean($var(ydata))]]
+ set median [format "%6.3f" [blt::vector expr median($var(ydata))]]
+ set varr [format "%6.3f" [expr [blt::vector expr var($var(ydata))]]]
+ set sdev [format "%6.3f" [expr [blt::vector expr sdev($var(ydata))]]]
+ }
+ }
+
+ set rr {}
+ append rr "min $min\n"
+ append rr "max $max\n"
+ append rr "mean $mean\n"
+ append rr "median $median\n"
+ append rr "var $varr\n"
+ append rr "sdev $sdev\n"
+ return $rr
+}
+
+proc PlotStatsDestroyCB {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(stats) 0
+}
+
+proc PlotTitle {varname title xaxis yaxis} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(graph,title) "$title"
+ set var(axis,x,title) "$xaxis"
+ set var(axis,y,title) "$yaxis"
+}
+
+proc PlotUpdateGraph {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ if {$var(axis,x,auto)} {
+ set xmin {}
+ set xmax {}
+ } else {
+ set xmin $var(axis,x,min)
+ set xmax $var(axis,x,max)
+ }
+
+ if {$var(axis,y,auto)} {
+ set ymin {}
+ set ymax {}
+ } else {
+ set ymin $var(axis,y,min)
+ set ymax $var(axis,y,max)
+ }
+
+ $var(graph) xaxis configure -min $xmin -max $xmax \
+ -descending $var(axis,x,flip)
+ $var(graph) yaxis configure -min $ymin -max $ymax \
+ -descending $var(axis,y,flip)
+
+ if {$var(graph,format)} {
+ if {$var(axis,x,format) != {}} {
+ $var(graph) xaxis configure \
+ -command [list PlotAxisFormat $varname x]
+ } else {
+ $var(graph) xaxis configure -command {}
+ }
+ if {$var(axis,y,format) != {}} {
+ $var(graph) yaxis configure \
+ -command [list PlotAxisFormat $varname y]
+ } else {
+ $var(graph) yaxis configure -command {}
+ }
+ }
+
+ # Menus
+ if {$var(xdata) != {}} {
+ $var(mb).file entryconfig "[msgcat::mc {Save Data}]..." -state normal
+ $var(mb).file entryconfig [msgcat::mc {Clear Data}] -state normal
+ $var(mb).file entryconfig [msgcat::mc {Statistics}] -state normal
+ $var(mb).file entryconfig [msgcat::mc {List Data}] -state normal
+
+ if {$var(1,manage)} {
+ $var(mb).file entryconfig [msgcat::mc {Duplicate Data}] \
+ -state disabled
+ } else {
+ $var(mb).file entryconfig [msgcat::mc {Duplicate Data}] \
+ -state normal
+ }
+ } else {
+ $var(mb).file entryconfig "[msgcat::mc {Save Data}]..." -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Clear Data}] -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Duplicate Data}] -state disabled
+ $var(mb).file entryconfig [msgcat::mc {Statistics}] -state disabled
+ $var(mb).file entryconfig [msgcat::mc {List Data}] -state disabled
+ }
+
+ # Graph
+ $var(graph) configure -plotpadx 0 -plotpady 0 \
+ -title $var(graph,title) \
+ -font "{$ds9($var(graph,title,family))} $var(graph,title,size) $var(graph,title,weight) $var(graph,title,slant)"
+
+ $var(graph) xaxis configure \
+ -grid $var(axis,x,grid) -logscale $var(axis,x,log) \
+ -title $var(axis,x,title) \
+ -tickfont "{$ds9($var(axis,font,family))} $var(axis,font,size) $var(axis,font,weight) $var(axis,font,slant)" \
+ -titlefont "{$ds9($var(axis,title,family))} $var(axis,title,size) $var(axis,title,weight) $var(axis,title,slant)"
+ $var(graph) yaxis configure \
+ -grid $var(axis,y,grid) -logscale $var(axis,y,log) \
+ -title $var(axis,y,title) \
+ -tickfont "{$ds9($var(axis,font,family))} $var(axis,font,size) $var(axis,font,weight) $var(axis,font,slant)" \
+ -titlefont "{$ds9($var(axis,title,family))} $var(axis,title,size) $var(axis,title,weight) $var(axis,title,slant)"
+
+ $var(graph) legend configure -hide [expr !$var(legend)] \
+ -position $var(legend,position) -title $var(legend,title) \
+ -font "{$ds9($var(legend,font,family))} $var(legend,font,size) $var(legend,font,weight) $var(legend,font,slant)" \
+ -titlefont "{$ds9($var(legend,title,family))} $var(legend,title,size) $var(legend,title,weight) $var(legend,title,slant)"
+}
+
+proc PlotCreateElement {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # warning: uses current vars
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ # delete current elements
+ set nn $var(data,current)
+ foreach el [$var(graph) element names] {
+ set f [split $el -]
+ if {[lindex $f 1] == $nn} {
+ $var(graph) element delete $el
+ }
+ }
+
+ global $var(xdata) $var(ydata)
+ $var(graph) element create "d-${nn}" -xdata $var(xdata) -ydata $var(ydata)
+ if {$var(xedata) != {}} {
+ if {[$var(xedata) length] != 0} {
+ $var(graph) element configure "d-${nn}" -xerror $var(xedata)
+ }
+ }
+ if {$var(yedata) != {}} {
+ if {[$var(yedata) length] != 0} {
+ $var(graph) element configure "d-${nn}" -yerror $var(yedata)
+ }
+ }
+}
+
+proc PlotColorMenu {w varname color cmd} {
+ upvar #0 $varname var
+ global $varname
+
+ menu $w
+ $w add radiobutton -label [msgcat::mc {Black}] \
+ -variable ${varname}($color) -value black -command $cmd
+ $w add radiobutton -label [msgcat::mc {White}] \
+ -variable ${varname}($color) -value white -command $cmd
+ $w add radiobutton -label [msgcat::mc {Red}] \
+ -variable ${varname}($color) -value red -command $cmd
+ $w add radiobutton -label [msgcat::mc {Green}] \
+ -variable ${varname}($color) -value green -command $cmd
+ $w add radiobutton -label [msgcat::mc {Blue}] \
+ -variable ${varname}($color) -value blue -command $cmd
+ $w add radiobutton -label [msgcat::mc {Cyan}] \
+ -variable ${varname}($color) -value cyan -command $cmd
+ $w add radiobutton -label [msgcat::mc {Magenta}] \
+ -variable ${varname}($color) -value magenta -command $cmd
+ $w add radiobutton -label [msgcat::mc {Yellow}] \
+ -variable ${varname}($color) -value yellow -command $cmd
+ $w add separator
+ $w add command -label "[msgcat::mc {Other Color}]..." \
+ -command [list ColorMenuOther $varname $color $cmd]
+}
+
+proc PlotSetVar {varname nn} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(name) $var($nn,name)
+ set var(show) $var($nn,show)
+ set var(shape,symbol) $var($nn,shape,symbol)
+ set var(shape,fill) $var($nn,shape,fill)
+ set var(shape,color) $var($nn,shape,color)
+ set var(smooth) $var($nn,smooth)
+ set var(color) $var($nn,color)
+ set var(fill) $var($nn,fill)
+ set var(fill,color) $var($nn,fill,color)
+ set var(width) $var($nn,width)
+ set var(dash) $var($nn,dash)
+ set var(error) $var($nn,error)
+ set var(error,cap) $var($nn,error,cap)
+ set var(error,color) $var($nn,error,color)
+ set var(error,width) $var($nn,error,width)
+ set var(bar,relief) $var($nn,bar,relief)
+}
+
+proc PlotGetVar {varname nn} {
+ upvar #0 $varname var
+ global $varname
+
+ set var($nn,name) $var(name)
+ set var($nn,show) $var(show)
+ set var($nn,shape,symbol) $var(shape,symbol)
+ set var($nn,shape,fill) $var(shape,fill)
+ set var($nn,shape,color) $var(shape,color)
+ set var($nn,smooth) $var(smooth)
+ set var($nn,color) $var(color)
+ set var($nn,fill) $var(fill)
+ set var($nn,fill,color) $var(fill,color)
+ set var($nn,width) $var(width)
+ set var($nn,dash) $var(dash)
+ set var($nn,error) $var(error)
+ set var($nn,error,cap) $var(error,cap)
+ set var($nn,error,color) $var(error,color)
+ set var($nn,error,width) $var(error,width)
+ set var($nn,bar,relief) $var(bar,relief)
+}
+
+proc PlotBackup {ch dir} {
+ global iap
+
+ set rdir "./[lindex [file split $dir] end]"
+
+ # only save ap plots
+ foreach tt $iap(windows) {
+ if {[string range $tt 0 1] == {ap}} {
+ set fdir [file join $dir $tt]
+
+ set varname $tt
+ upvar #0 $varname var
+ global $varname
+
+ # create dir if needed
+ if {![file isdirectory $fdir]} {
+ if {[catch {file mkdir $fdir}]} {
+ Error [msgcat::mc {An error has occurred during backup}]
+ return
+ }
+ }
+
+ switch $var(type) {
+ line {puts $ch "PlotLineTool"}
+ bar {puts $ch "PlotBarTool"}
+ scatter {puts $ch "PlotScatterTool"}
+ }
+
+ set save $var(data,current)
+ for {set ii 1} {$ii<=$var(data,total)} {incr ii} {
+ set ${varname}(data,current) $ii
+ PlotCurrentData $varname
+
+ PlotSaveDataFile $varname "$fdir/plot$ii.dat"
+ PlotSaveConfigFile $varname "$fdir/plot$ii.plt"
+
+ puts $ch "PlotLoadDataFile $varname $fdir/plot$ii.dat $var(dim)"
+ puts $ch "PlotLoadConfigFile $varname $fdir/plot$ii.plt"
+ }
+ set ${varname}(data,current) $save
+ PlotCurrentData $varname
+ }
+ }
+}
diff --git a/ds9/library/plotbar.tcl b/ds9/library/plotbar.tcl
new file mode 100644
index 0000000..136e34a
--- /dev/null
+++ b/ds9/library/plotbar.tcl
@@ -0,0 +1,201 @@
+# 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
+
+# used by backup
+proc PlotBarTool {} {
+ global iap
+ PlotBar $iap(tt) [msgcat::mc {Bar Plot Tool}] {} {} {} 2 {}
+}
+
+proc PlotBar {tt wtt title xaxis yaxis dim data} {
+ global iap
+
+ # make the window name unique
+ set ii [lsearch $iap(windows) $tt]
+ if {$ii>=0} {
+ incr iap(unique)
+ append tt $iap(unique)
+ }
+
+ # set the window title if none
+ if {$wtt == {}} {
+ set wtt $tt
+ }
+
+ set varname $tt
+ upvar #0 $varname var
+ global $varname
+
+ PlotBarProc $varname
+ PlotDialog $varname $wtt $title $xaxis $yaxis
+ PlotDialogBar $varname
+
+ PlotDataSet $varname $dim $data
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+}
+
+proc PlotBarDialog {varname wtt title xaxis yaxis} {
+ upvar #0 $varname var
+ global $varname
+
+ PlotBarProc $varname
+ PlotDialog $varname $wtt $title $xaxis $yaxis
+ PlotDialogBar $varname
+}
+
+proc PlotBarProc {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(proc,updategraph) PlotBarUpdateGraph
+ set var(proc,updateelement) PlotBarUpdateElement
+ set var(proc,highlite) PlotBarHighliteElement
+ set var(proc,button) PlotBarButton
+}
+
+proc PlotDialogBar {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ set var(seq) 1
+
+ # Graph
+ $var(mb).graph add separator
+ $var(mb).graph add cascade -label "[msgcat::mc {Mode}]..." \
+ -menu $var(mb).graph.mode
+
+ # Graph Mode
+ menu $var(mb).graph.mode
+ $var(mb).graph.mode add radiobutton -label [msgcat::mc {Normal}] \
+ -variable ${varname}(bar,mode) -value normal \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.mode add radiobutton -label [msgcat::mc {Stacked}] \
+ -variable ${varname}(bar,mode) -value stacked \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.mode add radiobutton -label [msgcat::mc {Aligned}] \
+ -variable ${varname}(bar,mode) -value aligned \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.mode add radiobutton -label [msgcat::mc {Overlap}] \
+ -variable ${varname}(bar,mode) -value overlap \
+ -command [list $var(proc,updategraph) $varname]
+
+ # Dataset
+ $var(mb).dataset add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(show) \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset add separator
+ $var(mb).dataset add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.color
+ $var(mb).dataset add cascade -label [msgcat::mc {Relief}] \
+ -menu $var(mb).dataset.relief
+ $var(mb).dataset add cascade -label [msgcat::mc {Error}] \
+ -menu $var(mb).dataset.error
+ $var(mb).dataset add separator
+ $var(mb).dataset add command -label "[msgcat::mc {Name}]..." \
+ -command [list DatasetNameDialog $varname]
+
+ PlotColorMenu $var(mb).dataset.color $varname color \
+ [list PlotBarUpdateElement $varname]
+
+ # Relief
+ menu $var(mb).dataset.relief
+ $var(mb).dataset.relief add radiobutton -label [msgcat::mc {Flat}] \
+ -variable ${varname}(bar,relief) -value flat \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset.relief add radiobutton -label [msgcat::mc {Sunken}] \
+ -variable ${varname}(bar,relief) -value sunken \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset.relief add radiobutton -label [msgcat::mc {Raised}] \
+ -variable ${varname}(bar,relief) -value raised \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset.relief add radiobutton -label [msgcat::mc {Solid}] \
+ -variable ${varname}(bar,relief) -value solid \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset.relief add radiobutton -label [msgcat::mc {Groove}] \
+ -variable ${varname}(bar,relief) -value groove \
+ -command [list PlotBarUpdateElement $varname]
+
+ # Error
+ menu $var(mb).dataset.error
+ $var(mb).dataset.error add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(error) \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset.error add checkbutton -label [msgcat::mc {Cap}] \
+ -variable ${varname}(error,cap) \
+ -command [list PlotBarUpdateElement $varname]
+ $var(mb).dataset.error add separator
+ $var(mb).dataset.error add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.error.color
+ $var(mb).dataset.error add cascade -label [msgcat::mc {Width}] \
+ -menu $var(mb).dataset.error.width
+
+ PlotColorMenu $var(mb).dataset.error.color $varname error,color \
+ [list PlotBarUpdateElement $varname]
+ WidthDashMenu $var(mb).dataset.error.width $varname error,width {} \
+ [list PlotBarUpdateElement $varname] {}
+
+ # graph
+ set var(type) bar
+ set var(graph) [blt::barchart $var(top).bar \
+ -width 600 \
+ -height 500 \
+ -highlightthickness 0 \
+ ]
+
+ $var(graph) xaxis configure -grid no -stepsize 0
+ $var(graph) yaxis configure -grid yes
+
+ pack $var(graph) -expand yes -fill both
+ PlotChangeMode $varname
+}
+
+proc PlotBarUpdateGraph {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ PlotUpdateGraph $varname
+ $var(graph) configure -barmode $var(bar,mode)
+}
+
+proc PlotBarUpdateElement {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set nn $var(data,current)
+ PlotGetVar $varname $nn
+
+ if {$var(error)} {
+ set show both
+ } else {
+ set show none
+ }
+
+ if {$var(error,cap)} {
+ set cap [expr $var(error,width)+3]
+ } else {
+ set cap 0
+ }
+
+ $var(graph) element configure "d-${nn}" \
+ -label $var(name) -hide [expr !$var(show)] \
+ -relief $var(bar,relief) -color $var(color) \
+ -showerrorbars $show -errorbarcolor $var(error,color) \
+ -errorbarwidth $var(error,width) -errorbarcap $cap
+}
+
+proc PlotBarButton {varname x y} {
+ upvar #0 $varname var
+ global $varname
+}
+
+proc PlotBarHighliteElement {varname rowlist} {
+ upvar #0 $varname var
+ global $varname
+}
diff --git a/ds9/library/plotdialog.tcl b/ds9/library/plotdialog.tcl
new file mode 100644
index 0000000..8c6fccb
--- /dev/null
+++ b/ds9/library/plotdialog.tcl
@@ -0,0 +1,511 @@
+# 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 PlotDialog {varname wtt title xaxis yaxis} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global pap
+
+ if {[PlotRaise $varname]} {
+ return
+ }
+
+ # add it to our xpa list
+ global iap
+ lappend iap(windows) $varname
+
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+ set var(stats) 0
+ set var(list) 0
+
+ set var(mode) zoom
+ set var(callback) {}
+
+ set var(data,total) 0
+ set var(data,current) 0
+
+ set var(name) {}
+ set var(xdata) {}
+ set var(ydata) {}
+ set var(xedata) {}
+ set var(yedata) {}
+
+ array set $varname [array get pap]
+
+ set var(graph,title) "$title"
+ set var(axis,x,title) "$xaxis"
+ set var(axis,y,title) "$yaxis"
+
+ # can be turned off for external line plots
+ set var(graph,format) 1
+
+ # create window
+ Toplevel $var(top) $var(mb) 7 $wtt [list PlotDestroy $varname]
+
+ $var(mb) add cascade -label [msgcat::mc {File}] -menu $var(mb).file
+ $var(mb) add cascade -label [msgcat::mc {Edit}] -menu $var(mb).edit
+ $var(mb) add cascade -label [msgcat::mc {Graph}] -menu $var(mb).graph
+ $var(mb) add cascade -label [msgcat::mc {Dataset}] -menu $var(mb).dataset
+ $var(mb) add cascade -label [msgcat::mc {Select}] -menu $var(mb).select
+
+ menu $var(mb).file
+ $var(mb).file add command -label "[msgcat::mc {Load Data}]..." \
+ -command [list PlotLoadData $varname]
+ $var(mb).file add command -label "[msgcat::mc {Save Data}]..." \
+ -command [list PlotSaveData $varname]
+ $var(mb).file add command -label [msgcat::mc {Clear Data}] \
+ -command [list PlotClearData $varname]
+ $var(mb).file add separator
+ $var(mb).file add command -label [msgcat::mc {Duplicate Data}] \
+ -command [list PlotDupData $varname 1]
+ $var(mb).file add separator
+ $var(mb).file add command -label [msgcat::mc {Statistics}] \
+ -command "set ${varname}(stats) 1; PlotStats $varname"
+ $var(mb).file add command -label [msgcat::mc {List Data}] \
+ -command "set ${varname}(list) 1; PlotList $varname"
+ $var(mb).file add separator
+ $var(mb).file add command -label "[msgcat::mc {Load Configuration}]..." \
+ -command [list PlotLoadConfig $varname]
+ $var(mb).file add command -label "[msgcat::mc {Save Configuration}]..." \
+ -command [list PlotSaveConfig $varname]
+ $var(mb).file add separator
+ switch $ds9(wm) {
+ x11 -
+ win32 {
+ $var(mb).file add command \
+ -label "[msgcat::mc {Page Setup}]..." \
+ -command PSPageSetup
+ $var(mb).file add command -label "[msgcat::mc {Print}]..." \
+ -command [list PlotPSPrint $varname]
+ }
+ aqua {
+ $var(mb).file add command \
+ -label "[msgcat::mc {Page Setup}]..." \
+ -command PSPageSetup
+ $var(mb).file add command -label "[msgcat::mc {Print}]..." \
+ -command [list PlotPSPrint $varname]
+# $var(mb).file add command -label "[msgcat::mc {Postscript Page Setup}]..." -command PSPageSetup
+# $var(mb).file add command -label "[msgcat::mc {Postscript Print}]..." -command [list PlotPSPrint $varname]
+ }
+ }
+ $var(mb).file add separator
+ $var(mb).file add command -label [msgcat::mc {Close}] \
+ -command [list PlotDestroy $varname]
+
+ menu $var(mb).edit
+ $var(mb).edit add command -label [msgcat::mc {Cut}] \
+ -state disabled -accelerator "${ds9(ctrl)}X"
+ $var(mb).edit add command -label [msgcat::mc {Copy}] \
+ -state disabled -accelerator "${ds9(ctrl)}C"
+ $var(mb).edit add command -label [msgcat::mc {Paste}] \
+ -state disabled -accelerator "${ds9(ctrl)}V"
+ $var(mb).edit add command -label [msgcat::mc {Clear}] \
+ -state disabled
+ $var(mb).edit add separator
+ $var(mb).edit add radiobutton -label [msgcat::mc {Pointer}] \
+ -variable ${varname}(mode) -value pointer \
+ -command [list PlotChangeMode $varname]
+ $var(mb).edit add radiobutton -label [msgcat::mc {Zoom}] \
+ -variable ${varname}(mode) -value zoom \
+ -command [list PlotChangeMode $varname]
+
+ # Graph
+ menu $var(mb).graph
+ $var(mb).graph add cascade -label [msgcat::mc {Axes}] \
+ -menu $var(mb).graph.axes
+ $var(mb).graph add cascade -label [msgcat::mc {Legend}] \
+ -menu $var(mb).graph.legend
+ $var(mb).graph add cascade -label [msgcat::mc {Font}] \
+ -menu $var(mb).graph.font
+ $var(mb).graph add separator
+ $var(mb).graph add command -label "[msgcat::mc {Title}]..." \
+ -command [list PlotTitleDialog $varname]
+
+ menu $var(mb).graph.axes
+ $var(mb).graph.axes add checkbutton -label [msgcat::mc {X Grid}] \
+ -variable ${varname}(axis,x,grid) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.axes add checkbutton -label [msgcat::mc {Log}] \
+ -variable ${varname}(axis,x,log) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.axes add checkbutton -label [msgcat::mc {Flip}] \
+ -variable ${varname}(axis,x,flip) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.axes add separator
+ $var(mb).graph.axes add checkbutton -label [msgcat::mc {Y Grid}] \
+ -variable ${varname}(axis,y,grid) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.axes add checkbutton -label [msgcat::mc {Log}] \
+ -variable ${varname}(axis,y,log) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.axes add checkbutton -label [msgcat::mc {Flip}] \
+ -variable ${varname}(axis,y,flip) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.axes add separator
+ $var(mb).graph.axes add command -label "[msgcat::mc {Range}]..." \
+ -command [list PlotRangeDialog $varname]
+
+ menu $var(mb).graph.legend
+ $var(mb).graph.legend add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(legend) \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.legend add separator
+ $var(mb).graph.legend add radiobutton -label [msgcat::mc {Right}] \
+ -variable ${varname}(legend,position) -value right \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.legend add radiobutton -label [msgcat::mc {Left}] \
+ -variable ${varname}(legend,position) -value left \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.legend add radiobutton -label [msgcat::mc {Top}] \
+ -variable ${varname}(legend,position) -value top \
+ -command [list $var(proc,updategraph) $varname]
+ $var(mb).graph.legend add radiobutton -label [msgcat::mc {Bottom}] \
+ -variable ${varname}(legend,position) -value bottom \
+ -command [list $var(proc,updategraph) $varname]
+
+ menu $var(mb).graph.font
+ $var(mb).graph.font add cascade -label [msgcat::mc {Title}] \
+ -menu $var(mb).graph.font.title
+ $var(mb).graph.font add cascade -label [msgcat::mc {Axes Title}] \
+ -menu $var(mb).graph.font.textlab
+ $var(mb).graph.font add cascade -label [msgcat::mc {Axes Number}] \
+ -menu $var(mb).graph.font.numlab
+ $var(mb).graph.font add cascade -label [msgcat::mc {Legend Title}] \
+ -menu $var(mb).graph.font.legendtitle
+ $var(mb).graph.font add cascade -label [msgcat::mc {Legend}] \
+ -menu $var(mb).graph.font.legend
+
+ FontMenu $var(mb).graph.font.title $varname graph,title,family graph,title,size graph,title,weight graph,title,slant [list $var(proc,updategraph) $varname]
+ FontMenu $var(mb).graph.font.textlab $varname axis,title,family axis,title,size axis,title,weight axis,title,slant [list $var(proc,updategraph) $varname]
+ FontMenu $var(mb).graph.font.numlab $varname axis,font,family axis,font,size axis,font,weight axis,font,slant [list $var(proc,updategraph) $varname]
+ FontMenu $var(mb).graph.font.legendtitle $varname legend,title,family legend,title,size legend,title,weight legend,title,slant [list $var(proc,updategraph) $varname]
+ FontMenu $var(mb).graph.font.legend $varname legend,font,family legend,font,size legend,font,weight legend,font,slant [list $var(proc,updategraph) $varname]
+
+ # dataset
+ menu $var(mb).dataset
+
+ # select
+ menu $var(mb).select
+}
+
+proc PlotChangeMode {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ blt::RemoveBindTag $var(graph) zoom-$var(graph)
+ bind $var(graph) <1> {}
+
+ switch $var(mode) {
+ pointer {bind $var(graph) <1> [list PlotButton $varname %x %y]}
+ zoom {
+ switch $ds9(wm) {
+ x11 -
+ win32 {Blt_ZoomStack $var(graph) -mode release}
+ aqua {Blt_ZoomStack $var(graph) -mode release -button "ButtonPress-2"}
+ }
+ }
+ }
+}
+
+proc PlotDataFormatDialog {xarname} {
+ upvar $xarname xar
+ global ed
+
+ set w {.apdata}
+
+ set ed(ok) 0
+ set ed(dim) $xar
+
+ DialogCreate $w [msgcat::mc {Data Format}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.title -text [msgcat::mc {Data Format}]
+ ttk::radiobutton $f.xy -text {X Y} -variable ed(dim) -value xy
+ ttk::radiobutton $f.xyex -text {X Y XErr} -variable ed(dim) -value xyex
+ ttk::radiobutton $f.xyey -text {X Y YErr} -variable ed(dim) -value xyey
+ ttk::radiobutton $f.xyexey -text {X Y XErr YErr} -variable ed(dim) \
+ -value xyexey
+
+ grid $f.title -padx 2 -pady 2 -sticky w
+ grid $f.xy -padx 2 -pady 2 -sticky w
+ grid $f.xyex -padx 2 -pady 2 -sticky w
+ grid $f.xyey -padx 2 -pady 2 -sticky w
+ grid $f.xyexey -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.param.xy
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set xar $ed(dim)
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PlotRangeDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ed
+
+ set w {.aptitle}
+
+ set ed(ok) 0
+
+ set ed(x,auto) $var(axis,x,auto)
+ set ed(x,min) $var(axis,x,min)
+ set ed(x,max) $var(axis,x,max)
+ set ed(x,format) $var(axis,x,format)
+
+ set ed(y,auto) $var(axis,y,auto)
+ set ed(y,min) $var(axis,y,min)
+ set ed(y,max) $var(axis,y,max)
+ set ed(y,format) $var(axis,y,format)
+
+ DialogCreate $w [msgcat::mc {Range}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.t -text [msgcat::mc {Axis}]
+ ttk::label $f.tto -text [msgcat::mc {To}]
+ ttk::label $f.tfrom -text [msgcat::mc {From}]
+ ttk::label $f.tformat -text [msgcat::mc {Format}]
+ ttk::label $f.tauto -text [msgcat::mc {Automatic}]
+
+ ttk::label $f.x -text [msgcat::mc {X}]
+ ttk::entry $f.xmin -textvariable ed(x,min) -width 12
+ ttk::entry $f.xmax -textvariable ed(x,max) -width 12
+ ttk::entry $f.xformat -textvariable ed(x,format) -width 8
+ ttk::checkbutton $f.xauto -variable ed(x,auto)
+
+ ttk::label $f.y -text [msgcat::mc {Y}]
+ ttk::entry $f.ymin -textvariable ed(y,min) -width 12
+ ttk::entry $f.ymax -textvariable ed(y,max) -width 12
+ ttk::entry $f.yformat -textvariable ed(y,format) -width 8
+ ttk::checkbutton $f.yauto -variable ed(y,auto)
+
+ grid $f.t $f.tfrom $f.tto $f.tformat $f.tauto -padx 2 -pady 2 -sticky w
+ grid $f.x $f.xmin $f.xmax $f.xformat $f.xauto -padx 2 -pady 2 -sticky w
+ grid $f.y $f.ymin $f.ymax $f.yformat $f.yauto -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.param.xmin
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set var(axis,x,auto) $ed(x,auto)
+ set var(axis,x,min) $ed(x,min)
+ set var(axis,x,max) $ed(x,max)
+ set var(axis,x,format) $ed(x,format)
+
+ set var(axis,y,auto) $ed(y,auto)
+ set var(axis,y,min) $ed(y,min)
+ set var(axis,y,max) $ed(y,max)
+ set var(axis,y,format) $ed(y,format)
+
+ $var(proc,updategraph) $varname
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PlotTitleDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+ global ed
+
+ set w {.aptitle}
+
+ set ed(ok) 0
+ set ed(graph,title) $var(graph,title)
+ set ed(axis,x,title) $var(axis,x,title)
+ set ed(axis,y,title) $var(axis,y,title)
+ set ed(legend,title) $var(legend,title)
+
+ DialogCreate $w [msgcat::mc {Title}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.label -text [msgcat::mc {Plot Title}]
+ ttk::entry $f.title -textvariable ed(graph,title) -width 30
+ ttk::label $f.xlabel -text [msgcat::mc {X Axis Title}]
+ ttk::entry $f.xtitle -textvariable ed(axis,x,title) -width 30
+ ttk::label $f.ylabel -text [msgcat::mc {Y Axis Title}]
+ ttk::entry $f.ytitle -textvariable ed(axis,y,title) -width 30
+ ttk::label $f.legendlabel -text [msgcat::mc {Legend Title}]
+ ttk::entry $f.legendtitle -textvariable ed(legend,title) -width 30
+
+ grid $f.label $f.title -padx 2 -pady 2 -sticky ew
+ grid $f.xlabel $f.xtitle -padx 2 -pady 2 -sticky ew
+ grid $f.ylabel $f.ytitle -padx 2 -pady 2 -sticky ew
+ grid $f.legendlabel $f.legendtitle -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 1 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.param.title
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ set var(graph,title) $ed(graph,title)
+ set var(axis,x,title) $ed(axis,x,title)
+ set var(axis,y,title) $ed(axis,y,title)
+ set var(legend,title) $ed(legend,title)
+
+ $var(proc,updategraph) $varname
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc DatasetNameDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+ global ed
+
+ set w {.aptitle}
+
+ set ed(ok) 0
+ set ed(name) $var(name)
+
+ DialogCreate $w [msgcat::mc {Dataset}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.label -text [msgcat::mc {Dataset Name}]
+ ttk::entry $f.name -textvariable ed(name) -width 30
+
+ grid $f.label $f.name -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 1 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.param.name
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ $var(mb).select entryconfig "$var(name)" -label "$ed(name)"
+ set var(name) $ed(name)
+ $var(proc,updateelement) $varname
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PlotButton {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(proc,button) $varname $x $y
+}
+
+proc PlotLineShapeMenu {which var} {
+ menu $which
+ $which add radiobutton -label [msgcat::mc {None}] \
+ -variable $var -value none
+ $which add radiobutton -label [msgcat::mc {Circle}] \
+ -variable $var -value circle
+ $which add radiobutton -label [msgcat::mc {Square}] \
+ -variable $var -value square
+ $which add radiobutton -label [msgcat::mc {Diamond}] \
+ -variable $var -value diamond
+ $which add radiobutton -label [msgcat::mc {Plus}] \
+ -variable $var -value plus
+ $which add radiobutton -label [msgcat::mc {Cross}] \
+ -variable $var -value cross
+ $which add radiobutton -label [msgcat::mc {Simple Plus}] \
+ -variable $var -value splus
+ $which add radiobutton -label [msgcat::mc {Simple Cross}] \
+ -variable $var -value scross
+ $which add radiobutton -label [msgcat::mc {Triangle}] \
+ -variable $var -value triangle
+ $which add radiobutton -label [msgcat::mc {Arrow}] \
+ -variable $var -value arrow
+}
+
+proc PlotLineSmoothMenu {which var} {
+ menu $which
+ $which add radiobutton -label [msgcat::mc {Step}] \
+ -variable $var -value step
+ $which add radiobutton -label [msgcat::mc {Linear}] \
+ -variable $var -value linear
+ $which add radiobutton -label [msgcat::mc {Cubic}] \
+ -variable $var -value cubic
+ $which add radiobutton -label [msgcat::mc {Quadratic}] \
+ -variable $var -value quadratic
+ $which add radiobutton -label [msgcat::mc {Catrom}] \
+ -variable $var -value catrom
+}
diff --git a/ds9/library/plotelement.tcl b/ds9/library/plotelement.tcl
new file mode 100644
index 0000000..4fc8e68
--- /dev/null
+++ b/ds9/library/plotelement.tcl
@@ -0,0 +1,17 @@
+# 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 PlotHighliteElement {varname rowlist} {
+ upvar #0 $varname var
+ global $varname
+
+ # rowlist starts at 1
+ set result {}
+ foreach rr $rowlist {
+ append result "[expr $rr-1] "
+ }
+ $var(proc,highlite) $varname $result
+}
diff --git a/ds9/library/plotline.tcl b/ds9/library/plotline.tcl
new file mode 100644
index 0000000..b6c0fe5
--- /dev/null
+++ b/ds9/library/plotline.tcl
@@ -0,0 +1,281 @@
+# 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
+
+# used by backup
+proc PlotLineTool {} {
+ global iap
+ PlotLine $iap(tt) [msgcat::mc {Line Plot Tool}] {} {} {} 2 {}
+}
+
+proc PlotLine {tt wtt title xaxis yaxis dim data} {
+ global iap
+
+ # make the window name unique
+ set ii [lsearch $iap(windows) $tt]
+ if {$ii>=0} {
+ incr iap(unique)
+ append tt $iap(unique)
+ }
+
+ # set the window title if none
+ if {$wtt == {}} {
+ set wtt $tt
+ }
+
+ set varname $tt
+ upvar #0 $varname var
+ global $varname
+
+ PlotLineProc $varname
+ PlotDialog $varname $wtt $title $xaxis $yaxis
+ PlotDialogLine $varname
+
+ PlotDataSet $varname $dim $data
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+}
+
+proc PlotLineDialog {varname wtt title xaxis yaxis} {
+ upvar #0 $varname var
+ global $varname
+
+ PlotLineProc $varname
+ PlotDialog $varname $wtt $title $xaxis $yaxis
+ PlotDialogLine $varname
+}
+
+proc PlotLineProc {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(proc,updategraph) PlotUpdateGraph
+ set var(proc,updateelement) PlotLineUpdateElement
+ set var(proc,highlite) PlotLineHighliteElement
+ set var(proc,button) PlotLineButton
+}
+
+proc PlotDialogLine {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ set var(seq) 1
+
+ # Dataset
+ $var(mb).dataset add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(show) \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset add separator
+ $var(mb).dataset add cascade -label [msgcat::mc {Shape}] \
+ -menu $var(mb).dataset.shape
+ $var(mb).dataset add cascade -label [msgcat::mc {Smooth}] \
+ -menu $var(mb).dataset.smooth
+ $var(mb).dataset add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.color
+ $var(mb).dataset add cascade -label [msgcat::mc {Width}] \
+ -menu $var(mb).dataset.width
+ $var(mb).dataset add cascade -label [msgcat::mc {Fill}] \
+ -menu $var(mb).dataset.fill
+ $var(mb).dataset add cascade -label [msgcat::mc {Error}] \
+ -menu $var(mb).dataset.error
+ $var(mb).dataset add separator
+ $var(mb).dataset add command -label "[msgcat::mc {Name}]..." \
+ -command [list DatasetNameDialog $varname]
+
+ # Shape
+ menu $var(mb).dataset.shape
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {None}] \
+ -variable ${varname}(shape,symbol) -value none \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Circle}] \
+ -variable ${varname}(shape,symbol) -value circle \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Square}] \
+ -variable ${varname}(shape,symbol) -value square \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Diamond}] \
+ -variable ${varname}(shape,symbol) -value diamond \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Plus}] \
+ -variable ${varname}(shape,symbol) -value plus \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Cross}] \
+ -variable ${varname}(shape,symbol) -value cross \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Simple Plus}] \
+ -variable ${varname}(shape,symbol) -value splus \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Simple Cross}] \
+ -variable ${varname}(shape,symbol) -value scross \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Triangle}] \
+ -variable ${varname}(shape,symbol) -value triangle \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Arrow}] \
+ -variable ${varname}(shape,symbol) -value arrow \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add separator
+ $var(mb).dataset.shape add checkbutton \
+ -label [msgcat::mc {Fill}] \
+ -variable ${varname}(shape,fill) \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.shape add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.shape.color
+
+ PlotColorMenu $var(mb).dataset.shape.color $varname shape,color \
+ [list PlotLineUpdateElement $varname]
+
+ # Smooth
+ menu $var(mb).dataset.smooth
+ $var(mb).dataset.smooth add radiobutton \
+ -label [msgcat::mc {Step}] \
+ -variable ${varname}(smooth) -value step \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.smooth add radiobutton \
+ -label [msgcat::mc {Linear}] \
+ -variable ${varname}(smooth) -value linear \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.smooth add radiobutton \
+ -label [msgcat::mc {Cubic}] \
+ -variable ${varname}(smooth) -value cubic \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.smooth add radiobutton \
+ -label [msgcat::mc {Quadratic}] \
+ -variable ${varname}(smooth) -value quadratic \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.smooth add radiobutton \
+ -label [msgcat::mc {Catrom}] \
+ -variable ${varname}(smooth) -value catrom \
+ -command [list PlotLineUpdateElement $varname]
+
+ # Color
+ PlotColorMenu $var(mb).dataset.color $varname color \
+ [list PlotLineUpdateElement $varname]
+
+ # Width
+ WidthDashMenu $var(mb).dataset.width $varname width dash \
+ [list PlotLineUpdateElement $varname] \
+ [list PlotLineUpdateElement $varname]
+
+ # Fill
+ menu $var(mb).dataset.fill
+ $var(mb).dataset.fill add checkbutton \
+ -label [msgcat::mc {Show}] \
+ -variable ${varname}(fill) \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.fill add separator
+ $var(mb).dataset.fill add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.fill.color
+
+ PlotColorMenu $var(mb).dataset.fill.color $varname fill,color \
+ [list PlotLineUpdateElement $varname]
+
+ # Error
+ menu $var(mb).dataset.error
+ $var(mb).dataset.error add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(error) \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.error add checkbutton -label [msgcat::mc {Cap}] \
+ -variable ${varname}(error,cap) \
+ -command [list PlotLineUpdateElement $varname]
+ $var(mb).dataset.error add separator
+ $var(mb).dataset.error add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.error.color
+ $var(mb).dataset.error add cascade -label [msgcat::mc {Width}] \
+ -menu $var(mb).dataset.error.width
+
+ PlotColorMenu $var(mb).dataset.error.color $varname error,color \
+ [list PlotLineUpdateElement $varname]
+ WidthDashMenu $var(mb).dataset.error.width $varname error,width {} \
+ [list PlotLineUpdateElement $varname] {}
+
+ # graph
+ set var(type) line
+ set var(graph) [blt::graph $var(top).line \
+ -width 600 \
+ -height 500 \
+ -highlightthickness 0 \
+ ]
+
+ pack $var(graph) -expand yes -fill both
+ PlotChangeMode $varname
+}
+
+proc PlotLineUpdateElement {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # warning: uses current vars
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ set nn $var(data,current)
+ PlotGetVar $varname $nn
+
+ if {$var(fill)} {
+ set fillClr $var(fill,color)
+ } else {
+ set fillClr {}
+ }
+
+ if {$var(shape,fill)} {
+ set clr $var(shape,color)
+ } else {
+ set clr {}
+ }
+
+ if {$var(dash)} {
+ set dash {8 3}
+ } else {
+ set dash { }
+ }
+
+ if {$var(error)} {
+ set show both
+ } else {
+ set show none
+ }
+
+ if {$var(error,cap)} {
+ set cap [expr $var(error,width)+3]
+ } else {
+ set cap 0
+ }
+
+ $var(graph) element configure "d-${nn}" \
+ -label $var(name) -hide [expr !$var(show)] \
+ -symbol $var(shape,symbol) -fill $clr -scalesymbols no \
+ -pixels 5 -outline $var(shape,color) \
+ -smooth $var(smooth) \
+ -color $var(color) -areabackground $fillClr \
+ -linewidth $var(width) -dashes $dash \
+ -showerrorbars $show -errorbarcolor $var(error,color) \
+ -errorbarwidth $var(error,width) -errorbarcap $cap
+}
+
+proc PlotLineButton {varname x y} {
+ upvar #0 $varname var
+ global $varname
+}
+
+proc PlotLineHighliteElement {varname rowlist} {
+ upvar #0 $varname var
+ global $varname
+}
+
diff --git a/ds9/library/plotprint.tcl b/ds9/library/plotprint.tcl
new file mode 100644
index 0000000..ac83384
--- /dev/null
+++ b/ds9/library/plotprint.tcl
@@ -0,0 +1,114 @@
+# 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 PlotPSPrint {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {[PlotPrintDialog]} {
+ if {[catch {PlotPostScript $varname} printError]} {
+ Error "[msgcat::mc {An error has occurred while printing}] $printError"
+ }
+ }
+}
+
+proc PlotPostScript {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ps
+ global ds9
+
+ # set postscript fonts
+ $var(graph) configure \
+ -font "$var(graph,title,family) $var(graph,title,size) $var(graph,title,weight) $var(graph,title,slant)"
+
+ $var(graph) xaxis configure \
+ -tickfont "$var(axis,font,family) $var(axis,font,size) $var(axis,font,weight) $var(axis,font,slant)" \
+ -titlefont "$var(axis,title,family) $var(axis,title,size) $var(axis,title,weight) $var(axis,title,slant)"
+
+ $var(graph) yaxis configure \
+ -tickfont "$var(axis,font,family) $var(axis,font,size) $var(axis,font,weight) $var(axis,font,slant)" \
+ -titlefont "$var(axis,title,family) $var(axis,title,size) $var(axis,title,weight) $var(axis,title,slant)"
+
+ $var(graph) legend configure \
+ -font "$var(legend,font,family) $var(legend,font,size) $var(legend,font,weight) $var(legend,font,slant)" \
+ -titlefont "$var(legend,title,family) $var(legend,title,size) $var(legend,title,weight) $var(legend,title,slant)"
+
+ set options "-decorations false"
+
+ # Color
+ switch -- $ps(color) {
+ rgb -
+ cmyk {append options " -greyscale no"}
+ gray {append options " -greyscale yes"}
+ }
+
+ # can't trust 'tk scaling'
+ switch $ds9(wm) {
+ x11 -
+ win32 {set scaling [tk scaling]}
+ aqua {set scaling 1.4}
+ }
+
+ # Size
+ set ww [expr [winfo width $var(top)]*$ps(scale)/100./$scaling]
+ set hh [expr [winfo height $var(top)]*$ps(scale)/100./$scaling]
+ append options " -width $ww -height $hh"
+
+ # Page size
+ switch -- $ps(size) {
+ letter {append options " -paperwidth 8.5i -paperheight 11.i"}
+ legal {append options " -paperwidth 8.5i -paperheight 14.i"}
+ tabloid {append options " -paperwidth 11i -paperheight 17.i"}
+ poster {append options " -paperwidth 36.i -paperheight 48.i"}
+ a4 {append options " -paperwidth 195m -paperheight 282m"}
+ other {
+ if {$ps(width) != {} && $ps(height) != {}} {
+ set pgww "[append ps(width) i]"
+ set pghh "[append ps(height) i]"
+ append options " -paperwidth $pgww -paperheight pghh"
+ }
+ }
+ othermm {
+ if {$ps(width) != {} && $ps(height) != {}} {
+ set pgww "[append ps(width) m]"
+ set pghh "[append ps(height) m]"
+ append options " -paperwidth $pgww -paperheight pghh"
+ }
+ }
+ }
+
+ # Orientation
+ switch -- $ps(orient) {
+ portrait {append options " -landscape false"}
+ landscape {append options " -landscape true"}
+ }
+
+ if {$ps(dest) == "file" && $ps(filename) != {}} {
+ eval $var(graph) postscript output $ps(filename) $options
+ } else {
+ set ch [open "| $ps(cmd)" w]
+ puts $ch [eval $var(graph) postscript output $options]
+ close $ch
+ }
+
+ # reset fonts
+ $var(graph) configure \
+ -font "{$ds9($var(graph,title,family))} $var(graph,title,size) $var(graph,title,weight) $var(graph,title,slant)"
+
+ $var(graph) xaxis configure \
+ -tickfont "{$ds9($var(axis,font,family))} $var(axis,font,size) $var(axis,font,weight) $var(axis,font,slant)" \
+ -titlefont "{$ds9($var(axis,title,family))} $var(axis,title,size) $var(axis,title,weight) $var(axis,title,slant)"
+
+ $var(graph) yaxis configure \
+ -tickfont "{$ds9($var(axis,font,family))} $var(axis,font,size) $var(axis,font,weight) $var(axis,font,slant)" \
+ -titlefont "{$ds9($var(axis,title,family))} $var(axis,title,size) $var(axis,title,weight) $var(axis,title,slant)"
+
+ $var(graph) legend configure \
+ -font "{$ds9($var(legend,font,family))} $var(legend,font,size) $var(legend,font,weight) $var(legend,font,slant)" \
+ -titlefont "{$ds9($var(legend,title,family))} $var(legend,title,size) $var(legend,title,weight) $var(legend,title,slant)"
+}
diff --git a/ds9/library/plotprocess.tcl b/ds9/library/plotprocess.tcl
new file mode 100644
index 0000000..3b43cd4
--- /dev/null
+++ b/ds9/library/plotprocess.tcl
@@ -0,0 +1,1217 @@
+# 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 PrefsDialogPlot {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Plot}]
+ lappend dprefs(tabs) [ttk::frame $w.plot]
+
+ # Grid
+ set f [ttk::labelframe $w.plot.grid -text [msgcat::mc {Grid}]]
+ ttk::label $f.ttitle -text [msgcat::mc {Title}]
+ FontMenuButton $f.title pap graph,title,family graph,title,size graph,title,weight graph,title,slant {}
+
+ grid $f.ttitle $f.title -padx 2 -pady 2 -sticky w
+
+ # Axis
+ set f [ttk::labelframe $w.plot.axis -text [msgcat::mc {Axis}]]
+
+ ttk::label $f.xtitle -text [msgcat::mc {X}]
+ ttk::checkbutton $f.x -text [msgcat::mc {Grid}] -variable pap(axis,x,grid)
+ ttk::radiobutton $f.xlinear -text [msgcat::mc {Linear}] \
+ -variable pap(axis,x,log) -value 0
+ ttk::radiobutton $f.xlog -text [msgcat::mc {Log}] \
+ -variable pap(axis,x,log) -value 1
+
+ ttk::label $f.ytitle -text [msgcat::mc {Y}]
+ ttk::checkbutton $f.y -text [msgcat::mc {Grid}] -variable pap(axis,y,grid)
+ ttk::radiobutton $f.ylinear -text [msgcat::mc {Linear}] \
+ -variable pap(axis,y,log) -value 0
+ ttk::radiobutton $f.ylog -text [msgcat::mc {Log}] \
+ -variable pap(axis,y,log) -value 1
+
+ ttk::label $f.ttextlab -text [msgcat::mc {Axis Title}]
+ FontMenuButton $f.textlab pap axis,title,family axis,title,size axis,title,weight axis,title,slant {}
+ ttk::label $f.tnumlab -text [msgcat::mc {Axis Numbers}]
+ FontMenuButton $f.numlab pap axis,font,family axis,font,size axis,font,weight axis,font,slant {}
+
+ grid $f.xtitle $f.x $f.xlinear $f.xlog -padx 2 -pady 2 -sticky w
+ grid $f.ytitle $f.y $f.ylinear $f.ylog -padx 2 -pady 2 -sticky w
+ grid $f.ttextlab $f.textlab -padx 2 -pady 2 -sticky w
+ grid $f.tnumlab $f.numlab -padx 2 -pady 2 -sticky w
+
+ # Dataset
+ set f [ttk::labelframe $w.plot.dataset -text [msgcat::mc {Dataset}]]
+
+ # Show
+ ttk::checkbutton $f.show -text [msgcat::mc {Show}] -variable pap(show)
+ grid $f.show -padx 2 -pady 2 -sticky w
+
+ # Shape
+ ttk::label $f.shapetitle -text [msgcat::mc {Shape}]
+ ttk::menubutton $f.shape -textvariable pap(shape,symbol) \
+ -menu $f.shape.menu
+ PlotLineShapeMenu $f.shape.menu pap(shape,symbol)
+ ttk::checkbutton $f.shapefill -text [msgcat::mc {Fill}] \
+ -variable pap(shape,fill)
+ ColorMenuButton $f.shapecolor pap shape,color {}
+ grid $f.shapetitle $f.shape $f.shapefill $f.shapecolor \
+ -padx 2 -pady 2 -sticky w
+
+ # Smooth
+ ttk::label $f.smoothtitle -text [msgcat::mc {Smooth}]
+ ttk::menubutton $f.smooth -textvariable pap(smooth) \
+ -menu $f.smooth.menu
+ PlotLineSmoothMenu $f.smooth.menu pap(smooth)
+ grid $f.smoothtitle $f.smooth -padx 2 -pady 2 -sticky w
+
+ # Color
+ ttk::label $f.colortitle -text [msgcat::mc {Color}]
+ ColorMenuButton $f.color pap color {}
+ grid $f.colortitle $f.color -padx 2 -pady 2 -sticky w
+
+ # Width
+ ttk::label $f.widthtitle -text [msgcat::mc {Width}]
+ ttk::menubutton $f.width -textvariable pap(width) -menu $f.width.menu
+ WidthDashMenu $f.width.menu pap width dash {} {}
+ grid $f.widthtitle $f.width -padx 2 -pady 2 -sticky w
+
+ # Error
+ ttk::label $f.errortitle -text [msgcat::mc {Error}]
+ ttk::checkbutton $f.error -text [msgcat::mc {Show}] \
+ -variable pap(error)
+ ttk::checkbutton $f.errorcap -text [msgcat::mc {Cap}] \
+ -variable pap(error,cap)
+ ColorMenuButton $f.errorcolor pap error,color {}
+ ttk::menubutton $f.errorwidth -textvariable pap(error,width) \
+ -menu $f.errorwidth.menu
+ WidthDashMenu $f.errorwidth.menu pap width dash {} {}
+ grid $f.errortitle $f.error $f.errorcap $f.errorcolor $f.errorwidth \
+ -padx 2 -pady 2 -sticky w
+
+ pack $w.plot.grid $w.plot.axis $w.plot.dataset \
+ -side top -fill both -expand true
+}
+
+proc ProcessPlotCmd {xarname iname buf fn} {
+ upvar $xarname xar
+ upvar $iname i
+
+ global iap
+ set varname $iap(tt)
+ set id 0
+
+ # check for next command line option
+ if {[string range [lindex $xar $i] 0 0] != {-}} {
+
+ # determine which plot
+ switch -- [string tolower [lindex $xar $i]] {
+ {} -
+ bar -
+ scatter -
+ new {}
+
+ data -
+ load -
+ save -
+ clear -
+ dup -
+ duplicate -
+ stats -
+ statistics -
+ list -
+ loadconfig -
+ saveconfig -
+ page -
+ pagesetup -
+ print -
+ close -
+
+ mode -
+ axis -
+ legend -
+ font -
+ title -
+ show -
+ color -
+ fill -
+ fillcolor -
+ error -
+ errorbar -
+ barmode -
+ name -
+ shape -
+ relief -
+ smooth -
+ width -
+ dash -
+ dataset -
+ select -
+
+ graph -
+ line -
+ view {
+ set varname [lindex $iap(windows) end]
+ set id [lsearch $iap(windows) $varname]
+ }
+
+ default {
+ set varname [lindex $xar $i]
+ set id [lsearch $iap(windows) $varname]
+ incr i
+ }
+ }
+ }
+
+ # we better have a tt by now
+ if {$id == -1} {
+ Error "[msgcat::mc {Unable to find plot window}] $varname"
+ return
+ }
+
+ upvar #0 $varname var
+ global $varname
+
+ # check for next command line option
+ if {[string range [lindex $xar $i] 0 0] != {-}} {
+
+ # now, process plot command
+ switch -- [string tolower [lindex $xar $i]] {
+ {} -
+ bar -
+ scatter {
+ if {$buf != {}} {
+ ProcessPlotNew $varname $xarname $iname $buf
+ } elseif {$fn != {}} {
+ if {[file exists $fn]} {
+ set ch [open $fn r]
+ set txt [read $ch]
+ close $ch
+ ProcessPlotNew $varname $xarname $iname $txt
+ }
+ } else {
+ ProcessPlotNew $varname $xarname $iname {}
+ }
+ }
+ new {
+ incr i
+ switch -- [lindex $xar $i] {
+ name {
+ set varname [lindex $xar [expr $i+1]]
+ incr i 2
+ }
+ }
+ if {$buf != {}} {
+ ProcessPlotNew $varname $xarname $iname $buf
+ } elseif {$fn != {}} {
+ if {[file exists $fn]} {
+ set ch [open $fn r]
+ set txt [read $ch]
+ close $ch
+ ProcessPlotNew $varname $xarname $iname $txt
+ }
+ } else {
+ ProcessPlotNew $varname $xarname $iname {}
+ }
+ }
+ data {
+ incr i
+ if {$buf != {}} {
+ ProcessPlotData $varname $xarname $iname $buf
+ } elseif {$fn != {}} {
+ if {[file exists $fn]} {
+ set ch [open $fn r]
+ set txt [read $ch]
+ close $ch
+ ProcessPlotData $varname $xarname $iname $txt
+ }
+ }
+ }
+
+ load {
+ # File Menu
+ set ff [lindex $xar [expr $i+1]]
+ set dim [lindex $xar [expr $i+2]]
+ incr i 2
+ PlotLoadDataFile $varname $ff $dim
+ FileLast apdatafbox $ff
+ }
+ save {
+ # File Menu
+ incr i
+ set ff [lindex $xar $i]
+ PlotSaveDataFile $varname $ff
+ FileLast apdatafbox $ff
+ }
+ clear {
+ # File Menu
+ PlotClearData $varname
+ }
+ dup -
+ duplicate {
+ # File Menu
+ incr i
+ set mm [lindex $xar $i]
+ if {$mm == {}} {
+ set mm 1
+ } elseif {![string is integer $mm]} {
+ set mm 1
+ incr i -1
+ }
+ PlotDupData $varname $mm
+ }
+ stats -
+ statistics {
+ # File Menu
+ set var(stats) 1
+ PlotStats $varname
+ }
+ list {
+ # File Menu
+ set var(list) 1
+ PlotList $varname
+ }
+ loadconfig {
+ # File Menu
+ incr i
+ set ff [lindex $xar $i]
+ PlotLoadConfigFile $varname $ff
+ FileLast apconfigfbox $ff
+ }
+ saveconfig {
+ # File Menu
+ incr i
+ set ff [lindex $xar $i]
+ PlotSaveConfigFile $varname $ff
+ FileLast apconfigfbox $ff
+ }
+ page -
+ pagesetup {
+ # File Menu
+ incr i
+ ProcessPlotPageSetup $varname $xarname $iname
+ }
+ print {
+ # File Menu
+ incr i
+ ProcessPlotPrint $varname $xarname $iname
+ }
+ close {
+ # File Menu
+ PlotDestroy $varname
+ }
+
+ mode {
+ # Edit Menu
+ incr i
+ set var(mode) [lindex $xar $i]
+ PlotChangeMode $varname
+ }
+
+ axis {
+ # Graph Menu
+ incr i
+ ProcessPlotAxis $varname $xarname $iname
+ }
+ legend {
+ # Graph Menu
+ incr i
+ ProcessPlotLegend $varname $xarname $iname
+ }
+ font {
+ # Graph Menu
+ incr i
+ ProcessPlotFont $varname $xarname $iname
+ }
+ title {
+ # Graph Menu
+ incr i
+ ProcessPlotTitle $varname $xarname $iname
+ }
+ barmode {
+ incr i
+ set var(bar,mode) [lindex $xar $i]
+ $var(proc,updategraph) $varname
+ }
+
+ show {
+ # Dataset Menu
+ incr i
+ set var(show) [FromYesNo [lindex $xar $i]]
+ $var(proc,updateelement) $varname
+ }
+ color {
+ incr i
+ ProcessPlotColor $varname $xarname $iname
+ }
+ fill {
+ incr i
+ set var(fill) [FromYesNo [lindex $xar $i]]
+ $var(proc,updateelement) $varname
+ }
+ fillcolor {
+ incr i
+ set var(fill,color) [lindex $xar $i]
+ $var(proc,updateelement) $varname
+ }
+ error -
+ errorbar {
+ # Dataset Menu
+ incr i
+ ProcessPlotErrorBar $varname $xarname $iname
+ }
+ name {
+ # Dataset Menu
+ incr i
+ set var(name) [lindex $xar $i]
+ $var(proc,updateelement) $varname
+ }
+ shape {
+ # Dataset Line Menu
+ incr i
+ ProcessPlotShape $varname $xarname $iname
+ }
+ relief {
+ # Dataset Bar Menu
+ incr i
+ set var(bar,relief) [lindex $xar $i]
+ $var(proc,updateelement) $varname
+ }
+ smooth {
+ # Dataset Line Menu
+ incr i
+ set var(smooth) [lindex $xar $i]
+ $var(proc,updateelement) $varname
+ }
+ width {
+ # Dataset Line Menu
+ incr i
+ set var(width) [lindex $xar $i]
+ $var(proc,updateelement) $varname
+ }
+ dash {
+ # Dataset Line Menu
+ incr i
+ set var(dash) [FromYesNo [lindex $xar $i]]
+ $var(proc,updateelement) $varname
+ }
+
+ dataset -
+ select {
+ # Select Menu
+ incr i
+ set var(data,current) [lindex $xar $i]
+ PlotCurrentData $varname
+ }
+
+ graph {
+ # backward compatibility
+ incr i
+ ProcessPlotGraph $varname $xarname $iname
+ }
+ line {
+ # backward compatibility
+ incr i
+ ProcessPlotLine $varname $xarname $iname
+ }
+ view {
+ # backward compatibility
+ incr i
+ ProcessPlotView $varname $xarname $iname
+ }
+ }
+ } else {
+ ProcessPlotNew $varname $xarname $iname {}
+ }
+
+ # force update
+ update idletasks
+}
+
+proc ProcessPlotNew {varname xarname iname buf} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ # check for next command line option
+ if {[string range [lindex $xar $i] 0 0] != {-}} {
+ switch -- [string tolower [lindex $xar $i]] {
+ line {incr i; ProcessPlotNewOne line $varname $xarname $iname $buf}
+ bar {incr i;ProcessPlotNewOne bar $varname $xarname $iname $buf}
+ scatter {
+ incr i
+ ProcessPlotNewOne scatter $varname $xarname $iname $buf
+ }
+ default {ProcessPlotNewOne line $varname $xarname $iname $buf}
+ }
+ } else {
+ PlotLine $varname {} {} {} {} xy $buf
+ incr i -1
+ }
+}
+
+proc ProcessPlotNewOne {which varname xarname iname buf} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 3 $xarname xar
+ upvar 3 $iname i
+
+ if {[string range [lindex $xar $i] 0 0] != {-}} {
+ switch -- [string tolower [lindex $xar $i]] {
+ stdin {incr i; AnalysisPlotStdin $which $varname {} $buf}
+ {} {
+ switch $which {
+ line {PlotLine $varname {} {} {} {} xy $buf}
+ bar {PlotBar $varname {} {} {} {} xy $buf}
+ scatter {PlotScatter $varname {} {} {} {} xy $buf}
+ }
+ }
+ default {
+ switch $which {
+ line {
+ PlotLine $varname {} \
+ [lindex $xar $i] \
+ [lindex $xar [expr $i+1]] \
+ [lindex $xar [expr $i+2]] \
+ [lindex $xar [expr $i+3]] \
+ $buf
+ }
+ bar {
+ PlotBar $varname {} \
+ [lindex $xar $i] \
+ [lindex $xar [expr $i+1]] \
+ [lindex $xar [expr $i+2]] \
+ [lindex $xar [expr $i+3]] \
+ $buf
+ }
+ scatter {
+ PlotScatter $varname {} \
+ [lindex $xar $i] \
+ [lindex $xar [expr $i+1]] \
+ [lindex $xar [expr $i+2]] \
+ [lindex $xar [expr $i+3]] \
+ $buf
+ }
+ }
+ incr i 3
+ }
+ }
+ } else {
+ switch $which {
+ line {PlotLine $varname {} {} {} {} xy $buf}
+ bar {PlotBar $varname {} {} {} {} xy $buf}
+ scatter {PlotScatter $varname {} {} {} {} xy $buf}
+ }
+ incr i -1
+ }
+}
+
+proc ProcessPlotData {varname xarname iname buf} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ PlotRaise $varname
+ PlotDataSet $varname [lindex $xar $i] $buf
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+}
+
+# File Menu
+proc ProcessPlotPrint {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ global ps
+ global current
+
+ switch -- [string tolower [lindex $xar $i]] {
+ destination {incr i; set ps(dest) [lindex $xar $i]}
+ command {incr i; set ps(cmd) [lindex $xar $i]}
+ filename {incr i; set ps(filename) [lindex $xar $i] }
+ palette -
+ color {incr i; set ps(color) [lindex $xar $i] }
+
+ {} {PlotPostScript $varname}
+ default {incr i -1; PlotPostScript $varname}
+ }
+}
+
+proc ProcessPlotPageSetup {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ global ps
+
+ switch -- [string tolower [lindex $xar $i]] {
+ orientation -
+ orient {incr i; set ps(orient) [lindex $xar $i]}
+ pagesize -
+ size {incr i; set ps(size) [lindex $xar $i] }
+ }
+}
+
+# Graph Menu
+proc ProcessPlotAxis {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ x {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ grid {incr i; set var(axis,x,grid) [FromYesNo [lindex $xar $i]]}
+ log {incr i; set var(axis,x,log) [FromYesNo [lindex $xar $i]]}
+ flip {incr i; set var(axis,x,flip) [FromYesNo [lindex $xar $i]]}
+ auto {incr i; set var(axis,x,auto) [FromYesNo [lindex $xar $i]]}
+ min {incr i; set var(axis,x,min) [lindex $xar $i]}
+ max {incr i; set var(axis,x,max) [lindex $xar $i]}
+ format {incr i; set var(axis,x,format) [lindex $xar $i]}
+ }
+ }
+ y {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ grid {incr i; set var(axis,y,grid) [FromYesNo [lindex $xar $i]]}
+ log {incr i; set var(axis,y,log) [FromYesNo [lindex $xar $i]]}
+ flip {incr i; set var(axis,y,flip) [FromYesNo [lindex $xar $i]]}
+ auto {incr i; set var(axis,y,auto) [FromYesNo [lindex $xar $i]]}
+ min {incr i; set var(axis,y,min) [lindex $xar $i]}
+ max {incr i; set var(axis,y,max) [lindex $xar $i]}
+ format {incr i; set var(axis,y,format) [lindex $xar $i]}
+ }
+ }
+ }
+
+ $var(proc,updategraph) $varname
+}
+
+proc ProcessPlotLegend {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ position {incr i; set var(legend,position) [lindex $xar $i]}
+ default {set var(legend) [FromYesNo [lindex $xar $i]]}
+ }
+
+ $var(proc,updategraph) $varname
+}
+
+proc ProcessPlotFont {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ title {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ family -
+ font {incr i; set var(graph,title,family) [lindex $xar $i]}
+ size {incr i; set var(graph,title,size) [lindex $xar $i]}
+ weight {incr i; set var(graph,title,weight) [lindex $xar $i]}
+ slant {incr i; set var(graph,title,slant) [lindex $xar $i]}
+ style {
+ incr i
+ switch [string tolower [lindex $xar $i]] {
+ normal {
+ set var(graph,title,weight) normal
+ set var(graph,title,slant) roman
+ }
+ bold {
+ set var(graph,title,weight) bold
+ set var(graph,title,slant) roman
+ }
+ italic {
+ set var(graph,title,weight) normal
+ set var(graph,title,slant) italic
+ }
+ }
+ }
+ }
+ }
+ axestitle -
+ labels {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ family -
+ font {incr i; set var(axis,title,family) [lindex $xar $i]}
+ size {incr i; set var(axis,title,size) [lindex $xar $i]}
+ weight {incr i; set var(axis,title,weight) [lindex $xar $i]}
+ slant {incr i; set var(axis,title,slant) [lindex $xar $i]}
+ style {
+ incr i
+ switch [string tolower [lindex $xar $i]] {
+ normal {
+ set var(axis,title,weight) normal
+ set var(axis,title,slant) roman
+ }
+ bold {
+ set var(axis,title,weight) bold
+ set var(axis,title,slant) roman
+ }
+ italic {
+ set var(axis,title,weight) normal
+ set var(axis,title,slant) italic
+ }
+ }
+ }
+ }
+ }
+ axesnumbers -
+ numbers {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ family -
+ font {incr i; set var(axis,font,family) [lindex $xar $i]}
+ size {incr i; set var(axis,font,size) [lindex $xar $i]}
+ weight {incr i; set var(axis,font,weight) [lindex $xar $i]}
+ slant {incr i; set var(axis,font,slant) [lindex $xar $i]}
+ style {
+ incr i
+ switch [string tolower [lindex $xar $i]] {
+ normal {
+ set var(axis,font,weight) normal
+ set var(axis,font,slant) roman
+ }
+ bold {
+ set var(axis,font,weight) bold
+ set var(axis,font,slant) roman
+ }
+ italic {
+ set var(axis,font,weight) normal
+ set var(axis,font,slant) italic
+ }
+ }
+ }
+ }
+ }
+ legendtitle {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ family -
+ font {incr i; set var(legend,title,family) [lindex $xar $i]}
+ size {incr i; set var(legend,title,size) [lindex $xar $i]}
+ weight {incr i; set var(legend,title,weight) [lindex $xar $i]}
+ slant {incr i; set var(legend,title,slant) [lindex $xar $i]}
+ }
+ }
+ legend {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ family -
+ font {incr i; set var(legend,font,family) [lindex $xar $i]}
+ size {incr i; set var(legend,font,size) [lindex $xar $i]}
+ weight {incr i; set var(legend,font,weight) [lindex $xar $i]}
+ slant {incr i; set var(legend,font,slant) [lindex $xar $i]}
+ }
+ }
+ }
+
+ $var(proc,updategraph) $varname
+}
+
+proc ProcessPlotTitle {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ x -
+ xaxis {incr i; set var(axis,x,title) [lindex $xar $i]}
+ y -
+ yaxis {incr i; set var(axis,y,title) [lindex $xar $i]}
+ legend {incr i; set var(legend,title) [lindex $xar $i]}
+ default {set var(graph,title) [lindex $xar $i]}
+ }
+
+ $var(proc,updategraph) $varname
+}
+
+proc ProcessPlotErrorBar {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ cap {incr i; set var(error,cap) [FromYesNo [lindex $xar $i]]}
+ color {incr i; set var(error,color) [lindex $xar $i]}
+ width {incr i; set var(error,width) [lindex $xar $i]}
+ default {set var(error) [FromYesNo [lindex $xar $i]]}
+ }
+
+ $var(proc,updateelement) $varname
+}
+
+# Dataset Menu
+proc ProcessPlotShape {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ fill {incr i; set var(shape,fill) [FromYesNo [lindex $xar $i]]}
+ color {incr i; set var(shape,color) [lindex $xar $i]}
+ default {set var(shape,symbol) [lindex $xar $i]}
+ }
+
+ $var(proc,updateelement) $varname
+}
+
+proc ProcessPlotColor {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ discrete -
+ line -
+ linear -
+ step -
+ quadratic -
+ bar {
+ # backward compatibility
+ incr i
+ set var(color) [lindex $xar $i]
+ }
+ error -
+ errorbar {
+ # backward compatibility
+ incr i
+ set var(error,color) [lindex $xar $i]
+ }
+ default {
+ # Dataset Menu
+ set var(color) [lindex $xar $i]
+ }
+ }
+
+ $var(proc,updateelement) $varname
+}
+
+# backward compatibility
+proc ProcessPlotGraph {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ grid {
+ incr i;
+ switch -- [string tolower [lindex $xar $i]] {
+ x {incr i; set var(axis,x,grid) [FromYesNo [lindex $xar $i]]}
+ y {incr i; set var(axis,y,grid) [FromYesNo [lindex $xar $i]]}
+ default {
+ # backward compatibility
+ set var(axis,y,grid) [FromYesNo [lindex $xar $i]]
+ set var(axis,x,grid) [FromYesNo [lindex $xar $i]]
+ }
+ }
+ }
+ log {
+ incr i;
+ switch -- [string tolower [lindex $xar $i]] {
+ x {incr i; set var(axis,x,log) [FromYesNo [lindex $xar $i]]}
+ y {incr i; set var(axis,y,log) [FromYesNo [lindex $xar $i]]}
+ }
+ }
+ flip {
+ incr i;
+ switch -- [string tolower [lindex $xar $i]] {
+ x {incr i; set var(axis,x,flip) [FromYesNo [lindex $xar $i]]}
+ y {incr i; set var(axis,y,flip) [FromYesNo [lindex $xar $i]]}
+ }
+ }
+ format {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ x {incr i; set var(axis,x,format) [lindex $xar $i]}
+ y {incr i; set var(axis,y,format) [lindex $xar $i]}
+ }
+ }
+ range {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ x {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ auto {
+ incr i
+ set var(axis,x,auto) [FromYesNo [lindex $xar $i]]
+ }
+ min {incr i; set var(axis,x,min) [lindex $xar $i]}
+ max {incr i; set var(axis,x,max) [lindex $xar $i]}
+ }
+ }
+ y {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ auto {
+ incr i
+ set var(axis,y,auto) [FromYesNo [lindex $xar $i]]
+ }
+ min {incr i; set var(axis,y,min) [lindex $xar $i]}
+ max {incr i; set var(axis,y,max) [lindex $xar $i]}
+ }
+ }
+ }
+ }
+ labels {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ title {incr i; set var(graph,title) [lindex $xar $i]}
+ xaxis {incr i; set var(axis,x,title) [lindex $xar $i]}
+ yaxis {incr i; set var(axis,y,title) [lindex $xar $i]}
+ legend {incr i; set var(legend,title) [lindex $xar $i]}
+ }
+ }
+ type {
+ # backward compatibility
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ line -
+ bar {}
+ }
+ }
+ scale {
+ # backward compatibility
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ linearlinear {
+ set var(axis,x,log) 0
+ set var(axis,y,log) 0
+ }
+ linearlog {
+ set var(axis,x,log) 0
+ set var(axis,y,log) 1
+ }
+ loglinear {
+ set var(axis,x,log) 1
+ set var(axis,y,log) 0
+ }
+ loglog {
+ set var(axis,x,log) 1
+ set var(axis,y,log) 1
+ }
+ }
+ }
+ }
+
+ $var(proc,updategraph) $varname
+}
+
+# backward compatibility
+proc ProcessPlotView {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ discrete {
+ incr i
+ set var(show) [FromYesNo [lindex $xar $i]]
+ }
+ line -
+ linear {
+ incr i
+ if {[FromYesNo [lindex $xar $i]]} {
+ set var(show) 1
+ set var(smooth) linear
+ }
+ }
+ step {
+ incr i
+ if {[FromYesNo [lindex $xar $i]]} {
+ set var(show) 1
+ set var(smooth) step
+ }
+ }
+ quadratic {
+ incr i
+ if {[FromYesNo [lindex $xar $i]]} {
+ set var(show) 1
+ set var(smooth) quadratic
+ }
+ }
+ error -
+ errorbar {
+ incr i
+ set var(error) [FromYesNo [lindex $xar $i]]
+ }
+ }
+
+ $var(proc,updateelement) $varname
+}
+
+# backward compatibility
+proc ProcessPlotLine {varname xarname iname} {
+ upvar #0 $varname var
+ global $varname
+
+ upvar 2 $xarname xar
+ upvar 2 $iname i
+
+ switch -- [string tolower [lindex $xar $i]] {
+ discrete {
+ incr i
+ set var(shape,symbol) [lindex $xar $i]
+ }
+ line -
+ linear -
+ step -
+ quadratic -
+ error -
+ errorbar {
+ incr i
+ switch -- [string tolower [lindex $xar $i]] {
+ width {
+ incr i
+ set var(width) [lindex $xar $i]
+ }
+ dash {
+ incr i
+ set var(dash) [FromYesNo [lindex $xar $i]]
+ }
+ style {
+ incr i
+ set var(error) 1
+ }
+ }
+ }
+ }
+
+ $var(proc,updateelement) $varname
+}
+
+proc ProcessSendPlotCmd {proc id param} {
+ global iap
+
+ set i 0
+
+ # determine which plot
+ switch -- [string tolower [lindex $param $i]] {
+ {} -
+ stats -
+ statistics -
+ list -
+ mode -
+ axis -
+ legend -
+ font -
+ title -
+ barmode -
+ show -
+ color -
+ error -
+ errorbar -
+ name -
+ shape -
+ relief -
+ smooth -
+ width -
+ dash -
+ dataset -
+ select {
+ set varname [lindex $iap(windows) end]
+ set idd [lsearch $iap(windows) $varname]
+ }
+
+ default {
+ set varname [lindex $param $i]
+ set idd [lsearch $iap(windows) $varname]
+ incr i
+ }
+ }
+
+ # we better have a tt by now
+ if {$idd == -1} {
+ Error "[msgcat::mc {Unable to find plot window}] $varname"
+ return
+ }
+
+ upvar #0 $varname var
+ global $varname
+
+ # now, process plot command
+ switch -- [string tolower [lindex $param $i]] {
+ {} {$proc $id "$iap(windows)\n"}
+ stats -
+ statistics {$proc $id "[PlotStatsGenerate $varname]"}
+ list {$proc $id "[PlotListGenerate $varname]"}
+ mode {$proc $id "$var(mode)\n"}
+ axis {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ x {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ grid {$proc $id [ToYesNo $var(axis,x,grid)]}
+ log {$proc $id [ToYesNo $var(axis,x,log)]}
+ flip {$proc $id [ToYesNo $var(axis,x,flip)]}
+ auto {$proc $id [ToYesNo $var(axis,x,auto)]}
+ min {$proc $id "$var(axis,x,min)\n"}
+ max {$proc $id "$var(axis,x,max)\n"}
+ format {$proc $id "$var(axis,x,format)\n"}
+ }
+ }
+ y {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ grid {$proc $id [ToYesNo $var(axis,y,grid)]}
+ log {$proc $id [ToYesNo $var(axis,y,log)]}
+ flip {$proc $id [ToYesNo $var(axis,y,flip)]}
+ auto {$proc $id [ToYesNo $var(axis,y,auto)]}
+ min {$proc $id "$var(axis,y,min)\n"}
+ max {$proc $id "$var(axis,y,max)\n"}
+ format {$proc $id "$var(axis,y,format)\n"}
+ }
+ }
+ }
+ }
+ legend {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ position {$proc $id "$var(legend,position)\n"}
+ default {$proc $id [ToYesNo $var(legend)]}
+ }
+ }
+ font {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ title {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ family -
+ font {$proc $id "$var(graph,title,family)\n"}
+ size {$proc $id "$var(graph,title,size)\n"}
+ weight {$proc $id "$var(graph,title,weight)\n"}
+ slant {$proc $id "$var(graph,title,slant)\n"}
+ }
+ }
+ axestitle -
+ labels {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ family -
+ font {$proc $id "$var(axis,title,family)\n"}
+ size {$proc $id "$var(axis,title,size)\n"}
+ weight {$proc $id "$var(axis,title,weight)\n"}
+ slant {$proc $id "$var(axis,title,slant)\n"}
+ }
+ }
+ axesnumbers -
+ numbers {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ family -
+ font {$proc $id "$var(axis,font,family)\n"}
+ size {$proc $id "$var(axis,font,size)\n"}
+ weight {$proc $id "$var(axis,font,weight)\n"}
+ slant {$proc $id "$var(axis,font,slant)\n"}
+ }
+ }
+ legendtitle {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ family -
+ font {$proc $id "$var(legend,title,family)\n"}
+ size {$proc $id "$var(legend,title,size)\n"}
+ weight {$proc $id "$var(legend,title,weight)\n"}
+ slant {$proc $id "$var(legend,title,slant)\n"}
+ }
+ }
+ legend {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ family -
+ font {$proc $id "$var(legend,font,family)\n"}
+ size {$proc $id "$var(legend,font,size)\n"}
+ weight {$proc $id "$var(legend,font,weight)\n"}
+ slant {$proc $id "$var(legend,font,slant)\n"}
+ }
+ }
+ }
+ }
+ title {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ x -
+ xaxis {$proc $id "$var(axis,x,title)\n"}
+ y -
+ yaxis {$proc $id "$var(axis,y,title)\n"}
+ legend {$proc $id "$var(legend,title)\n"}
+ default {$proc $id "$var(graph,title)\n"}
+ }
+ }
+ barmode {$proc $id "$var(bar,mode)\n"}
+
+ show {$proc $id [ToYesNo $var(show)]}
+ color {$proc $id "$var(color)\n"}
+ fill {$proc $id [ToYesNo $var(fill)]}
+ fillcolor {$proc $id "$var(fill,color)\n"}
+ error -
+ errorbar {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ cap {$proc $id [ToYesNo $var(error,cap)]}
+ color {$proc $id "$var(error,color)\n"}
+ width {$proc $id "$var(error,width)\n"}
+ default {$proc $id [ToYesNo $var(error)]}
+ }
+ }
+ name {$proc $id "$var(name)\n"}
+ shape {
+ incr i
+ switch -- [string tolower [lindex $param $i]] {
+ fill {$proc $id [ToYesNo $var(shape,fill)]}
+ color {$proc $id "$var(shape,color)\n"}
+ default {$proc $id "$var(shape,symbol)\n"}
+ }
+ }
+ relief {$proc $id "$var(bar,relief)\n"}
+ smooth {$proc $id "$var(smooth)\n"}
+ width {$proc $id "$var(width)\n"}
+ dash {$proc $id [ToYesNo $var(dash)]}
+ dataset -
+ select {$proc $id "$var(data,current)\n"}
+ }
+}
diff --git a/ds9/library/plotscatter.tcl b/ds9/library/plotscatter.tcl
new file mode 100644
index 0000000..335b527
--- /dev/null
+++ b/ds9/library/plotscatter.tcl
@@ -0,0 +1,256 @@
+# 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
+
+# used by backup
+proc PlotScatterTool {} {
+ global iap
+ PlotScatter $iap(tt) [msgcat::mc {Scatter Plot Tool}] {} {} {} 2 {}
+}
+
+proc PlotScatter {tt wtt title xaxis yaxis dim data} {
+ global iap
+
+ # make the window name unique
+ set ii [lsearch $iap(windows) $tt]
+ if {$ii>=0} {
+ incr iap(unique)
+ append tt $iap(unique)
+ }
+
+ # set the window title if none
+ if {$wtt == {}} {
+ set wtt $tt
+ }
+
+ set varname $tt
+ upvar #0 $varname var
+ global $varname
+
+ PlotScatterProc $varname
+ PlotDialog $varname $wtt $title $xaxis $yaxis
+ PlotDialogScatter $varname
+
+ PlotDataSet $varname $dim $data
+ $var(proc,updategraph) $varname
+ PlotStats $varname
+ PlotList $varname
+}
+
+proc PlotScatterDialog {varname wtt title xaxis yaxis} {
+ upvar #0 $varname var
+ global $varname
+
+ PlotScatterProc $varname
+ PlotDialog $varname $wtt $title $xaxis $yaxis
+ PlotDialogScatter $varname
+}
+
+proc PlotScatterProc {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(proc,updategraph) PlotUpdateGraph
+ set var(proc,updateelement) PlotScatterUpdateElement
+ set var(proc,highlite) PlotScatterHighliteElement
+ set var(proc,button) PlotScatterButton
+}
+
+proc PlotDialogScatter {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ set var(seq) 0
+
+ # Dataset
+ $var(mb).dataset add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(show) \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset add separator
+ $var(mb).dataset add cascade -label [msgcat::mc {Shape}] \
+ -menu $var(mb).dataset.shape
+ $var(mb).dataset add cascade -label [msgcat::mc {Error}] \
+ -menu $var(mb).dataset.error
+ $var(mb).dataset add separator
+ $var(mb).dataset add command -label "[msgcat::mc {Name}]..." \
+ -command [list DatasetNameDialog $varname]
+
+ # Shape
+ menu $var(mb).dataset.shape
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Circle}] \
+ -variable ${varname}(shape,symbol) -value circle \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Square}] \
+ -variable ${varname}(shape,symbol) -value square \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Diamond}] \
+ -variable ${varname}(shape,symbol) -value diamond \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Plus}] \
+ -variable ${varname}(shape,symbol) -value plus \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Cross}] \
+ -variable ${varname}(shape,symbol) -value cross \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Simple Plus}] \
+ -variable ${varname}(shape,symbol) -value splus \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Simple Cross}] \
+ -variable ${varname}(shape,symbol) -value scross \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Triangle}] \
+ -variable ${varname}(shape,symbol) -value triangle \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add radiobutton \
+ -label [msgcat::mc {Arrow}] \
+ -variable ${varname}(shape,symbol) -value arrow \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add separator
+ $var(mb).dataset.shape add checkbutton \
+ -label [msgcat::mc {Fill}] \
+ -variable ${varname}(shape,fill) \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.shape add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.shape.color
+
+ # Color
+ PlotColorMenu $var(mb).dataset.shape.color $varname shape,color \
+ [list PlotScatterUpdateElement $varname]
+
+ # Error
+ menu $var(mb).dataset.error
+ $var(mb).dataset.error add checkbutton -label [msgcat::mc {Show}] \
+ -variable ${varname}(error) \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.error add checkbutton -label [msgcat::mc {Cap}] \
+ -variable ${varname}(error,cap) \
+ -command [list PlotScatterUpdateElement $varname]
+ $var(mb).dataset.error add separator
+ $var(mb).dataset.error add cascade -label [msgcat::mc {Color}] \
+ -menu $var(mb).dataset.error.color
+ $var(mb).dataset.error add cascade -label [msgcat::mc {Width}] \
+ -menu $var(mb).dataset.error.width
+
+ PlotColorMenu $var(mb).dataset.error.color $varname error,color \
+ [list PlotScatterUpdateElement $varname]
+ WidthDashMenu $var(mb).dataset.error.width $varname error,width {} \
+ [list PlotScatterUpdateElement $varname] {}
+
+ # graph
+ set var(type) scatter
+ set var(graph) [blt::graph $var(top).scatter \
+ -width 600 \
+ -height 500 \
+ -highlightthickness 0 \
+ ]
+
+ pack $var(graph) -expand yes -fill both
+ PlotChangeMode $varname
+}
+
+proc PlotScatterUpdateElement {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # warning: uses current vars
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ set nn $var(data,current)
+ PlotGetVar $varname $nn
+
+ if {$var(shape,symbol) == "none"} {
+ set var(shape,symbol) circle
+ }
+
+ if {$var(shape,fill)} {
+ set clr $var(shape,color)
+ } else {
+ set clr {}
+ }
+
+ if {$var(error)} {
+ set show both
+ } else {
+ set show none
+ }
+
+ if {$var(error,cap)} {
+ set cap [expr $var(error,width)+3]
+ } else {
+ set cap 0
+ }
+
+ $var(graph) element configure "d-${nn}" \
+ -label "$var(name)" -hide [expr !$var(show)] \
+ -symbol $var(shape,symbol) \
+ -fill $clr -outline $var(shape,color) \
+ -linewidth 0 -pixels 5 -scalesymbols no \
+ -showerrorbars $show -errorbarcolor $var(error,color) \
+ -errorbarwidth $var(error,width) -errorbarcap $cap
+
+ $var(graph) pen configure active -color blue \
+ -symbol $var(shape,symbol) \
+ -linewidth 0 -pixels 5 \
+ -showerrorbars $show -errorbarcolor $var(error,color) \
+ -errorbarwidth $var(error,width) -errorbarcap $cap
+}
+
+proc PlotScatterButton {varname x y} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ if {$var(callback) == {}} {
+ return
+ }
+
+ set rr [$var(graph) element closest $x $y]
+ set elem [lindex $rr 1]
+ set row [lindex $rr 3]
+
+ if {$elem != {}} {
+ if {$row != {}} {
+ $var(graph) element deactivate $elem
+ $var(graph) element activate $elem $row
+ # rows start at 1
+ eval "$var(callback) [expr $row+1]"
+ } else {
+ $var(graph) element deactivate $elem
+ eval "$var(callback) {}"
+ }
+ }
+}
+
+proc PlotScatterHighliteElement {varname rowlist} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(data,total) == 0} {
+ return
+ }
+
+ if {$var(show)} {
+ $var(graph) element deactivate d-1
+ if {$rowlist != {}} {
+ # can have multiple rows
+ eval "$var(graph) element activate d-1 $rowlist"
+ }
+ }
+}
diff --git a/ds9/library/point.tcl b/ds9/library/point.tcl
new file mode 100644
index 0000000..fd9adde
--- /dev/null
+++ b/ds9/library/point.tcl
@@ -0,0 +1,111 @@
+# 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 PointDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(proc,apply) PointApply
+ set var(proc,close) PointClose
+ set var(proc,coordCB) PointCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # menus
+ $var(mb) add cascade -label [msgcat::mc {Shape}] -menu $var(mb).shape
+ menu $var(mb).shape
+ $var(mb).shape add radiobutton -label [msgcat::mc {Circle}] \
+ -variable ${varname}(shape) -value circle \
+ -command "PointShape $varname"
+ $var(mb).shape add radiobutton -label [msgcat::mc {Box}] \
+ -variable ${varname}(shape) -value box \
+ -command "PointShape $varname"
+ $var(mb).shape add radiobutton -label [msgcat::mc {Diamond}] \
+ -variable ${varname}(shape) -value diamond \
+ -command "PointShape $varname"
+ $var(mb).shape add radiobutton -label [msgcat::mc {Cross}] \
+ -variable ${varname}(shape) -value cross \
+ -command "PointShape $varname"
+ $var(mb).shape add radiobutton -label [msgcat::mc {X}] \
+ -variable ${varname}(shape) -value x \
+ -command "PointShape $varname"
+ $var(mb).shape add radiobutton -label [msgcat::mc {Arrow}] \
+ -variable ${varname}(shape) -value arrow \
+ -command "PointShape $varname"
+ $var(mb).shape add radiobutton -label [msgcat::mc {BoxCircle}] \
+ -variable ${varname}(shape) -value boxcircle \
+ -command "PointShape $varname"
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ # plot3d
+ MarkerAnalysisPlot3dDialog $varname
+
+ # init
+ set var(shape) [$var(frame) get marker $var(id) point shape]
+ set var(size) [$var(frame) get marker $var(id) point size]
+
+ set f $var(top).param
+
+ # size
+ ttk::label $f.tsize -text [msgcat::mc {Size}]
+ ttk::entry $f.size -textvariable ${varname}(size) -width 13
+ ttk::label $f.usize -text [msgcat::mc {Pixels}]
+
+ grid $f.tsize $f.size $f.usize -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc PointClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseCenterClose $varname
+}
+
+proc PointApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) point size $var(size)
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc PointCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "PointCoordCB"
+ }
+
+ MarkerAnalysisPlot3dSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+}
+
+# support
+
+proc PointShape {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) point shape $var(shape)
+}
diff --git a/ds9/library/polygon.tcl b/ds9/library/polygon.tcl
new file mode 100644
index 0000000..82ab00a
--- /dev/null
+++ b/ds9/library/polygon.tcl
@@ -0,0 +1,84 @@
+# 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 PolygonDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(proc,apply) PolygonApply
+ set var(proc,close) PolygonClose
+ set var(proc,coordCB) PolygonCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ MarkerAnalysisStatsDialog $varname
+ MarkerAnalysisHistogramDialog $varname
+ MarkerAnalysisPlot3dDialog $varname
+
+ # init
+ MarkerBaseCenterRotateCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback rotate MarkerBaseCenterRotateCB $varname
+
+ set f $var(top).param
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc PolygonClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc PolygonApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseCenterRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc PolygonCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "PolygonCoordCB"
+ }
+
+ MarkerAnalysisStatsSystem $varname
+ MarkerAnalysisPlot3dSystem $varname
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
diff --git a/ds9/library/prefs.tcl b/ds9/library/prefs.tcl
new file mode 100644
index 0000000..d894965
--- /dev/null
+++ b/ds9/library/prefs.tcl
@@ -0,0 +1,1004 @@
+# 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 PrefsDef {} {
+ global prefs
+ global iprefs
+ global ds9
+
+ set iprefs(top) .pf
+ set iprefs(mb) .pfmb
+ set iprefs(tabs) {}
+
+ set prefs(ext) {.prf}
+ set prefs(version) [lindex $ds9(version) 0]
+ set prefs(dir) [file join [GetEnvHome] ".$ds9(app)"]
+ set prefs(fn) [file join $prefs(dir) "$ds9(app).$prefs(version)$prefs(ext)"]
+}
+
+proc LoadPrefs {} {
+ global ds9
+ global prefs
+
+ if {[file exist $prefs(dir)] && [file isdirectory $prefs(dir)]} {
+ # new style
+ # look for current version
+ switch -- [SourceInitFile $prefs(fn)] {
+ 1 {
+ # success
+ FixPrefs $prefs(version)
+ }
+ 0 {
+ # found and failed to execute
+ }
+ -1 {
+ # look for prev version
+ set major [lindex [split $prefs(version) {.}] 0]
+ set minor [lindex [split $prefs(version) {.}] 1]
+ if {$minor>0} {
+ set minor [expr $minor-1]
+ } else {
+ set major [expr $minor-1]
+ set minor 9
+ }
+ set fn [file join $prefs(dir) "$ds9(app).${major}.${minor}$prefs(ext)"]
+ if {[SourceInitFile $fn] == 1} {
+ FixPrefs $prefs(version)
+ }
+ }
+ }
+ } else {
+ # ok, try old style
+ if {[SourceInitFileDir $prefs(ext)]} {
+ # ok, this is a major kludge to fix a major booboo.
+ # Beta versions generated prefs with version set to
+ # something like '7.4b7'. We need to remove the 'b7' part.
+ set ll [string first {b} $prefs(version)]
+ if {$ll != -1} {
+ set ll [expr $ll -1]
+ set prefs(version) [string range $prefs(version) 0 $ll]
+ }
+ FixPrefs $prefs(version)
+ }
+ }
+}
+
+proc CheckPrefs {} {
+ global ds9
+ global prefs
+
+ set rr [string compare $prefs(version) [lindex $ds9(version) 0]]
+ switch $rr {
+ -1 {
+ if {[tk_messageBox -type yesno -icon question -message [msgcat::mc {DS9 has detected an older preferences file, do you wish to update?}]] == {yes}} {
+ SavePrefs
+ }
+ }
+ 0 {}
+ 1 {
+ tk_messageBox -type ok -icon warning -message [msgcat::mc {DS9 has detected a newer version of a preferences file.}]
+ }
+ }
+}
+
+proc ClearPrefs {} {
+ global ds9
+ global prefs
+
+ if {[file exist $prefs(dir)] && [file isdirectory $prefs(dir)]} {
+ # clear new style
+ if {[file exist $prefs(fn)]} {
+ catch {file delete -force $prefs(fn)}
+ }
+ } else {
+ # make sure old prefs files are removed
+ foreach pp {{.} {}} {
+ set fn $pp$ds9(app)$prefs(ext)
+ foreach dir [list {.} [GetEnvHome]] {
+ set ff [file join $dir $fn]
+ if {[file exist $ff]} {
+ catch {file delete -force $ff}
+ return
+ }
+ }
+ }
+ }
+}
+
+proc SavePrefs {} {
+ global tcl_platform
+ global ds9
+ global prefs
+
+ ClearPrefs
+
+ # new style prefs file
+ # mkdir if needed
+ catch {file mkdir $prefs(dir)}
+ if {![file exist $prefs(dir)] || ![file isdirectory $prefs(dir)]} {
+ # something is wrong, just bail
+ Error [msgcat::mc {An error has occurred while saving}]
+ return
+ }
+
+ # open prefs file
+ if {[catch {set ch [open $prefs(fn) w]}]} {
+ Error [msgcat::mc {An error has occurred while saving}]
+ return
+ }
+
+ switch $tcl_platform(platform) {
+ unix {file attributes $prefs(fn) -permissions "rw-r--r--"}
+ windows {}
+ }
+
+ puts $ch "global ds9"
+ puts $ch "global prefs"
+ puts $ch "set prefs(version) [lindex $ds9(version) 0]"
+
+ # check for wrong prefs
+ puts $ch "\# this is a check for to ensure a match between the"
+ puts $ch "\# current ds9 version matches the prefs version"
+ puts $ch "if {\[string compare \$prefs(version) \[lindex \$ds9(version)\ 0\]] == 1} {"
+ puts $ch " return"
+ puts $ch "}"
+
+ # Basic
+
+ global pds9
+ puts $ch "global pds9"
+ puts $ch "array set pds9 \{ [array get pds9] \}"
+
+ global current
+ global pcurrent
+ puts $ch "global current"
+ puts $ch "global pcurrent"
+ puts $ch "array set pcurrent \{ [array get pcurrent] \}"
+ puts $ch {array set current [array get pcurrent]}
+
+ global view
+ global pview
+ puts $ch "global view"
+ puts $ch "global pview"
+ puts $ch "array set pview \{ [array get pview] \}"
+ puts $ch {array set view [array get pview]}
+
+ global phttp
+ puts $ch "global phttp"
+ puts $ch "array set phttp \{ [array get phttp] \}"
+
+ global pbuttons
+ puts $ch "global pbuttons"
+ puts $ch "array set pbuttons \{ [array get pbuttons] \}"
+
+ global ppanner
+ puts $ch "global ppanner"
+ puts $ch "array set ppanner \{ [array get ppanner] \}"
+
+ global pmagnifier
+ puts $ch "global pmagnifier"
+ puts $ch "array set pmagnifier \{ [array get pmagnifier] \}"
+
+ # File
+
+ global ps
+ global pps
+ puts $ch "global ps"
+ puts $ch "global pps"
+ puts $ch "array set pps \{ [array get pps] \}"
+ puts $ch {array set ps [array get pps]}
+
+ global pr
+ global ppr
+ puts $ch "global pr"
+ puts $ch "global ppr"
+ puts $ch "array set ppr \{ [array get ppr] \}"
+ puts $ch {array set pr [array get ppr]}
+
+ # Frame
+
+ global blink
+ global pblink
+ puts $ch "global blink"
+ puts $ch "global pblink"
+ puts $ch "array set pblink \{ [array get pblink] \}"
+ puts $ch {array set blink [array get pblink]}
+
+ global tile
+ global ptile
+ puts $ch "global tile"
+ puts $ch "global ptile"
+ puts $ch "array set ptile \{ [array get ptile] \}"
+ puts $ch {array set tile [array get ptile]}
+
+ global threed
+ global pthreed
+ puts $ch "global threed"
+ puts $ch "global pthreed"
+ puts $ch "array set pthreed \{ [array get pthreed] \}"
+ puts $ch {array set threed [array get pthreed]}
+
+ # Bin
+
+ global bin
+ global pbin
+ puts $ch "global bin"
+ puts $ch "global pbin"
+ puts $ch "array set pbin \{ [array get pbin] \}"
+ puts $ch {array set bin [array get pbin]}
+
+ # Zoom
+
+ global panzoom
+ global ppanzoom
+ puts $ch "global panzoom"
+ puts $ch "global ppanzoom"
+ puts $ch "array set ppanzoom \{ [array get ppanzoom] \}"
+ puts $ch {array set panzoom [array get ppanzoom]}
+
+ # Scale
+
+ global scale
+ global pscale
+ puts $ch "global scale"
+ puts $ch "global pscale"
+ puts $ch "array set pscale \{ [array get pscale] \}"
+ puts $ch {array set scale [array get pscale]}
+
+ global minmax
+ global pminmax
+ puts $ch "global minmax"
+ puts $ch "global pminmax"
+ puts $ch "array set pminmax \{ [array get pminmax] \}"
+ puts $ch {array set minmax [array get pminmax]}
+
+ global zscale
+ global pzscale
+ puts $ch "global zscale"
+ puts $ch "global pzscale"
+ puts $ch "array set pzscale \{ [array get pzscale] \}"
+ puts $ch {array set zscale [array get pzscale]}
+
+ # Region
+
+ global marker
+ global pmarker
+ puts $ch "global marker"
+ puts $ch "global pmarker"
+ puts $ch "array set pmarker \{ [array get pmarker] \}"
+ puts $ch {array set marker [array get pmarker]}
+
+ # WCS
+
+ global wcs
+ global pwcs
+ puts $ch "global wcs"
+ puts $ch "global pwcs"
+ puts $ch "array set pwcs \{ [array get pwcs] \}"
+ puts $ch {array set wcs [array get pwcs]}
+
+ # Analysis
+
+ global ime
+ global pime
+ puts $ch "global pime"
+ puts $ch "array set pime \{ [array get pime] \}"
+ puts $ch {array set ime [array get pime]}
+
+ global pgraph
+ puts $ch "global pgraph"
+ puts $ch "array set pgraph \{ [array get pgraph] \}"
+
+ global pcoord
+ puts $ch "global pcoord"
+ puts $ch "array set pcoord \{ [array get pcoord] \}"
+
+ global pexamine
+ puts $ch "global pexamine"
+ puts $ch "array set pexamine \{ [array get pexamine] \}"
+
+ global pixel
+ global ppixel
+ puts $ch "global pixel"
+ puts $ch "global ppixel"
+ puts $ch "array set ppixel \{ [array get ppixel] \}"
+ puts $ch {array set pixel [array get ppixel]}
+
+ global mask
+ global pmask
+ puts $ch "global mask"
+ puts $ch "global pmask"
+ puts $ch "array set pmask \{ [array get pmask] \}"
+ puts $ch {array set mask [array get pmask]}
+
+ global contour
+ global pcontour
+ puts $ch "global contour"
+ puts $ch "global pcontour"
+ puts $ch "array set pcontour \{ [array get pcontour] \}"
+ puts $ch {array set contour [array get pcontour]}
+
+ global grid
+ global pgrid
+ puts $ch "global grid"
+ puts $ch "global pgrid"
+ puts $ch "array set pgrid \{ [array get pgrid] \}"
+ puts $ch {array set grid [array get pgrid]}
+
+ global block
+ global pblock
+ puts $ch "global block"
+ puts $ch "global pblock"
+ puts $ch "array set pblock \{ [array get pblock] \}"
+ puts $ch {array set block [array get pblock]}
+
+ global smooth
+ global psmooth
+ puts $ch "global smooth"
+ puts $ch "global psmooth"
+ puts $ch "array set psmooth \{ [array get psmooth] \}"
+ puts $ch {array set smooth [array get psmooth]}
+
+ global pnres
+ puts $ch "global pnres"
+ puts $ch "array set pnres \{ [array get pnres] \}"
+
+ global pcat
+ puts $ch "global pcat"
+ puts $ch "array set pcat \{ [array get pcat] \}"
+
+ global pvo
+ puts $ch "global pvo"
+ puts $ch "array set pvo \{ [array get pvo] \}"
+
+ global pap
+ puts $ch "global pap"
+ puts $ch "array set pap \{ [array get pap] \}"
+
+ global panalysis
+ puts $ch "global panalysis"
+ puts $ch "array set panalysis \{ [array get panalysis] \}"
+
+ # Other
+
+ puts $ch ""
+ puts $ch "\# Colorbar prefs"
+ global colorbar
+ global pcolorbar
+ puts $ch "global colorbar"
+ puts $ch "global pcolorbar"
+ puts $ch "array set pcolorbar \{ [array get pcolorbar] \}"
+ puts $ch {array set colorbar [array get pcolorbar]}
+
+ # and close
+ close $ch
+}
+
+# Backward Compatibility
+proc FixVar {varname ovarname} {
+ global aa bb
+ set aa $varname
+ set bb $ovarname
+
+ uplevel #0 {
+ if {[info exists $bb]} {
+ set $aa [expr $$bb]
+ unset $bb
+ }
+ }
+}
+
+proc FixVarRm {ovarname} {
+ global aa
+ set aa $ovarname
+
+ uplevel #0 {
+ if {[info exists $aa]} {
+ unset $aa
+ }
+ }
+}
+
+proc FixFontVar {weightname slantname stylename} {
+ global aa bb cc
+ set aa $weightname
+ set bb $slantname
+ set cc $stylename
+
+ uplevel #0 {
+ if {[info exists $cc]} {
+ switch [expr $$cc] {
+ normal {
+ set $aa normal
+ set $bb roman
+ }
+ bold {
+ set $aa bold
+ set $bb roman
+ }
+ italic {
+ set $aa normal
+ set $bb italic
+ }
+ }
+ unset $cc
+ }
+ }
+}
+
+# we only support 6.x and higher
+proc FixPrefs {version} {
+ set major [lindex [split $version {.}] 0]
+ if {$major == {5}} {
+ set version 5.x
+ }
+
+ switch $version {
+ 5.x {
+ FixPrefs5.xto6.0
+ FixPrefs6.0to6.1
+ FixPrefs6.1to6.2
+ FixPrefs6.2to7.0
+ FixPrefs7.0to7.1
+ FixPrefs7.1to7.2
+ FixPrefs7.2to7.3
+ }
+ 6.0 {
+ FixPrefs6.0to6.1
+ FixPrefs6.1to6.2
+ FixPrefs6.2to7.0
+ FixPrefs7.0to7.1
+ FixPrefs7.1to7.2
+ FixPrefs7.2to7.3
+ }
+ 6.1 -
+ 6.1.1 -
+ 6.1.2 {
+ FixPrefs6.1to6.2
+ FixPrefs6.2to7.0
+ FixPrefs7.0to7.1
+ FixPrefs7.1to7.2
+ FixPrefs7.2to7.3
+ }
+ 6.2 {
+ FixPrefs6.2to7.0
+ FixPrefs7.0to7.1
+ FixPrefs7.1to7.2
+ FixPrefs7.2to7.3
+ }
+ 7.0 {
+ FixPrefs7.0to7.1
+ FixPrefs7.1to7.2
+ FixPrefs7.2to7.3
+ }
+ 7.1 {
+ FixPrefs7.1to7.2
+ FixPrefs7.2to7.3
+ }
+ 7.2 {
+ FixPrefs7.2to7.3
+ }
+ 7.3 -
+ 7.3.1 -
+ 7.3.2 {
+ }
+ 7.4 {
+ }
+ 7.5 {
+ FixPrefs7.4to7.5
+ }
+ }
+}
+
+proc FixPrefs7.4to7.5 {} {
+ FixVarRm pds9(threads)
+}
+
+proc FixPrefs7.2to7.3 {} {
+ global current
+ if {$current(mode) == {pointer}} {
+ set current(mode) region
+ }
+
+ FixVar pbuttons(edit,region) pbuttons(edit,pointer)
+ FixVar pbuttons(frame,match,cube,image) pbuttons(frame,match,cube)
+ FixVar pbuttons(frame,lock,cube,image) pbuttons(frame,lock,cube)
+
+ FixVar pap(axis,x,grid) pap(graph,x,grid)
+ FixVar pap(axis,x,log) pap(graph,x,log)
+ FixVar pap(axis,x,flip) pap(graph,x,flip)
+ FixVar pap(axis,y,grid) pap(graph,y,grid)
+ FixVar pap(axis,y,log) pap(graph,y,log)
+ FixVar pap(axis,y,flip) pap(graph,y,flip)
+
+ FixVar pap(graph,title,family) pap(titleFont)
+ FixVar pap(graph,title,size) pap(titleSize)
+ FixVar pap(graph,title,weight) pap(titleWeight)
+ FixVar pap(graph,title,slant) pap(titleSlant)
+
+ FixVar pap(axis,title,family) pap(textlabFont)
+ FixVar pap(axis,title,size) pap(textlabSize)
+ FixVar pap(axis,title,weight) pap(textlabWeight)
+ FixVar pap(axis,title,slant) pap(textlabSlant)
+
+ FixVar pap(axis,font,family) pap(numlabFont)
+ FixVar pap(axis,font,size) pap(numlabSize)
+ FixVar pap(axis,font,weight) pap(numlabWeight)
+ FixVar pap(axis,font,slant) pap(numlabSlant)
+
+ FixVar pap(show) pap(linear)
+ FixVar pap(shape,color) pap(discrete,color)
+ FixVar pap(shape,fill) pap(discrete,fill)
+ FixVar pap(width) pap(linear,width)
+ FixVar pap(color) pap(linear,color)
+
+ if {[info exists pap(linear,dash)]} {
+ set pap(linear,dash) [FromYesNo $pap(linear,dash)]
+ }
+ FixVar pap(dash) pap(linear,dash)
+
+ if {[info exists pap(discrete)]} {
+ if {$pap(discrete)} {
+ FixVar pap(shape,symbol) pap(discrete,symbol)
+ } else {
+ FixVarRm pap(discrete,symbol)
+ }
+ }
+
+ FixVarRm pap(bar)
+ FixVarRm pap(bar,color)
+
+ FixVarRm pap(discrete)
+ FixVarRm pap(linear,dash)
+
+ FixVarRm pap(quadratic)
+ FixVarRm pap(quadratic,width)
+ FixVarRm pap(quadratic,color)
+ FixVarRm pap(quadratic,dash)
+
+ FixVarRm pap(step)
+ FixVarRm pap(step,color)
+ FixVarRm pap(step,dash)
+ FixVarRm pap(step,width)
+}
+
+proc FixPrefs7.1to7.2 {} {
+ FixVar pbuttons(file,xpa,info) pbuttons(file,xpa)
+ FixVar pcurrent(align) pwcs(align)
+}
+
+proc FixPrefs7.0to7.1 {} {
+ global pap
+ if {[info exists pap(grid)]} {
+ set pap(grid,x) $pap(grid)
+ set pap(grid,y) $pap(grid)
+ switch $pap(grid,log) {
+ linearlinear {
+ set pap(grid,xlog) 0
+ set pap(grid,ylog) 0
+ }
+ linearlog {
+ set pap(grid,xlog) 0
+ set pap(grid,ylog) 1
+ }
+ loglinear {
+ set pap(grid,xlog) 1
+ set pap(grid,ylog) 0
+ }
+ loglog {
+ set pap(grid,xlog) 1
+ set pap(grid,ylog) 1
+ }
+ }
+ unset pap(grid)
+ unset pap(grid,log)
+ }
+}
+
+proc FixPrefs6.2to7.0 {} {
+ global ps
+ global pps
+ switch $pps(scale) {
+ scaled -
+ fixed {
+ set ps(scale) 100
+ set pps(scale) 100
+ }
+ }
+
+ global colorbar
+ global pcolorbar
+ set colorbar(map) [string tolower $colorbar(map)]
+ set pcolorbar(map) [string tolower $pcolorbar(map)]
+
+ FixVar pbuttons(frame,match,frame,wcs) pbuttons(frame,matchframe,wcs)
+ FixVar pbuttons(frame,match,frame,image) pbuttons(frame,matchframe,image)
+ FixVar pbuttons(frame,match,frame,physical) pbuttons(frame,matchframe,physical)
+ FixVar pbuttons(frame,match,frame,amplifier) pbuttons(frame,matchframe,amplifier)
+ FixVar pbuttons(frame,match,frame,detector) pbuttons(frame,matchframe,detector)
+
+ FixVar pbuttons(bin,match) pbuttons(frame,matchbin)
+ FixVar pbuttons(scale,match) pbuttons(frame,matchscale)
+ FixVar pbuttons(color,match) pbuttons(frame,matchcolor)
+
+ FixVar ppanner(compass) ppanner(compass,image)
+ FixVarRm ppanner(compass,wcs,system)
+ FixVarRm ppanner(compass,wcs,sky)
+
+ global pmarker
+ FixVarRm pmarker(dialog,system)
+ FixVarRm pmarker(dialog,sky)
+ FixVarRm pmarker(dialog,skyformat)
+ FixVarRm pmarker(dialog,dist,system)
+ FixVarRm pmarker(dialog,dist,format)
+
+ # mousewheel MacOSX Lion
+ global tcl_platform
+ global ppanzoom
+ global pbin
+ switch -- $tcl_platform(os) {
+ Darwin {
+ switch [lindex [split $tcl_platform(osVersion) {.}] 0] {
+ 11 {
+ set ppanzoom(wheel,factor) 1.01
+ set pbin(wheel,factor) 1.01
+ }
+ }
+ }
+ }
+
+ global pcoord
+ FixVarRm pcoord(sky)
+ FixVarRm pcoord(skyformat)
+}
+
+proc FixPrefs6.1to6.2 {} {
+ FixVar pbuttons(frame,matchframe,wcs) pbuttons(frame,matchframe)
+
+ global pds9
+ switch -- $pds9(font) {
+ helvetica -
+ courier -
+ times {}
+ default {set pds9(font) helvetica}
+ }
+ switch -- $pds9(font,size) {
+ 10 {set pds9(font,size) 9}
+ }
+ FixVar pmarker(centroid,auto) pmarker(autocentroid)
+ FixVarRm marker(autocentroid)
+
+ FixFontVar pds9(font,weight) pds9(font,slant) pds9(font,style)
+ FixFontVar pmarker(font,weight) pmarker(font,slant) pmarker(font,style)
+ FixFontVar pcolorbar(font,weight) pcolorbar(font,slant) \
+ pcolorbar(font,style)
+}
+
+proc FixPrefs6.0to6.1 {} {
+ # ds9
+ FixVar pds9(automarker) ds9(automarker)
+ FixVar pds9(xpa) ds9(xpa)
+ FixVar pds9(samp) ds9(samp,auto)
+ FixVar pds9(confirm) ds9(confirm)
+ FixVar pds9(bg) ds9(bg,color)
+ FixVar pds9(nan) ds9(nan,color)
+ FixVar pds9(dialog) ds9(dialog)
+ FixVar pds9(language) ds9(language)
+ FixVar pds9(language,name) ds9(language,name)
+ FixVar pds9(language,dir) ds9(language,dir)
+ FixVar pds9(font) ds9(font)
+ FixVar pds9(font,size) ds9(font,size)
+ FixVar pds9(font,style) ds9(font,style)
+ FixVar pcurrent(display) ds9(display,user)
+ FixVar pcurrent(mode) pds9(mode)
+
+ # note: versions 5.3 to 6.0 have array set ds9 [array get pds9]
+ # which will set following ds9(var), so delete
+ FixVarRm ds9(samp)
+ FixVarRm ds9(backup)
+ FixVarRm ds9(nan)
+ # which will overwrite the following ds9(var), so reset
+ global ds9
+ set ds9(bg) white
+
+ # analysis
+ FixVar panalysis(user) ds9(analysis,user)
+ FixVar panalysis(user2) ds9(analysis,user2)
+ FixVar panalysis(user3) ds9(analysis,user3)
+ FixVar panalysis(user4) ds9(analysis,user4)
+ global analysis
+ catch {unset analysis}
+
+ # magnifier
+ FixVar pmagnifier(region) magnifier(region)
+ FixVar pmagnifier(zoom) magnifier(zoom)
+ FixVar pmagnifier(cursor) magnifier(cursor)
+ global magnifier
+ catch {unset magnifier}
+
+ # panner
+ FixVar ppanner(compass,image) panner(compass,image)
+ FixVar ppanner(compass,wcs) panner(compass,wcs)
+ FixVar ppanner(compass,wcs,system) panner(compass,wcs,system)
+ FixVar ppanner(compass,wcs,sky) panner(compass,wcs,sky)
+ global panner
+ catch {unset panner}
+
+ # examine
+ FixVar pexamine(mode) examine(mode)
+ FixVar pexamine(zoom) examine(zoom)
+ global examine
+ catch {unset examine}
+
+ # vo
+ FixVar pvo(server) vo(server)
+ FixVar pvo(hv) vo(hv)
+ FixVar pvo(method) vo(method)
+ FixVar pvo(delay) vo(delay)
+ global vo
+ catch {unset vo}
+
+ # http
+ FixVar phttp(proxy) http(proxy)
+ FixVar phttp(proxy,host) http(proxy,host)
+ FixVar phttp(proxy,port) http(proxy,port)
+ FixVar phttp(auth) http(auth)
+ FixVar phttp(auth,user) http(auth,user)
+ FixVar phttp(auth,passwd) http(auth,passwd)
+ global http
+ catch {unset http}
+
+ # nres
+ FixVar pnres(server) nres(server)
+
+ # graph
+ FixVar pgraph(horz,grid) graph(horz,grid)
+ FixVar pgraph(horz,log) graph(horz,log)
+ FixVar pgraph(vert,grid) graph(vert,grid)
+ FixVar pgraph(vert,log) graph(vert,log)
+ global graph
+ catch {unset graph}
+
+ # cat
+ FixVar pcat(server) cat(server)
+ FixVar pcat(sym,shape) cat(sym,shape)
+ FixVar pcat(sym,color) cat(sym,color)
+ FixVar pcat(vot) cat(vot)
+
+ # contour
+ FixVarRm pcontour(color,msg)
+
+ # coords
+ global coord
+ catch {unset coord}
+
+ # scale
+ FixVarRm pscale(min)
+ FixVarRm pscale(max)
+ FixVarRm pscale(xaxis)
+ FixVarRm pscale(yaxis)
+
+ # marker
+ FixVarRm pmarker(maxdialog)
+ FixVarRm pmarker(load)
+ FixVarRm pmarker(paste,system)
+ FixVarRm pmarker(paste,sky)
+ FixVarRm pmarker(system)
+ FixVarRm pmarker(sky)
+ FixVarRm pmarker(skyformat)
+ FixVarRm pmarker(strip)
+
+ FixVarRm marker(dialog,system)
+ FixVarRm marker(dialog,sky)
+ FixVarRm marker(dialog,skyformat)
+ FixVarRm marker(dialog,dist,system)
+ FixVarRm marker(dialog,dist,format)
+
+ FixVarRm marker(circle,radius)
+ FixVarRm marker(annulus,inner)
+ FixVarRm marker(annulus,outer)
+ FixVarRm marker(annulus,annuli)
+ FixVarRm marker(panda,inner)
+ FixVarRm marker(panda,outer)
+ FixVarRm marker(panda,annuli)
+ FixVarRm marker(panda,ang1)
+ FixVarRm marker(panda,ang2)
+ FixVarRm marker(panda,angnum)
+ FixVarRm marker(ellipse,radius1)
+ FixVarRm marker(ellipse,radius2)
+ FixVarRm marker(ellipseannulus,radius1)
+ FixVarRm marker(ellipseannulus,radius2)
+ FixVarRm marker(ellipseannulus,radius3)
+ FixVarRm marker(ellipseannulus,annuli)
+ FixVarRm marker(epanda,radius1)
+ FixVarRm marker(epanda,radius2)
+ FixVarRm marker(epanda,radius3)
+ FixVarRm marker(epanda,annuli)
+ FixVarRm marker(epanda,ang1)
+ FixVarRm marker(epanda,ang2)
+ FixVarRm marker(epanda,angnum)
+ FixVarRm marker(box,radius1)
+ FixVarRm marker(box,radius2)
+ FixVarRm marker(boxannulus,radius1)
+ FixVarRm marker(boxannulus,radius2)
+ FixVarRm marker(boxannulus,radius3)
+ FixVarRm marker(boxannulus,annuli)
+ FixVarRm marker(bpanda,radius1)
+ FixVarRm marker(bpanda,radius2)
+ FixVarRm marker(bpanda,radius3)
+ FixVarRm marker(bpanda,annuli)
+ FixVarRm marker(bpanda,ang1)
+ FixVarRm marker(bpanda,ang2)
+ FixVarRm marker(bpanda,angnum)
+ FixVarRm marker(polygon,width)
+ FixVarRm marker(polygon,height)
+ FixVarRm marker(projection,thick)
+ FixVarRm marker(compass,radius)
+ FixVarRm marker(point,size)
+}
+
+proc FixPrefs5.xto6.0 {} {
+ FixVar pap(grid) prefs(ap,grid)
+ FixVar pap(grid,log) prefs(ap,grid,log)
+
+ FixVar pap(discrete) prefs(ap,discrete)
+ FixVar pap(discrete,symbol) prefs(ap,discrete,symbol)
+ FixVar pap(discrete,color) prefs(ap,discrete,color)
+
+ FixVar pap(linear) prefs(ap,linear)
+ FixVar pap(linear,width) prefs(ap,linear,width)
+ FixVar pap(linear,color) prefs(ap,linear,color)
+ FixVar pap(linear,dash) prefs(ap,linear,dash)
+
+ FixVar pap(step) prefs(ap,step)
+ FixVar pap(step,width) prefs(ap,step,width)
+ FixVar pap(step,color) prefs(ap,step,color)
+ FixVar pap(step,dash) prefs(ap,step,dash)
+
+ FixVar pap(quadratic) prefs(ap,quadratic)
+ FixVar pap(quadratic,width) prefs(ap,quadratic,width)
+ FixVar pap(quadratic,color) prefs(ap,quadratic,color)
+ FixVar pap(quadratic,dash) prefs(ap,quadratic,dash)
+
+ FixVar pap(error,color) prefs(ap,error,color)
+ FixVar pap(error,width) prefs(ap,error,width)
+ FixVar pap(error,style) prefs(ap,error,style)
+
+ FixVar pap(titleFont) prefs(ap,titleFont)
+ FixVar pap(titleSize) prefs(ap,titleSize)
+ FixVar pap(titleStyle) prefs(ap,titleStyle)
+
+ FixVar pap(textlabFont) prefs(ap,textlabFont)
+ FixVar pap(textlabSize) prefs(ap,textlabSize)
+ FixVar pap(textlabStyle) prefs(ap,textlabStyle)
+
+ FixVar pap(numlabFont) prefs(ap,numlabFont)
+ FixVar pap(numlabSize) prefs(ap,numlabSize)
+ FixVar pap(numlabStyle) prefs(ap,numlabStyle)
+
+ FixVar pcurrent(zoom) prefs(zoom)
+ FixVar pcurrent(orient) prefs(orient)
+ FixVar pcurrent(rotate) prefs(rotate)
+
+ FixVar panalysis(log) prefs(analysis,log)
+ FixVar pds9(mode) prefs(ds9,mode)
+ FixVar pblink(interval) prefs(blink,interval)
+ FixVar ptile(mode) prefs(tile,mode)
+
+ FixVar pcolorbar(map) prefs(colorbar,map)
+ FixVar pcolorbar(invert) prefs(colorbar,invert)
+
+ FixVar pmarker(shape) prefs(marker,shape)
+ FixVar pmarker(color) prefs(marker,color)
+ FixVar pmarker(width) prefs(marker,width)
+ FixVar pmarker(fixed) prefs(marker,fixed)
+ FixVar pmarker(edit) prefs(marker,edit)
+ FixVar pmarker(move) prefs(marker,move)
+ FixVar pmarker(rotate) prefs(marker,rotate)
+ FixVar pmarker(delete) prefs(marker,delete)
+ FixVar pmarker(include) prefs(marker,include)
+ FixVar pmarker(source) prefs(marker,source)
+ FixVar pmarker(font) prefs(marker,font)
+ FixVar pmarker(font,size) prefs(marker,font,size)
+ FixVar pmarker(font,style) prefs(marker,font,style)
+ FixVar pmarker(format) prefs(marker,format)
+ FixVar pmarker(strip) prefs(marker,strip)
+ FixVar pmarker(system) prefs(marker,system)
+ FixVar pmarker(sky) prefs(marker,sky)
+ FixVar pmarker(skyformat) prefs(marker,skyformat)
+ FixVarRm prefs(marker,wcs)
+ FixVarRm marker(wcs)
+ FixVarRm marker(polygon,width)
+ FixVarRm marker(polygon,height)
+
+ FixVar pmarker(dialog,system) marker(dialog,system)
+ FixVar pmarker(dialog,sky) marker(dialog,sky)
+ FixVar pmarker(dialog,skyformat) marker(dialog,skyformat)
+ FixVar pmarker(dialog,dist,system) marker(dialog,dist,system)
+ FixVar pmarker(dialog,dist,format) marker(dialog,dist,format)
+
+ FixVar pmarker(circle,radius) marker(circle,radius)
+ FixVar pmarker(annulus,inner) marker(annulus,inner)
+ FixVar pmarker(annulus,outer) marker(annulus,outer)
+ FixVar pmarker(annulus,annuli) marker(annulus,annuli)
+ FixVar pmarker(panda,inner) marker(panda,inner)
+ FixVar pmarker(panda,outer) marker(panda,outer)
+ FixVar pmarker(panda,annuli) marker(panda,annuli)
+ FixVar pmarker(panda,ang1) marker(panda,ang1)
+ FixVar pmarker(panda,ang2) marker(panda,ang2)
+ FixVar pmarker(panda,angnum) marker(panda,angnum)
+ FixVar pmarker(ellipse,radius1) marker(ellipse,radius1)
+ FixVar pmarker(ellipse,radius2) marker(ellipse,radius2)
+ FixVar pmarker(ellipseannulus,radius1) marker(ellipseannulus,radius1)
+ FixVar pmarker(ellipseannulus,radius2) marker(ellipseannulus,radius2)
+ FixVar pmarker(ellipseannulus,radius3) marker(ellipseannulus,radius3)
+ FixVar pmarker(ellipseannulus,annuli) marker(ellipseannulus,annuli)
+ FixVar pmarker(epanda,radius1) marker(epanda,radius1)
+ FixVar pmarker(epanda,radius2) marker(epanda,radius2)
+ FixVar pmarker(epanda,radius3) marker(epanda,radius3)
+ FixVar pmarker(epanda,annuli) marker(epanda,annuli)
+ FixVar pmarker(epanda,ang1) marker(epanda,ang1)
+ FixVar pmarker(epanda,ang2) marker(epanda,ang2)
+ FixVar pmarker(epanda,angnum) marker(epanda,angnum)
+ FixVar pmarker(box,radius1) marker(box,radius1)
+ FixVar pmarker(box,radius2) marker(box,radius2)
+ FixVar pmarker(boxannulus,radius1) marker(boxannulus,radius1)
+ FixVar pmarker(boxannulus,radius2) marker(boxannulus,radius2)
+ FixVar pmarker(boxannulus,radius3) marker(boxannulus,radius3)
+ FixVar pmarker(boxannulus,annuli) marker(boxannulus,annuli)
+ FixVar pmarker(bpanda,radius1) marker(bpanda,radius1)
+ FixVar pmarker(bpanda,radius2) marker(bpanda,radius2)
+ FixVar pmarker(bpanda,radius3) marker(bpanda,radius3)
+ FixVar pmarker(bpanda,annuli) marker(bpanda,annuli)
+ FixVar pmarker(bpanda,ang1) marker(bpanda,ang1)
+ FixVar pmarker(bpanda,ang2) marker(bpanda,ang2)
+ FixVar pmarker(bpanda,angnum) marker(bpanda,angnum)
+ FixVar pmarker(projection,thick) marker(projection,thick)
+ FixVar pmarker(point,size) marker(point,size)
+
+ # buttons
+ global buttons
+ global pbuttons
+ if {[info exists buttons(file,about)]} {
+ foreach nn [array names buttons] {
+ set aa [split $nn ,]
+ if {[lindex $aa 1] != {}} {
+ switch [lindex $aa 0] {
+ file -
+ edit -
+ view -
+ frame -
+ bin -
+ zoom -
+ scale -
+ color -
+ region -
+ wcs -
+ help {
+ set pbuttons($nn) $buttons($nn)
+ unset buttons($nn)
+ }
+ }
+ }
+ }
+
+ FixVar pbuttons(scale,995) buttons(scale,99.5)
+ FixVar pbuttons(scale,925) buttons(scale,92.5)
+ FixVar pbuttons(zoom,i32) buttons(zoom,1/32)
+ FixVar pbuttons(zoom,i16) buttons(zoom,1/16)
+ FixVar pbuttons(zoom,i8) buttons(zoom,1/8)
+ FixVar pbuttons(zoom,i4) buttons(zoom,1/4)
+ FixVar pbuttons(zoom,i2) buttons(zoom,1/2)
+
+ FixVarRm pbuttons(scale,92.5)
+ FixVarRm pbuttons(scale,99.5)
+ FixVarRm pbuttons(zoom,1/32)
+ FixVarRm pbuttons(zoom,1/16)
+ FixVarRm pbuttons(zoom,1/8)
+ FixVarRm pbuttons(zoom,1/4)
+ FixVarRm pbuttons(zoom,1/2)
+ }
+}
diff --git a/ds9/library/prefsdialog.tcl b/ds9/library/prefsdialog.tcl
new file mode 100644
index 0000000..be90b92
--- /dev/null
+++ b/ds9/library/prefsdialog.tcl
@@ -0,0 +1,317 @@
+# 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 PrefsDialog {{which {}}} {
+ global ds9
+ global iprefs
+ global dprefs
+
+ # see if we already have a window visible
+ if {[winfo exists $iprefs(top)]} {
+ raise $iprefs(top)
+ return
+ }
+
+ # create the window
+ set w $iprefs(top)
+ set mb $iprefs(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Preferences}] PrefsDialogSave
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Clear Preferences}] \
+ -command PrefsDialogClear
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Save}] -command PrefsDialogSave
+ $mb.file add command -label [msgcat::mc {Close}] -command PrefsDialogClose
+
+ EditMenu $mb iprefs
+
+ # List
+ set f [ttk::frame $w.param]
+
+ ttk::scrollbar $f.scroll -command [list $f.box yview]
+ set dprefs(list) [listbox $f.box \
+ -yscroll [list $f.scroll set] \
+ -selectmode browse \
+ -setgrid true \
+ -width 18 -height 28 \
+ ]
+ grid $f.box $f.scroll -sticky news
+ grid rowconfigure $f 0 -weight 1
+ grid columnconfigure $f 2 -weight 1
+
+ bind $dprefs(list) <<ListboxSelect>> [list PrefsDialogListUpdate]
+
+ set dprefs(tab) $f
+ set dprefs(tabs) {}
+
+ PrefsDialogGeneral
+ PrefsDialogStartup
+ PrefsDialogMenu
+ PrefsDialogPanner
+ PrefsDialogMagnifier
+ PrefsDialog3d
+ PrefsDialogGraph
+ PrefsDialogScale
+ PrefsDialogColor
+ PrefsDialogBin
+ PrefsDialogZoom
+ PrefsDialogRegion
+ PrefsDialogAnnulus
+ PrefsDialogPanda
+ PrefsDialogAnalysis
+ PrefsDialogPixelTable
+ PrefsDialogContour
+ PrefsDialogSmooth
+ PrefsDialogCatalog
+ PrefsDialogNRES
+ PrefsDialogPlot
+ PrefsDialogVO
+ PrefsDialogPrint
+ PrefsDialogPageSetup
+ PrefsDialogCoord
+ PrefsDialogExamine
+ PrefsDialogHTTP
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.save -text [msgcat::mc {Save}] \
+ -command PrefsDialogSave
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command PrefsDialogClose
+ ttk::button $f.clear -text [msgcat::mc {Clear Preferences}] \
+ -command PrefsDialogClear
+ pack $f.clear $f.save $f.close \
+ -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 -fill both -expand true
+
+ # http is hard coded to be last
+ switch $which {
+ http {$dprefs(list) selection set end}
+ default {$dprefs(list) selection set 0}
+ }
+
+ PrefsDialogListUpdate
+}
+
+proc PrefsDialogListUpdate {} {
+ global dprefs
+
+ set which [$dprefs(list) curselection]
+ if {$which == {}} {
+ set which 0
+ }
+ foreach tab $dprefs(tabs) {
+ grid forget $tab
+ }
+
+ grid [lindex $dprefs(tabs) $which] -row 0 -column 2 -sticky new
+}
+
+proc PrefsDialogSave {} {
+ global iprefs
+
+ if {[winfo exists $iprefs(top)]} {
+ destroy $iprefs(top)
+ destroy $iprefs(mb)
+ }
+
+ SavePrefs
+}
+
+proc PrefsDialogClose {} {
+ global iprefs
+ global dprefs
+
+ if {[winfo exists $iprefs(top)]} {
+ destroy $iprefs(top)
+ destroy $iprefs(mb)
+ }
+
+ unset dprefs
+}
+
+proc PrefsDialogClear {} {
+ global iprefs
+ global dprefs
+ global pds9
+
+ if {$pds9(confirm)} {
+ if {[tk_messageBox -type okcancel -icon question -message [msgcat::mc {Clear Preferences?}]] != {ok}} {
+ return
+ }
+ }
+
+ ClearPrefs
+ PrefsDialogClose
+}
+
+# Pref Frames
+
+proc PrefsDialogGeneral {} {
+ global dprefs
+ global ds9
+ global pds9
+ global pmagnifier
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {General}]
+ lappend dprefs(tabs) [ttk::frame $w.general]
+
+ # General
+ set f [ttk::labelframe $w.general.misc -text [msgcat::mc {General}]]
+
+ ttk::checkbutton $f.backup \
+ -text [msgcat::mc {Always save files during Backup}] \
+ -variable pds9(backup)
+ ttk::checkbutton $f.auto -text [msgcat::mc {Autoload FITS Regions}] \
+ -variable pds9(automarker)
+ ttk::checkbutton $f.confirm \
+ -text [msgcat::mc {Enable Confirmation Dialogs}] \
+ -variable pds9(confirm)
+ ttk::label $f.tthreads -text [msgcat::mc {Number of Threads}]
+ ttk::entry $f.threads -textvariable ds9(threads) \
+ -validate focusout -validatecommand ChangeThreads -width 8
+
+ grid $f.backup -padx 2 -pady 2 -sticky w
+ grid $f.auto -padx 2 -pady 2 -sticky w
+ grid $f.confirm -padx 2 -pady 2 -sticky w
+ grid $f.tthreads $f.threads -padx 2 -pady 2 -sticky w
+
+ # Language
+ set f [ttk::labelframe $w.general.lang -text [msgcat::mc {Language}]]
+
+ ttk::menubutton $f.lang -textvariable pds9(language,name) -menu $f.lang.menu
+
+ set m $f.lang.menu
+ menu $m
+ $m add radiobutton -label [LanguageToName locale] \
+ -variable pds9(language,name) -command "set pds9(language) locale"
+ $m add separator
+ $m add radiobutton -label [LanguageToName cs] \
+ -variable pds9(language,name) -command "set pds9(language) cs"
+ $m add radiobutton -label [LanguageToName da] \
+ -variable pds9(language,name) -command "set pds9(language) da"
+ $m add radiobutton -label [LanguageToName de] \
+ -variable pds9(language,name) -command "set pds9(language) de"
+ $m add radiobutton -label [LanguageToName en] \
+ -variable pds9(language,name) -command "set pds9(language) en"
+ $m add radiobutton -label [LanguageToName es] \
+ -variable pds9(language,name) -command "set pds9(language) es"
+ $m add radiobutton -label [LanguageToName fr] \
+ -variable pds9(language,name) -command "set pds9(language) fr"
+ $m add radiobutton -label [LanguageToName ja] \
+ -variable pds9(language,name) -command "set pds9(language) ja"
+ $m add radiobutton -label [LanguageToName pt] \
+ -variable pds9(language,name) -command "set pds9(language) pt"
+ $m add radiobutton -label [LanguageToName zh] \
+ -variable pds9(language,name) -command "set pds9(language) zh"
+
+ grid $f.lang -padx 2 -pady 2 -sticky w
+
+ # GUI Font
+ set f [ttk::labelframe $w.general.font -text [msgcat::mc {GUI Font}]]
+
+ FontMenuButton $f.font pds9 font \
+ font,size font,weight font,slant \
+ [list SetDefaultFont true]
+ ttk::button $f.reset -text [msgcat::mc {Reset}] \
+ -command ResetDefaultFont
+
+ grid $f.font $f.reset -padx 2 -pady 2 -sticky w
+
+ # Text Font
+ set f [ttk::labelframe $w.general.textfont -text [msgcat::mc {Text Font}]]
+
+ FontMenuButton $f.textfont pds9 text,font \
+ text,font,size text,font,weight text,font,slant \
+ [list SetDefaultTextFont true]
+ ttk::button $f.textreset -text [msgcat::mc {Reset}] \
+ -command ResetDefaultTextFont
+
+ grid $f.textfont $f.textreset -padx 2 -pady 2 -sticky w
+
+ # Color
+ set f [ttk::labelframe $w.general.color -text [msgcat::mc {Color}]]
+
+ ttk::label $f.tbg -text [msgcat::mc {Background Color}]
+ ColorMenuButton $f.bg pds9 bg PrefsBgColor
+
+ ttk::label $f.tnan -text [msgcat::mc {Blank/Inf/NaN Color}]
+ ColorMenuButton $f.nan pds9 nan PrefsNanColor
+
+ grid $f.tbg $f.bg -padx 2 -pady 2 -sticky w
+ grid $f.tnan $f.nan -padx 2 -pady 2 -sticky w
+
+ # Mosaic
+ set f [ttk::labelframe $w.general.mosaic -text [msgcat::mc {Mosaic}]]
+ ttk::checkbutton $f.align -text {IRAF DETSEC Align} -variable pds9(iraf) \
+ -command PrefsIRAFAlign
+
+ grid $f.align -padx 2 -pady 2 -sticky w
+
+ # Dialog Box
+ set f [ttk::labelframe $w.general.box -text [msgcat::mc {Dialog Box}]]
+
+ ttk::radiobutton $f.motif -text {Motif} -variable pds9(dialog) \
+ -value motif
+ ttk::radiobutton $f.windows -text {Windows} -variable pds9(dialog) \
+ -value windows
+ grid $f.motif $f.windows -padx 2 -pady 2 -sticky w
+
+ switch $ds9(wm) {
+ x11 {}
+ aqua -
+ win32 {
+ ttk::radiobutton $f.native -text [msgcat::mc {Native Dialog}] \
+ -variable pds9(dialog) -value native
+ grid $f.native -row 0 -column 2 -padx 2 -pady 2 -sticky w
+ }
+ }
+
+ ttk::checkbutton $f.center -text [msgcat::mc {Center Non-modal Dialogs}] \
+ -variable pds9(dialog,center)
+ ttk::checkbutton $f.all -text [msgcat::mc {Default All Files}] \
+ -variable pds9(dialog,all)
+
+ grid $f.center - -padx 2 -pady 2 -sticky w
+ grid $f.all - -padx 2 -pady 2 -sticky w
+
+ pack $w.general.misc $w.general.lang $w.general.font \
+ $w.general.textfont $w.general.color $w.general.mosaic \
+ $w.general.box \
+ -side top -fill both -expand true
+}
+
+proc PrefsDialogStartup {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Startup}]
+ lappend dprefs(tabs) [ttk::frame $w.startup]
+
+ set f [ttk::labelframe $w.startup.params -text [msgcat::mc {At Startup}]]
+
+ ttk::checkbutton $f.xpa -text [msgcat::mc {Initialize XPA}] \
+ -variable pds9(xpa)
+ ttk::checkbutton $f.samp -text [msgcat::mc {Connect SAMP}] \
+ -variable pds9(samp)
+
+ grid $f.xpa -padx 2 -pady 2 -sticky w
+ grid $f.samp -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true -anchor nw
+}
diff --git a/ds9/library/print.tcl b/ds9/library/print.tcl
new file mode 100644
index 0000000..6b92061
--- /dev/null
+++ b/ds9/library/print.tcl
@@ -0,0 +1,612 @@
+# 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 PSDef {} {
+ global ds9
+ global ps
+ global pps
+
+ set ps(dest) printer
+ set ps(cmd) {lp}
+ set ps(filename) {ds9.ps}
+ set ps(filename,txt) {ds9.txt}
+ set ps(color) rgb
+ set ps(level) 2
+ set ps(resolution) 150
+
+ set ps(orient) portrait
+ set ps(scale) 100
+ set ps(size) letter
+ set ps(width) 8.5
+ set ps(height) 11
+
+ array set pps [array get ps]
+}
+
+# Print procs
+
+proc PSPrint {} {
+ if {[PSPrintDialog ps]} {
+ if {[catch {PostScript} printError]} {
+ Error "[msgcat::mc {An error has occurred while printing}] $printError"
+ }
+ }
+}
+
+proc PostScript {} {
+ global ds9
+ global ps
+ global view
+ global canvas
+ global colorbar
+ global current
+
+ # we need to be realized
+ RealizeDS9
+ # need the colorbar levels updated
+ UpdateColormapLevel
+
+ set options {}
+
+ # Orientation
+ switch -- $ps(orient) {
+ portrait {append options " -rotate false"}
+ landscape {append options " -rotate true"}
+ }
+
+ # Page size
+ # reduce size to .95 for backward compatibility
+ set width [winfo width $ds9(canvas)]
+ set height [winfo height $ds9(canvas)]
+ set xx [expr $width*(1- (100./$ps(scale)/.95))/2.]
+ set yy [expr $height*(1- (100./$ps(scale)/.95))/2.]
+ set ww [expr $width*100./$ps(scale)/.95]
+ set hh [expr $height*100./$ps(scale)/.95]
+
+ append options " -x $xx -y $yy -width $ww -height $hh"
+
+ switch -- $ps(size) {
+ letter {PostScriptPageSize 4.25 5.5 7.5 10. i options}
+ legal {PostScriptPageSize 4.25 7. 7.5 13. i options}
+ tabloid {PostScriptPageSize 5.5 8.5 10. 16. i options}
+ poster {PostScriptPageSize 18. 24. 35. 47. i options}
+ a4 {PostScriptPageSize 105 148.5 185 272 m options}
+ other {
+ if {$ps(width) != {} && $ps(height) != {}} {
+ set pxx [expr double($ps(width))/2.]
+ set pyy [expr double($ps(height))/2.]
+ set pww [expr $ps(width)-1.]
+ set phh [expr $ps(height)-1.]
+ PostScriptPageSize $pxx $pyy $pww $phh i options
+ }
+ }
+ othermm {
+ if {$ps(width) != {} && $ps(height) != {}} {
+ set pxx [expr double($ps(width))/2.]
+ set pyy [expr double($ps(height))/2.]
+ set pww [expr $ps(width)-1.]
+ set phh [expr $ps(height)-1.]
+ PostScriptPageSize $pxx $pyy $pww $phh m options
+ }
+ }
+ }
+
+ # Printer vs File
+ set channel {}
+ switch -- $ps(dest) {
+ "file" {
+ append options " -file \{$ps(filename)\}"
+ }
+ "printer" {
+ set channel [open "| $ps(cmd)" w]
+ append options " -channel $channel"
+ }
+ }
+
+ # resolution
+ switch $ps(resolution) {
+ screen -
+ Screen -
+ SCREEN {set res 96}
+ default {set res $ps(resolution)}
+ }
+
+ # set color specific postscript options
+ colorbar postscript level $ps(level)
+ colorbar postscript colorspace $ps(color)
+ colorbar postscript resolution $res
+
+ colorbarrgb postscript level $ps(level)
+ colorbarrgb postscript colorspace $ps(color)
+ colorbarrgb postscript resolution $res
+
+ # set frame specific postscript options
+ foreach ff $ds9(frames) {
+ $ff postscript level $ps(level)
+ $ff postscript colorspace $ps(color)
+ $ff postscript resolution $res
+ }
+
+ # graphs
+ if {$view(graph,vert)} {
+ $ds9(graph,vert) configure -plotbackground white -bg white
+ }
+ if {$view(graph,horz)} {
+ $ds9(graph,horz) configure -plotbackground white -bg white
+ }
+
+ # now invoke canvas postscript command
+ if {[catch {eval $ds9(canvas) postscript $options} rr]} {
+ Error "[msgcat::mc {A postscript generation error has occurred}] $rr"
+ }
+
+ switch -- $ps(dest) {
+ "file" {}
+ "printer" {
+ if {$channel != {}} {
+ close $channel
+ }
+ }
+ }
+
+ # reset graphs
+ if {$view(graph,vert)} {
+ $ds9(graph,vert) configure -plotbackground $ds9(bg) -bg $ds9(bg)
+ }
+ if {$view(graph,horz)} {
+ $ds9(graph,horz) configure -plotbackground $ds9(bg) -bg $ds9(bg)
+ }
+}
+
+proc EPS {fn} {
+ global ds9
+ global ps
+ global view
+ global canvas
+ global colorbar
+ global current
+
+ # we need to be realized
+ RealizeDS9
+ # need the colorbar levels updated
+ UpdateColormapLevel
+
+ set color rgb
+ set level 2
+ set resolution 72
+
+ set options {}
+
+ # Page size
+ set width [winfo width $ds9(canvas)]
+ set height [winfo height $ds9(canvas)]
+ append options " -pagex 0 -pagey 0 -pageanchor sw"
+ if ($width>$height) {
+ append options " -pagewidth $width"
+ } else {
+ append options " -pageheight $height"
+ }
+
+ # File
+ append options " -file \{$fn\}"
+
+ # set color specific postscript options
+ colorbar postscript level $level
+ colorbar postscript colorspace $color
+ colorbar postscript resolution $resolution
+
+ colorbarrgb postscript level $level
+ colorbarrgb postscript colorspace $color
+ colorbarrgb postscript resolution $resolution
+
+ # set frame specific postscript options
+ foreach ff $ds9(frames) {
+ $ff postscript level $level
+ $ff postscript colorspace $color
+ $ff postscript resolution $resolution
+ }
+
+ # graphs
+ if {$view(graph,vert)} {
+ $ds9(graph,vert) configure -plotbackground white -bg white
+ }
+ if {$view(graph,horz)} {
+ $ds9(graph,horz) configure -plotbackground white -bg white
+ }
+
+ # now invoke canvas postscript command
+ if {[catch {eval $ds9(canvas) postscript $options} rr]} {
+ Error "[msgcat::mc {A postscript generation error has occurred}] $rr"
+ }
+
+ # reset graphs
+ if {$view(graph,vert)} {
+ $ds9(graph,vert) configure -plotbackground $ds9(bg) -bg $ds9(bg)
+ }
+ if {$view(graph,horz)} {
+ $ds9(graph,horz) configure -plotbackground $ds9(bg) -bg $ds9(bg)
+ }
+}
+
+proc PostScriptPageSize {xx yy ww hh unit optname} {
+ upvar $optname options
+
+ global ds9
+ global ps
+
+ append options " -pagex $xx$unit -pagey $yy$unit"
+
+ set width [winfo width $ds9(canvas)]
+ set height [winfo height $ds9(canvas)]
+
+ switch -- $ps(orient) {
+ portrait {
+ if {[expr double($ww)/$width] < [expr double($hh)/$height]} {
+ append options " -pagewidth $ww$unit"
+ } else {
+ append options " -pageheight $hh$unit"
+ }
+ }
+ landscape {
+ if {[expr double($ww)/$width] > [expr double($hh)/$height]} {
+ append options " -pageheight $ww$unit"
+ } else {
+ append options " -pagewidth $hh$unit"
+ }
+ }
+ }
+}
+
+# Print Dialog procs
+proc PSPrintDialog {which} {
+ global ps
+ global ed
+
+ set ed(ok) 0
+ array set ed [array get ps]
+
+ set w {.print}
+
+ DialogCreate $w [msgcat::mc {Print}] ed(ok)
+
+ # PrintTo
+ set f [ttk::labelframe $w.pt -text [msgcat::mc {Print To}]]
+
+ ttk::radiobutton $f.printer -text [msgcat::mc {Printer}] \
+ -variable ed(dest) -value printer
+ ttk::label $f.tcmd -text [msgcat::mc {Command}]
+ ttk::entry $f.cmd -textvariable ed(cmd) -width 20
+
+ ttk::radiobutton $f.file -text [msgcat::mc {File}] \
+ -variable ed(dest) -value file
+ ttk::label $f.tname -text [msgcat::mc {Name}]
+ ttk::entry $f.name -textvariable ed(filename) -width 20
+ ttk::button $f.browse -text [msgcat::mc {Browse}] \
+ -command "PSPrintBrowse ed(filename)"
+
+ grid $f.printer $f.tcmd $f.cmd -padx 2 -pady 2 -sticky ew
+ grid $f.file $f.tname $f.name $f.browse -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 2 -weight 1
+
+ # Options
+ set f [ttk::labelframe $w.ps -text [msgcat::mc {Postscript}]]
+
+ ttk::label $f.color -text [msgcat::mc {Color}]
+ ttk::radiobutton $f.rgb -text [msgcat::mc {RGB}] \
+ -variable ed(color) -value rgb
+ ttk::radiobutton $f.cmyk -text [msgcat::mc {CMYK}] \
+ -variable ed(color) -value cmyk
+ ttk::radiobutton $f.gray -text [msgcat::mc {Grayscale}] \
+ -variable ed(color) -value gray
+ ttk::label $f.level -text [msgcat::mc {Level}]
+ ttk::radiobutton $f.level1 -text "[msgcat::mc {Level}] 1" \
+ -variable ed(level) -value 1
+ ttk::radiobutton $f.level2 -text "[msgcat::mc {Level}] 2" \
+ -variable ed(level) -value 2
+ ttk::radiobutton $f.level3 -text "[msgcat::mc {Level}] 3" \
+ -variable ed(level) -value 3
+ ttk::label $f.dpi -text [msgcat::mc {DPI}]
+ tk_optionMenu $f.resolution ed(resolution) 72 Screen 96 144 150 225 300 600 1200
+
+ grid $f.color $f.rgb $f.cmyk $f.gray -padx 2 -pady 2 -sticky w
+ grid $f.level $f.level3 $f.level2 $f.level1 -padx 2 -pady 2 -sticky w
+ grid $f.dpi $f.resolution -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ grid $w.pt -sticky news
+ grid $w.ps -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ array set ps [array get ed]
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PSPrintBrowse {varname} {
+ upvar $varname var
+
+ FileLast pssavfbox $var
+ set var [SaveFileDialog pssavfbox]
+}
+
+# Used for plots
+proc PlotPrintDialog {} {
+ global ps
+ global ed
+
+ set ed(ok) 0
+ array set ed [array get ps]
+
+ set w {.print}
+
+ DialogCreate $w [msgcat::mc {Print}] ed(ok)
+
+ # PrintTo
+ set f [ttk::labelframe $w.pt -text [msgcat::mc {Print To}]]
+
+ ttk::radiobutton $f.printer -text [msgcat::mc {Printer}] \
+ -variable ed(dest) -value printer
+ ttk::label $f.tcmd -text [msgcat::mc {Command}]
+ ttk::entry $f.cmd -textvariable ed(cmd) -width 20
+
+ ttk::radiobutton $f.file -text [msgcat::mc {File}] \
+ -variable ed(dest) -value file
+ ttk::label $f.tname -text [msgcat::mc {Name}]
+ ttk::entry $f.name -textvariable ed(filename) -width 20
+ ttk::button $f.browse -text [msgcat::mc {Browse}] \
+ -command "PlotPrintBrowse ed(filename)"
+
+ grid $f.printer $f.tcmd $f.cmd -padx 2 -pady 2 -sticky ew
+ grid $f.file $f.tname $f.name $f.browse -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 2 -weight 1
+
+ # Options
+ set f [ttk::labelframe $w.ps -text [msgcat::mc {Postscript}]]
+
+ ttk::label $f.color -text [msgcat::mc {Color}]
+ ttk::radiobutton $f.rgb -text [msgcat::mc {RGB}] \
+ -variable ed(color) -value rgb
+ ttk::radiobutton $f.gray -text [msgcat::mc {Grayscale}] \
+ -variable ed(color) -value gray
+
+ grid $f.color $f.rgb $f.gray -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ grid $w.pt -sticky news
+ grid $w.ps -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ array set ps [array get ed]
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PlotPrintBrowse {varname} {
+ upvar $varname var
+
+ FileLast apsavfbox $var
+ set var [SaveFileDialog apsavfbox]
+}
+
+# Used for SimpleText and Catalog
+proc PRPrintDialog {} {
+ global ps
+ global ed
+
+ set ed(ok) 0
+ array set ed [array get ps]
+
+ set w {.print}
+
+ DialogCreate $w [msgcat::mc {Print}] ed(ok)
+
+ # PrintTo
+ set f [ttk::labelframe $w.pt -text [msgcat::mc {Print To}]]
+
+ ttk::radiobutton $f.printer -text [msgcat::mc {Printer}] \
+ -variable ed(dest) -value printer
+ ttk::label $f.tcmd -text [msgcat::mc {Command}]
+ ttk::entry $f.cmd -textvariable ed(cmd) -width 20
+
+ ttk::radiobutton $f.file -text [msgcat::mc {File}] \
+ -variable ed(dest) -value file
+ ttk::label $f.tname -text [msgcat::mc {Name}]
+ ttk::entry $f.name -textvariable ed(filename,txt) -width 20
+ ttk::button $f.browse -text [msgcat::mc {Browse}] \
+ -command "PRPrintBrowse ed(filename,txt)"
+
+ grid $f.printer $f.tcmd $f.cmd -padx 2 -pady 2 -sticky ew
+ grid $f.file $f.tname $f.name $f.browse -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 2 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # Fini
+ grid $w.pt -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ DialogCenter $w
+ DialogWait $w ed(ok) $w.buttons.ok
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ array set ps [array get ed]
+ }
+
+ set rr $ed(ok)
+ unset ed
+ return $rr
+}
+
+proc PRPrintBrowse {varname} {
+ upvar $varname var
+
+ FileLast prsavfbox $var
+ set var [SaveFileDialog prsavfbox]
+}
+
+proc PrefsDialogPrint {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Postscript}]
+ lappend dprefs(tabs) [ttk::frame $w.print]
+
+ # PrintTo
+ set f [ttk::labelframe $w.print.printto -text [msgcat::mc {Print To}]]
+
+ ttk::radiobutton $f.printer -text [msgcat::mc {Printer}] \
+ -variable pps(dest) -value printer
+ ttk::label $f.tcmd -text [msgcat::mc {Command}]
+ ttk::entry $f.cmd -textvariable pps(cmd) -width 20
+
+ ttk::radiobutton $f.file -text [msgcat::mc {File}] \
+ -variable pps(dest) -value file
+ ttk::label $f.tname -text [msgcat::mc {Name}]
+ ttk::entry $f.name -textvariable pps(filename) -width 20
+ ttk::button $f.browse -text [msgcat::mc {Browse}] \
+ -command "PSPrintBrowse pps(filename)"
+
+ grid $f.printer $f.tcmd $f.cmd -padx 2 -pady 2 -sticky w
+ grid $f.file $f.tname $f.name $f.browse -padx 2 -pady 2 -sticky w
+
+ # Options
+ set f [ttk::labelframe $w.print.ps -text [msgcat::mc {Postscript}]]
+
+ ttk::label $f.color -text [msgcat::mc {Color}]
+ ttk::radiobutton $f.rgb -text [msgcat::mc {RGB}] \
+ -variable pps(color) -value rgb
+ ttk::radiobutton $f.cmyk -text [msgcat::mc {CMYK}] \
+ -variable pps(color) -value cmyk
+ ttk::radiobutton $f.gray -text [msgcat::mc {Grayscale}] \
+ -variable pps(color) -value gray
+ ttk::label $f.level -text [msgcat::mc {Level}]
+ ttk::radiobutton $f.level1 -text "[msgcat::mc {Level}] 1" \
+ -variable pps(level) -value 1
+ ttk::radiobutton $f.level2 -text "[msgcat::mc {Level}] 2" \
+ -variable pps(level) -value 2
+ ttk::radiobutton $f.level3 -text "[msgcat::mc {Level}] 3" \
+ -variable pps(level) -value 3
+ ttk::label $f.dpi -text [msgcat::mc {DPI}]
+ tk_optionMenu $f.resolution pps(resolution) 72 Screen 96 144 150 225 300 600 1200
+
+ grid $f.color $f.rgb $f.cmyk $f.gray -padx 2 -pady 2 -sticky w
+ grid $f.level $f.level3 $f.level2 $f.level1 -padx 2 -pady 2 -sticky w
+ grid $f.dpi $f.resolution -padx 2 -pady 2 -sticky w
+
+ pack $w.print.printto $w.print.ps \
+ -side top -fill both -expand true
+}
+
+# Process Cmds
+
+proc ProcessPrintCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ aqua -
+ win32 {ProcessPSPrintCmd var i}
+ }
+}
+
+proc ProcessSendPrintCmd {proc id param} {
+ global ds9
+
+ switch $ds9(wm) {
+ x11 -
+ aqua -
+ win32 {ProcessSendPSPrintCmd $proc $id $param}
+ }
+}
+
+proc ProcessPSPrintCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ps
+
+ switch -- [string tolower [lindex $var $i]] {
+ destination {incr i; set ps(dest) [lindex $var $i]}
+ command {incr i; set ps(cmd) [lindex $var $i]}
+ filename {incr i; set ps(filename) [lindex $var $i]}
+ palette -
+ color {incr i; set ps(color) [lindex $var $i]}
+ level {incr i; set ps(level) [lindex $var $i]}
+ interpolate {incr i}
+ resolution {incr i; set ps(resolution) [lindex $var $i]}
+
+ {} {PostScript}
+ default {incr i -1; PostScript}
+ }
+}
+
+proc ProcessSendPSPrintCmd {proc id param} {
+ global ps
+
+ switch -- [string tolower $param] {
+ destination {$proc $id "$ps(dest)\n"}
+ command {$proc $id "$ps(cmd)\n"}
+ filename {$proc $id "$ps(filename)\n"}
+ palette -
+ color {$proc $id "$ps(color)\n"}
+ level {$proc $id "$ps(level)\n"}
+ interpolate {$proc $id "0\n"}
+ resolution {$proc $id "$ps(resolution)\n"}
+ }
+}
diff --git a/ds9/library/projection.tcl b/ds9/library/projection.tcl
new file mode 100644
index 0000000..9dc331e
--- /dev/null
+++ b/ds9/library/projection.tcl
@@ -0,0 +1,128 @@
+# 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 ProjectionDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(tcoord) [lindex $rr 0]
+ set var(tformat) degrees
+ AdjustCoordSystem $varname tcoord
+
+ # procs
+ set var(which) projection
+ set var(proc,apply) ProjectionApply
+ set var(proc,coordCB) ProjectionCoordCB
+ set var(proc,editCB) ProjectionEditCB
+ set var(proc,distCB) ProjectionDistCB
+
+ # base
+ MarkerBaseLineDialog $varname 500 200
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ # plot2d
+ MarkerAnalysisPlot2dDialog $varname
+
+ # init
+ ProjectionThickCB $varname
+
+ set f $var(top).param
+
+ # Thick
+ ttk::label $f.tthick -text [msgcat::mc {Thickness}]
+ ttk::entry $f.thick -textvariable ${varname}(thick) -width 13
+ DistMenuButton $f.uthick $varname tcoord 1 tformat \
+ [list ProjectionThickCB $varname]
+ DistMenuEnable $f.uthick.menu $varname tcoord 1 tformat
+
+ grid $f.tthick $f.thick $f.uthick -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc ProjectionApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) projection $var(system) $var(sky) \
+ $var(x) $var(y) $var(x2) $var(y2) \
+ $var(thick) $var(tcoord) $var(tformat)
+
+ MarkerBaseLineApply $varname
+}
+
+# callbacks
+
+proc ProjectionCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "ProjectionCoordCB"
+ }
+
+ MarkerAnalysisPlot2dSystem $varname
+ MarkerBaseCoordCB $varname
+ ProjectionEditCB $varname
+}
+
+proc ProjectionEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "ProjectionEditCB"
+ }
+
+ MarkerBaseLineEditCB $varname
+
+ set var(dist) [$var(frame) get marker $var(id) projection length \
+ $var(dcoord) $var(dformat)]
+ set var(thick) [$var(frame) get marker $var(id) projection thick \
+ $var(tcoord) $var(tformat)]
+ set var(angle) [$var(frame) get marker $var(id) angle \
+ $var(system) $var(sky)]
+}
+
+proc ProjectionDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "ProjectionDistCB"
+ }
+
+ set var(dist) [$var(frame) get marker $var(id) projection length \
+ $var(dcoord) $var(dformat)]
+}
+
+proc ProjectionThickCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "ProjectionThickCB"
+ }
+
+ set var(thick) [$var(frame) get marker $var(id) projection thick \
+ $var(tcoord) $var(tformat)]
+}
+
diff --git a/ds9/library/rgb.tcl b/ds9/library/rgb.tcl
new file mode 100644
index 0000000..292a9d2
--- /dev/null
+++ b/ds9/library/rgb.tcl
@@ -0,0 +1,365 @@
+# 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 RGBDef {} {
+ global rgb
+ global irgb
+
+ set irgb(top) .rgb
+ set irgb(mb) .rgbmb
+
+ set rgb(red) 1
+ set rgb(green) 1
+ set rgb(blue) 1
+ set rgb(system) wcs
+ set rgb(lock,wcs) 0
+ set rgb(lock,crop) 0
+ set rgb(lock,slice) 0
+ set rgb(lock,bin) 0
+ set rgb(lock,axes) 0
+ set rgb(lock,scale) 0
+ set rgb(lock,scalelimits) 0
+ set rgb(lock,colorbar) 0
+ set rgb(lock,block) 0
+ set rgb(lock,smooth) 0
+}
+
+proc RGBEvalLockCurrent {varname cmd} {
+ global current
+
+ global rgb
+ global crop
+ global cube
+ global bin
+ global scale
+ global colorbar
+ global block
+ global smooth
+
+ RGBEvalLock $varname $current(frame) $cmd
+}
+
+proc RGBEvalLock {varname which cmd} {
+ upvar $varname var
+
+ global rgb
+ global crop
+ global cube
+ global bin
+ global scale
+ global colorbar
+ global block
+ global smooth
+
+ if {$var && [$which get type] == {rgb}} {
+ set ch [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ eval $cmd
+ }
+ $which rgb channel $ch
+ } else {
+ eval $cmd
+ }
+}
+
+proc RGBEvalLockColorbar {cmd} {
+ global current
+ global scale
+ global rgb
+
+ if {$rgb(lock,colorbar) && [$current(frame) get type] == {rgb}} {
+ set ch $current(rgb)
+ foreach c {red green blue} {
+ colorbarrgb rgb channel $c
+ eval $cmd
+ }
+ set current(rgb) $ch
+ colorbarrgb rgb channel $current(rgb)
+ } else {
+ eval $cmd
+ }
+}
+
+proc RGBChannel {} {
+ global current
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) get type] == {rgb}} {
+ colorbarrgb rgb channel $current(rgb)
+ }
+ $current(frame) rgb channel $current(rgb)
+ UpdateDS9
+ }
+}
+
+proc RGBView {} {
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ $current(frame) rgb view $rgb(red) $rgb(green) $rgb(blue)
+ }
+}
+
+proc RGBSystem {} {
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ $current(frame) rgb system $rgb(system)
+ }
+}
+
+# used by backup
+proc RGBDialog {} {
+ global rgb
+ global irgb
+
+ global current
+ global ds9
+
+ # see if we already have a window visible
+ if {[winfo exists $irgb(top)]} {
+ raise $irgb(top)
+ return
+ }
+
+ # create the rgb window
+ set w $irgb(top)
+ set mb $irgb(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {RGB}] RGBDestroyDialog
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Align}] -menu $mb.align
+ $mb add cascade -label [msgcat::mc {Lock}] -menu $mb.lock
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Close}] -command RGBDestroyDialog
+
+ CoordMenu $mb.align rgb system 1 {} {} RGBSystem
+
+ menu $mb.lock
+ $mb.lock add checkbutton -label [msgcat::mc {WCS}] \
+ -variable rgb(lock,wcs)
+ $mb.lock add checkbutton -label [msgcat::mc {Crop}] \
+ -variable rgb(lock,crop)
+ $mb.lock add checkbutton -label [msgcat::mc {Slice}] \
+ -variable rgb(lock,slice)
+ $mb.lock add checkbutton -label [msgcat::mc {Bin}] \
+ -variable rgb(lock,bin)
+ $mb.lock add checkbutton -label [msgcat::mc {Axes Order}] \
+ -variable rgb(lock,axes)
+ $mb.lock add checkbutton -label [msgcat::mc {Scale}] \
+ -variable rgb(lock,scale)
+ $mb.lock add checkbutton -label [msgcat::mc {Scale and Limits}] \
+ -variable rgb(lock,scalelimits)
+ $mb.lock add checkbutton -label [msgcat::mc {Colorbar}] \
+ -variable rgb(lock,colorbar)
+ $mb.lock add checkbutton -label [msgcat::mc {Block}] \
+ -variable rgb(lock,block)
+ $mb.lock add checkbutton -label [msgcat::mc {Smooth}] \
+ -variable rgb(lock,smooth)
+
+ # Param
+ set f [ttk::frame $w.param]
+ ttk::label $f.currenttitle -text [msgcat::mc {Current}]
+ ttk::label $f.viewtitle -text [msgcat::mc {View}]
+ ttk::label $f.redtitle -text [msgcat::mc {Red}]
+ ttk::label $f.bluetitle -text [msgcat::mc {Blue}]
+ ttk::label $f.greentitle -text [msgcat::mc {Green}]
+
+ ttk::radiobutton $f.redcurrent -variable current(rgb) \
+ -value red -command RGBChannel
+ ttk::radiobutton $f.greencurrent -variable current(rgb) \
+ -value green -command RGBChannel
+ ttk::radiobutton $f.bluecurrent -variable current(rgb) \
+ -value blue -command RGBChannel
+
+ ttk::checkbutton $f.redview -variable rgb(red) -command RGBView
+ ttk::checkbutton $f.greenview -variable rgb(green) -command RGBView
+ ttk::checkbutton $f.blueview -variable rgb(blue) -command RGBView
+
+ grid x $f.currenttitle $f.viewtitle -padx 2 -pady 2 -sticky w
+ grid $f.redtitle $f.redcurrent $f.redview -padx 2 -pady 2 -sticky w
+ grid $f.greentitle $f.greencurrent $f.greenview -padx 2 -pady 2 -sticky w
+ grid $f.bluetitle $f.bluecurrent $f.blueview -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command RGBDestroyDialog
+ pack $f.close -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
+}
+
+proc RGBDestroyDialog {} {
+ global irgb
+
+ if {[winfo exists $irgb(top)]} {
+ destroy $irgb(top)
+ destroy $irgb(mb)
+ }
+}
+
+proc UpdateRGBMenu {} {
+ # can be changed by wcs
+ SetCoordSystem rgb system {} {}
+}
+
+proc UpdateRGBDialog {} {
+ global rgb
+ global irgb
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateRGBDialog"
+ }
+
+ if {![winfo exists $irgb(top)]} {
+ return
+ }
+
+ if {$current(frame) != {}} {
+ set rgb(frame) $current(frame)
+ if {[$current(frame) has fits]} {
+ # now make sure we have the coord systems
+ AdjustCoordSystem rgb system
+ CoordMenuEnable $irgb(mb).align rgb system 1 {} {}
+ } else {
+ CoordMenuReset $irgb(mb).align rgb system 1 {} {}
+ }
+ }
+
+ if {$current(frame) != {}} {
+ set current(rgb) [$current(frame) get rgb channel]
+ set r [$current(frame) get rgb view]
+ set rgb(red) [lindex $r 0]
+ set rgb(green) [lindex $r 1]
+ set rgb(blue) [lindex $r 2]
+ set rgb(system) [$current(frame) get rgb system]
+ }
+}
+
+proc RGBBackup {ch which} {
+ puts $ch "$which rgb channel [$which get rgb channel]"
+ puts $ch "$which rgb view [$which get rgb view]"
+ puts $ch "$which rgb system [$which get rgb system]"
+}
+
+# Process Cmds
+
+proc ProcessRGBCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+ global rgb
+
+ RGBDialog
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {}
+ close {RGBDestroyDialog}
+ red -
+ green -
+ blue {
+ set current(rgb) [string tolower [lindex $var $i]]
+ RGBChannel
+ }
+ channel {
+ incr i
+ set current(rgb) [string tolower [lindex $var $i]]
+ RGBChannel
+ }
+ lock {
+ incr i
+ set item [string tolower [lindex $var $i]]
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set rr [FromYesNo [lindex $var $i]]
+ } else {
+ set rr 1
+ incr i -1
+ }
+ switch -- $item {
+ wcs {set rgb(lock,wcs) $rr}
+ crop {set rgb(lock,crop) $rr}
+ slice {set rgb(lock,slice) $rr}
+ bin {set rgb(lock,bin) $rr}
+ axes -
+ order {set rgb(lock,axes) $rr}
+ scale {set rgb(lock,scale) $rr}
+ limits -
+ scalelimits {set rgb(lock,scalelimits) $rr}
+ color -
+ colormap -
+ colorbar {set rgb(lock,colorbar) $rr}
+ block {set rgb(lock,block) $rr}
+ smooth {set rgb(lock,smooth) $rr}
+ }
+ }
+ system {
+ incr i
+ set rgb(system) [string tolower [lindex $var $i]]
+ RGBSystem
+ }
+ view {
+ set w [lindex $var [expr $i+1]]
+ set yesno [lindex $var [expr $i+2]]
+ switch -- [string tolower $w] {
+ red {set rgb(red) [FromYesNo $yesno]; RGBView}
+ green {set rgb(green) [FromYesNo $yesno]; RGBView}
+ blue {set rgb(blue) [FromYesNo $yesno]; RGBView}
+ }
+ incr i 2
+ }
+ default {
+ CreateRGBFrame
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendRGBCmd {proc id param} {
+ global current
+ global rgb
+
+ switch -- [lindex $param 0] {
+ channel {$proc $id "$current(rgb)\n"}
+ lock {
+ switch -- [string tolower [lindex $param 1]] {
+ wcs {$proc $id [ToYesNo $rgb(lock,wcs)]}
+ crop {$proc $id [ToYesNo $rgb(lock,crop)]}
+ slice {$proc $id [ToYesNo $rgb(lock,slice)]}
+ bin {$proc $id [ToYesNo $rgb(lock,bin)]}
+ axes -
+ order {$proc $id [ToYesNo $rgb(lock,axes)]}
+ scale {$proc $id [ToYesNo $rgb(lock,scale)]}
+ limits -
+ scalelimits {$proc $id [ToYesNo $rgb(lock,scalelimits)]}
+ colorbar {$proc $id [ToYesNo $rgb(lock,colorbar)]}
+ block {$proc $id [ToYesNo $rgb(lock,block)]}
+ smooth {$proc $id [ToYesNo $rgb(lock,smooth)]}
+ }
+ }
+ system {$proc $id "$rgb(system)\n"}
+ view {
+ switch -- [lindex $param 1] {
+ red {$proc $id [ToYesNo $rgb(red)]}
+ green {$proc $id [ToYesNo $rgb(green)]}
+ blue {$proc $id [ToYesNo $rgb(blue)]}
+ }
+ }
+ }
+}
+
diff --git a/ds9/library/rgbarray.tcl b/ds9/library/rgbarray.tcl
new file mode 100644
index 0000000..2dc38d0
--- /dev/null
+++ b/ds9/library/rgbarray.tcl
@@ -0,0 +1,185 @@
+# 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 ImportRGBArrayFile {fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {return}
+ rgb {}
+ }
+
+ set loadParam(file,type) array
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) mmapincr
+
+ # if no zdim is present, insert one
+ set exp {.*\[.*zdim[ ]*=[ ]*[0-9]+}
+ if {![regexp $exp $fn]} {
+ set i [string last "\]" $fn]
+ set fn "[string range $fn 0 [expr $i-1]],zdim=3\]"
+ }
+ set loadParam(file,name) $fn
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ # check for stdin/gz
+ ConvertArrayFile
+ ProcessLoad
+}
+
+proc ImportRGBArrayAlloc {path fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {return}
+ rgb {}
+ }
+
+ set loadParam(file,type) array
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) allocgz
+
+ # if no zdim is present, insert one
+ set exp {.*\[.*zdim[ ]*=[ ]*[0-9]+}
+ if {![regexp $exp $fn]} {
+ set i [string last "\]" $fn]
+ set fn "[string range $fn 0 [expr $i-1]],zdim=3\]"
+ }
+ if {![regexp $exp $path]} {
+ set i [string last "\]" $path]
+ set path "[string range $path 0 [expr $i-1]],zdim=3\]"
+ }
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc ImportRGBArraySocket {sock fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {return}
+ rgb {}
+ }
+
+ set loadParam(file,type) array
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) socketgz
+ # if no zdim is present, insert one
+ set exp {.*\[.*zdim[ ]*=[ ]*[0-9]+}
+ if {![regexp $exp $fn]} {
+ set i [string last "\]" $fn]
+ set fn "[string range $fn 0 [expr $i-1]],zdim=3\]"
+ }
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ return [ProcessLoad 0]
+}
+
+proc ExportRGBArrayFile {fn opt} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save array rgb cube file "\{$fn\}" $opt
+}
+
+proc ExportRGBArraySocket {sock opt} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save array rgb cube socket $sock $opt
+}
+
+proc ProcessRGBArrayCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateRGBFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![ImportRGBArraySocket $sock $param]} {
+ InitError xpa
+ ImportRGBArrayFile $param
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ ImportRGBArrayAlloc $fn $param
+ } else {
+ ImportRGBArrayFile $param
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendRGBArrayCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ set opt [string tolower [lindex $param 0]]
+ if {$sock != {}} {
+ # xpa
+ ExportRGBArraySocket $sock $opt
+ } elseif {$fn != {}} {
+ # comm
+ ExportRGBArrayFile $fn $opt
+ $proc $id {} $fn
+ }
+}
+
+
diff --git a/ds9/library/rgbcube.tcl b/ds9/library/rgbcube.tcl
new file mode 100644
index 0000000..612cd89
--- /dev/null
+++ b/ds9/library/rgbcube.tcl
@@ -0,0 +1,163 @@
+# 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 LoadRGBCubeFile {fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadRGBCubeAlloc {path fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc LoadRGBCubeSocket {sock fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ return [ProcessLoad 0]
+}
+
+proc SaveRGBCubeFile {fn} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits rgb cube file "\{$fn\}"
+}
+
+proc SaveRGBCubeSocket {sock} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits rgb cube socket $sock
+}
+
+proc ProcessRGBCubeCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateRGBFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadRGBCubeSocket $sock $param]} {
+ InitError xpa
+ LoadRGBCubeFile $param
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadRGBCubeAlloc $fn $param
+ } else {
+ LoadRGBCubeFile $param
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendRGBCubeCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {$sock != {}} {
+ # xpa
+ SaveRGBCubeSocket $sock
+ } elseif {$fn != {}} {
+ # comm
+ SaveRGBCubeFile $fn
+ $proc $id {} $fn
+ }
+}
diff --git a/ds9/library/rgbimage.tcl b/ds9/library/rgbimage.tcl
new file mode 100644
index 0000000..6ed2b3b
--- /dev/null
+++ b/ds9/library/rgbimage.tcl
@@ -0,0 +1,181 @@
+# 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 LoadRGBImageFile {fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb image}
+ set loadParam(load,type) mmapincr
+ set loadParam(file,name) $fn
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ConvertFitsFile
+ ProcessLoad
+}
+
+proc LoadRGBImageAlloc {path fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb image}
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $path
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc LoadRGBImageSocket {sock fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb image}
+ set loadParam(load,type) socketgz
+ set loadParam(file,name) $fn
+ set loadParam(socket,id) $sock
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ return [ProcessLoad 0]
+}
+
+proc SaveRGBImageFile {fn} {
+ global current
+
+ if {$fn == {} || $current(frame) == {}} {
+ return
+ }
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to save RGB image from a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits rgb image file "\{$fn\}"
+}
+
+proc SaveRGBImageSocket {sock} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to save RGB image from a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ $current(frame) save fits rgb image socket $sock
+}
+
+proc ProcessRGBImageCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateRGBFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+ set param [lindex $var $i]
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {![LoadRGBImageSocket $sock $param]} {
+ InitError xpa
+ LoadRGBImageFile $param
+ }
+ } else {
+ # comm
+ if {$fn != {}} {
+ LoadRGBImageAlloc $fn $param
+ } else {
+ LoadRGBImageFile $param
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendRGBImageCmd {proc id param sock fn} {
+ global current
+
+ if {$current(frame) == {}} {
+ return
+ }
+
+ if {$sock != {}} {
+ # xpa
+ SaveRGBImageSocket $sock
+ } elseif {$fn != {}} {
+ # comm
+ SaveRGBImageFile $fn
+ $proc $id {} $fn
+ }
+}
diff --git a/ds9/library/ruler.tcl b/ds9/library/ruler.tcl
new file mode 100644
index 0000000..2aa9779
--- /dev/null
+++ b/ds9/library/ruler.tcl
@@ -0,0 +1,117 @@
+# 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 RulerDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set s [$var(frame) get marker $var(id) ruler system]
+ set var(system) [lindex $s 0]
+ set var(sky) [lindex $s 1]
+ set var(skyformat) degrees
+ set var(dcoord) [lindex $s 2]
+ set var(dformat) [lindex $s 3]
+
+ # procs
+ set var(which) ruler
+ set var(proc,apply) RulerApply
+ set var(proc,coordCB) RulerCoordCB
+ set var(proc,editCB) RulerEditCB
+ set var(proc,distCB) RulerDistCB
+
+ # base
+ MarkerBaseLineDialog $varname 375 200
+
+ set f $var(top).param
+
+ # Axis Length
+ ttk::label $f.tlen -text [msgcat::mc {Axis Length}]
+ ttk::label $f.rx -textvariable ${varname}(distx) -relief groove -width 12
+ ttk::label $f.ry -textvariable ${varname}(disty) -relief groove -width 12
+ ttk::label $f.ulen -textvariable ${varname}(dcoord,msg)
+
+ grid $f.tlen $f.rx $f.ry $f.ulen -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc RulerApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) ruler point $var(system) $var(sky) \
+ $var(x) $var(y) $var(x2) $var(y2)
+
+ MarkerBaseLineApply $varname
+}
+
+# callbacks
+
+proc RulerCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "RulerCoordCB"
+ }
+
+ MarkerBaseCoordCB $varname
+
+ $var(frame) marker $var(id) ruler system $var(system) $var(sky) \
+ $var(dcoord) $var(dformat)
+
+ RulerEditCB $varname
+}
+
+proc RulerEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "RulerEditCB"
+ }
+
+ MarkerBaseLineEditCB $varname
+
+ set d [$var(frame) get marker $var(id) ruler length \
+ $var(dcoord) $var(dformat)]
+ set var(dist) [lindex $d 0]
+ set var(distx) [lindex $d 1]
+ set var(disty) [lindex $d 2]
+
+ set var(angle) [$var(frame) get marker $var(id) angle \
+ $var(system) $var(sky)]
+}
+
+proc RulerDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "RulerDistCB"
+ }
+
+ $var(frame) marker $var(id) ruler system $var(system) $var(sky) \
+ $var(dcoord) $var(dformat)
+
+ set d [$var(frame) get marker $var(id) ruler length \
+ $var(dcoord) $var(dformat)]
+ set var(dist) [lindex $d 0]
+ set var(distx) [lindex $d 1]
+ set var(disty) [lindex $d 2]
+}
+
+
diff --git a/ds9/library/samp.tcl b/ds9/library/samp.tcl
new file mode 100644
index 0000000..6971008
--- /dev/null
+++ b/ds9/library/samp.tcl
@@ -0,0 +1,1730 @@
+# 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 SAMPDef {} {
+ global isamp
+
+ set isamp(timeout) 1000
+}
+
+proc InitSAMP {} {
+ global pds9
+
+ if {$pds9(samp)} {
+ catch {SAMPConnect 0}
+ }
+}
+
+# Cmds
+
+proc SAMPConnect {{verbose 1}} {
+ global ds9
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ # connected?
+ if {[info exists samp]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: already connected}]
+ }
+ return
+ }
+
+ # reset samp array
+ catch {unset samp}
+ set samp(apps,image) {}
+ set samp(apps,table) {}
+ set samp(apps,votable) {}
+
+ # these are to try to prevent feedback problems with
+ # other probgrams
+ set samp(rcvd,lock) 0
+ set samp(send,lock) 0
+
+ # delete any old tmp files
+ SAMPDelTmpFiles
+
+ # can we find a hub?
+ if {![SAMPParseHub]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: unable to locate HUB}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ # register
+ set params [list "string $samp(secret)"]
+ if {![SAMPSend {samp.hub.register} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+ set rr [lindex $rr 1]
+ foreach ff $rr {
+ foreach {key val} $ff {
+ switch -- $key {
+ samp.hub-id {set samp(hub) $val}
+ samp.self-id {set samp(self) $val}
+ samp.private-key {set samp(private) $val}
+ }
+ }
+ }
+
+ # declare metadata
+ catch {unset sampmap}
+ set sampmap(samp.name) {string "SAOImage DS9"}
+ set sampmap(samp.description.text) {string "SAOImage DS9 is an astronomical visualization application"}
+ set sampmap(samp.icon.url) {string "http://ds9.si.edu/doc/sun.gif"}
+ set sampmap(samp.documentation.url) {string "http://ds9.si.edu/doc/ref/index.html"}
+
+ set sampmap(home.page) {string "http://ds9.si.edu/"}
+ set sampmap(author.name) {string "William Joye"}
+ set sampmap(author.email) {string "saord@cfa.harvard.edu"}
+ set sampmap(author.affiliation) {string "Smithsonian Astrophysical Observatory"}
+ set sampmap(ds9.version) "string [lindex $ds9(version) 0]"
+
+ set param1 [list "string $samp(private)"]
+ set param2 [list "struct sampmap"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.declareMetadata} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ # who are we
+ set samp(port) [lindex [fconfigure [xmlrpc::serve 0] -sockname] 2]
+ set samp(home) "[info hostname]:$samp(port)"
+
+ # callback
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string http://$samp(home)"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.setXmlrpcCallback} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ # declare subscriptions
+ catch {unset sampmap}
+ catch {unset sampmap2}
+ set sampmap(samp.app.ping) {struct mapPing}
+
+ set sampmap(samp.hub.event.shutdown) {struct mapShutdown}
+ set sampmap(samp.hub.event.register) {struct mapRegister}
+ set sampmap(samp.hub.event.unregister) {struct mapUnregister}
+ set sampmap(samp.hub.disconnect) {struct mapDisconnect}
+
+ set sampmap(image.load.fits) {struct mapImageLoadFits}
+ set sampmap(table.load.fits) {struct mapTableLoadFits}
+ set sampmap(table.load.votable) {struct mapTableLoadVotable}
+ set sampmap(table.highlight.row) {struct mapTableHighlightRow}
+ set sampmap(table.select.rowList) {struct mapTableSelectRowList}
+ set sampmap(coord.pointAt.sky) {struct mapCoordPointAtSky}
+ set sampmap(client.env.get) {struct mapClientEnvGet}
+
+ set sampmap(x-samp.affiliation.name) {struct mapAffiliationName}
+ set sampmap(x-samp.affiliation.url) {struct mapAffiliationURL}
+ set sampmap(x-samp.homepage.url) {struct mapHomepageURL}
+ set sampmap(x-samp.releasenotes.url) {struct mapReleasenotesURL}
+ set sampmap(x-samp.faq.url) {struct mapFAQURL}
+ set sampmap(x-samp.authors) {struct mapAuthors}
+ set sampmap(x-samp.release.version) {struct mapReleaseVersion}
+
+ set sampmap(ds9.get) {struct mapDS9Get}
+ set sampmap(ds9.set) {struct mapDS9Set}
+ set sampmap(ds9.restricted-get) {struct sampmap2}
+ set sampmap(ds9.restricted-set) {struct sampmap2}
+
+ set sampmap2(x-samp.mostly-harmless) {string "1"}
+
+ set param1 [list "string $samp(private)"]
+ set param2 [list "struct sampmap"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.declareSubscriptions} $params rr]} {
+ if {$verbose} {
+ Error [msgcat::mc {SAMP: internal error}]
+ }
+ catch {unset samp}
+ return
+ }
+
+ after $isamp(timeout) SAMPUpdate
+}
+
+proc SAMPDisconnect {} {
+ global ds9
+ global samp
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # disconnect
+ if {[info exists samp(private)]} {
+ set params [list "string $samp(private)"]
+ set rr {}
+ SAMPSend {samp.hub.unregister} $params rr
+ SAMPShutdown
+ }
+
+ UpdateFileMenu
+ UpdateCATDialog
+}
+
+proc SAMPSendImageLoadFits {id} {
+ global ds9
+ global current
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendImageLoadFits"
+ }
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ # got something to send?
+ if {![$current(frame) has fits]} {
+ return
+ }
+
+ # save current frame
+ set fn [tmpnam {.samp}]
+ catch {$current(frame) save fits image file "\{$fn\}"}
+
+ # name to use
+ set fnb [$current(frame) get fits file name root base]
+ if {[regexp {(.*)\[.*\]} $fnb aa bb]} {
+ set fnb $bb
+ }
+
+ # cmd
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "image.load.fits"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(url) "string \"[XMLQuote file://localhost/$fn]\""
+ set sampmap2(name) "string \"[XMLQuote $fnb]\""
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableLoadFits {id} {
+ global ds9
+ global current
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableLoadFits"
+ }
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ # got something to send?
+ if {![$current(frame) has fits] && [$current(frame) has fits bin]} {
+ return
+ }
+
+ # save current frame
+ set fn [tmpnam {.samp}]
+ catch {$current(frame) save fits table file "\{$fn\}"}
+
+ # name to use
+ set fnb [$current(frame) get fits file name root base]
+ if {[regexp {(.*)\[.*\]} $fnb aa bb]} {
+ set fnb $bb
+ }
+
+ # cmd
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.load.fits"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(url) "string \"[XMLQuote file://localhost/$fn]\""
+ set sampmap2(name) "string \"[XMLQuote $fnb]\""
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableLoadVotable {id varname} {
+ global ds9
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableLoadVotable $id $varname"
+ }
+
+ # connected?
+ if {![info exists samp]} {
+ Error [msgcat::mc {SAMP: not connected}]
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ # remember
+ set samp(icat,$varname$samp(port)) $varname
+ set samp(ocat,$varname) $varname$samp(port)
+
+ # save votable
+ set fn [tmpnam {.samp}]
+ CATSaveFn $varname $fn VOTWrite
+
+ # cmd
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.load.votable"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(url) "string \"[XMLQuote file://localhost/$fn]\""
+ set sampmap2(table-id) "string [XMLQuote $varname$samp(port)]"
+ set sampmap2(name) "string \"[XMLQuote $var(title)]\""
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableHighlightRow {id varname row} {
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ # row starts at 1
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableHighlightRow $samp(ocat,$varname) $row"
+ }
+
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.highlight.row"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(table-id) "string [XMLQuote $samp(ocat,$varname)]"
+ set sampmap2(row) "string [XMLQuote [expr $row-1]]"
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableSelectRowList {id varname rows} {
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ # rows start at 1
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendTableSelectRowList $samp(ocat,$varname) $rows"
+ }
+
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "table.select.rowList"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(table-id) "string [XMLQuote $samp(ocat,$varname)]"
+ set ss {}
+ foreach rr $rows {
+ lappend ss "string [expr $rr-1]"
+ }
+ set sampmap2(row-list) [list array $ss]
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendTableRowListCmd {varname rowlist} {
+ global ds9
+ global samp
+
+ # connected?
+ if {![info exists samp]} {
+ return
+ }
+
+ if {$samp(apps,votable) == {}} {
+ return
+ }
+
+ # are we good?
+ if {![info exists samp(ocat,$varname)]} {
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ switch -- [llength $rowlist] {
+ 0 {}
+ 1 {SAMPSendTableHighlightRow {} $varname $rowlist}
+ default {SAMPSendTableSelectRowList {} $varname $rowlist}
+ }
+}
+
+proc SAMPSendCoordPointAtSky {id coord} {
+ global isamp
+ global samp
+ global sampmap
+ global sampmap2
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSendCoordPointAtSky $id $coord"
+ }
+
+ catch {unset sampmap}
+ set sampmap(samp.mtype) {string "coord.pointAt.sky"}
+ set sampmap(samp.params) {struct sampmap2}
+
+ catch {unset sampmap2}
+ set sampmap2(ra) "string [XMLQuote [lindex $coord 0]]"
+ set sampmap2(dec) "string [XMLQuote [lindex $coord 1]]"
+
+ set param1 [list "string $samp(private)"]
+ if {$id != {}} {
+ set param2 [list "string $id"]
+ } else {
+ set param2 {}
+ }
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+
+ if {$id != {}} {
+ SAMPSend {samp.hub.notify} $params rr
+ } else {
+ SAMPSend {samp.hub.notifyAll} $params rr
+ }
+
+ # set lock
+ set samp(send,lock) 1
+ after $isamp(timeout) SAMPClearSendLock
+}
+
+proc SAMPSendCoordPointAtSkyCmd {which} {
+ global ds9
+ global samp
+
+ # connected?
+ if {![info exists samp]} {
+ return
+ }
+
+ # are we locked?
+ if {$samp(rcvd,lock)} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Rcvd locked"
+ }
+ return
+ }
+
+ if {$samp(apps,image) == {} || $samp(apps,table) == {}} {
+ return
+ }
+
+ if {[$which has wcs equatorial wcs]} {
+ set coord [$which get coordinates [$which get cursor canvas] wcs fk5 degrees]
+ if {$coord != {}} {
+ SAMPSendCoordPointAtSky {} "$coord"
+ }
+ }
+}
+
+# Support
+
+proc SAMPShutdown {} {
+ global ds9
+ global samp
+
+ # delete any files
+ SAMPDelTmpFiles
+
+ # close the server socket if still up
+ catch {close $xmlrpc::acceptfd}
+
+ # update the menus
+ set samp(apps,image) {}
+ set samp(apps,table) {}
+ set samp(apps,votable) {}
+ UpdateFileMenu
+ UpdateCATDialog
+
+ # unset samp array
+ catch {unset samp}
+}
+
+proc SAMPUpdate {} {
+ # this routine is run after a delay since it needs to
+ # call the hub for metadata
+
+ # connected? we might have already disconnected.
+ global samp
+ if {![info exists samp]} {
+ return
+ }
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPUpdate"
+ }
+
+ # image fits
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string image.load.fits"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getSubscribedClients} $params rr]} {
+ return
+ }
+
+ set samp(apps,image) {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ if {$key != {}} {
+ lappend samp(apps,image) [list $key [SAMPGetAppName $key]]
+ }
+ }
+ }
+
+ # table fits
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string table.load.fits"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getSubscribedClients} $params rr]} {
+ return
+ }
+
+ set samp(apps,table) {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ if {$key != {}} {
+ lappend samp(apps,table) [list $key [SAMPGetAppName $key]]
+ }
+ }
+ }
+
+ # votable
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string table.load.votable"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getSubscribedClients} $params rr]} {
+ return
+ }
+
+ set samp(apps,votable) {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ if {$key != {}} {
+ lappend samp(apps,votable) [list $key [SAMPGetAppName $key]]
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPUpdate: image apps: $samp(apps,image)"
+ puts stderr "SAMPUpdate: table apps: $samp(apps,table)"
+ puts stderr "SAMPUpdate: votable apps: $samp(apps,votable)"
+ }
+
+ UpdateFileMenu
+ UpdateCATDialog
+}
+
+proc SAMPSend {method params resultVar} {
+ upvar $resultVar result
+
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSend: $method $params"
+ }
+
+ if {[catch {set result [xmlrpc::call $samp(url) $samp(method) $method $params]}]} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSend Error: $result"
+ }
+ return 0
+ }
+
+ # reset error if needed
+ # xmlrpc leaves error msgs
+ InitError samp
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPSend Result: $result"
+ }
+ return 1
+}
+
+proc SAMPReply {msgid status {result {}} {url {}} {error {}}} {
+ global samp
+ global sampmap
+ global sampmap2
+ global sampmap3
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReply:$msgid:$status:$result:$url:$error:"
+ }
+
+ catch {unset sampmap}
+ catch {unset sampmap2}
+ catch {unset sampmap3}
+ switch -- $status {
+ OK {
+ set sampmap(samp.status) {string "samp.ok"}
+ set sampmap(samp.result) {struct sampmap2}
+ if {$result != {}} {
+ set sampmap2(value) "string \"[XMLQuote $result]\""
+ }
+ if {$url != {}} {
+ set sampmap2(url) "string \"[XMLQuote $url]\""
+ }
+ }
+ WARNING {
+ set sampmap(samp.status) {string "samp.warning"}
+ set sampmap(samp.result) {struct sampmap2}
+ set sampmap(samp.error) {struct sampmap3}
+ if {$result != {}} {
+ set sampmap2(value) "string \"[XMLQuote $result]\""
+ }
+ if {$url != {}} {
+ set sampmap2(url) "string \"[XMLQuote $url]\""
+ }
+ set sampmap3(samp.errortxt) "string \"[XMLQuote $error]\""
+ }
+ ERROR {
+ set sampmap(samp.status) {string "samp.error"}
+ set sampmap(samp.error) {struct sampmap3}
+ set sampmap3(samp.errortxt) "string \"[XMLQuote $error]\""
+ }
+ }
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string $msgid"]
+ set param3 [list "struct sampmap"]
+ set params "$param1 $param2 $param3"
+ if {![SAMPSend {samp.hub.reply} $params rr]} {
+ return
+ }
+}
+
+proc SAMPReplySimple {msgid str} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReplySimple: $str"
+ }
+
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ SAMPReply $msgid OK "$str"
+}
+
+proc SAMPClearSendLock {} {
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPClearSendLock"
+ }
+ set samp(send,lock) 0
+}
+
+# receiveNotification(string sender-id, map message)
+proc samp.client.receiveNotification {args} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReceivedNotification: $args"
+ }
+ set secret [lindex $args 0]
+ set id [lindex $args 1]
+ set map [lindex $args 2]
+
+ set mtype {}
+ set params {}
+ foreach mm $map {
+ foreach {key val} $mm {
+ switch -- $key {
+ samp.mtype {set mtype $val}
+ samp.params {set params $val}
+ }
+ }
+ }
+
+ switch -- $mtype {
+ samp.hub.event.shutdown {
+ SAMPRcvdEventShutdown params
+ }
+ samp.hub.event.register {
+ SAMPRcvdEventRegister params
+ }
+ samp.hub.event.unregister {
+ SAMPRcvdEventUnregister params
+ }
+ samp.hub.disconnect {
+ SAMPRcvdDisconnect params
+ }
+ image.load.fits {
+ SAMPRcvdImageLoadFits params
+ }
+ table.load.fits {
+ SAMPRcvdTableLoadFits params
+ }
+ table.load.votable {
+ SAMPRcvdTableLoadVotable params
+ }
+ table.highlight.row {
+ SAMPRcvdTableHighlightRow params
+ }
+ table.select.rowList {
+ SAMPRcvdTableSelectRowList params
+ }
+ coord.pointAt.sky {
+ SAMPRcvdCoordPointAtSky params
+ }
+ ds9.set {
+ SAMPRcvdDS9Set {} params 0
+ }
+ ds9.restricted-set {
+ SAMPRcvdDS9Set {} params 1
+ }
+ default {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP samp.client.receiveNotification: bad mtype $mtype"
+ }
+ }
+ }
+ return {string OK}
+}
+
+# receiveCall(string sender-id, string msg-id, map message)
+proc samp.client.receiveCall {args} {
+ global ds9
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReceivedCall: $args"
+ }
+
+ set secret [lindex $args 0]
+ set id [lindex $args 1]
+ set msgid [lindex $args 2]
+ set map [lindex $args 3]
+
+ set mtype {}
+ set params {}
+ foreach mm $map {
+ foreach {key val} $mm {
+ switch -- $key {
+ samp.mtype {set mtype $val}
+ samp.params {set params $val}
+ }
+ }
+ }
+
+ switch -- $mtype {
+ samp.app.ping {
+ SAMPReply $msgid OK
+ }
+ image.load.fits {
+ SAMPRcvdImageLoadFits params
+ SAMPReply $msgid OK
+ }
+ table.load.fits {
+ SAMPRcvdTableLoadFits params
+ SAMPReply $msgid OK
+ }
+ table.load.votable {
+ SAMPRcvdTableLoadVotable params
+ SAMPReply $msgid OK
+ }
+ table.highlight.row {
+ SAMPRcvdTableHighlightRow params
+ SAMPReply $msgid OK
+ }
+ table.select.rowList {
+ SAMPRcvdTableSelectRowList params
+ SAMPReply $msgid OK
+ }
+ coord.pointAt.sky {
+ SAMPRcvdCoordPointAtSky params
+ SAMPReply $msgid OK
+ }
+ client.env.get {
+ SAMPRcvdClientEnvGet $msgid params
+ }
+ x-samp.affiliation.name {
+ SAMPReplySimple $msgid "SMITHSONIAN ASTROPHYSICAL OBSERVATORY"
+ }
+ x-samp.affiliation.url {
+ SAMPReplySimple $msgid "https://www.cfa.harvard.edu/sao"
+ }
+ x-samp.homepage.url {
+ SAMPReplySimple $msgid "http://ds9.si.edu"
+ }
+ x-samp.releasenotes.url {
+ SAMPReplySimple $msgid OK "http://ds9.si.edu/doc/release/r7.0.html"
+ }
+ x-samp.faq.url {
+ SAMPReplySimple $msgid OK "http://ds9.si.edu/doc/faq.html"
+ }
+ x-samp.authors {
+ global help
+ SAMPReplySimple $msgid OK "$help(authors)"
+ }
+ x-samp.release.version {
+ SAMPReplySimple $msgid OK "$ds9(version)"
+ }
+ ds9.get {
+ SAMPRcvdDS9Get $msgid params
+ }
+ ds9.set {
+ SAMPRcvdDS9Set $msgid params 0
+ }
+ ds9.restricted-get {
+ SAMPRcvdDS9Get $msgid params
+ }
+ ds9.restricted-set {
+ SAMPRcvdDS9Set $msgid params 1
+ }
+ default {
+ SAMPReply $msgid ERROR {} {} "[msgcat::mc {Unknown command}]: $mtype"
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP samp.client.receiveCall: bad mtype $mtype"
+ }
+ }
+ }
+ return {string OK}
+}
+
+# receiveResponse(string responder-id, string msg-tag, map response)
+proc samp.client.receiveResponse {args} {
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPReceivedResponse: $args"
+ }
+
+ set msgtag [lindex $args 0]
+ set value [lindex $args 1]
+ set map [lindex $args 2]
+
+ return {string OK}
+}
+
+# Support
+
+proc SAMPParseHub {} {
+ global samp
+ global env
+
+ set fn {}
+
+ if {[info exists env(SAMP_HUB)]} {
+ if {$env(SAMP_HUB) != {}} {
+ set exp {std-lockurl:(.*)}
+ if {[regexp $exp $env(SAMP_HUB) dummy url]} {
+
+ ParseURL $url rr
+ switch -- $rr(scheme) {
+ ftp {
+ set fn [tmpnam {.samp}]
+ GetFileFTP $rr(authority) $rr(path) $fn
+ }
+ file {set fn $rr(path)}
+ http -
+ default {
+ set fn [tmpnam {.samp}]
+ GetFileHTTP $url $fn
+ }
+ }
+ }
+ }
+ }
+
+ if {$fn == {}} {
+ # look in home directory for .samp
+ global tcl_platform
+ switch $tcl_platform(platform) {
+ unix {
+ set fn [file join [GetEnvHome] {.samp}]
+ }
+ windows {
+ set fn [file join "$env(HOMEDRIVE)$env(HOMEPATH)" {.samp}]
+ }
+ }
+ }
+
+ # no hub to be found
+ if {![file exist $fn]} {
+ return 0
+ }
+
+ set samp(secret) {}
+ set samp(url) {}
+ set samp(metod) {}
+ set fp [open $fn r]
+ while {1} {
+ if {[gets $fp line] == -1} {
+ break
+ }
+
+ # skip any comments
+ if {[string range $line 0 0] == "#"} {
+ continue;
+ }
+
+ if {[regexp -nocase {samp.secret=(.*)} $line foo ss]} {
+ set samp(secret) $ss
+ }
+ if {[regexp -nocase {samp.hub.xmlrpc.url=(.*)} $line foo url]} {
+ if {[ParseURL $url r]} {
+ set samp(url) $r(scheme)://$r(authority)
+ set samp(method) [string range $r(path) 1 end]
+ }
+ }
+ }
+ catch {close $fp}
+
+ if {$samp(secret) == {} || $samp(url) == {}} {
+ SAMPDelTmpFiles
+ return 0
+ }
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPParseHub: $samp(secret) $samp(url) $samp(method)"
+ }
+ return 1
+}
+
+proc SAMPGetAppName {id} {
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPGetAppName: $id"
+ }
+
+ set param1 [list "string $samp(private)"]
+ set param2 [list "string $id"]
+ set params "$param1 $param2"
+ if {![SAMPSend {samp.hub.getMetadata} $params rr]} {
+ return
+ }
+
+ set name {}
+ foreach arg [lindex $rr 1] {
+ foreach {key val} $arg {
+ switch -- $key {
+ samp.name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ return $name
+}
+
+# CallBacks
+# Hub
+
+proc SAMPRcvdEventShutdown {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdEventShutdown: $args"
+ }
+
+ SAMPShutdown
+}
+
+proc SAMPRcvdEventRegister {varname} {
+ upvar $varname args
+
+ global isamp
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdEventRegister: $args"
+ }
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ id {
+ # check to see if its just us
+ if {$samp(self) == $val} {
+ return
+ }
+ }
+ }
+ }
+ }
+
+ # wait
+ after $isamp(timeout) SAMPUpdate
+}
+
+proc SAMPRcvdEventUnregister {varname} {
+ upvar $varname args
+
+ global isamp
+ global samp
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdEventUnregister: $args"
+ }
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ id {
+ # check to see if its just us
+ if {$samp(self) == $val} {
+ return
+ }
+ }
+ }
+ }
+ }
+
+ # wait
+ after $isamp(timeout) SAMPUpdate
+}
+
+proc SAMPRcvdDisconnect {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDisconnect: $args"
+ }
+
+ set msg {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ reason {set msg [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ SAMPShutdown
+}
+
+# HTTPClient
+
+proc SAMPRcvdImageLoadFits {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdImageLoadFits: $args"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set imageid {}
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ image-id {set imageid [XMLUnQuote $val]}
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdImageLoadFits: $url $imageid $name"
+ }
+
+ if {$url != {}} {
+ MultiLoad
+ LoadURLFits $url {} {}
+ }
+}
+
+proc SAMPRcvdTableLoadFits {varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadFits: $args"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set imageid {}
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ image-id {set imageid [XMLUnQuote $val]}
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadFits: $url $imageid $name"
+ }
+
+ if {$url != {}} {
+ MultiLoad
+ LoadURLFits $url {} {}
+ }
+}
+
+proc SAMPRcvdTableLoadVotable {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadVotable: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set tabid {}
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ table-id {set tabid [XMLUnQuote $val]}
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableLoadVotable: $url $tabid $name"
+ }
+
+ global icat
+ if {$url != {}} {
+ CATVOTURL $url $name $tabid
+ if {$tabid != {}} {
+ set catid [lindex $icat(cats) end]
+ set samp(icat,$tabid) $catid
+ set samp(ocat,$catid) $tabid
+ }
+ }
+}
+
+proc SAMPRcvdTableHighlightRow {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableHighlightRow: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set tabid {}
+ set row {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ table-id {set tabid [XMLUnQuote $val]}
+ row {set row [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableHighlightRow: $url $tabid $row"
+ }
+
+ if {$tabid != {} && $row != {}} {
+ if {[info exists samp(icat,$tabid)]} {
+ CATSelectRows $samp(icat,$tabid) samp [expr $row+1]
+ }
+ }
+}
+
+proc SAMPRcvdTableSelectRowList {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableSelectRowList: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set tabid {}
+ set rowlist {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ table-id {set tabid [XMLUnQuote $val]}
+ row-list {
+ foreach rr [XMLUnQuote $val] {
+ lappend rowlist [expr $rr+1]
+ }
+ }
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdTableSelectRowList: $url $tabid $rowlist"
+ }
+
+ if {$tabid != {} && [llength $rowlist] != 0} {
+ if {[info exists samp(icat,$tabid)]} {
+ CATSelectRows $samp(icat,$tabid) samp $rowlist
+ }
+ }
+}
+
+proc SAMPRcvdCoordPointAtSky {varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdCoordPointAtSky: $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set ra {}
+ set dec {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ ra {set ra [XMLUnQuote $val]}
+ dec {set dec [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdCoordPointAtSky: $ra $dec"
+ }
+
+ global current
+ if {$ra != {} && $dec != {} && [$current(frame) has wcs equatorial wcs]} {
+ set samp(rcvd,lock) 1
+ PanTo $ra $dec wcs fk5
+ set samp(rcvd,lock) 0
+ }
+}
+
+proc SAMPRcvdClientEnvGet {msgid varname} {
+ upvar $varname args
+
+ global samp
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdClientEnvGet: $msgid $args"
+ }
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set name {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ name {set name [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdClientEnvGet: $name"
+ }
+
+ global env
+ if {[catch {set rr $env($name)}]} {
+ SAMPReply $msgid ERROR {} {} [lindex [split $errorInfo "\n"] 0]
+ global errorInfo
+ set errorInfo {}
+ } else {
+ SAMPReply $msgid OK $rr
+ }
+}
+
+proc SAMPRcvdDS9Set {msgid varname safemode} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9Set: $msgid $args $safemode"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set cmd {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ cmd {set cmd [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ set fn {}
+
+ InitError samp
+ if {$url != {}} {
+ set fn [tmpnam {.samp}]
+ GetFileURL $url fn
+ }
+ CommSet $fn $cmd $safemode
+ if {$msgid != {}} {
+ SAMPRcvdDS9SetReply $msgid
+ }
+}
+
+proc SAMPRcvdDS9SetReply {msgid} {
+ global ds9
+ global icursor
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9SetReply: $msgid"
+ }
+
+ global errorInfo
+ if {$errorInfo != {} || $ds9(msg) != {}} {
+ if {$ds9(msg) != {}} {
+ switch $ds9(msg,level) {
+ info -
+ warning {SAMPReply $msgid OK $ds9(msg)}
+ error -
+ fatal {SAMPReply $msgid ERROR {} {} $ds9(msg)}
+ }
+ } else {
+ SAMPReply $msgid ERROR {} {} [lindex [split $errorInfo "\n"] 0]
+ }
+ InitError samp
+ } else {
+ SAMPReply $msgid OK
+ }
+}
+
+proc SAMPRcvdDS9Get {msgid varname} {
+ upvar $varname args
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9Get: $args"
+ }
+
+ global current
+ global samp
+
+ # are we locked?
+ if {$samp(send,lock)} {
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMP: ABORT Send locked"
+ }
+ return
+ }
+
+ set url {}
+ set cmd {}
+
+ foreach arg $args {
+ foreach {key val} $arg {
+ switch -- $key {
+ url {set url [XMLUnQuote $val]}
+ cmd {set cmd [XMLUnQuote $val]}
+ }
+ }
+ }
+
+ set fn [tmpnam {.samp}]
+ InitError samp
+ CommGet SAMPRcvdDS9GetReply $msgid $cmd $fn
+}
+
+proc SAMPRcvdDS9GetReply {msgid msg {fn {}}} {
+ global ds9
+ global icursor
+
+ global debug
+ if {$debug(tcl,samp)} {
+ puts stderr "SAMPRcvdDS9GetReply: $msgid $msg $fn"
+ }
+
+ global errorInfo
+ if {$errorInfo != {} || $ds9(msg) != {}} {
+ if {$ds9(msg) != {}} {
+ switch $ds9(msg,level) {
+ info -
+ warning {SAMPReply $msgid OK $ds9(msg)}
+ error -
+ fatal {SAMPReply $msgid ERROR {} {} $ds9(msg)}
+ }
+ } else {
+ SAMPReply $msgid ERROR {} {} [lindex [split $errorInfo "\n"] 0]
+ }
+ InitError samp
+ } else {
+ # be sure to white space any newlines, backslashes, and trim
+ set value [string trim [string map {\n { } \\ {}} $msg]]
+
+ # create url
+ set url {}
+ if {$fn != {}} {
+ set url "file://localhost/$fn"
+ }
+
+ SAMPReply $msgid OK $value $url
+ }
+}
+
+proc SAMPDelTmpFiles {} {
+ global ds9
+
+ # delete any previous files
+ foreach fn [glob -directory $ds9(tmpdir) -nocomplain {ds9*samp*}] {
+ catch {file delete -force "$fn"}
+ }
+}
+
+# Cmds
+
+proc ProcessSAMPCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global samp
+ global ds9
+ global env
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ SAMPUpdate
+
+ switch -- [string tolower [lindex $var $i]] {
+ send {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ image {
+ incr i
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,image) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendImageLoadFits $key
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ table {
+ incr i
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,table) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendTableLoadFits $key
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ default {
+ set name [string tolower [lindex $var $i]]
+ if {[info exists samp]} {
+ foreach arg $samp(apps,image) {
+ foreach {key val} $arg {
+ if {[string tolower $val] == $name} {
+ SAMPSendImageLoadFits $key
+ break
+ }
+ }
+ }
+ } else {
+ Error [msgcat::mc {SAMP: not connected}]
+ }
+ }
+ }
+ }
+ broadcast {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ image {SAMPSendImageLoadFits {}}
+ table {SAMPSendTableLoadFits {}}
+ default {
+ incr i -1
+ SAMPSendImageLoadFits {}
+ }
+ }
+ }
+ connect {SAMPConnect}
+ disconnect {SAMPDisconnect}
+ default {
+ if {[FromYesNo [lindex $var $i]]} {
+ SAMPConnect
+ } else {
+ SAMPDisconnect
+ }
+ }
+ }
+}
diff --git a/ds9/library/sao.tcl b/ds9/library/sao.tcl
new file mode 100644
index 0000000..9724992
--- /dev/null
+++ b/ds9/library/sao.tcl
@@ -0,0 +1,158 @@
+# 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 SAODef {} {
+ global sao
+ global isao
+
+ set isao(top) .sao
+ set isao(mb) .saomb
+
+ set sao(sky) fk5
+ set sao(rformat) arcmin
+ set sao(width) 15
+ set sao(height) 15
+ set sao(mode) new
+ set sao(save) 0
+ set sao(survey) dss
+}
+
+proc SAODialog {} {
+ global sao
+ global isao
+ global wcs
+
+ if {[winfo exists $isao(top)]} {
+ raise $isao(top)
+ return
+ }
+
+ set varname dsao
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $isao(top)
+ set var(mb) $isao(mb)
+ set var(sky) $sao(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $sao(rformat)
+ set var(width) $sao(width)
+ set var(height) $sao(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(mode) $sao(mode)
+ set var(save) $sao(save)
+ set var(survey) $sao(survey)
+
+ set w $var(top)
+ IMGSVRInit $varname "SAO-DSS [msgcat::mc {Server}]" \
+ SAOExec SAOAck ARDone ARError
+
+ IMGSVRUpdate $varname
+}
+
+proc SAOExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set compress no
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set compress gzip
+ set var(fn) [tmpnam {.fits.gz}]
+ }
+
+ # skyformat
+ switch -- $var(skyformat) {
+ degrees {
+ set xx [uformat d h: $var(x)]
+ set yy [uformat d d: $var(y)]
+ }
+ sexagesimal {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ }
+
+ # size - convert to arcmin
+ switch -- $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcmin {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcsec {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ }
+ if {$ww>60} {
+ set ww 60
+ }
+ if {$hh>60} {
+ set hh 60
+ }
+
+ # query
+ set var(query) [http::formatQuery r $xx d $yy e J2000 w $ww h $ww c $compress]
+ set url "http://www.cfa.harvard.edu/archive/dss"
+ IMGSVRGetURL $varname $url
+}
+
+proc SAOAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the DSS-SAO
+
+The Digitized Sky Surveys were produced at the Space Telescope Science
+Institute under U.S. Government grant NAG W-2166. The images of these
+surveys are based on photographic data obtained using the Oschin
+Schmidt Telescope on Palomar Mountain and the UK Schmidt Telescope.
+The plates were processed into the present compressed digital form
+with the permission of these institutions.
+
+The Oschin Schmidt Telescope is operated by the California Institute
+of Technology and Palomar Observatory.
+
+The UK Schmidt Telescope was operated by the Royal Observatory
+Edinburgh, with funding from the UK Science and Engineering Research
+Council (later the UK Particle Physics and Astronomy Research Council),
+until 1988 June, and thereafter by the Anglo-Australian
+Observatory. The blue plates of the southern Sky Atlas and its
+Equatorial Extension (together known as the SERC-J), as well as the
+Equatorial Red (ER), and the Second Epoch [red] Survey (SES) were all
+taken with the UK Schmidt.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc ProcessSAOCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ SAODialog
+ IMGSVRProcessCmd $varname $iname dsao
+}
+
+proc ProcessSendSAOCmd {proc id param} {
+ SAODialog
+ IMGSVRProcessSendCmd $proc $id $param dsao
+}
+
diff --git a/ds9/library/save.tcl b/ds9/library/save.tcl
new file mode 100644
index 0000000..e4ec500
--- /dev/null
+++ b/ds9/library/save.tcl
@@ -0,0 +1,251 @@
+# 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 SaveDef {} {
+ global savefits
+
+ set savefits(type) image
+ set savefits(mosaic) 1
+}
+
+proc Save {format fn} {
+ global savefits
+
+ switch -- $format {
+ fits {SaveFitsFile $savefits(type) $fn}
+ sfits {}
+ rgbimage {SaveRGBImageFile $fn}
+ rgbcube {SaveRGBCubeFile $fn}
+ srgbcube {}
+ mecube {SaveMECubeFile $fn}
+ multiframe {}
+ mosaicimage -
+ mosaicimagewcs {SaveMosaicImageWCSFile $fn}
+ mosaicimageiraf {}
+ mosaicimagewfpc {}
+ mosaic -
+ mosaicwcs {SaveMosaicWCSFile $fn $savefits(mosaic)}
+ mosaiciraf {}
+ smosaicwcs {}
+ smosaiciraf {}
+ }
+}
+
+# Process Cmds
+
+proc ProcessSaveCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ set format {}
+ set fn [lindex $var $i]
+ if {$fn == {}} {
+ return
+ }
+
+ switch -- $fn {
+ fits -
+ sfits -
+ rgbimage -
+ rgbcube -
+ srgbcube -
+ mecube -
+ multiframe -
+ mosaicimagewcs -
+ mosaicimageiraf -
+ mosaicimagewfpc -
+ mosaicwcs -
+ mosaiciraf -
+ smosaicwcs -
+ smosaiciraf {
+ set format $fn
+ set fn {}
+ incr i
+ }
+ mosaicimage -
+ mosaic {
+ set format $fn
+ set fn {}
+ incr i
+
+ # eat any wcs
+ if {[string range [lindex $var $i] 0 2] == {wcs}} {
+ incr i
+ }
+ }
+ }
+
+ # one last time
+ if {$fn == {}} {
+ set fn [lindex $var $i]
+ if {$fn == {}} {
+ return
+ }
+ }
+
+ if {$format == {}} {
+ set format [ExtToFormat $fn]
+ }
+
+ global savefits
+ set param [string tolower [lindex $var [expr $i+1]]]
+ switch $format {
+ fits {
+ switch $param {
+ slice -
+ image -
+ table {
+ set savefits(type) $param
+ incr i
+ }
+ default {set savefits(type) image}
+ }
+ }
+ mosaic -
+ mosaiciraf -
+ mosaicwcs {
+ if {[string is integer -strict $param]} {
+ set savefits(mosaic) $param
+ incr i
+ }
+ }
+ }
+
+ global savefitsfbox
+ FileLast savefitsfbox $fn
+ Save $format $fn
+}
+
+# Support
+
+proc SaveDialog {format} {
+ global savefits
+ global current
+
+ set fn [SaveFileDialog savefitsfbox]
+
+ set which image
+ if {$fn != {}} {
+ set ok 1
+ if {$current(frame) != {}} {
+ switch -- $format {
+ fits {
+ if {[$current(frame) has fits bin]} {
+ set ok [SaveParams savefits]
+ }
+ }
+ slice {
+ set format fits
+ set savefits(type) slice
+ }
+ mosaicwcs -
+ mosaiciraf {
+ if {[$current(frame) has fits mosaic]} {
+ set ok [SaveMosaicParams savefits]
+ }
+ }
+ }
+ }
+
+ if {$ok} {
+ Save $format $fn
+ }
+ }
+}
+
+proc SaveParams {varname} {
+ upvar $varname var
+ global ed2
+ set w {.savefits}
+
+ set ed2(ok) 0
+ set ed2(type) $var(type)
+
+ DialogCreate $w {Fits} ed2(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.tfits -text [msgcat::mc {Fits}]
+ ttk::radiobutton $f.image -text [msgcat::mc {Image}] \
+ -variable ed2(type) -value image
+ ttk::radiobutton $f.table -text {Table} \
+ -variable ed2(type) -value table
+ grid $f.tfits $f.image $f.table -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ set var(type) $ed2(type)
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
+
+proc SaveMosaicParams {varname} {
+ upvar $varname var
+ global ed2
+ set w {.savefits}
+
+ set ed2(ok) 0
+ set ed2(mosaic) $var(mosaic)
+
+ DialogCreate $w {Mosaic} ed2(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ ttk::label $f.tmosaic -text [msgcat::mc {Mosaic}]
+ ttk::entry $f.mosaic -textvariable ed2(mosaic) -width 8
+ grid $f.tmosaic $f.mosaic -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed2(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed2(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed2(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed2(ok)
+ DialogDismiss $w
+
+ if {$ed2(ok)} {
+ set var(mosaic) $ed2(mosaic)
+ }
+
+ set rr $ed2(ok)
+ unset ed2
+ return $rr
+}
diff --git a/ds9/library/saveimage.tcl b/ds9/library/saveimage.tcl
new file mode 100644
index 0000000..4ddef37
--- /dev/null
+++ b/ds9/library/saveimage.tcl
@@ -0,0 +1,271 @@
+# 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 SaveImageDef {} {
+ global saveimage
+
+ set saveimage(jpeg,quality) 75
+ set saveimage(tiff,compress) none
+
+ set aa [msgcat::mc {An error has occurred while creating the image. Please be sure that the entire image window is visible on the screen.}]
+ set bb [msgcat::mc {An error has occurred while creating the image. Please be sure that the ds9 window is in the upper left corner of the default screen and the entire window is visible.}]
+ set cc [msgcat::mc {This function is not currently supported for this port.}]
+
+ global ds9
+ switch $ds9(wm) {
+ x11 {
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Darwin {
+ switch [lindex [split $tcl_platform(osVersion) {.}] 0] {
+ 10 -
+ 11 {set saveimage(error) $bb}
+ 8 -
+ 9 -
+ default {set saveimage(error) $aa}
+ }
+ }
+ default {set saveimage(error) $aa}
+ }
+ }
+ aqua -
+ win32 {set saveimage(error) $cc}
+ }
+}
+
+proc SaveImageDialog {format} {
+ global saveimage
+ global fitsfbox
+ global epsfbox
+ global giffbox
+ global jpegfbox
+ global tifffbox
+ global pngfbox
+
+ switch -- $format {
+ fits {set fn [SaveFileDialog fitsfbox]}
+ eps {set fn [SaveFileDialog epsfbox]}
+ gif {set fn [SaveFileDialog giffbox]}
+ jpeg {set fn [SaveFileDialog jpegfbox]}
+ tiff {set fn [SaveFileDialog tifffbox]}
+ png {set fn [SaveFileDialog pngfbox]}
+ }
+
+ if {$fn != {}} {
+ set ok 1
+ switch -- $format {
+ fits -
+ eps -
+ gif -
+ png {}
+ jpeg {set ok [JPEGExportDialog saveimage(jpeg,quality)]}
+ tiff {set ok [TIFFExportDialog saveimage(tiff,compress)]}
+ }
+
+ if {$ok} {
+ SaveImage $fn $format
+ }
+ }
+}
+
+proc SaveImage {fn format} {
+ global ds9
+ global current
+ global saveimage
+ global cube
+
+ if {$fn == {} || ![$current(frame) has fits]} {
+ return
+ }
+
+ # besure we are on top
+ raise $ds9(top)
+
+ # and no highlite
+ $current(frame) highlite off
+ # and refresh screen
+ RealizeDS9
+
+ switch -- $format {
+ fits {$current(frame) save fits resample file "\{$fn\}"}
+ eps {EPS $fn}
+ gif -
+ tiff -
+ jpeg -
+ png {SaveImagePhoto $fn $format}
+ }
+
+ # reset
+ switch -- $ds9(display) {
+ single -
+ blink {}
+ tile {$current(frame) highlite on}
+ }
+
+ # and refresh screen
+ RealizeDS9
+}
+
+# Support
+
+proc SaveImagePhoto {fn format} {
+ global ds9
+ global saveimage
+
+ switch $ds9(wm) {
+ x11 {}
+ aqua -
+ win32 {
+ Error $saveimage(error)
+ return
+ }
+ }
+
+ set rr [catch {image create photo -format window -data $ds9(canvas)} ph]
+ if {$rr != 0} {
+ Error $saveimage(error)
+ }
+
+ switch -- $format {
+ gif -
+ png {$ph write $fn -format $format}
+ jpeg {$ph write $fn \
+ -format [list $format -quality $saveimage(jpeg,quality)]}
+ tiff {$ph write $fn \
+ -format [list $format -compression $saveimage(tiff,compress)]}
+ }
+
+ image delete $ph
+}
+
+# Process Cmds
+
+proc ProcessSaveImageCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ # yes, really need this
+ # ProcessRealizeDS9
+ UpdateDS9
+ RealizeDS9
+
+ set format {}
+ set param {}
+ set fn [lindex $var $i]
+ if {$fn == {}} {
+ return
+ }
+
+ # backward compatibility
+ switch $fn {
+ fits -
+ eps -
+ gif -
+ tiff -
+ jpeg -
+ png {
+ set format $fn
+ set fn {}
+ incr i
+ }
+ jpg {
+ set format jpeg
+ set fn {}
+ incr i
+ }
+ tif {
+ set format tiff
+ set fn {}
+ incr i
+ }
+ mpeg {
+ # backward compatibility
+ global movie
+ incr i
+ set fn [lindex $var $i]
+ if {[string is integer -strict $fn]} {
+ incr i
+ set fn [lindex $var $i]
+ }
+ set movie(action) slice
+ Movie $fn
+ }
+ }
+
+ # try again
+ if {$fn == {}} {
+ set fn [lindex $var $i]
+ if {$fn == {}} {
+ return
+ }
+
+ if {[string is integer -strict $fn] ||
+ $fn == {none} || $fn == {jpeg} ||
+ $fn == {backbits} || $fn == {deflate}} {
+ set param $fn
+ set fn {}
+ incr i
+ }
+ }
+
+ # one last time
+ if {$fn == {}} {
+ set fn [lindex $var $i]
+ if {$fn == {}} {
+ return
+ }
+ }
+
+ global saveimage
+ if {$format == {}} {
+ set format [ExtToFormat $fn]
+ }
+
+ if {$param == {}} {
+ set param [string tolower [lindex $var [expr $i+1]]]
+ switch $format {
+ fits -
+ eps -
+ gif -
+ png {}
+ jpeg {
+ if {[string is integer -strict $param]} {
+ set saveimage(jpeg,quality) $param
+ incr i
+ }
+ }
+ tiff {
+ switch $param {
+ none -
+ jpeg -
+ packbits -
+ deflate {
+ set saveimage(tiff,compress) $param
+ incr i
+ }
+ }
+ }
+ }
+ }
+
+ global fitsfbox
+ global epsfbox
+ global giffbox
+ global jpegfbox
+ global tifffbox
+ global pngfbox
+ switch -- $format {
+ fits {FileLast fitsfbox $fn}
+ eps {FileLast epsfbox $fn}
+ gif {FileLast giffbox $fn}
+ jpeg {FileLast jpegfbox $fn}
+ tiff {FileLast tifffbox $fn}
+ png {FileLast pngfbox $fn}
+ }
+ SaveImage $fn $format
+}
+
diff --git a/ds9/library/scale.tcl b/ds9/library/scale.tcl
new file mode 100644
index 0000000..fa1c84e
--- /dev/null
+++ b/ds9/library/scale.tcl
@@ -0,0 +1,1053 @@
+# 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 ScaleDef {} {
+ global scale
+ global iscale
+ global pscale
+
+ set iscale(top) .scale
+ set iscale(mb) .scalemb
+
+ set scale(min) 1
+ set scale(max) 100
+ set scale(xaxis) full
+ set scale(yaxis) log
+ set scale(bins) 512
+
+ set scale(lock) 0
+ set scale(lock,limits) 0
+
+ set scale(type) linear
+ set scale(log) 1000
+ set scale(mode) minmax
+ set scale(scope) local
+ set scale(datasec) 1
+
+ set pscale(type) $scale(type)
+ set pscale(log) $scale(log)
+ set pscale(mode) $scale(mode)
+ set pscale(scope) $scale(scope)
+ set pscale(datasec) $scale(datasec)
+}
+
+proc MinMaxDef {} {
+ global minmax
+ global pminmax
+
+ set minmax(mode) scan
+ set minmax(sample) 25
+
+ array set pminmax [array get minmax]
+}
+
+proc ZScaleDef {} {
+ global zscale
+ global pzscale
+
+ set zscale(contrast) .25
+ set zscale(sample) 600
+ set zscale(line) 120
+
+ array set pzscale [array get zscale]
+}
+
+proc ChangeDATASEC {} {
+ global current
+ global scale
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) datasec $scale(datasec)]
+ UpdateScale
+ }
+}
+
+proc ChangeScale {} {
+ global current
+ global scale
+ global rgb
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has iis]} {
+ return {}
+ }
+
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) colorscale log $scale(log)]
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) colorscale $scale(type)]
+ ResetWatchCursor
+ UpdateScale
+ }
+}
+
+proc ChangeScaleMode {} {
+ global current
+ global scale
+ global rgb
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has iis]} {
+ return {}
+ }
+
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip mode $scale(mode)]
+ ResetWatchCursor
+ UpdateScale
+ }
+}
+
+proc ChangeScaleLimit {} {
+ global current
+ global scale
+ global rgb
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has iis]} {
+ return {}
+ }
+
+ set scale(mode) user
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip user $scale(min) $scale(max)]
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip mode $scale(mode)]
+ UpdateScale
+ }
+}
+
+proc ChangeScaleScope {} {
+ global current
+ global scale
+ global rgb
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has iis]} {
+ return {}
+ }
+
+ SetWatchCursor
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip scope $scale(scope)]
+ ResetWatchCursor
+ UpdateScale
+ }
+}
+
+proc ChangeMinMax {} {
+ global current
+ global minmax
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,scale) \
+ [list $current(frame) clip minmax $minmax(sample) $minmax(mode)]
+ UpdateScale
+ }
+}
+
+proc ChangeZScale {} {
+ global current
+ global zscale
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip zscale $zscale(contrast) $zscale(sample) $zscale(line)]
+ UpdateScale
+ }
+}
+
+proc UpdateScale {} {
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateScale"
+ }
+
+ LockScaleCurrent
+ LockScaleLimitsCurrent
+ UpdateScaleMenu
+ UpdateScaleDialog
+ UpdateContourScale
+ UpdateGraphYAxis $current(frame)
+ UpdateInfoBoxBase
+ UpdateMain
+}
+
+proc ScaleDialog {} {
+ global scale
+ global iscale
+ global dscale
+
+ global current
+ global ds9
+ global minmax
+ global canvas
+
+ # see if we already have a window visible
+
+ if {[winfo exists $iscale(top)]} {
+ raise $iscale(top)
+ return
+ }
+
+ # create the window
+ set w $iscale(top)
+ set mb $iscale(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Scale Parameters}] ScaleDestroyDialog
+
+ $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 {Scale}] -menu $mb.scale
+ $mb add cascade -label [msgcat::mc {Limits}] -menu $mb.limit
+ $mb add cascade -label [msgcat::mc {Scope}] -menu $mb.scope
+ $mb add cascade -label [msgcat::mc {Min Max}] -menu $mb.minmax
+ $mb add cascade -label [msgcat::mc {Parameters}] -menu $mb.param
+ $mb add cascade -label [msgcat::mc {Graph}] -menu $mb.graph
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command ScaleApplyDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command ScaleDestroyDialog
+
+ EditMenu $mb iscale
+
+ menu $mb.scale
+ $mb.scale add radiobutton -label [msgcat::mc {Linear}] \
+ -variable scale(type) -command ChangeScale -value linear
+ $mb.scale add radiobutton -label [msgcat::mc {Log}] \
+ -variable scale(type) -command ChangeScale -value log
+ $mb.scale add radiobutton -label [msgcat::mc {Power}] \
+ -variable scale(type) -command ChangeScale -value pow
+ $mb.scale add radiobutton -label [msgcat::mc {Square Root}] \
+ -variable scale(type) -command ChangeScale -value sqrt
+ $mb.scale add radiobutton -label [msgcat::mc {Squared}] \
+ -variable scale(type) -command ChangeScale -value squared
+ $mb.scale add radiobutton -label {ASINH} \
+ -variable scale(type) -command ChangeScale -value asinh
+ $mb.scale add radiobutton -label {SINH} \
+ -variable scale(type) -command ChangeScale -value sinh
+ $mb.scale add radiobutton -label [msgcat::mc {Histogram Equalization}] \
+ -variable scale(type) -command ChangeScale -value histequ
+ $mb.scale add separator
+ $mb.scale add command -label "[msgcat::mc {Log Exponent}]..." \
+ -command ScaleLogDialog
+
+ menu $mb.limit
+ $mb.limit add radiobutton -label [msgcat::mc {Min Max}] \
+ -variable scale(mode) -command ChangeScaleMode -value minmax
+ $mb.limit add separator
+ $mb.limit add radiobutton -label {99.5%} \
+ -variable scale(mode) -command ChangeScaleMode -value 99.5
+ $mb.limit add radiobutton -label {99%} \
+ -variable scale(mode) -command ChangeScaleMode -value 99
+ $mb.limit add radiobutton -label {98%} \
+ -variable scale(mode) -command ChangeScaleMode -value 98
+ $mb.limit add radiobutton -label {97%} \
+ -variable scale(mode) -command ChangeScaleMode -value 97
+ $mb.limit add radiobutton -label {96%} \
+ -variable scale(mode) -command ChangeScaleMode -value 96
+ $mb.limit add radiobutton -label {95%} \
+ -variable scale(mode) -command ChangeScaleMode -value 95
+ $mb.limit add radiobutton -label {92.5%} \
+ -variable scale(mode) -command ChangeScaleMode -value 92.5
+ $mb.limit add radiobutton -label {90%} \
+ -variable scale(mode) -command ChangeScaleMode -value 90
+ $mb.limit add separator
+ $mb.limit add radiobutton -label {ZScale} \
+ -variable scale(mode) -command ChangeScaleMode -value zscale
+ $mb.limit add radiobutton -label {ZMax} \
+ -variable scale(mode) -command ChangeScaleMode -value zmax
+ $mb.limit add radiobutton -label [msgcat::mc {User}] \
+ -variable scale(mode) -command ChangeScaleMode -value user
+
+ menu $mb.scope
+ $mb.scope add radiobutton -label [msgcat::mc {Global}] \
+ -variable scale(scope) -command ChangeScaleScope -value global
+ $mb.scope add radiobutton -label [msgcat::mc {Local}] \
+ -variable scale(scope) -command ChangeScaleScope -value local
+
+ menu $mb.minmax
+ $mb.minmax add radiobutton -label [msgcat::mc {Scan}] \
+ -variable minmax(mode) -value scan -command ChangeMinMax
+ $mb.minmax add radiobutton -label [msgcat::mc {Sample}] \
+ -variable minmax(mode) -value sample -command ChangeMinMax
+ $mb.minmax add radiobutton -label {DATAMIN DATAMAX} \
+ -variable minmax(mode) -value datamin -command ChangeMinMax
+ $mb.minmax add radiobutton -label {IRAF-MIN IRAF-MAX} \
+ -variable minmax(mode) -value irafmin -command ChangeMinMax
+ $mb.minmax add separator
+ $mb.minmax add command -label "[msgcat::mc {Sample Parameters}]..." \
+ -command MinMaxDialog
+
+ menu $mb.param
+ $mb.param add checkbutton -label "[msgcat::mc {Use}] DATASEC" \
+ -variable scale(datasec) -command ChangeDATASEC
+ $mb.param add separator
+ $mb.param add command -label {ZScale...} -command ZScaleDialog
+
+ menu $mb.graph
+ $mb.graph add radiobutton -label [msgcat::mc {Linear}] \
+ -value linear -variable scale(yaxis) -command ScaleYAxisDialog
+ $mb.graph add radiobutton -label [msgcat::mc {Log}] \
+ -value log -variable scale(yaxis) -command ScaleYAxisDialog
+ $mb.graph add separator
+ $mb.graph add radiobutton -label [msgcat::mc {Full Range}] \
+ -value full -variable scale(xaxis) -command ScaleXAxisDialog
+ $mb.graph add radiobutton -label [msgcat::mc {Current Range}] \
+ -value current -variable scale(xaxis) -command ScaleXAxisDialog
+
+ # Param
+ set f [ttk::frame $w.param]
+
+ # Graph
+ set dscale(hist) [blt::graph $f.chart \
+ -width 500 \
+ -height 200 \
+ -title [msgcat::mc {Pixel Distribution}] \
+ -font [font actual TkDefaultFont] \
+ -plotrelief groove \
+ -plotborderwidth 2 \
+ ]
+
+ $dscale(hist) legend configure -hide yes
+ $dscale(hist) xaxis configure -hide yes -grid no -ticklength 3 \
+ -tickfont [font actual TkDefaultFont]
+ $dscale(hist) yaxis configure -hide yes -grid yes -ticklength 3 \
+ -tickfont [font actual TkDefaultFont]
+ set dscale(xdata) histX
+ set dscale(ydata) histY
+ blt::vector create $dscale(xdata) $dscale(ydata)
+ $dscale(hist) element create bar1 -smooth step -areabackground black \
+ -xdata $dscale(xdata) -ydata $dscale(ydata)
+
+ # Cut Lines
+ $dscale(hist) marker bind min <B1-Motion> \
+ [list ScaleMotionDialog %x %y dscale(min)]
+ $dscale(hist) marker bind max <B1-Motion> \
+ [list ScaleMotionDialog %x %y dscale(max)]
+ $dscale(hist) marker bind up <ButtonRelease-1> ScaleReleaseDialog
+
+ set dscale(histmin) [$dscale(hist) marker create line -element bar1 \
+ -outline red -bindtags [list min up]]
+ set dscale(histmax) [$dscale(hist) marker create line -element bar1 \
+ -outline green -bindtags [list max up]]
+
+ # Cut Levels
+ ttk::label $f.title -text [msgcat::mc {Limits}]
+ ttk::label $f.ltitle -text [msgcat::mc {Low}]
+ ttk::entry $f.lvalue -textvariable dscale(min) -width 13
+ ttk::label $f.htitle -text [msgcat::mc {High}]
+ ttk::entry $f.hvalue -textvariable dscale(max) -width 13
+
+ pack $dscale(hist) -fill both -expand true
+ pack $f.title $f.ltitle $f.lvalue $f.htitle $f.hvalue \
+ -side left -padx 2 -pady 2
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command ScaleApplyDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command ScaleDestroyDialog
+ pack $f.apply $f.close -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
+
+ UpdateScaleDialog
+}
+
+proc ScaleApplyDialog {} {
+ global scale
+ global dscale
+ global current
+ global rgb
+
+ if {$current(frame) != {} &&
+ $dscale(min) != {} &&
+ $dscale(max) != {}} {
+ $dscale(hist) marker configure $dscale(histmin) \
+ -coords "$dscale(min) -Inf $dscale(min) Inf"
+ $dscale(hist) marker configure $dscale(histmax) \
+ -coords "$dscale(max) -Inf $dscale(max) Inf"
+
+ set scale(min) $dscale(min)
+ set scale(max) $dscale(max)
+
+ set scale(mode) user
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip user $scale(min) $scale(max)]
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip mode $scale(mode)]
+ UpdateScale
+ }
+}
+
+proc ScaleDestroyDialog {} {
+ global scale
+ global iscale
+ global dscale
+
+ if {[winfo exists $iscale(top)]} {
+ destroy $iscale(top)
+ destroy $iscale(mb)
+ }
+
+ blt::vector destroy $dscale(xdata) $dscale(ydata)
+ unset dscale
+}
+
+proc ScaleMotionDialog {x y varname} {
+ upvar $varname var
+ global scale
+ global dscale
+
+ set var [lindex [$dscale(hist) invtransform $x $y] 0]
+ if {$dscale(min) > $dscale(max)} {
+ if {$varname == "dscale(min)"} {
+ set var $dscale(max)
+ } else {
+ set var $dscale(min)
+ }
+ }
+
+ $dscale(hist) marker configure $dscale(histmin) \
+ -coords "$dscale(min) -Inf $dscale(min) Inf"
+ $dscale(hist) marker configure $dscale(histmax) \
+ -coords "$dscale(max) -Inf $dscale(max) Inf"
+}
+
+proc ScaleReleaseDialog {} {
+ global scale
+ global dscale
+ global current
+ global rgb
+
+ if {$current(frame) != {} &&
+ $dscale(min) != {} &&
+ $dscale(max) != {}} {
+
+ set scale(min) $dscale(min)
+ set scale(max) $dscale(max)
+
+ set scale(mode) user
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip user $scale(min) $scale(max)]
+ RGBEvalLockCurrent rgb(lock,scale) [list $current(frame) clip mode $scale(mode)]
+
+ UpdateScale
+ ScaleXAxisDialog
+ }
+}
+
+proc UpdateScaleDialog {} {
+ global scale
+ global iscale
+ global dscale
+
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateScaleDialog"
+ }
+
+ if {![winfo exists $iscale(top)]} {
+ return
+ }
+
+ set dscale(min) {}
+ set dscale(max) {}
+
+ if {$current(frame) != {}} {
+ set limits [$current(frame) get clip]
+
+ set dscale(min) [lindex $limits 0]
+ set dscale(max) [lindex $limits 1]
+
+ # "nan" will not pass
+ if {[$current(frame) has fits] && ![$current(frame) has iis] &&
+ ($dscale(min)<$dscale(max))} {
+
+ set limits [$current(frame) get minmax]
+
+ set dscale(minmin) [lindex $limits 0]
+ set dscale(minmax) [lindex $limits 1]
+
+ SetWatchCursor
+ $current(frame) get histogram \
+ $dscale(xdata) $dscale(ydata) $scale(bins)
+ ResetWatchCursor
+
+ # we seem to need to do this so that the min/max values are known
+ blt::vector expr min($dscale(ydata))
+ blt::vector expr max($dscale(ydata))
+
+ $dscale(hist) element configure bar1 -hide no
+
+ $dscale(hist) xaxis configure -hide no
+ $dscale(hist) yaxis configure -hide no -min 1
+
+ $dscale(hist) marker configure $dscale(histmin) \
+ -coords "$dscale(min) -Inf $dscale(min) Inf"
+ $dscale(hist) marker configure $dscale(histmax) \
+ -coords "$dscale(max) -Inf $dscale(max) Inf"
+
+ if {[$current(frame) has datamin]} {
+ $iscale(mb).minmax \
+ entryconfig {DATAMIN DATAMAX} -state normal
+ } else {
+ $iscale(mb).minmax \
+ entryconfig {DATAMIN DATAMAX} -state disabled
+ }
+ if {[$current(frame) has irafmin]} {
+ $iscale(mb).minmax \
+ entryconfig {IRAF-MIN IRAF-MAX} -state normal
+ } else {
+ $iscale(mb).minmax \
+ entryconfig {IRAF-MIN IRAF-MAX} -state disabled
+ }
+
+ ScaleYAxisDialog
+ ScaleXAxisDialog
+
+ return
+ }
+ }
+
+ $dscale(hist) element configure bar1 -hide yes
+ $dscale(hist) xaxis configure -hide yes
+ $dscale(hist) yaxis configure -hide yes
+
+ $iscale(mb) entryconfig [msgcat::mc {Scope}] -state normal
+ $iscale(mb).minmax entryconfig {DATAMIN DATAMAX} -state normal
+ $iscale(mb).minmax entryconfig {IRAF-MIN IRAF-MAX} -state normal
+}
+
+proc UpdateScaleDialogFont {} {
+ global iscale
+ global dscale
+
+ if {![winfo exists $iscale(top)]} {
+ return
+ }
+
+ $dscale(hist) configure -font [font actual TkDefaultFont]
+ $dscale(hist) xaxis configure -tickfont [font actual TkDefaultFont]
+ $dscale(hist) yaxis configure -tickfont [font actual TkDefaultFont]
+}
+
+proc ScaleYAxisDialog {} {
+ global scale
+ global dscale
+
+ switch -- $scale(yaxis) {
+ linear {$dscale(hist) yaxis configure -logscale 0 -min 0}
+ log {$dscale(hist) yaxis configure -logscale 1 -min 1}
+ }
+}
+
+proc ScaleXAxisDialog {} {
+ global scale
+ global dscale
+
+ switch -- $scale(xaxis) {
+ full {
+ set width [expr abs(1.0*($dscale(minmax)-$dscale(minmin))/ \
+ [$dscale(xdata) length])]
+
+ $dscale(hist) xaxis configure \
+ -min [expr $dscale(minmin)-$width] \
+ -max [expr $dscale(minmax)+$width]
+ }
+ current {
+ set width [expr abs(1.0*($dscale(max)-$dscale(min))/ \
+ [$dscale(xdata) length])]
+
+ if {[expr abs($dscale(max)-$dscale(min)) > 0]} {
+ set diff [expr $dscale(max)-$dscale(min)]
+ set per .10
+ set a [expr $dscale(min)-($diff*$per)]
+ set b [expr $dscale(max)+($diff*$per)]
+ $dscale(hist) xaxis configure -min $a -max $b
+ }
+ }
+ }
+}
+
+proc ScaleLogDialog {} {
+ global scale
+
+ if {[EntryDialog [msgcat::mc {Scale}] [msgcat::mc {Log Exponent}] 10 scale(log)]} {
+ ChangeScale
+ }
+}
+
+proc MinMaxDialog {} {
+ global minmax
+ global ed
+
+ set w {.sample}
+
+ set ed(ok) 0
+ set ed(sample) $minmax(sample)
+
+ DialogCreate $w [msgcat::mc {Sample Parameters}] ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ slider $f.ssample 0 100 [msgcat::mc {Sample Increment}] ed(sample) {}
+ grid $f.ssample -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ if {$ed(sample) == 0} {
+ set ed(sample) 1
+ }
+ set minmax(sample) $ed(sample)
+ ChangeMinMax
+ }
+
+ unset ed
+}
+
+proc ZScaleDialog {} {
+ global zscale
+ global ed
+
+ set w {.zscale}
+
+ set ed(ok) 0
+ array set ed [array get zscale]
+
+ DialogCreate $w "ZScale [msgcat::mc {Parameters}]" ed(ok)
+
+ # Param
+ set f [ttk::frame $w.param]
+ slider $f.scontrast 0. 1. [msgcat::mc {Contrast}] ed(contrast) {}
+ slider $f.ssize 0 1000 [msgcat::mc {Number of Samples}] ed(sample) {}
+ slider $f.sline 0 500 [msgcat::mc {Samples per Line}] ed(line) {}
+
+ grid $f.scontrast -padx 2 -pady 2 -sticky ew
+ grid $f.ssize -padx 2 -pady 2 -sticky ew
+ grid $f.sline -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ ttk::button $f.cancel -text [msgcat::mc {Cancel}] -command {set ed(ok) 0}
+ pack $f.ok $f.cancel -side left -expand true -padx 2 -pady 4
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ if {$ed(ok)} {
+ if {$ed(line) == 0} {
+ set ed(line) 1
+ }
+ array set zscale [array get ed]
+ ChangeZScale
+ }
+
+ unset ed
+}
+
+proc MatchScaleCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchScale $current(frame)
+ }
+}
+
+proc MatchScaleLimitsCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchScaleLimits $current(frame)
+ }
+}
+
+proc MatchScale {which} {
+ global ds9
+ global rgb
+ global scale
+
+ set type [$which get colorscale]
+ set log [$which get colorscale log]
+ set limits [$which get clip]
+ set mode [$which get clip mode]
+ set scope [$which get clip scope]
+ set mmsample [$which get clip minmax sample]
+ set mmmode [$which get clip minmax mode]
+ set zscontrast [$which get clip zscale contrast]
+ set zssample [$which get clip zscale sample]
+ set zsline [$which get clip zscale line]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,scale) $ff [list $ff colorscale $type]
+ RGBEvalLock rgb(lock,scale) $ff [list $ff colorscale log $log]
+ RGBEvalLock rgb(lock,scale) $ff [list $ff clip user $limits]
+ RGBEvalLock rgb(lock,scale) $ff [list $ff clip mode $mode]
+ RGBEvalLock rgb(lock,scale) $ff [list $ff clip scope $scope]
+ RGBEvalLock rgb(lock,scale) $ff \
+ [list $ff clip minmax $mmsample $mmmode]
+ RGBEvalLock rgb(lock,scale) $ff \
+ [list $ff clip zscale $zscontrast $zssample $zsline]
+ }
+ }
+}
+
+proc MatchScaleLimits {which} {
+ global ds9
+ global rgb
+ global scale
+
+ set limits [$which get clip]
+ set mode user
+ set type [$which get colorscale]
+ set log [$which get colorscale log]
+ set scope [$which get clip scope]
+ set mmmode [$which get clip minmax mode]
+ set mmsample [$which get clip minmax sample]
+ set zscontrast [$which get clip zscale contrast]
+ set zssample [$which get clip zscale sample]
+ set zsline [$which get clip zscale line]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ RGBEvalLock rgb(lock,scalelimits) $ff [list $ff colorscale $type]
+ RGBEvalLock rgb(lock,scalelimits) $ff [list $ff colorscale log $log]
+ RGBEvalLock rgb(lock,scalelimits) $ff [list $ff clip user $limits]
+ RGBEvalLock rgb(lock,scalelimits) $ff [list $ff clip mode $mode]
+ RGBEvalLock rgb(lock,scalelimits) $ff [list $ff clip scope $scope]
+ RGBEvalLock rgb(lock,scalelimits) $ff \
+ [list $ff clip minmax $mmsample $mmmode]
+ RGBEvalLock rgb(lock,scalelimits) $ff \
+ [list $ff clip zscale $zscontrast $zssample $zsline]
+ }
+ }
+}
+
+proc LockScaleCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockScale $current(frame)
+ }
+}
+
+proc LockScaleLimitsCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockScaleLimits $current(frame)
+ }
+}
+
+proc LockScale {which} {
+ global scale
+
+ if {$scale(lock)} {
+ MatchScale $which
+ }
+}
+
+proc LockScaleLimits {which} {
+ global scale
+
+ if {$scale(lock,limits)} {
+ MatchScaleLimits $which
+ }
+}
+
+proc ScaleBackup {ch which} {
+ switch -- [$which get type] {
+ base -
+ 3d {ScaleBackupBase $ch $which}
+ rgb {ScaleBackupRGB $ch $which}
+ }
+}
+
+proc ScaleBackupBase {ch which} {
+ puts $ch "$which colorscale [$which get colorscale]"
+ puts $ch "$which colorscale log [$which get colorscale log]"
+ puts $ch "$which datasec [$which get datasec]"
+ puts $ch "$which clip user [$which get clip]"
+ puts $ch "$which clip mode [$which get clip mode]"
+ puts $ch "$which clip scope [$which get clip scope]"
+ puts $ch "$which clip minmax mode [$which get clip minmax mode]"
+ puts $ch "$which clip minmax sample [$which get clip minmax sample]"
+ puts $ch "$which clip zscale contrast [$which get clip zscale contrast]"
+ puts $ch "$which clip zscale sample [$which get clip zscale sample]"
+ puts $ch "$which clip zscale line [$which get clip zscale line]"
+}
+
+proc ScaleBackupRGB {ch which} {
+ set sav [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ puts $ch "$which rgb channel $cc"
+ ScaleBackupBase $ch $which
+ }
+ $which rgb channel $sav
+ puts $ch "$which rgb channel $sav"
+}
+
+# Process Cmds
+
+proc ProcessScaleCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global scale
+
+ switch -- [string tolower [lindex $var $i]] {
+ match {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ limits -
+ scalelimits {
+ MatchScaleLimitsCurrent
+ }
+ default {
+ incr i -1
+ MatchScaleCurrent
+ }
+ }
+ }
+ lock {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ limits -
+ scalelimits {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set scale(lock,limits) [FromYesNo [lindex $var $i]]
+ } else {
+ set scale(lock,limits) 1
+ incr i -1
+ }
+ LockScaleLimitsCurrent
+ }
+ default {
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set scale(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set scale(lock) 1
+ incr i -1
+ }
+ LockScaleCurrent
+ }
+ }
+ }
+ open {ScaleDialog}
+ close {ScaleDestroyDialog}
+ linear -
+ pow -
+ sqrt -
+ squared -
+ asinh -
+ sinh -
+ histequ {
+ set scale(type) [string tolower [lindex $var $i]]
+ ChangeScale
+ }
+ log {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ exp {
+ incr i
+ set scale(log) [string tolower [lindex $var $i]]
+ ChangeScale
+ }
+ default {
+ incr i -1
+ set scale(type) [string tolower [lindex $var $i]]
+ ChangeScale
+ }
+ }
+ }
+ datasec {
+ incr i
+ set scale(datasec) [FromYesNo [lindex $var $i]]
+ ChangeDATASEC
+ }
+ limits -
+ scalelimits {
+ incr i
+ set scale(min) [lindex $var $i]
+ incr i
+ set scale(max) [lindex $var $i]
+ ChangeScaleLimit
+ }
+ minmax -
+ zscale -
+ zmax -
+ user {
+ set scale(mode) [string tolower [lindex $var $i]]
+ ChangeScaleMode
+ }
+ mode {
+ incr i
+ set scale(mode) [string tolower [lindex $var $i]]
+ ChangeScaleMode
+ }
+ local -
+ global {
+ set scale(scope) [string tolower [lindex $var $i]]
+ ChangeScaleScope
+ }
+ scope {
+ incr i
+ set scale(scope) [string tolower [lindex $var $i]]
+ ChangeScaleScope
+ }
+ }
+}
+
+proc ProcessSendScaleCmd {proc id param} {
+ global current
+ global scale
+
+ switch -- [string tolower $param] {
+ lock {$proc $id [ToYesNo $scale(lock)]}
+ {lock limits} {$proc $id [ToYesNo $scale(lock,limits)]}
+ datasec {$proc $id "$scale(datasec)\n"}
+ limits {
+ if {$current(frame) != {}} {
+ set lims [$current(frame) get clip]
+ $proc $id "[lindex $lims 0] [lindex $lims 1]\n"
+ }
+ }
+ mode {$proc $id "$scale(mode)\n"}
+ scope {$proc $id "$scale(scope)\n"}
+ log -
+ {log exp} {$proc $id "$scale(log)\n"}
+ default {$proc $id "$scale(type)\n"}
+ }
+}
+
+proc ProcessMinMaxCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global minmax
+ global scale
+
+ switch -- [string tolower [lindex $var $i]] {
+ auto {
+ # backward compatibility
+ set minmax(mode) scan
+ ChangeMinMax
+ }
+ scan -
+ sample -
+ datamin -
+ irafmin {
+ set minmax(mode) [string tolower [lindex $var $i]]
+ ChangeMinMax
+ }
+ mode {
+ incr i
+ set minmax(mode) [string tolower [lindex $var $i]]
+ ChangeMinMax
+ }
+ interval {
+ incr i
+ set minmax(sample) [lindex $var $i]
+ ChangeMinMax
+ }
+ default {
+ # for backward compatibility
+ set scale(mode) minmax
+ ChangeScaleMode
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendMinMaxCmd {proc id param} {
+ global minmax
+
+ switch -- [string tolower $param] {
+ mode {$proc $id "$minmax(mode)\n"}
+ interval {$proc $id "$minmax(sample)\n"}
+ default {
+ # for backward compatibility
+ $proc $id "$minmax(mode)\n"
+ }
+ }
+}
+
+proc ProcessZScaleCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global zscale
+ global scale
+
+ switch -- [string tolower [lindex $var $i]] {
+ contrast {
+ incr i
+ set zscale(contrast) [lindex $var $i]
+ ChangeZScale
+ }
+ sample {
+ incr i
+ set zscale(sample) [lindex $var $i]
+ ChangeZScale
+ }
+ line {
+ incr i
+ set zscale(line) [lindex $var $i]
+ ChangeZScale
+ }
+ default {
+ # for backward compatibility
+ set scale(mode) zscale
+ ChangeScaleMode
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendZScaleCmd {proc id param} {
+ global zscale
+
+ switch -- [string tolower $param] {
+ contrast {$proc $id "$zscale(contrast)\n"}
+ sample {$proc $id "$zscale(sample)\n"}
+ line {$proc $id "$zscale(line)\n"}
+ }
+}
diff --git a/ds9/library/segment.tcl b/ds9/library/segment.tcl
new file mode 100644
index 0000000..eb1ba95
--- /dev/null
+++ b/ds9/library/segment.tcl
@@ -0,0 +1,74 @@
+# 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 SegmentDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # procs
+ set var(proc,apply) SegmentApply
+ set var(proc,close) SegmentClose
+ set var(proc,coordCB) SegmentCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # init
+ MarkerBaseCenterRotateCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback rotate MarkerBaseCenterRotateCB $varname
+
+ set f $var(top).param
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc SegmentClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc SegmentApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseCenterRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+# callbacks
+
+proc SegmentCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "SegmentCoordCB"
+ }
+
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
diff --git a/ds9/library/sfits.tcl b/ds9/library/sfits.tcl
new file mode 100644
index 0000000..9339ca9
--- /dev/null
+++ b/ds9/library/sfits.tcl
@@ -0,0 +1,64 @@
+# 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 LoadSFitsFile {hdr fn layer mode} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) smmap
+ set loadParam(file,name) $fn
+ set loadParam(file,header) $hdr
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc ProcessSFitsCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+ set mode {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ set mode slice
+ }
+ }
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {0} {
+ # not supported
+ } else {
+ LoadSFitsFile [lindex $var $i] [lindex $var [expr $i+1]] \
+ $layer $mode
+ }
+ } else {
+ # comm
+ if {0} {
+ # not supported
+ } else {
+ LoadSFitsFile [lindex $var $i] [lindex $var [expr $i+1]] \
+ $layer $mode
+ }
+ }
+ FinishLoad
+}
diff --git a/ds9/library/shm.tcl b/ds9/library/shm.tcl
new file mode 100644
index 0000000..c75c0de
--- /dev/null
+++ b/ds9/library/shm.tcl
@@ -0,0 +1,251 @@
+# 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 ProcessShmCmd {varname iname ml} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+ global ds9
+
+ StartLoad
+ set done 0
+ while {!$done} {
+
+ # defaults
+ set loadParam(load,type) shared
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {}
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ set nn [lindex $var [expr $i+4]]
+ if {$nn == {} || [string range $nn 0 0] == "-"} {
+ set def 1
+ } else {
+ set def 0
+ }
+
+ switch -- [lindex $var $i] {
+ key -
+ shmid {
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(shared,idtype) [lindex $var $i]
+ set loadParam(shared,id) [lindex $var [expr $i+1]]
+ set loadParam(file,name) [lindex $var [expr $i+2]]
+ incr i 2
+ }
+
+ fits {
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ sfits {
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(load,type) sshared
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,hdr) [lindex $var [expr $i+2]]
+ set loadParam(shared,id) [lindex $var [expr $i+3]]
+ set loadParam(file,name) [lindex $var [expr $i+4]]
+ incr i 4
+ }
+
+ mosaicimage {
+ if {$ml} {
+ MultiLoad
+ }
+ if {$def} {
+ set loadParam(file,mode) {mosaic image iraf}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ } else {
+ set loadParam(file,mode) \
+ [list mosaic image [lindex $var [expr $i+1]]]
+ set loadParam(shared,idtype) [lindex $var [expr $i+2]]
+ set loadParam(shared,id) [lindex $var [expr $i+3]]
+ set loadParam(file,name) [lindex $var [expr $i+4]]
+ incr i 4
+ }
+ }
+ mosaic {
+ if {$def} {
+ set loadParam(file,mode) {mosaic iraf}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ } else {
+ set loadParam(file,mode) \
+ [list mosaic [lindex $var [expr $i+1]]]
+ set loadParam(shared,idtype) [lindex $var [expr $i+2]]
+ set loadParam(shared,id) [lindex $var [expr $i+3]]
+ set loadParam(file,name) [lindex $var [expr $i+4]]
+ incr i 4
+ }
+ }
+ smosaic {
+ set loadParam(load,type) sshared
+ set loadParam(file,mode) \
+ [list mosaic [lindex $var [expr $i+1]]]
+ set loadParam(shared,idtype) [lindex $var [expr $i+2]]
+ set loadParam(shared,hdr) [lindex $var [expr $i+3]]
+ set loadParam(shared,id) [lindex $var [expr $i+4]]
+ set loadParam(file,name) [lindex $var [expr $i+5]]
+ incr i 5
+ }
+
+ mosaicimageiraf {
+ # backward compatibility
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(file,mode) {mosaic image iraf}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ mosaiciraf {
+ # backward compatibility
+ set loadParam(file,mode) {mosaic iraf}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ mosaicimagewcs {
+ # backward compatibility
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(file,mode) {mosaic image wcs}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ mosaicwcs {
+ # backward compatibility
+ set loadParam(file,mode) {mosaic wcs}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ mosaicimagewfpc2 {
+ # backward compatibility
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(file,mode) {mosaic image wfpc2}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+
+ rgbcube {
+ if {$ml} {
+ CreateRGBFrame
+ }
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ srgbcube {
+ if {$ml} {
+ CreateRGBFrame
+ }
+ set loadParam(load,type) sshared
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,hdr) [lindex $var [expr $i+2]]
+ set loadParam(shared,id) [lindex $var [expr $i+3]]
+ set loadParam(file,name) [lindex $var [expr $i+4]]
+ incr i 4
+ }
+ rgbimage {
+ if {$ml} {
+ CreateRGBFrame
+ }
+ set loadParam(file,mode) {rgb image}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ rgbarray {
+ if {$ml} {
+ CreateRGBFrame
+ }
+ set loadParam(file,type) array
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+ array {
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(file,type) array
+ set loadParam(shared,idtype) [lindex $var [expr $i+1]]
+ set loadParam(shared,id) [lindex $var [expr $i+2]]
+ set loadParam(file,name) [lindex $var [expr $i+3]]
+ incr i 3
+ }
+
+ default {
+ if {$ml} {
+ MultiLoad
+ }
+ set loadParam(shared,idtype) key
+ set loadParam(shared,id) [lindex $var $i]
+ set loadParam(file,name) [lindex $var [expr $i+1]]
+ incr i 1
+ }
+ }
+
+ ProcessLoad
+
+ # more to come?
+ incr i
+ if {([lindex $var $i] == "-shm") ||
+ ([lindex $var $i] == "shm")} {
+ set done 0
+ incr i
+ } else {
+ set done 1
+ incr i -1
+ }
+ }
+ FinishLoad
+}
+
+proc ProcessSendShmCmd {proc id param} {
+ global current
+
+ if {$current(frame) != {}} {
+ $proc $id "[$current(frame) get fits file name full]\n"
+ }
+}
+
diff --git a/ds9/library/sia.tcl b/ds9/library/sia.tcl
new file mode 100644
index 0000000..d992ccb
--- /dev/null
+++ b/ds9/library/sia.tcl
@@ -0,0 +1,499 @@
+# 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 SIADef {} {
+ global sia
+ global isia
+ global psia
+ global wcs
+
+ set isia(sias) {}
+
+ set isia(rformat) arcmin
+ set isia(width) 15
+ set isia(height) 15
+
+ set isia(minrows) 20
+ set isia(mincols) 10
+
+ set isia(mode) new
+ set isia(save) 0
+
+ set isia(def) { \
+ {{2MASS (NASA/IPAC)} \
+ sia2mass \
+ {http://irsa.ipac.caltech.edu/cgi-bin/2MASS/IM/nph-im_sia}\
+ {} \
+ post \
+ } \
+ {{AKARI (ISAS/JAXA)} \
+ siaakari \
+ {http://jvo.nao.ac.jp/skynode/do/siap/akari/fis_image_v1/1.0}\
+ {} \
+ post \
+ } \
+ {{Astro-Wise} \
+ siaastrowise \
+ {http://vo.astro-wise.org/SIAP}\
+ {VERB=2&FORM=VOTable&PROJECT=ALL&INSTRUMENT=ALL&} \
+ post \
+ } \
+ {{CADC} \
+ siacadc \
+ {http://www1.cadc-ccda.hia-iha.nrc-cnrc.gc.ca/sia/query}\
+ {} \
+ post \
+ } \
+ {{Chandra (NASA/CXC)} \
+ siacxc \
+ {http://cda.harvard.edu/cxcsiap/queryImages}\
+ {} \
+ post \
+ } \
+ {{MAST (STSCI)} siamast \
+ {http://archive.stsci.edu/siap/search.php}\
+ {} \
+ post \
+ } \
+ {{SDSS DR12} \
+ siasdss \
+ {http://skyserver.sdss.org/SkyserverWS/dr12/SIAP/getSIAP}\
+ {} \
+ get \
+ } \
+ {{SkyView (NASA/HEASARC)} \
+ siaskyview \
+ {http://skyview.gsfc.nasa.gov/cgi-bin/vo/sia.pl}\
+ {} \
+ post \
+ } \
+ {{TGSSADR (GMRT)} \
+ siatgssadr \
+ {http://vo.astron.nl/tgssadr/q_fits/imgs/siap.xml}\
+ {} \
+ post \
+ } \
+ }
+
+# {{NASA/CXC Chandra} \
+# siacxc \
+# {http://cda.harvard.edu/cxcsiap/queryImages}\
+# {} \
+# post \
+# } \
+# {{MPE/MPG ROSAT} siarosat \
+# {http://gavo.mpe.mpg.de/rosat/SIAP} \
+# {action=queryImage&siap=siap.service.rosat&} \
+# get \
+# } \
+}
+
+proc SIAAnalysisMenu {mb} {
+ global isia
+ global ds9
+
+ foreach ff $isia(def) {
+ set title [lindex $ff 0]
+ set vars [lindex $ff 1]
+ set url [lindex $ff 2]
+ set opts [lindex $ff 3]
+ set method [lindex $ff 4]
+
+ $mb add command -label $title \
+ -command [list SIADialog $vars $title $url $opts $method apply]
+ }
+}
+
+proc SIAGetURL {varname url2} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIAGetURL $varname $var(method) $url2?$var(query2)"
+ }
+
+ ARStatus $varname [msgcat::mc {Loading}]
+
+ # geturl --method does not work
+ switch $var(method) {
+ get {
+ set url $url2?$var(query2)
+ set query {}
+ }
+ default {
+ set url $url2
+ set query $var(query2)
+ }
+ }
+
+ global ihttp
+ if {$var(sync)} {
+ if {![catch {set var(token) [http::geturl $url \
+ -query $query \
+ -timeout $ihttp(timeout) \
+ -headers "[ProxyHTTP]"]
+
+
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ SIAGetURLFinish $varname $var(token)
+ } else {
+ SIAError $varname "[msgcat::mc {Unable to locate URL}] $url2"
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $url \
+ -query $query \
+ -timeout $ihttp(timeout) \
+ -command \
+ [list SIAGetURLFinish $varname] \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ } else {
+ SIAError $varname "[msgcat::mc {Unable to locate URL}] $url2"
+ }
+ }
+}
+
+proc SIAGetURLFinish {varname token} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIAGetURLFinish $varname"
+ }
+
+ if {!($var(active))} {
+ SIACancelled $varname
+ return
+ }
+
+ upvar #0 $token t
+
+ # Code
+ set code [http::ncode $token]
+
+ # Meta
+ set meta $t(meta)
+
+ # Log it
+ HTTPLog $token
+
+ # Result?
+ switch -- $code {
+ {} -
+ 200 -
+ 203 -
+ 404 -
+ 503 {
+ VOTParse $var(tbldb) $token
+ SIADone $varname
+ SIALoadDone $varname
+ }
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $meta {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIAGetURLFinish redirect $code to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset var(token)
+
+ SIAGetURL $varname $value
+ }
+ }
+ }
+
+ default {
+ SIAError $varname "[msgcat::mc {Error code was returned}] $code"
+ }
+ }
+}
+
+proc SIALoad {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # clear previous db
+ global $var(tbldb)
+ if {[info exists $var(tbldb)]} {
+ unset $var(tbldb)
+ }
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIALoad $varname $var(url2)?$var(query2)"
+ }
+
+ SIAGetURL $varname $var(url2)
+ return
+}
+
+proc SIALoadDone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIALoadDone $varname"
+ }
+
+ SIATable $varname
+
+ SIADialogUpdate $varname
+}
+
+proc SIAOff {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global $var(tbldb)
+ if {[info exists $var(tbldb)]} {
+ unset $var(tbldb)
+ }
+ set db $var(tbldb)
+ set ${db}(Nrows) {}
+
+ $var(tbl) selection clear all
+
+ SIADialogUpdate $varname
+}
+
+proc SIATable {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+ global isia
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIATable $varname"
+ }
+
+ if {![CATValidDB $var(tbldb)]} {
+ return
+ }
+
+ # clear the selection
+ $var(tbl) selection clear all
+
+ global $var(tbldb)
+ $var(found) configure -textvariable ${var(tbldb)}(Nrows)
+
+# starbase_writefp $var(tbldb) stdout
+
+ if {[starbase_nrows $var(tbldb)] == 0} {
+ ARStatus $varname [msgcat::mc {No Items Found}]
+ return
+ }
+
+ set nc [starbase_ncols $var(tbldb)]
+ if { $nc > $isia(mincols)} {
+ $var(tbl) configure -cols $nc
+ } else {
+ $var(tbl) configure -cols $isia(mincols)
+ }
+
+ # add header
+ set nr [expr [starbase_nrows $var(tbldb)]+1]
+ if {$nr > $isia(minrows)} {
+ $var(tbl) configure -rows $nr
+ } else {
+ $var(tbl) configure -rows $isia(minrows)
+ }
+}
+
+# Process Cmds
+
+proc ProcessSIACmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global isia
+
+ # we need to be realized
+ ProcessRealizeDS9
+
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ cancel -
+ clear -
+ close -
+ coordinate -
+ crosshair -
+ export -
+ name -
+ print -
+ retreive -
+ retrieve -
+ save -
+ size -
+ sky -
+ skyformat -
+ system -
+ update {ProcessSIA $varname $iname [lindex $isia(sias) end]}
+
+ default {
+ # existing sia or load new one?
+ set ref $item
+
+ incr i
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ cancel -
+ clear -
+ close -
+ coordinate -
+ crosshair -
+ export -
+ name -
+ print -
+ retreive -
+ retrieve -
+ save -
+ size -
+ sky -
+ skyformat -
+ system -
+ update {ProcessSIA $varname $iname sia${ref}}
+
+ default {
+ # ok, new sia
+ incr i -1
+ set item [string tolower [lindex $var $i]]
+
+ # see if its from our list of sias
+ foreach mm $isia(def) {
+ set title [lindex $mm 0]
+ set vars [lindex $mm 1]
+ set url [lindex $mm 2]
+ set opts [lindex $mm 3]
+ set method [lindex $mm 4]
+
+ if {$title != {-} && "sia${item}" == $vars} {
+ SIADialog $vars $title $url $opts $method sync
+ return
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+proc ProcessSIA {varname iname cvarname} {
+ upvar 2 $varname var
+ upvar 2 $iname i
+
+ global isia
+ global psia
+ global current
+
+ # we should have a sia now
+ global $cvarname
+ upvar #0 $cvarname cvar
+
+ if {![info exists cvar(top)]} {
+ Error "[msgcat::mc {Unable to find SIAP window}] $cvarname"
+ return
+ }
+ if {![winfo exists $cvar(top)]} {
+ Error "[msgcat:: mc {Unable to find SIAP window}] $cvarname"
+ return
+ }
+
+ # now, process it
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ cancel {ARCancel $cvarname}
+ clear {SIAOff $cvarname}
+ close {SIADestroy $cvarname}
+ coordinate {
+ incr i
+ set cvar(x) [lindex $var $i]
+ incr i
+ set cvar(y) [lindex $var $i]
+ incr i
+ set cvar(sky) [lindex $var $i]
+ }
+ crosshair {IMGSVRCrosshair $cvarname}
+ export -
+ save {
+ incr i
+ set writer VOTWrite
+ switch -- [lindex $var $i] {
+ xml -
+ vot {incr i; set writer VOTWrite}
+ sb -
+ starbase {incr i; set writer starbase_write}
+ csv -
+ tsv {incr i; set writer TSVWrite}
+ }
+
+ set fn [lindex $var $i]
+ CATSaveFn $cvarname $fn $writer
+ FileLast catfbox $fn
+ }
+ name {
+ incr i
+ set cvar(name) [lindex $var $i]
+ }
+ print {CATPrint $cvarname}
+ retrieve -
+ retreive {SIAApply $cvarname 1}
+ size {
+ incr i
+ set cvar(width) [lindex $var $i]
+ incr i
+ set cvar(height) [lindex $var $i]
+ incr i
+ set cvar(rformat) [lindex $var $i]
+ set cvar(rformat,msg) $cvar(rformat)
+ }
+ sky {
+ incr i
+ set cvar(sky) [lindex $var $i]
+ CoordMenuButtonCmd $cvarname system sky \
+ [list SIAWCSMenuUpdate $cvarname]
+ }
+ skyformat {
+ incr i
+ set cvar(skyformat) [lindex $var $i]
+ }
+ system {
+ incr i
+ set cvar(system) [lindex $var $i]
+ CoordMenuButtonCmd $cvarname system sky \
+ [list SIAWCSMenuUpdate $cvarname]
+ }
+ update {IMGSVRUpdate $cvarname}
+ }
+}
+
+proc ProcessSendSIACmd {proc id param sock fn} {
+ global isia
+
+ $proc $id "$isia(sias)\n"
+}
diff --git a/ds9/library/siadialog.tcl b/ds9/library/siadialog.tcl
new file mode 100644
index 0000000..3542c0f
--- /dev/null
+++ b/ds9/library/siadialog.tcl
@@ -0,0 +1,488 @@
+# 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
+
+# used by backup
+proc SIADialog {varname title url opts method action} {
+ global sia
+ global isia
+ global psia
+ global ds9
+
+ global wcs
+
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIADialog $varname:$title:$url:$opts:$action:$method"
+ }
+
+ # main dialog
+ set var(top) ".${varname}"
+ set var(mb) ".${varname}mb"
+
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ global current
+ if {$current(frame) == {}} {
+ return
+ }
+
+ # AR variables
+ ARInit $varname IMGSVRServer
+
+ # IMG variables
+ set var(proc,done) SIADone
+ set var(proc,exec) SIAVOT1
+ set var(proc,error) SIAError
+
+ # SIA variables
+ lappend isia(sias) $varname
+
+ set var(tbldb) ${varname}db
+
+ set var(system) $wcs(system)
+ set var(sky) $wcs(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $isia(rformat)
+ set var(width) $isia(width)
+ set var(height) $isia(height)
+ set var(save) $isia(save)
+ set var(mode) $isia(mode)
+
+ set var(url2) $url
+ set var(title) $title
+ set var(opts) $opts
+ set var(method) $method
+
+ # create the window
+ set w $var(top)
+ set mb $var(mb)
+
+ set tt $title
+
+ Toplevel $w $mb 7 $tt "SIADestroy $varname"
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+ NSVRServerMenu $varname
+ $mb add cascade -label [msgcat::mc {Preferences}] -menu $mb.prefs
+
+ # file
+ menu $mb.file
+ $mb.file add command -label "[msgcat::mc {Save}]..." \
+ -command [list CATSaveVOTFile $varname]
+ $mb.file add separator
+ $mb.file add cascade -label [msgcat::mc {Export}] -menu $mb.file.export
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Retrieve}] \
+ -command [list SIAApply $varname 0]
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command [list ARCancel $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Load}] \
+ -command [list SIAImageCmd $varname]
+ $mb.file add command -label [msgcat::mc {Clear}] \
+ -command [list SIAOff $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Update from Current Frame}] \
+ -command [list IMGSVRUpdate $varname]
+ $mb.file add command \
+ -label [msgcat::mc {Update from Current Crosshair}] \
+ -command [list IMGSVRCrosshair $varname]
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Print}]..." \
+ -command [list CATPrint $varname]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command [list SIADestroy $varname]
+
+ # Export
+ menu $mb.file.export
+ $mb.file.export add command -label "[msgcat::mc {Starbase}]..." \
+ -command [list CATSaveSBFile $varname]
+ $mb.file.export add command -label "[msgcat::mc {Tab-Separated-Value}]..." \
+ -command [list CATSaveTSVFile $varname]
+
+ # edit
+ menu $mb.edit
+ $mb.edit add command -label [msgcat::mc {Cut}] \
+ -command "CATCut $varname" -accelerator "${ds9(ctrl)}X"
+ $mb.edit add command -label [msgcat::mc {Copy}] \
+ -command "CATCopy $varname" -accelerator "${ds9(ctrl)}C"
+ $mb.edit add command -label [msgcat::mc {Paste}] \
+ -command "EntryPaste $var(top)" -accelerator "${ds9(ctrl)}V"
+ $mb.edit add separator
+ $mb.edit add command -label [msgcat::mc {Clear}] \
+ -command [list ARClear $varname]
+
+ # prefs
+ menu $mb.prefs
+ $mb.prefs add checkbutton -label [msgcat::mc {Save Image on Download}] \
+ -variable ${varname}(save)
+ $mb.prefs add separator
+ $mb.prefs add radiobutton -label [msgcat::mc {New Frame}] \
+ -variable ${varname}(mode) -value new
+ $mb.prefs add radiobutton -label [msgcat::mc {Current Frame}] \
+ -variable ${varname}(mode) -value current
+
+ # Object
+ set f [ttk::labelframe $w.obj -text [msgcat::mc {Object}] -padding 2]
+
+ ttk::label $f.nametitle -text [msgcat::mc {Name}]
+ ttk::entry $f.name -textvariable ${varname}(name) -width 60
+
+ set var(xname) [ttk::label $f.xtitle -text {} -width 1]
+ ttk::entry $f.x -textvariable ${varname}(x) -width 14
+ set var(yname) [ttk::label $f.ytitle -text {} -width 1]
+ ttk::entry $f.y -textvariable ${varname}(y) -width 14
+
+ CoordMenuButton $f.coord $varname system 0 sky skyformat \
+ [list SIAWCSMenuUpdate $varname]
+ CoordMenuEnable $f.coord.menu $varname system 0 sky skyformat
+
+ ttk::label $f.wtitle -text [msgcat::mc {Width}]
+ ttk::entry $f.w -textvariable ${varname}(width) -width 14
+ ttk::label $f.htitle -text [msgcat::mc {Height}]
+ ttk::entry $f.h -textvariable ${varname}(height) -width 14
+
+ ARRFormat $f.rformat $varname
+
+ grid $f.nametitle $f.name - - - - -padx 2 -pady 2 -sticky w
+ grid $f.xtitle $f.x $f.ytitle $f.y $f.coord -padx 2 -pady 2 -sticky w
+ grid $f.wtitle $f.w $f.htitle $f.h $f.rformat -padx 2 -pady 2 -sticky w
+
+ # Param
+ set f [ttk::labelframe $w.param -text [msgcat::mc {Table}] -padding 2]
+
+ ttk::label $f.ftitle -text [msgcat::mc {Found}]
+ set var(found) [ttk::label $f.found \
+ -width 14 -relief groove -anchor w]
+
+ grid $f.ftitle $f.found -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(tbldb) \
+ -colorigin 1 \
+ -roworigin 0 \
+ -cols $isia(mincols) \
+ -rows $isia(minrows) \
+ -width -1 \
+ -height -1 \
+ -maxwidth 300 \
+ -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 SIASelectCmd $varname %s %S] \
+ ]
+
+ 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
+
+ # Status
+ set f [ttk::frame $w.status]
+
+ ttk::label $f.title -text [msgcat::mc {Status}]
+ ttk::label $f.item -textvariable ${varname}(status)
+
+ grid $f.title $f.item -padx 2 -pady 2 -sticky w
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+
+ set var(apply) [ttk::button $f.apply \
+ -text [msgcat::mc {Retrieve}] \
+ -command [list SIAApply $varname 0]]
+ set var(cancel) [ttk::button $f.cancel -text \
+ [msgcat::mc {Cancel}] \
+ -command [list ARCancel $varname] \
+ -state disabled]
+ set var(load) [ttk::button $f.load \
+ -text [msgcat::mc {Load}] \
+ -command [list SIAImageCmd $varname]]
+ ttk::button $f.clear -text [msgcat::mc {Clear}] \
+ -command [list SIAOff $varname]
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command [list SIADestroy $varname]
+
+ pack $f.apply $f.cancel $f.load $f.clear $f.close \
+ -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ ttk::separator $w.stbl -orient horizontal
+ ttk::separator $w.sstatus -orient horizontal
+ pack $w.buttons $w.sstatus $w.status $w.stbl -side bottom -fill x
+ pack $w.obj $w.param -side top -fill x
+ pack $w.tbl -side top -fill both -expand true
+
+ ARCoord $varname
+ IMGSVRUpdate $varname
+ SIADialogUpdate $varname
+
+ ARStatus $varname {}
+
+ switch -- $action {
+ apply {SIAApply $varname 0}
+ sync {SIAApply $varname 1}
+ none {}
+ }
+
+ # return the actual varname
+ return $varname
+}
+
+proc SIAApply {varname sync} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIAApply $varname $sync"
+ }
+
+ set var(sync) $sync
+ ARApply $varname
+ $var(mb).file entryconfig [msgcat::mc {Load}] -state disabled
+ $var(load) configure -state disabled
+
+ if {$var(name) != {}} {
+ set var(sky) fk5
+ CoordMenuButtonCmd $varname system sky {}
+ SIAWCSMenuUpdate $varname
+
+ NSVRServer $varname
+ } else {
+ IMGSVRServer $varname
+ }
+}
+
+proc SIADestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+ global $var(tbldb)
+ global isia
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIADestroy $varname"
+ }
+
+ if {[info exists $var(tbldb)]} {
+ unset $var(tbldb)
+ }
+
+ set ii [lsearch $isia(sias) $varname]
+ if {$ii>=0} {
+ set isia(sias) [lreplace $isia(sias) $ii $ii]
+ }
+
+ ARDestroy $varname
+}
+
+proc SIAApplyLoad {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARApply $varname
+ $var(mb).file entryconfig [msgcat::mc {Load}] -state disabled
+ $var(load) configure -state disabled
+}
+
+proc SIADone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARDone $varname
+ $var(mb).file entryconfig [msgcat::mc {Load}] -state normal
+ $var(load) configure -state normal
+}
+
+proc SIACancelled {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARCancelled $varname
+ $var(mb).file entryconfig [msgcat::mc {Load}] -state normal
+ $var(load) configure -state normal
+}
+
+proc SIAError {varname message} {
+ upvar #0 $varname var
+ global $varname
+
+ ARError $varname $message
+ $var(mb).file entryconfig [msgcat::mc {Load}] -state normal
+ $var(load) configure -state normal
+}
+
+proc SIADialogUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+ global samp
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIADialogUpdate $varname"
+ }
+
+ # do we have a db?
+ if {[CATValidDB $var(tbldb)]} {
+ $var(mb).file entryconfig [msgcat::mc {Clear}] -state normal
+ $var(mb).file entryconfig "[msgcat::mc {Print}]..." -state normal
+
+ $var(top).buttons.clear configure -state normal
+ } else {
+ $var(mb).file entryconfig [msgcat::mc {Clear}] -state disabled
+ $var(mb).file entryconfig "[msgcat::mc {Print}]..." -state disabled
+
+ $var(top).buttons.clear configure -state disabled
+ }
+}
+
+proc SIAImageCmd {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ds9
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIAImage $varname"
+ }
+
+ global $var(tbldb)
+ if {![CATValidDB $var(tbldb)]} {
+ return
+ }
+
+ set rowlist {}
+ foreach sel [$var(tbl) curselection] {
+ set rr [lindex [split $sel ,] 0]
+ lappend rowlist $rr
+ }
+ set rowlist [lsort -unique $rowlist]
+
+ set col [expr [lsearch [subst $${varname}db(Ucd)] {VOX:Image_AccessReference}] +1]
+ if {$col == 0} {
+ ARError $varname [msgcat::mc {Unable to find URL column}]
+ return
+ }
+
+ if {$rowlist != {}} {
+ set url [starbase_get $var(tbldb) $rowlist $col]
+ SIAApplyLoad $varname
+ ParseURL $url r
+ switch -- $r(scheme) {
+ http {
+ if {$var(save)} {
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ SIADone $varname
+ return
+ }
+ } else {
+ set var(fn) [tmpnam [file extension $r(path)]]
+ }
+
+ set var(query) {}
+ IMGSVRGetURL $varname $url
+ }
+ default {
+ SIAError $varname "$r(scheme) [msgcat::mc {Not Supported}]"
+ return
+ }
+ }
+ }
+}
+
+proc SIASelectCmd {varname ss rc} {
+ upvar #0 $varname var
+ global $varname
+
+ # starts at 1
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIASelectCmd $varname ss=$ss rc=$rc"
+ }
+}
+
+proc SIAVOT1 {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,sia)} {
+ puts stderr "SIAVOT1 $varname"
+ }
+
+ # coord (degrees)
+ switch $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ set xx [h2d [Sex2H $var(x)]]
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ # size (degrees)
+ switch $var(rformat) {
+ degrees {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+
+ # query
+ set var(query2) "$var(opts)[http::formatQuery POS "$xx,$yy" SIZE $rr FORMAT image/fits]"
+
+ SIALoad $varname
+}
+
+proc SIAWCSMenuUpdate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ ARCoord $varname
+
+ set var(psystem) $var(system)
+ set var(psky) $var(sky)
+ CoordMenuButtonCmd $varname psystem psky {}
+}
+
diff --git a/ds9/library/skyview.tcl b/ds9/library/skyview.tcl
new file mode 100644
index 0000000..5c0ef96
--- /dev/null
+++ b/ds9/library/skyview.tcl
@@ -0,0 +1,619 @@
+# 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 SkyViewDef {} {
+ global skyview
+ global iskyview
+
+ set iskyview(top) .skyview
+ set iskyview(mb) .skyviewmb
+
+ set skyview(sky) fk5
+ set skyview(rformat) arcsec
+ set skyview(width) 300
+ set skyview(height) 300
+ set skyview(width,pixels) 300
+ set skyview(height,pixels) 300
+ set skyview(mode) new
+ set skyview(save) 0
+ set skyview(survey) dss
+}
+
+proc SkyViewDialog {} {
+ global skyview
+ global iskyview
+ global wcs
+
+ if {[winfo exists $iskyview(top)]} {
+ raise $iskyview(top)
+ return
+ }
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "SkyViewDialog"
+ }
+
+ set varname dskyview
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $iskyview(top)
+ set var(mb) $iskyview(mb)
+ set var(sky) $skyview(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $skyview(rformat)
+ set var(width) $skyview(width)
+ set var(height) $skyview(height)
+ set var(width,pixels) $skyview(width,pixels)
+ set var(height,pixels) $skyview(height,pixels)
+ set var(mode) $skyview(mode)
+ set var(save) $skyview(save)
+ set var(survey) $skyview(survey)
+
+ set w $var(top)
+ IMGSVRInit $varname "HEASARC-SkyView [msgcat::mc {Server}]" \
+ SkyViewExec SkyViewAck ARDone ARError
+
+ # pixels size
+ set f $w.param
+ ttk::label $f.pimage -text [msgcat::mc {Image}]
+ ttk::entry $f.pw -textvariable ${varname}(width,pixels) -width 14
+ ttk::entry $f.ph -textvariable ${varname}(height,pixels) -width 14
+ ttk::label $f.ptitle -text [msgcat::mc {Pixels}]
+
+ grid $f.pimage x $f.pw x $f.ph $f.ptitle -padx 2 -pady 2 -sticky w
+
+ menu $var(mb).survey
+ $var(mb) add cascade -label Survey -menu $var(mb).survey
+ $var(mb).survey add cascade -label {Gamma Ray} \
+ -menu $var(mb).survey.gamma
+ $var(mb).survey add cascade -label {Hard X-ray} \
+ -menu $var(mb).survey.hard
+ $var(mb).survey add cascade -label {X-ray: Swift BAT} \
+ -menu $var(mb).survey.bat
+ $var(mb).survey add cascade -label {Soft X-ray} \
+ -menu $var(mb).survey.soft
+ $var(mb).survey add cascade -label {Diffuse X-ray} \
+ -menu $var(mb).survey.diffuse
+ $var(mb).survey add cascade -label {UV} \
+ -menu $var(mb).survey.uv
+ $var(mb).survey add cascade -label {Optical: DSS} \
+ -menu $var(mb).survey.dss
+ $var(mb).survey add cascade -label {Optical: SDSS} \
+ -menu $var(mb).survey.sdss
+ $var(mb).survey add cascade -label {Other Optical} \
+ -menu $var(mb).survey.other
+ $var(mb).survey add cascade -label {IR: IRAS} \
+ -menu $var(mb).survey.iras
+ $var(mb).survey add cascade -label {IR: 2MASS} \
+ -menu $var(mb).survey.ir2mass
+ $var(mb).survey add cascade -label {IR: UKIDSS} \
+ -menu $var(mb).survey.irukidss
+ $var(mb).survey add cascade -label {IR: WISE} \
+ -menu $var(mb).survey.irwise
+ $var(mb).survey add cascade -label {IR: AKARI} \
+ -menu $var(mb).survey.irakari
+ $var(mb).survey add cascade -label {IR: Planck} \
+ -menu $var(mb).survey.planck
+ $var(mb).survey add cascade -label {IR: WMAP/COBE} \
+ -menu $var(mb).survey.wmap
+ $var(mb).survey add cascade -label {Radio: Ghz} \
+ -menu $var(mb).survey.radioghz
+ $var(mb).survey add cascade -label {Radio: Mhz} \
+ -menu $var(mb).survey.radiomhz
+ $var(mb).survey add cascade -label {All: GOODS/HDF/CDF} \
+ -menu $var(mb).survey.goods
+
+ set f $var(mb).survey.gamma
+ menu $f
+ $f add radiobutton -label {Fermi 5} \
+ -variable ${varname}(survey) -value {Fermi 5}
+ $f add radiobutton -label {Fermi 4} \
+ -variable ${varname}(survey) -value {Fermi 4}
+ $f add radiobutton -label {Fermi 3} \
+ -variable ${varname}(survey) -value {Fermi 3}
+ $f add radiobutton -label {Fermi 2} \
+ -variable ${varname}(survey) -value {Fermi 2}
+ $f add radiobutton -label {Fermi 1} \
+ -variable ${varname}(survey) -value {Fermi 1}
+ $f add separator
+ $f add radiobutton -label {EGRET (3D)} \
+ -variable ${varname}(survey) -value {EGRET (3D)}
+ $f add radiobutton -label {EGRET <100 Mev} \
+ -variable ${varname}(survey) -value {EGRET <100 Mev}
+ $f add radiobutton -label {EGRET >100 Mev} \
+ -variable ${varname}(survey) -value {EGRET >100 Mev}
+ $f add separator
+ $f add radiobutton -label {COMPTEL} \
+ -variable ${varname}(survey) -value {COMPTEL}
+
+ set f $var(mb).survey.hard
+ menu $f
+ $f add radiobutton -label {INT GAL 17-35 Flux} \
+ -variable ${varname}(survey) -value {INT GAL 17-35 Flux}
+ $f add radiobutton -label {INT GAL 17-60 Flux} \
+ -variable ${varname}(survey) -value {INT GAL 17-60 Flux}
+ $f add radiobutton -label {INT GAL 35-80 Flux} \
+ -variable ${varname}(survey) -value {INT GAL 35-80 Flux}
+ $f add separator
+ $f add radiobutton -label {INTEGRAL/SPI GC} \
+ -variable ${varname}(survey) -value {INTEGRAL/SPI GC}
+ $f add radiobutton -label {GRANAT/SIGMA} \
+ -variable ${varname}(survey) -value {GRANAT/SIGMA}
+ $f add separator
+ $f add radiobutton -label {RXTE Allsky 3-8keV Flux} \
+ -variable ${varname}(survey) -value {RXTE Allsky 3-8keV Flux}
+ $f add radiobutton -label {RXTE Allsky 3-20keV Flux} \
+ -variable ${varname}(survey) -value {RXTE Allsky 3-20keV Flux}
+ $f add radiobutton -label {RXTE Allsky 8-20keV Flux} \
+ -variable ${varname}(survey) -value {RXTE Allsky 8-20keV Flux}
+
+ set f $var(mb).survey.bat
+ menu $f
+ $f add radiobutton -label {BAT SNR 14-195} \
+ -variable ${varname}(survey) -value {BAT SNR 14-195}
+ $f add radiobutton -label {BAT SNR 14-20} \
+ -variable ${varname}(survey) -value {BAT SNR 14-20}
+ $f add radiobutton -label {BAT SNR 20-24} \
+ -variable ${varname}(survey) -value {BAT SNR 20-24}
+ $f add radiobutton -label {BAT SNR 24-35} \
+ -variable ${varname}(survey) -value {BAT SNR 24-35}
+ $f add radiobutton -label {BAT SNR 35-50} \
+ -variable ${varname}(survey) -value {BAT SNR 35-50}
+ $f add radiobutton -label {BAT SNR 50-75} \
+ -variable ${varname}(survey) -value {BAT SNR 50-75}
+ $f add radiobutton -label {BAT SNR 75-100} \
+ -variable ${varname}(survey) -value {BAT SNR 75-100}
+ $f add radiobutton -label {BAT SNR 100-150} \
+ -variable ${varname}(survey) -value {BAT SNR 100-150}
+ $f add radiobutton -label {BAT SNR 150-195} \
+ -variable ${varname}(survey) -value {BAT SNR 150-195}
+
+ set f $var(mb).survey.soft
+ menu $f
+ $f add radiobutton -label {RASS-Cnt Soft} \
+ -variable ${varname}(survey) -value {RASS-Cnt Soft}
+ $f add radiobutton -label {RASS-Cnt Hard} \
+ -variable ${varname}(survey) -value {RASS-Cnt Hard}
+ $f add radiobutton -label {RASS-Cnt Broad} \
+ -variable ${varname}(survey) -value {RASS-Cnt Broad}
+ $f add separator
+ $f add radiobutton -label {PSPC 2.0 Deg-Int} \
+ -variable ${varname}(survey) -value {PSPC 2.0 Deg-Int}
+ $f add radiobutton -label {PSPC 1.0 Deg-Int} \
+ -variable ${varname}(survey) -value {PSPC 1.0 Deg-Int}
+ $f add radiobutton -label {PSPC 0.6 Deg-Int} \
+ -variable ${varname}(survey) -value {PSPC 0.6 Deg-Int}
+ $f add separator
+ $f add radiobutton -label {HRI} \
+ -variable ${varname}(survey) -value {HRI}
+ $f add radiobutton -label {HEAO 1 A-2} \
+ -variable ${varname}(survey) -value {HEAO 1 A-2}
+
+ set f $var(mb).survey.diffuse
+ menu $f
+ $f add radiobutton -label {RASS Background 1} \
+ -variable ${varname}(survey) -value {RASS Background 1}
+ $f add radiobutton -label {RASS Background 2} \
+ -variable ${varname}(survey) -value {RASS Background 2}
+ $f add radiobutton -label {RASS Background 3} \
+ -variable ${varname}(survey) -value {RASS Background 3}
+ $f add radiobutton -label {RASS Background 4} \
+ -variable ${varname}(survey) -value {RASS Background 4}
+ $f add radiobutton -label {RASS Background 5} \
+ -variable ${varname}(survey) -value {RASS Background 5}
+ $f add radiobutton -label {RASS Background 6} \
+ -variable ${varname}(survey) -value {RASS Background 6}
+ $f add radiobutton -label {RASS Background 7} \
+ -variable ${varname}(survey) -value {RASS Background 7}
+
+ set f $var(mb).survey.uv
+ menu $f
+ $f add radiobutton -label {GALEX Near UV} \
+ -variable ${varname}(survey) -value {GALEX Near UV}
+ $f add radiobutton -label {GALEX Far UV} \
+ -variable ${varname}(survey) -value {GALEX Far UV}
+ $f add separator
+ $f add radiobutton -label {ROSAT WFC F1} \
+ -variable ${varname}(survey) -value {ROSAT WFC F1}
+ $f add radiobutton -label {ROSAT WFC F2} \
+ -variable ${varname}(survey) -value {ROSAT WFC F2}
+ $f add separator
+ $f add radiobutton -label {EUVE 171 A} \
+ -variable ${varname}(survey) -value {EUVE 171 A}
+ $f add radiobutton -label {EUVE 405 A} \
+ -variable ${varname}(survey) -value {EUVE 405 A}
+ $f add radiobutton -label {EUVE 555 A} \
+ -variable ${varname}(survey) -value {EUVE 555 A}
+
+ set f $var(mb).survey.dss
+ menu $f
+ $f add radiobutton -label {DSS} \
+ -variable ${varname}(survey) -value {DSS}
+ $f add separator
+ $f add radiobutton -label {DSS1 Blue} \
+ -variable ${varname}(survey) -value {DSS1 Blue}
+ $f add radiobutton -label {DSS1 Red} \
+ -variable ${varname}(survey) -value {DSS1 Red}
+ $f add separator
+ $f add radiobutton -label {DSS2 Red} \
+ -variable ${varname}(survey) -value {DSS2 Red}
+ $f add radiobutton -label {DSS2 Blue} \
+ -variable ${varname}(survey) -value {DSS2 Blue}
+ $f add separator
+ $f add radiobutton -label {DSS2 IR} \
+ -variable ${varname}(survey) -value {DSS2 IR}
+
+ set f $var(mb).survey.sdss
+ menu $f
+ $f add radiobutton -label {SDSSg} \
+ -variable ${varname}(survey) -value {SDSSg}
+ $f add radiobutton -label {SDSSi} \
+ -variable ${varname}(survey) -value {SDSSi}
+ $f add radiobutton -label {SDSSr} \
+ -variable ${varname}(survey) -value {SDSSr}
+ $f add radiobutton -label {SDSSu} \
+ -variable ${varname}(survey) -value {SDSSu}
+ $f add radiobutton -label {SDSSz} \
+ -variable ${varname}(survey) -value {SDSSz}
+ $f add separator
+ $f add radiobutton -label {SDSSdr7g} \
+ -variable ${varname}(survey) -value {SDSSdr7g}
+ $f add radiobutton -label {SDSSdr7i} \
+ -variable ${varname}(survey) -value {SDSSdr7i}
+ $f add radiobutton -label {SDSSdr7r} \
+ -variable ${varname}(survey) -value {SDSSdr7r}
+ $f add radiobutton -label {SDSSdr7u} \
+ -variable ${varname}(survey) -value {SDSSdr7u}
+ $f add radiobutton -label {SDSSdr7z} \
+ -variable ${varname}(survey) -value {SDSSdr7z}
+
+ set f $var(mb).survey.other
+ menu $f
+ $f add radiobutton -label {Mellinger Red} \
+ -variable ${varname}(survey) -value {Mellinger Red}
+ $f add radiobutton -label {Mellinger Green} \
+ -variable ${varname}(survey) -value {Mellinger Green}
+ $f add radiobutton -label {Mellinger Blue} \
+ -variable ${varname}(survey) -value {Mellinger Blue}
+ $f add separator
+ $f add radiobutton -label {NEAT} \
+ -variable ${varname}(survey) -value {NEAT}
+ $f add radiobutton -label {H-Alpha Comp} \
+ -variable ${varname}(survey) -value {H-Alpha Comp}
+ $f add separator
+ $f add radiobutton -label {SHASSA H} \
+ -variable ${varname}(survey) -value {SHASSA H}
+ $f add radiobutton -label {SHASSA CC} \
+ -variable ${varname}(survey) -value {SHASSA CC}
+ $f add radiobutton -label {SHASSA C} \
+ -variable ${varname}(survey) -value {SHASSA C}
+ $f add radiobutton -label {SHASSA Sm} \
+ -variable ${varname}(survey) -value {SHASSA Sm}
+
+ set f $var(mb).survey.iras
+ menu $f
+ $f add radiobutton -label {IRIS 12} \
+ -variable ${varname}(survey) -value {IRIS 12}
+ $f add radiobutton -label {IRIS 25} \
+ -variable ${varname}(survey) -value {IRIS 25}
+ $f add radiobutton -label {IRIS 60} \
+ -variable ${varname}(survey) -value {IRIS 160}
+ $f add radiobutton -label {IRIS 100} \
+ -variable ${varname}(survey) -value {IRIS 100}
+ $f add separator
+ $f add radiobutton -label {SFD100m} \
+ -variable ${varname}(survey) -value {SFD100m}
+ $f add radiobutton -label {SFD Dust Map} \
+ -variable ${varname}(survey) -value {SFD Dust Map}
+ $f add separator
+ $f add radiobutton -label {IRAS 12 micron} \
+ -variable ${varname}(survey) -value {IRAS 12 micron}
+ $f add radiobutton -label {IRAS 25 micron} \
+ -variable ${varname}(survey) -value {IRAS 25 micron}
+ $f add radiobutton -label {IRAS 60 micron} \
+ -variable ${varname}(survey) -value {IRAS 60 micron}
+ $f add radiobutton -label {IRAS 100 micron} \
+ -variable ${varname}(survey) -value {IRAS 100 micron}
+
+ set f $var(mb).survey.ir2mass
+ menu $f
+ $f add radiobutton -label {2MASS-J} \
+ -variable ${varname}(survey) -value {2MASS-J}
+ $f add radiobutton -label {2MASS-H} \
+ -variable ${varname}(survey) -value {2MASS-H}
+ $f add radiobutton -label {2MASS-K} \
+ -variable ${varname}(survey) -value {2MASS-K}
+
+ set f $var(mb).survey.irukidss
+ menu $f
+ $f add radiobutton -label {UKIDSS-Y} \
+ -variable ${varname}(survey) -value {UKIDSS-Y}
+ $f add radiobutton -label {UKIDSS-J} \
+ -variable ${varname}(survey) -value {UKIDSS-J}
+ $f add radiobutton -label {UKIDSS-H} \
+ -variable ${varname}(survey) -value {UKIDSS-H}
+ $f add radiobutton -label {UKIDSS-K} \
+ -variable ${varname}(survey) -value {UKIDSS-K}
+
+ set f $var(mb).survey.irwise
+ menu $f
+ $f add radiobutton -label {WISE 3.4} \
+ -variable ${varname}(survey) -value {WISE 3.4}
+ $f add radiobutton -label {WISE 4.6} \
+ -variable ${varname}(survey) -value {WISE 4.6}
+ $f add radiobutton -label {WISE 12} \
+ -variable ${varname}(survey) -value {WISE 12}
+ $f add radiobutton -label {WISE 22} \
+ -variable ${varname}(survey) -value {WISE 22}
+
+ set f $var(mb).survey.irakari
+ menu $f
+ $f add radiobutton -label {AKARI N60} \
+ -variable ${varname}(survey) -value {AKARI N60}
+ $f add radiobutton -label {AKARI WIDE-S} \
+ -variable ${varname}(survey) -value {AKARI WIDE-S}
+ $f add radiobutton -label {AKARI WIDE-L} \
+ -variable ${varname}(survey) -value {AKARI WIDE-L}
+ $f add radiobutton -label {AKARI N160} \
+ -variable ${varname}(survey) -value {AKARI N160}
+
+ set f $var(mb).survey.planck
+ menu $f
+ $f add radiobutton -label {Planck 857} \
+ -variable ${varname}(survey) -value {Planck 857}
+ $f add radiobutton -label {Planck 545} \
+ -variable ${varname}(survey) -value {Planck 545}
+ $f add radiobutton -label {Planck 353} \
+ -variable ${varname}(survey) -value {Planck 353}
+ $f add radiobutton -label {Planck 217} \
+ -variable ${varname}(survey) -value {Planck 217}
+ $f add radiobutton -label {Planck 143} \
+ -variable ${varname}(survey) -value {Planck 143}
+ $f add radiobutton -label {Planck 100} \
+ -variable ${varname}(survey) -value {Planck 100}
+ $f add radiobutton -label {Planck 070} \
+ -variable ${varname}(survey) -value {Planck 070}
+ $f add radiobutton -label {Planck 044} \
+ -variable ${varname}(survey) -value {Planck 044}
+ $f add radiobutton -label {Planck 030} \
+ -variable ${varname}(survey) -value {Planck 030}
+
+ set f $var(mb).survey.wmap
+ menu $f
+ $f add radiobutton -label {WMAP Ka} \
+ -variable ${varname}(survey) -value {WMAP Ka}
+ $f add radiobutton -label {WMAP K} \
+ -variable ${varname}(survey) -value {WMAP K}
+ $f add radiobutton -label {WMAP Q} \
+ -variable ${varname}(survey) -value {WMAP Q}
+ $f add radiobutton -label {WMAP V} \
+ -variable ${varname}(survey) -value {WMAP V}
+ $f add radiobutton -label {WMAP W} \
+ -variable ${varname}(survey) -value {WMAP W}
+ $f add separator
+ $f add radiobutton -label {COBE DIRBE/AAM} \
+ -variable ${varname}(survey) -value cobeaam
+ $f add radiobutton -label {COBE DIRBE/ZSMA} \
+ -variable ${varname}(survey) -value cobezsma
+
+ set f $var(mb).survey.radioghz
+ menu $f
+ $f add radiobutton -label {CO} \
+ -variable ${varname}(survey) -value {CO}
+ $f add radiobutton -label {GB6 (4850MHZ)} \
+ -variable ${varname}(survey) -value {GB6 (4850MHZ)}
+ $f add radiobutton -label {VLA FIRST (1.4 GHz)} \
+ -variable ${varname}(survey) -value {VLA FIRST (1.4 GHz)}
+ $f add radiobutton -label {NVSS} \
+ -variable ${varname}(survey) -value {NVSS}
+ $f add radiobutton -label {Stripe82VLA} \
+ -variable ${varname}(survey) -value {Stripe82VLA}
+ $f add radiobutton -label {1420MHz (Bonn)} \
+ -variable ${varname}(survey) -value {1420MHz (Bonn)}
+ $f add radiobutton -label {nH} \
+ -variable ${varname}(survey) -value {nH}
+
+ set f $var(mb).survey.radiomhz
+ menu $f
+ $f add radiobutton -label {SUMSS 843 MHz} \
+ -variable ${varname}(survey) -value {SUMSS 843 MHz}
+ $f add radiobutton -label {0408MHz} \
+ -variable ${varname}(survey) -value {0408MHz}
+ $f add radiobutton -label {WENSS} \
+ -variable ${varname}(survey) -value {WENSS}
+ $f add radiobutton -label {TGSS ADR1} \
+ -variable ${varname}(survey) -value {TGSS ADR1}
+ $f add radiobutton -label {VLSSr} \
+ -variable ${varname}(survey) -value {VLSSr}
+ $f add radiobutton -label {0035MHz} \
+ -variable ${varname}(survey) -value {0035MHz}
+
+ set f $var(mb).survey.goods
+ menu $f
+ $f add radiobutton -label {GOODS: Chandra ACIS HB} \
+ -variable ${varname}(survey) -value {GOODS: Chandra ACIS HB}
+ $f add radiobutton -label {GOODS: Chandra ACIS FB} \
+ -variable ${varname}(survey) -value {GOODS: Chandra ACIS FB}
+ $f add radiobutton -label {GOODS: Chandra ACIS SB} \
+ -variable ${varname}(survey) -value {GOODS: Chandra ACIS SB}
+ $f add separator
+ $f add radiobutton -label {GOODS: VLT VIMOS U} \
+ -variable ${varname}(survey) -value {GOODS: VLT VIMOS U}
+ $f add radiobutton -label {GOODS: VLT VIMOS R} \
+ -variable ${varname}(survey) -value {GOODS: VLT VIMOS R}
+ $f add separator
+ $f add radiobutton -label {GOODS: HST ACS B} \
+ -variable ${varname}(survey) -value {GOODS: HST ACS B}
+ $f add radiobutton -label {GOODS: HST ACS V} \
+ -variable ${varname}(survey) -value {GOODS: HST ACS V}
+ $f add radiobutton -label {GOODS: HST ACS I} \
+ -variable ${varname}(survey) -value {GOODS: HST ACS I}
+ $f add radiobutton -label {GOODS: HST ACS Z} \
+ -variable ${varname}(survey) -value {GOODS: HST ACS Z}
+ $f add separator
+ $f add radiobutton -label {Hawaii HDF U} \
+ -variable ${varname}(survey) -value {Hawaii HDF U}
+ $f add radiobutton -label {Hawaii HDF B} \
+ -variable ${varname}(survey) -value {Hawaii HDF B}
+ $f add radiobutton -label {Hawaii HDF V0201} \
+ -variable ${varname}(survey) -value {Hawaii HDF V0201}
+ $f add radiobutton -label {Hawaii HDF V0401} \
+ -variable ${varname}(survey) -value {Hawaii HDF V0401}
+ $f add radiobutton -label {Hawaii HDF R} \
+ -variable ${varname}(survey) -value {Hawaii HDF R}
+ $f add radiobutton -label {Hawaii HDF I} \
+ -variable ${varname}(survey) -value {Hawaii HDF I}
+ $f add radiobutton -label {Hawaii HDF Z} \
+ -variable ${varname}(survey) -value {Hawaii HDF Z}
+ $f add radiobutton -label {Hawaii HDF HK} \
+ -variable ${varname}(survey) -value {Hawaii HDF HK}
+ $f add separator
+ $f add radiobutton -label {GOODS: HST NICMOS} \
+ -variable ${varname}(survey) -value {GOODS: HST NICMOS}
+ $f add radiobutton -label {GOODS: VLT ISAAC J} \
+ -variable ${varname}(survey) -value {GOODS: VLT ISAAC J}
+ $f add radiobutton -label {GOODS: VLT ISAAC H} \
+ -variable ${varname}(survey) -value {GOODS: VLT ISAAC H}
+ $f add radiobutton -label {GOODS: VLT ISAAC Ks} \
+ -variable ${varname}(survey) -value {GOODS: VLT ISAAC Ks}
+ $f add radiobutton -label {HUDF: VLT ISAAC Ks} \
+ -variable ${varname}(survey) -value {HUDF: VLT ISAAC Ks}
+ $f add separator
+ $f add radiobutton -label {GOODS: Spitzer IRAC 3.6} \
+ -variable ${varname}(survey) -value {GOODS: Spitzer IRAC 3.6}
+ $f add radiobutton -label {GOODS: Spitzer IRAC 4.5} \
+ -variable ${varname}(survey) -value {GOODS: Spitzer IRAC 4.5}
+ $f add radiobutton -label {GOODS: Spitzer IRAC 5.8} \
+ -variable ${varname}(survey) -value {GOODS: Spitzer IRAC 5.8}
+ $f add radiobutton -label {GOODS: Spitzer IRAC 8.0} \
+ -variable ${varname}(survey) -value {GOODS: Spitzer IRAC 8.0}
+ $f add radiobutton -label {GOODS: Spitzer MIPS 24} \
+ -variable ${varname}(survey) -value {GOODS: Spitzer MIPS 24}
+ $f add separator
+ $f add radiobutton -label {GOODS: Herschel 100} \
+ -variable ${varname}(survey) -value {GOODS: Herschel 100}
+ $f add radiobutton -label {GOODS: Herschel 100} \
+ -variable ${varname}(survey) -value {GOODS: Herschel 100}
+ $f add radiobutton -label {GOODS: Herschel 250} \
+ -variable ${varname}(survey) -value {GOODS: Herschel 250}
+ $f add radiobutton -label {GOODS: Herschel 350} \
+ -variable ${varname}(survey) -value {GOODS: Herschel 350}
+ $f add radiobutton -label {GOODS: Herschel 500} \
+ -variable ${varname}(survey) -value {GOODS: Herschel 500}
+ $f add separator
+ $f add radiobutton -label {CDFS: LESS} \
+ -variable ${varname}(survey) -value {CDFS: LESS}
+ $f add radiobutton -label {GOODS: VLA North} \
+ -variable ${varname}(survey) -value {GOODS: VLA North}
+
+ IMGSVRUpdate $varname
+}
+
+proc SkyViewExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "SkyViewExec $varname"
+ }
+
+ if {$var(save)} {
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set var(fn) [tmpnam {.fits}]
+ }
+
+ # skyformat
+ switch -- $var(skyformat) {
+ degrees {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ sexagesimal {
+ set xx [h2d [Sex2H $var(x)]]
+ set yy [Sex2D $var(y)]
+ }
+ }
+
+ # size - convert to arcsec
+ switch -- $var(rformat) {
+ degrees {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+ if {$ww>5} {
+ set ww 5
+ }
+ if {$hh>5} {
+ set hh 5
+ }
+
+ # now average
+ set rr [expr ($ww+$hh)/2.]
+
+ # query
+ set var(query) [http::formatQuery Position $xx,$yy Survey $var(survey) Size $ww,$hh Pixels $var(width,pixels),$var(height,pixels) Return FITS]
+ set url "http://skyview.gsfc.nasa.gov/cgi-bin/images"
+ IMGSVRGetURL $varname $url
+}
+
+proc SkyViewAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,image)} {
+ puts stderr "SkyViewAck $varname"
+ }
+
+ set msg {Acknowledgments for the Skyview
+
+SkyView has been developed with generous support from the NASA AISR and ADP
+programs (P.I. Thomas A. McGlynn) under the auspices of the High Energy
+Astrophysics Science Archive Research Center (HEASARC) at the
+NASA/ GSFC Astrophysics Science Division.
+
+We gratefully acknowledge the support of NASA and contributors of
+SkyView surveys.
+
+Maintained by: Laura McDonald lmm@skyview.gsfc.nasa.gov
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+
+proc ProcessSkyViewCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ SkyViewDialog
+ IMGSVRProcessCmd $varname $iname dskyview
+}
+
+proc ProcessSendSkyViewCmd {proc id param} {
+ SkyViewDialog
+ IMGSVRProcessSendCmd $proc $id $param dskyview
+}
diff --git a/ds9/library/slider.tcl b/ds9/library/slider.tcl
new file mode 100644
index 0000000..2453ecd
--- /dev/null
+++ b/ds9/library/slider.tcl
@@ -0,0 +1,72 @@
+# 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 slider {w from to label varname cmd {num {5}} {width {7}}} {
+ ttk::frame $w
+ ttk::scale $w.slider \
+ -length 300 \
+ -orient horizontal \
+ -variable $varname \
+ -takefocus 0 \
+ -command [list SliderCmd $w $varname $cmd]
+
+ ttk::label $w.label -text $label
+ ttk::entry $w.entry -textvariable $varname -width $width
+ grid $w.label -sticky w -columnspan $num
+ grid $w.slider -row 1 -columnspan $num -padx 2 -pady 2 -sticky news
+ grid $w.entry -row 1 -column $num -padx 2 -pady 2
+
+ for {set ii 0} {$ii<$num} {incr ii} {
+ ttk::label $w.t$ii -width $width -anchor center
+ grid $w.t$ii -row 2 -column $ii
+ grid columnconfigure $w $ii -weight 1
+ }
+
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+ grid rowconfigure $w 2 -weight 1
+
+ bind $w.entry <Return> $cmd
+
+ SliderMinMax $w $from $to $num
+
+ return $w
+}
+
+proc SliderMinMax {w from to num} {
+ $w.slider configure -from $from -to $to
+
+ if {$from == $to} {
+ for {set ii 0} {$ii<$num} {incr ii} {
+ $w.t$ii configure -text {}
+ }
+ } else {
+ for {set ii 0} {$ii<$num} {incr ii} {
+ set vv [expr ($to*1.-$from)/($num-1)*$ii + $from]
+
+ if {[string is integer $from] && [string is integer $to]} {
+ set vv [expr int($vv)]
+ } else {
+ set vv [format {%.5g} $vv]
+ }
+ $w.t$ii configure -text $vv
+ }
+ }
+}
+
+proc SliderCmd {w varname cmd vv} {
+ upvar $varname var
+
+ set from [$w.slider cget -from]
+ set to [$w.slider cget -to]
+
+ if {[string is integer $from] && [string is integer $to]} {
+ set var [expr int($vv)]
+ }
+ if {$cmd != {}} {
+ eval $cmd
+ }
+}
diff --git a/ds9/library/smooth.tcl b/ds9/library/smooth.tcl
new file mode 100644
index 0000000..f116510
--- /dev/null
+++ b/ds9/library/smooth.tcl
@@ -0,0 +1,304 @@
+# 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 SmoothDef {} {
+ global smooth
+ global ismooth
+ global psmooth
+
+ set ismooth(top) .sm
+ set ismooth(mb) .smmb
+
+ set smooth(lock) 0
+ set smooth(view) 0
+ set smooth(function) gaussian
+ set smooth(radius) 3
+
+ array set psmooth [array get smooth]
+}
+
+proc SmoothUpdate {} {
+ global smooth
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ SetWatchCursor
+ if {$smooth(view)} {
+ RGBEvalLockCurrent rgb(lock,smooth) [list $current(frame) smooth $smooth(function) $smooth(radius)]
+ } else {
+ RGBEvalLockCurrent rgb(lock,smooth) [list $current(frame) smooth delete]
+ }
+ ResetWatchCursor
+ }
+
+ LockSmoothCurrent
+ UpdateCubeDialog
+ UpdateContourScale
+ UpdateContourDialog
+ UpdateScaleDialog
+ UpdateGraphXAxis $current(frame)
+ UpdateMain
+}
+
+proc SmoothDialog {} {
+ global ds9
+ global smooth
+ global ismooth
+
+ # see if we already have a window visible
+ if {[winfo exists $ismooth(top)]} {
+ raise $ismooth(top)
+ return
+ }
+
+ # create the window
+ set w $ismooth(top)
+ set mb $ismooth(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Smooth Parameters}] SmoothDestroyDialog
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+ $mb add cascade -label [msgcat::mc {Edit}] -menu $mb.edit
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command SmoothApplyDialog
+ $mb.file add command -label [msgcat::mc {Clear}] -command SmoothOffDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command SmoothDestroyDialog
+
+ EditMenu $mb ismooth
+
+ # Function
+ set f [ttk::labelframe $w.func -text [msgcat::mc {Function}] -padding 2]
+ ttk::radiobutton $f.boxcar -text [msgcat::mc {Boxcar}] \
+ -variable smooth(function) -value boxcar
+ ttk::radiobutton $f.tophat -text [msgcat::mc {Tophat}] \
+ -variable smooth(function) -value tophat
+ ttk::radiobutton $f.gaussian -text [msgcat::mc {Gaussian}] \
+ -variable smooth(function) -value gaussian
+ grid $f.boxcar $f.tophat $f.gaussian -padx 2 -pady 2
+
+ # Kernal
+ set f [ttk::labelframe $w.rad -text [msgcat::mc {Kernel}] -padding 2]
+ slider $f.slider 1 20 {Radius} smooth(radius) {}
+ grid $f.slider -padx 2 -pady 2 -sticky ew
+ grid columnconfigure $f 0 -weight 1
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command SmoothApplyDialog
+ ttk::button $f.clear -text [msgcat::mc {Clear}] -command SmoothOffDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command SmoothDestroyDialog
+ pack $f.apply $f.clear $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ grid $w.func -sticky news
+ grid $w.rad -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+}
+
+proc SmoothApplyDialog {} {
+ global smooth
+
+ set smooth(view) 1
+ SmoothUpdate
+}
+
+proc SmoothDestroyDialog {} {
+ global ismooth
+
+ if {[winfo exists $ismooth(top)]} {
+ destroy $ismooth(top)
+ destroy $ismooth(mb)
+ }
+}
+
+proc SmoothOffDialog {} {
+ global smooth
+
+ set smooth(view) 0
+ SmoothUpdate
+}
+
+proc UpdateSmoothMenu {} {
+ global smooth
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateSmoothMenu"
+ }
+
+ if {$current(frame) != {}} {
+ set smooth(view) [$current(frame) has smooth]
+ set smooth(function) [$current(frame) get smooth function]
+ set smooth(radius) [$current(frame) get smooth radius]
+ }
+}
+
+proc MatchSmoothCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ MatchSmooth $current(frame)
+ }
+}
+
+proc MatchSmooth {which} {
+ global ds9
+ global rgb
+
+ set view [$which has smooth]
+ set function [$which get smooth function]
+ set radius [$which get smooth radius]
+
+ foreach ff $ds9(frames) {
+ if {$ff != $which} {
+ if {$view} {
+ RGBEvalLock rgb(lock,smooth) $ff [list $ff smooth $function $radius]
+ } else {
+ RGBEvalLock rgb(lock,smooth) $ff [list $ff smooth delete]
+ }
+ }
+ }
+}
+
+proc LockSmoothCurrent {} {
+ global current
+
+ if {$current(frame) != {}} {
+ LockSmooth $current(frame)
+ }
+}
+
+proc LockSmooth {which} {
+ global smooth
+
+ if {$smooth(lock)} {
+ MatchSmooth $which
+ }
+}
+
+proc SmoothBackup {ch which} {
+ switch [$which get type] {
+ base -
+ 3d {SmoothBackupBase $ch $which}
+ rgb {SmoothBackupRGB $ch $which}
+ }
+}
+
+proc SmoothBackupBase {ch which} {
+ if {[$which has smooth]} {
+ set function [$which get smooth function]
+ set radius [$which get smooth radius]
+ puts $ch "$which smooth $function $radius"
+ }
+}
+
+proc SmoothBackupRGB {ch which} {
+ set sav [$which get rgb channel]
+ foreach cc {red green blue} {
+ $which rgb channel $cc
+ puts $ch "$which rgb channel $cc"
+ SmoothBackupBase $ch $which
+ }
+ $which rgb channel $sav
+ puts $ch "$which rgb channel $sav"
+}
+
+proc PrefsDialogSmooth {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {Smooth}]
+ lappend dprefs(tabs) [ttk::frame $w.smooth]
+
+ set f [ttk::labelframe $w.smooth.param -text [msgcat::mc {Smooth}]]
+
+ ttk::label $f.title -text [msgcat::mc {Function}]
+ ttk::menubutton $f.function -textvariable psmooth(function) \
+ -menu $f.function.menu
+
+ menu $f.function.menu
+ $f.function.menu add radiobutton -label [msgcat::mc {Boxcar}] \
+ -variable psmooth(function) -value boxcar
+ $f.function.menu add radiobutton -label [msgcat::mc {Tophat}] \
+ -variable psmooth(function) -value tophat
+ $f.function.menu add radiobutton -label [msgcat::mc {Gaussian}] \
+ -variable psmooth(function) -value gaussian
+
+ grid $f.title $f.function -padx 2 -pady 2 -sticky w
+
+ pack $f -side top -fill both -expand true
+}
+
+proc ProcessSmoothCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global smooth
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {SmoothDialog}
+ close {SmoothDestroyDialog}
+ match {MatchSmoothCurrent}
+ lock {
+ incr i
+ if {!([string range [lindex $var $i] 0 0] == "-")} {
+ set smooth(lock) [FromYesNo [lindex $var $i]]
+ } else {
+ set smooth(lock) 1
+ incr i -1
+ }
+ LockSmoothCurrent
+ }
+ radius {
+ incr i
+ set smooth(radius) [lindex $var $i]
+ SmoothUpdate
+ }
+ function {
+ incr i
+ set smooth(function) [lindex $var $i]
+ SmoothUpdate
+ }
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ set smooth(view) [FromYesNo [lindex $var $i]]
+ SmoothUpdate
+ }
+
+ default {
+ set smooth(view) 1
+ SmoothUpdate
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendSmoothCmd {proc id param} {
+ global smooth
+
+ switch -- [lindex $param 0] {
+ lock {$proc $id [ToYesNo $smooth(lock)]}
+ function {$proc $id "$smooth(function)\n"}
+ radius {$proc $id "$smooth(radius)\n"}
+ default {$proc $id [ToYesNo $smooth(view)]}
+ }
+}
+
diff --git a/ds9/library/smosaic.tcl b/ds9/library/smosaic.tcl
new file mode 100644
index 0000000..37ee762
--- /dev/null
+++ b/ds9/library/smosaic.tcl
@@ -0,0 +1,25 @@
+# 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 ProcessSMosaicCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ set vvar $var
+ set ii $i
+
+ switch -- [string tolower [lindex $var $i]] {
+ iraf {
+ incr ii
+ ProcessSMosaicIRAFCmd vvar ii $sock $fn
+ }
+ {} {
+ set vvar [linsert $var $i wcs]
+ ProcessSMosaicWCSCmd vvar ii $sock $fn
+ }
+ default {ProcessSMosaicWCSCmd vvar ii $sock $fn}
+ }
+}
diff --git a/ds9/library/smosaiciraf.tcl b/ds9/library/smosaiciraf.tcl
new file mode 100644
index 0000000..8534508
--- /dev/null
+++ b/ds9/library/smosaiciraf.tcl
@@ -0,0 +1,70 @@
+# 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 LoadSMosaicIRAFFile {hdr fn layer} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {mosaic iraf}
+ set loadParam(load,type) smmap
+ set loadParam(file,name) $fn
+ set loadParam(file,header) $hdr
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc ProcessSMosaicIRAFCmd {varname iname sock fn layer} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+
+ set opt [lindex $var $i]
+ if {$opt != {}} {
+ incr i
+ } else {
+ set opt wcs
+ }
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {0} {
+ # not supported
+ } else {
+ LoadSMosaicIRAFFile [lindex $var $i] [lindex $var [expr $i+1]] \
+ $layer $opt
+ }
+ } else {
+ # comm
+ if {0} {
+ # not supported
+ } else {
+ LoadSMosaicIRAFFile [lindex $var $i] [lindex $var [expr $i+1]] \
+ $layer $opt
+ }
+ }
+ FinishLoad
+}
diff --git a/ds9/library/smosaicwcs.tcl b/ds9/library/smosaicwcs.tcl
new file mode 100644
index 0000000..e751659
--- /dev/null
+++ b/ds9/library/smosaicwcs.tcl
@@ -0,0 +1,70 @@
+# 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 LoadSMosaicWCSFitsFile {hdr fn layer sys} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) [list mosaic $sys]
+ set loadParam(load,type) smmap
+ set loadParam(file,name) $fn
+ set loadParam(file,header) $hdr
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc ProcessSMosaicWCSCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global loadParam
+ global current
+
+ set layer {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+
+ set opt [lindex $var $i]
+ if {$opt != {}} {
+ incr i
+ } else {
+ set opt wcs
+ }
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {0} {
+ # not supported
+ } else {
+ LoadSMosaicWCSFile [lindex $var $i] [lindex $var [expr $i+1]] \
+ $layer $opt
+ }
+ } else {
+ # comm
+ if {0} {
+ # not supported
+ } else {
+ LoadSMosaicWCSFile [lindex $var $i] [lindex $var [expr $i+1]] \
+ $layer $opt
+ }
+ }
+ FinishLoad
+}
diff --git a/ds9/library/source.tcl b/ds9/library/source.tcl
new file mode 100644
index 0000000..584a986
--- /dev/null
+++ b/ds9/library/source.tcl
@@ -0,0 +1,195 @@
+# 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
+
+source $ds9(root)/library/2mass.tcl
+source $ds9(root)/library/3d.tcl
+source $ds9(root)/library/array.tcl
+source $ds9(root)/library/analysis.tcl
+source $ds9(root)/library/analysisparam.tcl
+source $ds9(root)/library/annulus.tcl
+source $ds9(root)/library/ar.tcl
+source $ds9(root)/library/backup.tcl
+source $ds9(root)/library/bin.tcl
+source $ds9(root)/library/block.tcl
+source $ds9(root)/library/box.tcl
+source $ds9(root)/library/boxannulus.tcl
+source $ds9(root)/library/bpanda.tcl
+source $ds9(root)/library/buttons.tcl
+source $ds9(root)/library/cat.tcl
+source $ds9(root)/library/catcds.tcl
+source $ds9(root)/library/catcdssrch.tcl
+source $ds9(root)/library/catcdssrchdialog.tcl
+source $ds9(root)/library/catcmd.tcl
+source $ds9(root)/library/catcxc.tcl
+source $ds9(root)/library/catdialog.tcl
+source $ds9(root)/library/catflt.tcl
+source $ds9(root)/library/catmatch.tcl
+source $ds9(root)/library/catned.tcl
+source $ds9(root)/library/catopt.tcl
+source $ds9(root)/library/catplot.tcl
+source $ds9(root)/library/catreg.tcl
+source $ds9(root)/library/catsdss.tcl
+source $ds9(root)/library/catsimbad.tcl
+source $ds9(root)/library/catskybot.tcl
+source $ds9(root)/library/catsym.tcl
+source $ds9(root)/library/catvot.tcl
+source $ds9(root)/library/centroid.tcl
+source $ds9(root)/library/circle.tcl
+source $ds9(root)/library/colorbar.tcl
+source $ds9(root)/library/comm.tcl
+source $ds9(root)/library/command.tcl
+source $ds9(root)/library/compass.tcl
+source $ds9(root)/library/composite.tcl
+source $ds9(root)/library/contour.tcl
+source $ds9(root)/library/convert.tcl
+source $ds9(root)/library/coord.tcl
+source $ds9(root)/library/cpanda.tcl
+source $ds9(root)/library/crop.tcl
+source $ds9(root)/library/crosshair.tcl
+source $ds9(root)/library/cube.tcl
+source $ds9(root)/library/debug.tcl
+source $ds9(root)/library/dialog.tcl
+source $ds9(root)/library/ellipse.tcl
+source $ds9(root)/library/ellipseannulus.tcl
+source $ds9(root)/library/envi.tcl
+source $ds9(root)/library/epanda.tcl
+source $ds9(root)/library/error.tcl
+source $ds9(root)/library/eso.tcl
+source $ds9(root)/library/examine.tcl
+source $ds9(root)/library/export.tcl
+source $ds9(root)/library/external.tcl
+source $ds9(root)/library/file.tcl
+source $ds9(root)/library/fits.tcl
+source $ds9(root)/library/frame.tcl
+source $ds9(root)/library/graph.tcl
+source $ds9(root)/library/grid.tcl
+source $ds9(root)/library/group.tcl
+source $ds9(root)/library/header.tcl
+source $ds9(root)/library/help.tcl
+source $ds9(root)/library/http.tcl
+source $ds9(root)/library/hv.tcl
+source $ds9(root)/library/hvform.tcl
+source $ds9(root)/library/hvsup.tcl
+source $ds9(root)/library/iexam.tcl
+source $ds9(root)/library/iis.tcl
+source $ds9(root)/library/ime.tcl
+source $ds9(root)/library/imgsvr.tcl
+source $ds9(root)/library/import.tcl
+source $ds9(root)/library/info.tcl
+source $ds9(root)/library/layout.tcl
+source $ds9(root)/library/line.tcl
+source $ds9(root)/library/load.tcl
+source $ds9(root)/library/magnifier.tcl
+source $ds9(root)/library/marker.tcl
+source $ds9(root)/library/markeranalysishist.tcl
+source $ds9(root)/library/markeranalysispanda.tcl
+source $ds9(root)/library/markeranalysisplot2d.tcl
+source $ds9(root)/library/markeranalysisplot3d.tcl
+source $ds9(root)/library/markeranalysisradial.tcl
+source $ds9(root)/library/markeranalysisstats.tcl
+source $ds9(root)/library/markerbase.tcl
+source $ds9(root)/library/markerbaseannulus.tcl
+source $ds9(root)/library/markerbaseannulusrect.tcl
+source $ds9(root)/library/markerbasecenter.tcl
+source $ds9(root)/library/markerbaseline.tcl
+source $ds9(root)/library/markerbasepanda.tcl
+source $ds9(root)/library/markerbasepandarect.tcl
+source $ds9(root)/library/markerdialog.tcl
+source $ds9(root)/library/mask.tcl
+source $ds9(root)/library/manalysis.tcl
+source $ds9(root)/library/mbin.tcl
+source $ds9(root)/library/mcolor.tcl
+source $ds9(root)/library/mecube.tcl
+source $ds9(root)/library/medit.tcl
+source $ds9(root)/library/menu.tcl
+source $ds9(root)/library/mfile.tcl
+source $ds9(root)/library/mframe.tcl
+source $ds9(root)/library/mhelp.tcl
+source $ds9(root)/library/mosaicimage.tcl
+source $ds9(root)/library/mosaicimageiraf.tcl
+source $ds9(root)/library/mosaicimagewcs.tcl
+source $ds9(root)/library/mosaicimagewfpc2.tcl
+source $ds9(root)/library/mosaic.tcl
+source $ds9(root)/library/mosaiciraf.tcl
+source $ds9(root)/library/mosaicwcs.tcl
+source $ds9(root)/library/movie.tcl
+source $ds9(root)/library/mregion.tcl
+source $ds9(root)/library/mscale.tcl
+source $ds9(root)/library/multiframe.tcl
+source $ds9(root)/library/mview.tcl
+source $ds9(root)/library/mwcs.tcl
+source $ds9(root)/library/mzoom.tcl
+source $ds9(root)/library/nameres.tcl
+source $ds9(root)/library/nsvr.tcl
+source $ds9(root)/library/nrrd.tcl
+source $ds9(root)/library/nvss.tcl
+source $ds9(root)/library/open.tcl
+source $ds9(root)/library/pagesetup.tcl
+source $ds9(root)/library/panner.tcl
+source $ds9(root)/library/panzoom.tcl
+source $ds9(root)/library/photo.tcl
+source $ds9(root)/library/pixel.tcl
+source $ds9(root)/library/plot.tcl
+source $ds9(root)/library/plotbar.tcl
+source $ds9(root)/library/plotdialog.tcl
+source $ds9(root)/library/plotelement.tcl
+source $ds9(root)/library/plotline.tcl
+source $ds9(root)/library/plotprint.tcl
+source $ds9(root)/library/plotprocess.tcl
+source $ds9(root)/library/plotscatter.tcl
+source $ds9(root)/library/point.tcl
+source $ds9(root)/library/polygon.tcl
+source $ds9(root)/library/prefs.tcl
+source $ds9(root)/library/prefsdialog.tcl
+source $ds9(root)/library/print.tcl
+source $ds9(root)/library/projection.tcl
+source $ds9(root)/library/rgb.tcl
+source $ds9(root)/library/rgbarray.tcl
+source $ds9(root)/library/rgbcube.tcl
+source $ds9(root)/library/rgbimage.tcl
+source $ds9(root)/library/ruler.tcl
+source $ds9(root)/library/samp.tcl
+source $ds9(root)/library/sao.tcl
+source $ds9(root)/library/save.tcl
+source $ds9(root)/library/saveimage.tcl
+source $ds9(root)/library/scale.tcl
+source $ds9(root)/library/sia.tcl
+source $ds9(root)/library/siadialog.tcl
+source $ds9(root)/library/segment.tcl
+source $ds9(root)/library/sfits.tcl
+source $ds9(root)/library/shm.tcl
+source $ds9(root)/library/skyview.tcl
+source $ds9(root)/library/slider.tcl
+source $ds9(root)/library/smosaic.tcl
+source $ds9(root)/library/smosaiciraf.tcl
+source $ds9(root)/library/smosaicwcs.tcl
+source $ds9(root)/library/smooth.tcl
+source $ds9(root)/library/srgbcube.tcl
+source $ds9(root)/library/starbase.tcl
+source $ds9(root)/library/stdfbox.tcl
+source $ds9(root)/library/stsci.tcl
+source $ds9(root)/library/template.tcl
+source $ds9(root)/library/text.tcl
+source $ds9(root)/library/tkfbox.tcl
+source $ds9(root)/library/tsv.tcl
+source $ds9(root)/library/url.tcl
+source $ds9(root)/library/util.tcl
+source $ds9(root)/library/var.tcl
+source $ds9(root)/library/vector.tcl
+source $ds9(root)/library/vla.tcl
+source $ds9(root)/library/vlss.tcl
+source $ds9(root)/library/vo.tcl
+source $ds9(root)/library/vot.tcl
+source $ds9(root)/library/wcs.tcl
+source $ds9(root)/library/xmfbox.tcl
+source $ds9(root)/library/xmlrpc.tcl
+source $ds9(root)/library/xpa.tcl
+
+switch [tk windowingsystem] {
+ x11 {}
+ aqua {source $ds9(root)/library/macosx.tcl}
+ win32 {source $ds9(root)/library/win32.tcl}
+}
diff --git a/ds9/library/srgbcube.tcl b/ds9/library/srgbcube.tcl
new file mode 100644
index 0000000..f460c51
--- /dev/null
+++ b/ds9/library/srgbcube.tcl
@@ -0,0 +1,68 @@
+# 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 LoadSRGBCubeFile {hdr fn} {
+ global loadParam
+ global current
+
+ switch -- [$current(frame) get type] {
+ base -
+ 3d {
+ Error [msgcat::mc {Unable to load RGB image into a non-rgb frame}]
+ return
+ }
+ rgb {}
+ }
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) {rgb cube}
+ set loadParam(load,type) smmap
+ set loadParam(file,name) $fn
+ set loadParam(file,header) $hdr
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
+proc ProcessSRGBCubeCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateRGBFrame
+ }
+ mask {
+ incr i
+ # not supported
+ }
+ slice {
+ incr i
+ # not supported
+ }
+ }
+
+ StartLoad
+ if {$sock != {}} {
+ # xpa
+ if {0} {
+ # not supported
+ } else {
+ LoadSRGBCubeFile [lindex $var $i] [lindex $var [expr $i+1]]
+ }
+ } else {
+ # comm
+ if {0} {
+ # not supported
+ } else {
+ LoadSRGBCubeFile [lindex $var $i] [lindex $var [expr $i+1]]
+ }
+ }
+ FinishLoad
+}
diff --git a/ds9/library/starbase.tcl b/ds9/library/starbase.tcl
new file mode 100644
index 0000000..218115e
--- /dev/null
+++ b/ds9/library/starbase.tcl
@@ -0,0 +1,547 @@
+# 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
+
+# ####
+#
+# starbase.tcl -- Tcl interface to starbase
+#
+# ####
+
+# Starbase Tables Interface
+#
+
+set starbase_debug 0
+
+proc Starbase {} {
+ global Starbase
+ return $Starbase(version)
+}
+
+set Starbase(version) "Starbase Tcl Driver 1.0"
+
+proc starbase_nrows { D } { upvar $D data; return $data(Nrows) }
+proc starbase_ncols { D } { upvar $D data; return $data(Ncols) }
+proc starbase_get { D row col } { upvar $D data; return $data($row,$col) }
+proc starbase_set { D row col val } { upvar $D data; set data($row,$col) $val; }
+proc starbase_colname { D num } { upvar $D data; return $data(0,$num) }
+#proc starbase_columns { D } { upvar $D data; return $data(Header) }
+proc starbase_colnum { D name } { upvar $D data; return $data($name) }
+
+proc starbase_columns {t} {
+ upvar $t T
+
+ set row {}
+ set Ncols $T(Ncols)
+ for { set c 1 } { $c <= $Ncols } { incr c } {
+ lappend row $T(0,$c)
+ }
+
+ return $row
+}
+
+proc starbase_init { t } {
+ upvar t T
+
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) ""
+}
+
+# Set up a starbase data array for use with ted
+#
+proc starbase_driver { Dr } {
+ upvar $Dr driver
+
+ set driver(nrows) starbase_nrows
+ set driver(ncols) starbase_ncols
+ set driver(get) starbase_get
+ set driver(set) starbase_set
+ set driver(colname) starbase_colname
+ set driver(colnum) starbase_colnum
+ set driver(columns) starbase_columns
+ set driver(colins) starbase_colins
+ set driver(coldel) starbase_coldel
+ set driver(colapp) starbase_colapp
+ set driver(rowins) starbase_rowins
+ set driver(rowdel) starbase_rowdel
+ set driver(rowapp) starbase_rowapp
+}
+starbase_driver Starbase
+
+proc starbase_new { t args } {
+ upvar $t T
+
+ set T(Header) $args
+ set T(Ndshs) [llength $T(Header)]
+ set T(HLines) 2
+ starbase_colmap T
+
+ set T(Nrows) 0
+}
+
+proc starbase_colmap { h } {
+ upvar $h H
+
+ set c 0
+ foreach column $H(Header) {
+ incr c
+ set column [string trim $column]
+ set H($column) $c
+ set H(0,$c) $column
+ }
+ set H(Ncols) $c
+}
+
+proc starbase_coldel { t here } {
+ upvar $t T
+
+ set Ncols $T(Ncols)
+
+ set T(Header) [lreplace $T(Header) [expr $here - 1] [expr $here - 1]
+ starbase_colmap T
+
+ for { set row 1 } { $row <= $T(Nrows) } { incr row } {
+ for { set col $here } { $col < $Ncols } { incr col } {
+ if { [catch { set val $T($row,[expr $col + 1]) }] } {
+ set T($row,$col) ""
+ } else {
+ set T($row,$col) $val
+ }
+ }
+ }
+}
+
+proc starbase_colins { t name here } {
+ upvar $t T
+
+ if { [info exists $T(Header)] == 0 } {
+ set T(Header) $name
+ } else {
+ set T(Header) [linsert $T(Header) [expr $here - 1] $name]
+ }
+ starbase_colmap T
+
+ for { set row 1 } { $row <= $T(Nrows) } { incr row } {
+ for { set col $T(Ncol) } { $col > $here } { incr col -1 } {
+ if { [catch { set val $T($row,[expr $col - 1]) }] } {
+ set T($row,$col) ""
+ } else {
+ set T($row,$col) $val
+ }
+ }
+ }
+
+ for { set row 1 } { $row <= $T(Nrows) } { incr row } {
+ set T($row,$here) ""
+ }
+}
+
+proc starbase_header { h fp } {
+ upvar $h H
+ global starbase_line
+ set N 1
+
+ if { [info exists starbase_line] } {
+ set line $starbase_line
+ set n 1
+
+ set H(H_$n) $line
+ if { [regexp -- {^ *(-)+ *(\t *(-)+ *)*} $line] } break
+ if { $n >= 2 } {
+ set ind [string first "\t" $H(H_[expr $n-1])]
+ if { $ind >= 0 } {
+ set name [string range $H(H_[expr $n-1]) 0 [expr $ind - 1]]
+ incr ind
+ set H(H_$name) [string range $H(H_[expr $n-1]) $ind end]
+ set H(N_$name) [expr $n-1]
+ }
+# set l [split $H(H_[expr $n-1]) "\t"]
+# if { [llength $l] > 1 } {
+# set name [lindex $l 0]
+# set H(H_$name) [lrange $l 1 end]
+# set H(N_$name) [expr $n-1]
+# }
+ }
+
+ unset starbase_line
+ set N 2
+ }
+ for { set n $N } { [set eof [gets $fp line]] != -1 } { incr n } {
+ set H(H_$n) $line
+ if { [regexp -- {^ *(-)+ *(\t *(-)+ *)*} $line] } break
+
+ if { $n >= 2 } {
+ set ind [string first "\t" $H(H_[expr $n-1])]
+ if { $ind >= 0 } {
+ set name [string range $H(H_[expr $n-1]) 0 [expr $ind - 1]]
+ incr ind
+ set H(H_$name) [string range $H(H_[expr $n-1]) $ind end]
+ set H(N_$name) [expr $n-1]
+ }
+# set l [split $H(H_[expr $n-1]) "\t"]
+# if { [llength $l] > 1 } {
+# set name [lindex $l 0]
+# set H(H_$name) [lrange $l 1 end]
+# set H(N_$name) [expr $n-1]
+# }
+ }
+
+ }
+
+ if { $eof == -1 } {
+ error "ERROR: in starbase_header: unexpected eof"
+ }
+
+ set H(H_$n) $line
+ set H(HLines) $n
+ set H(Header) [split $H(H_[expr $n-1]) "\t"]
+ set H(Dashes) [split $H(H_$n) "\t"]
+ set H(Ndshs) [llength $H(Dashes)]
+
+ starbase_colmap H
+
+ return H(Header)
+}
+
+proc starbase_hdrget { h name } {
+ upvar $h H
+
+ return $H(H_$name)
+}
+
+proc starbase_hdrset { h name value } {
+ upvar #0 $h H
+
+ if { ![info exists H(H_$name)] } {
+ set n [incr H(HLines)]
+
+ set H(H_[expr $n-0]) $H(H_[expr $n-1])
+ set H(H_[expr $n-1]) $H(H_[expr $n-2])
+ set H(N_$name) [expr $n-2]
+ }
+ set H(H_$name) $value
+ set H(H_$H(N_$name)) "$name $value"
+}
+
+proc starbase_hdrput { h fp } {
+ upvar $h H
+
+ if { ![info exists H(HLines)] || ($H(HLines) == 0) } {
+ return
+ }
+
+ set nl [expr $H(HLines) - 2]
+ for { set l 1 } { $l <= $nl } { incr l } {
+ puts $fp $H(H_$l)
+ }
+
+ if { ![info exists H(Ncols)] || ($H(Ncols) == 0) } {
+ return
+ }
+
+ set nc $H(Ncols)
+ for { set c 1 } { $c <= $nc } { incr c } {
+ puts -nonewline $fp "$H(0,$c)"
+ if { $c != $nc } {
+ puts -nonewline $fp "\t"
+ } else {
+ puts -nonewline $fp "\n"
+ }
+ }
+
+ for { set c 1 } { $c <= $nc } { incr c } {
+ set len [string length $H(0,$c)]
+ for { set d 1 } { $d <= $len } { incr d } {
+ puts -nonewline $fp "-"
+ }
+ if { $c != $nc } {
+ puts -nonewline $fp "\t"
+ } else {
+ puts -nonewline $fp "\n"
+ }
+ }
+}
+
+proc starbase_hdrput_ { h varname } {
+ upvar $h H
+ upvar $varname var
+
+ if { ![info exists H(HLines)] || ($H(HLines) == 0) } {
+ return
+ }
+
+ set nl [expr $H(HLines) - 2]
+ for { set l 1 } { $l <= $nl } { incr l } {
+ append var "$H(H_$l)\n"
+ }
+
+ if { ![info exists H(Ncols)] || ($H(Ncols) == 0) } {
+ return
+ }
+
+ set nc $H(Ncols)
+ for { set c 1 } { $c <= $nc } { incr c } {
+ append var "$H(0,$c)"
+ if { $c != $nc } {
+ append var "\t"
+ } else {
+ append var "\n"
+ }
+ }
+
+ for { set c 1 } { $c <= $nc } { incr c } {
+ set len [string length $H(0,$c)]
+ for { set d 1 } { $d <= $len } { incr d } {
+ append var "-"
+ }
+ if { $c != $nc } {
+ append var "\t"
+ } else {
+ append var "\n"
+ }
+ }
+}
+
+proc starbase_readfp { t fp } {
+ upvar $t T
+
+ starbase_header T $fp
+
+ set NCols [starbase_ncols T]
+
+ for { set r 1 } { [gets $fp line] != -1 } { incr r } {
+ if { [string index $line 0] == "\f" } {
+ global starbase_line
+ set starbase_line [string range $line 1 end]
+ break
+ }
+ set c 1
+ foreach val [split $line "\t"] {
+ set T($r,$c) [string trim $val]
+ incr c
+ }
+ for { } { $c <= $NCols } { incr c } {
+ set T($r,$c) {}
+ }
+ }
+ set T(Nrows) [expr $r-1]
+}
+
+proc starbase_read { t file } {
+ upvar $t T
+
+ set fp [open $file]
+ starbase_readfp T $fp
+ close $fp
+
+ set T(filename) $file
+}
+
+proc starbase_writefp { t fp } {
+ upvar $t T
+
+ starbase_hdrput T $fp
+
+ if { ![info exists T(Nrows)] || ($T(Nrows) == 0) } {
+ return
+ }
+
+ set nr $T(Nrows)
+ set nc $T(Ncols)
+ for { set r 1 } { $r <= $nr } { incr r } {
+ for { set c 1 } { $c < $nc } { incr c } {
+ if { [catch { set val $T($r,$c) }] } {
+ set val ""
+ }
+
+ puts -nonewline $fp "$val "
+ }
+ if { [catch { set val $T($r,$c) }] } {
+ set val ""
+ }
+ puts $fp $val
+ }
+}
+
+proc starbase_write { t file } {
+ upvar $t T
+
+ set fp [open $file w]
+ starbase_writefp T $fp
+ close $fp
+}
+
+proc starbase_write_ { t } {
+ upvar $t T
+
+ set rr {}
+ starbase_hdrput_ T rr
+
+ if { ![info exists T(Nrows)] || ($T(Nrows) == 0) } {
+ return
+ }
+
+ set nr $T(Nrows)
+ set nc $T(Ncols)
+ for { set r 1 } { $r <= $nr } { incr r } {
+ for { set c 1 } { $c < $nc } { incr c } {
+ if { [catch { set val $T($r,$c) }] } {
+ set val ""
+ }
+
+ append rr "$val "
+ }
+ if { [catch { set val $T($r,$c) }] } {
+ set val ""
+ }
+ append rr "$val\n"
+ }
+ return $rr
+}
+
+proc starbase_rowins { t row } {
+ upvar $t T
+
+ incr T(Nrows)
+
+ set nr $T(Nrows)
+ set nc $T(Ncols)
+ for { set r $nr } { $r > $row } { set r [expr $r-1] } {
+ for { set c 1 } { $c <= $nc } { incr c } {
+ if { [catch { set val $T([expr $r-1],$c) }] } {
+ set val ""
+ }
+
+ set T($r,$c) $val
+ }
+ }
+
+ for { set c 1 } { $c <= $nc } { incr c } {
+ set T($r,$c) ""
+ }
+}
+
+proc starbase_rowdel { t row } {
+ upvar $t T
+
+ incr T(Nrows) -1
+
+ set nr $T(Nrows)
+ set nc $T(Ncols)
+ for { set r $row } { $r <= $nr } { incr r } {
+ for { set c 1 } { $c <= $nc } { incr c } {
+ if { [catch { set val $T([expr $r+1],$c) }] } {
+ set val ""
+ }
+
+ set T($r,$c) $val
+ }
+ }
+
+ for { set c 1 } { $c <= $nc } { incr c } {
+ set T($r,$c) ""
+ }
+}
+
+proc starbase_httpreader { t wait sock http } {
+ global $t
+ global starbase_debug
+ upvar #0 $wait W
+ upvar #0 $t T
+
+ set T(http) $http
+
+ if { ![info exists T(state)] } {
+ error "ERROR: starbase_httpreader not properly initialized"
+ }
+
+ switch -- $T(state) {
+ 0 {
+ fconfigure $sock -blocking 1
+ set T(state) 1
+ set T(Nrows) 0
+ set T(HLines) 0
+ }
+
+ 1 {
+ incr ${t}(HLines)
+ set n $T(HLines)
+
+ if { [gets $sock line] == -1 } {
+ set T(state) -1
+ set T(HLines) [expr $T(HLines) - 1]
+ set T(Nrows) 0
+ return
+ }
+
+ set T(H_$n) $line
+ set l [split $line]
+ if { [llength $l] > 1 } {
+ set T(H_[lindex $l 0]) [lrange $l 1 end]
+ }
+ set T(H_$n) $line
+
+ if { [regexp -- {^ *(-)+ *(\t *(-)+ *)*} $line] } {
+ set T(Header) [split $T(H_[expr $n-1]) "\t"]
+ set T(Dashes) [split $T(H_$n) "\t"]
+ set T(Ndshs) [llength $T(Dashes)]
+
+ starbase_colmap T
+ set T(state) 2
+ }
+ }
+
+ 2 {
+ if { [gets $sock line] == -1 } {
+ set T(state) 0
+ } else {
+ if { $starbase_debug } {
+ puts [format "starbase_httpreader: %s" $line]
+ }
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols T]
+ set c 1
+ foreach val [split $line "\t"] {
+ set T($r,$c) $val
+ incr c
+ }
+ for { } { $c <= $NCols } { incr c } {
+ set T($r,$c) {}
+ }
+ }
+ }
+
+ default {
+ error "ERROR: unknown switch in starbase_httpreader"
+ }
+ }
+}
+
+proc starbase_cancel { t wait http } {
+ upvar #0 $wait W
+ upvar #0 $t T
+
+# set T(state) 0
+ set W 1
+}
+
+proc starbase_http { t url wait } {
+ upvar #0 $t T
+
+ set T(state) 0
+ set T(http) [http::geturl $url \
+ -handler [list starbase_httpreader $t $wait] \
+ -command [list starbase_cancel $t $wait]]
+}
+
+proc starbase_httpkill { t } {
+ upvar #0 $t T
+
+ http::reset $T(http)
+}
+
diff --git a/ds9/library/stdfbox.tcl b/ds9/library/stdfbox.tcl
new file mode 100644
index 0000000..1fc0676
--- /dev/null
+++ b/ds9/library/stdfbox.tcl
@@ -0,0 +1,547 @@
+# 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
+
+# do this after the language has been defined and the prefs sourced
+proc InitDialogBox {} {
+ global ds9
+ global pds9
+ global env
+
+ global fitsurl
+ set fitsurl {}
+
+ global fitsfbox
+ set fitsfbox(file) {ds9.fits}
+ set fitsfbox(dir) {}
+ set fitsfbox(types) [list \
+ [list {FITS} {*.fits}] \
+ [list {FITS} {*.FITS}] \
+ [list {FITS} {*.fit}] \
+ [list {FITS} {*.FIT}] \
+ [list {FITS} {*.fts}] \
+ [list {FITS} {*.FTS}] \
+ [list {FITS} {*.ds}] \
+ [list {FITS} {*.DS}] \
+ [list {FITS} {*.fits.gz}] \
+ [list {FITS} {*.fits.bz2}] \
+ [list {FITS} {*.fits.Z}] \
+ [list {FITS} {*.fits.z}] \
+ [list {FITS} {*.fitz}] \
+ [list {FITS} {*.FITZ}] \
+ [list {FITS} {*.ftz}] \
+ [list {FITS} {*.FTZ}] \
+ [list {FITS} {*.fz}] \
+ [list {FITS} {*.FZ}] \
+ ]
+
+ global savefitsfbox
+ set savefitsfbox(file) {ds9.fits}
+ set savefitsfbox(dir) {}
+ set savefitsfbox(types) [list \
+ [list {FITS} {*.fits}] \
+ [list {FITS} {*.fit}] \
+ [list {FITS} {*.fts}] \
+ [list {FITS} {*.fits.gz}] \
+ [list {FITS} {*.fits.bz2}] \
+ [list {FITS} {*.fits.Z}] \
+ [list {FITS} {*.fits.z}] \
+ ]
+
+ global epsfbox
+ set epsfbox(file) {ds9.eps}
+ set epsfbox(dir) {}
+ set epsfbox(types) [list \
+ [list {EPS} {*.eps}] \
+ ]
+ global arrayfbox
+ set arrayfbox(file) {ds9.arr}
+ set arrayfbox(dir) {}
+ set arrayfbox(types) [list \
+ [list [::msgcat::mc {Array}] {*.arr}] \
+ ]
+ global rgbarrayfbox
+ set rgbarrayfbox(file) {ds9.rgb}
+ set rgbarrayfbox(dir) {}
+ set rgbarrayfbox(types) [list \
+ [list [::msgcat::mc {RGB Array}] {*.rgb}] \
+ ]
+ global nrrdfbox
+ set nrrdfbox(file) {ds9.nrrd}
+ set nrrdfbox(dir) {}
+ set nrrdfbox(types) [list \
+ [list {NRRD} {*.nrrd}] \
+ ]
+ global envifbox
+ set envifbox(file) {ds9.hdr}
+ set envifbox(dir) {}
+ set envifbox(types) [list \
+ [list {ENVI} {*.hdr}] \
+ ]
+ global envi2fbox
+ set envi2fbox(file) {ds9.bsq}
+ set envi2fbox(dir) {}
+ set envi2fbox(types) [list \
+ [list {ENVI2} {*.bil}] \
+ [list {ENVI2} {*.bip}] \
+ [list {ENVI2} {*.bsq}] \
+ [list {ENVI2} {*.cube}] \
+ ]
+ global giffbox
+ set giffbox(file) {ds9.gif}
+ set giffbox(dir) {}
+ set giffbox(types) [list \
+ [list {GIF} {*.gif}] \
+ ]
+ global jpegfbox
+ set jpegfbox(file) {ds9.jpeg}
+ set jpegfbox(dir) {}
+ set jpegfbox(types) [list \
+ [list {JPEG} {*.jpeg}] \
+ [list {JPEG} {*.jpg}] \
+ ]
+ global tifffbox
+ set tifffbox(file) {ds9.tiff}
+ set tifffbox(dir) {}
+ set tifffbox(types) [list \
+ [list {TIFF} {*.tiff}] \
+ [list {TIFF} {*.tif}] \
+ ]
+ global pngfbox
+ set pngfbox(file) {ds9.png}
+ set pngfbox(dir) {}
+ set pngfbox(types) [list \
+ [list {PNG} {*.png}] \
+ ]
+ global mpegfbox
+ set mpegfbox(file) {ds9.mpeg}
+ set mpegfbox(dir) {}
+ set mpegfbox(types) [list \
+ [list {MPEG} {*.mpeg}] \
+ [list {MPEG} {*.mpg}] \
+ ]
+
+ global pixelfbox
+ set pixelfbox(file) {ds9.pix}
+ set pixelfbox(dir) {}
+ set pixelfbox(types) [list \
+ [list {PIX} {*.pix}] \
+ ]
+
+ global markerfbox
+ set markerfbox(file) {ds9.reg}
+ set markerfbox(dir) {}
+ set markerfbox(types) [list \
+ [list {REG} {*.reg}] \
+ [list {FITS} {*.fits}] \
+ [list {XML} {*.xml}] \
+ ]
+
+ global templatefbox
+ set templatefbox(file) {ds9.tpl}
+ set templatefbox(dir) {}
+ set templatefbox(types) \
+ [list [list {TPL} {*.tpl}] [list [::msgcat::mc {All}] {*}] ]
+
+ global colorbarfbox
+ set colorbarfbox(file) {ds9.sao}
+ set colorbarfbox(dir) {}
+ set colorbarfbox(types) [list \
+ [list [::msgcat::mc {Colormap}] {*.sao}] \
+ [list [::msgcat::mc {Colormap}] {*.lut}] \
+ ]
+
+ global contrastbiasfbox
+ set contrastbiasfbox(file) {ds9.cb}
+ set contrastbiasfbox(dir) {}
+ set contrastbiasfbox(types) [list \
+ [list {CB} {*.cb}] \
+ ]
+
+ global colortagfbox
+ set colortagfbox(file) {ds9.tag}
+ set colortagfbox(dir) {}
+ set colortagfbox(types) [list \
+ [list {Colortag} {*.tag}] \
+ ]
+
+ global pssavfbox
+ set pssavfbox(file) {ds9.ps}
+ set pssavfbox(dir) {}
+ set pssavfbox(types) [list \
+ [list {PS} {*.ps}] \
+ ]
+
+ global prsavfbox
+ set prsavfbox(file) {ds9.txt}
+ set prsavfbox(dir) {}
+ set prsavfbox(types) [list \
+ [list {TXT} {*.txt}] \
+ ]
+
+ # contour load
+ global contourlfbox
+ set contourlfbox(file) {ds9.ctr}
+ set contourlfbox(dir) {}
+ set contourlfbox(types) [list \
+ [list {CTR} {*.ctr}] \
+ [list {CON} {*.con}] \
+ ]
+
+ # contour save
+ global contoursfbox
+ set contoursfbox(file) {ds9.ctr}
+ set contoursfbox(dir) {}
+ set contoursfbox(types) [list \
+ [list {CTR} {*.ctr}] \
+ ]
+
+ # contour level load
+ global contourlevlfbox
+ set contourlevlfbox(file) {ds9.ctr}
+ set contourlevlfbox(dir) {}
+ set contourlevlfbox(types) [list \
+ [list {CTR} {*.ctr}] \
+ [list {LEV} {*.lev}] \
+ ]
+
+ # contour level save
+ global contourlevsfbox
+ set contourlevsfbox(file) {ds9.lev}
+ set contourlevsfbox(dir) {}
+ set contourlevsfbox(types) [list \
+ [list {LEV} {*.lev}] \
+ ]
+
+ global gridfbox
+ set gridfbox(file) {ds9.grd}
+ set gridfbox(dir) {}
+ set gridfbox(types) [list \
+ [list {GRD} {*.grd}] \
+ ]
+
+ global catfbox
+ set catfbox(file) {ds9.cat}
+ set catfbox(dir) {}
+ set catfbox(types) [list \
+ [list [::msgcat::mc {Catalog}] {*.cat}] \
+ [list [::msgcat::mc {Catalog}] {*.rdb}] \
+ ]
+
+ global cattsvfbox
+ set cattsvfbox(file) {ds9.tsv}
+ set cattsvfbox(dir) {}
+ set cattsvfbox(types) [list \
+ [list [::msgcat::mc {Catalog}] {*.tsv}] \
+ [list [::msgcat::mc {Catalog}] {*.csv}] \
+ ]
+
+ global catvotfbox
+ set catvotfbox(file) {ds9.xml}
+ set catvotfbox(dir) {}
+ set catvotfbox(types) [list \
+ [list [::msgcat::mc {Catalog}] {*.xml}] \
+ [list [::msgcat::mc {Catalog}] {*.vot}] \
+ [list [::msgcat::mc {Catalog}] {*.votable}] \
+ ]
+
+ global catfltfbox
+ set catfltfbox(file) {ds9.flt}
+ set catfltfbox(dir) {}
+ set catfltfbox(types) [list \
+ [list {FLT} {*.flt}] \
+ ]
+
+ global catsymfbox
+ set catsymfbox(file) {ds9.sym}
+ set catsymfbox(dir) {}
+ set catsymfbox(types) [list \
+ [list {SYM} {*.sym}] \
+ ]
+
+ global catcdssrchfbox
+ set catcdssrchfbox(file) {ds9.cds}
+ set catcdssrchfbox(dir) {}
+ set catcdssrchfbox(types) [list \
+ [list {CDS} {*.cds}] \
+ ]
+
+ global analysisfbox
+ set analysisfbox(file) {ds9.ans}
+ set analysisfbox(dir) {}
+ set analysisfbox(types) [list \
+ [list [::msgcat::mc {Analysis}] {*.ans}] \
+ [list [::msgcat::mc {Analysis}] {*.ds9}] \
+ ]
+
+ global analysisparamfbox
+ set analysisparamfbox(file) {}
+ set analysisparamfbox(dir) {}
+ set analysisparamfbox(types) [list \
+ ]
+
+ global apsavfbox
+ set apsavfbox(file) {ds9.ps}
+ set apsavfbox(dir) {}
+ set apsavfbox(types) [list \
+ [list {PS} {*.ps}] \
+ ]
+
+ global apdatafbox
+ set apdatafbox(file) {ds9.dat}
+ set apdatafbox(dir) {}
+ set apdatafbox(types) [list \
+ [list {DAT} {*.dat}] \
+ ]
+
+ global apconfigfbox
+ set apconfigfbox(file) {ds9.plt}
+ set apconfigfbox(dir) {}
+ set apconfigfbox(types) [list \
+ [list {PLT} {*.plt}] \
+ ]
+
+ global textfbox
+ set textfbox(file) {ds9.txt}
+ set textfbox(dir) {}
+ set textfbox(types) [list \
+ [list {TXT} {*.txt}] \
+ ]
+
+ global tclfbox
+ set tclfbox(file) {ds9.tcl}
+ set tclfbox(dir) {}
+ set tclfbox(types) [list \
+ [list {TCL} {*.tcl}] \
+ ]
+
+ global hvhtmlfbox
+ set hvhtmlfbox(file) {ds9.html}
+ set hvhtmlfbox(dir) {}
+ set hvhtmlfbox(types) [list \
+ [list {HTML} {*.html}] \
+ [list {HTML} {*.htm}] \
+ ]
+
+ global wcsfbox
+ set wcsfbox(file) {ds9.wcs}
+ set wcsfbox(dir) {}
+ set wcsfbox(types) [list \
+ [list {WCS} {*.wcs}] \
+ ]
+
+ global backupfbox
+ set backupfbox(file) {ds9.bck}
+ set backupfbox(dir) {}
+ set backupfbox(types) [list \
+ [list {BCK} {*.bck}] \
+ ]
+
+}
+
+proc SetFileLast {format item} {
+ switch $format {
+ mecube -
+ multiframe -
+ mosaic -
+ mosaicimage -
+ rgbcube -
+ rgbimage -
+ fits {FileLast fitsfbox $item}
+
+ array {FileLast arrayfbox $item}
+ rgbarray {FileLast rgbarrayfbox $item}
+ envi {FileLast envifbox $item}
+ envi2 {FileLast envi2fbox $item}
+ gif {FileLast giffbox $item}
+ jpeg {FileLast jpegfbox $item}
+ nrrd {FileLast nrrdfbox $item}
+ tiff {FileLast tifffbox $item}
+ png {FileLast pngfbox $item}
+
+ sfits -
+ srgbcube -
+ sfits -
+ smosaic -
+ url {}
+ }
+}
+
+proc ExtToFormat {fn} {
+ switch -- [file extension $fn] {
+ .fits -
+ .FITS -
+ .fit -
+ .FIT -
+ .fts -
+ .FTS -
+ .ds -
+ .DS -
+ .fits.gz -
+ .fits.bz2 -
+ .fits.Z -
+ .fits.z -
+ .fitz -
+ .FITZ -
+ .ftz -
+ .FTZ -
+ .fz -
+ .FZ {return fits}
+ .arr -
+ .array {return array}
+ .rgb {return rgbarray}
+ .nrrd {return nrrd}
+ .eps -
+ .epsf {return eps}
+ .gif -
+ .giff {return gif}
+ .jpg -
+ .jpeg {return jpeg}
+ .tif -
+ .tiff {return tiff}
+ .png {return png}
+ .mpg -
+ .mpeg {return mpeg}
+ .hdr -
+ .bil -
+ .bip -
+ .bsq -
+ .cube {return envi}
+ }
+}
+
+# used by backup
+proc OpenFileDialog {varname} {
+ return [FileDialog $varname tk_getOpenFile]
+}
+
+proc SaveFileDialog {varname} {
+ return [FileDialog $varname tk_getSaveFile]
+}
+
+proc FileDialog {varname which} {
+ global pds9
+
+ switch -- $pds9(dialog) {
+ motif {return [FileDialogMotif $varname $which]}
+ windows {return [FileDialogWindows $varname $which]}
+ native {return [FileDialogNative $varname $which]}
+ }
+}
+
+proc FileDialogMotif {varname which} {
+ upvar #0 $varname var
+ global ds9
+ global pds9
+
+ switch -- $which {
+ tk_getOpenFile {set type open}
+ tk_getSaveFile {set type save}
+ }
+
+
+ if {$pds9(dialog,all)} {
+ set types [linsert $var(types) 0 [list [::msgcat::mc {All}] {*}]]
+ } else {
+ set types [linsert $var(types) end [list [::msgcat::mc {All}] {*}]]
+ }
+
+ set result [::tk::MotifFDialog $type \
+ -filetypes $types \
+ -initialdir $var(dir) \
+ -initialfile $var(file) \
+ -parent $ds9(top)]
+
+ if {$result != {}} {
+ set var(file) [file tail $result]
+ set var(dir) [file dirname $result]
+ }
+
+ return $result
+}
+
+proc FileDialogWindows {varname which} {
+ upvar #0 $varname var
+ global ds9
+ global pds9
+
+ switch -- $which {
+ tk_getOpenFile {set type open}
+ tk_getSaveFile {set type save}
+ }
+
+ if {$pds9(dialog,all)} {
+ set types [linsert $var(types) 0 [list [::msgcat::mc {All}] {*}]]
+ } else {
+ set types [linsert $var(types) end [list [::msgcat::mc {All}] {*}]]
+ }
+
+ set result [::tk::dialog::file:: $type \
+ -filetypes $types \
+ -initialdir $var(dir) \
+ -initialfile $var(file) \
+ -parent $ds9(top)]
+
+ if {$result != {}} {
+ set var(file) [file tail $result]
+ set var(dir) [file dirname $result]
+ }
+
+ return $result
+}
+
+proc FileDialogNative {varname which} {
+ upvar #0 $varname var
+ global ds9
+ global pds9
+
+ if {$pds9(dialog,all)} {
+ set types [linsert $var(types) 0 [list [::msgcat::mc {All}] {*}]]
+ } else {
+ set types [linsert $var(types) end [list [::msgcat::mc {All}] {*}]]
+ }
+
+ if {[catch {$which \
+ -filetypes $types \
+ -initialdir $var(dir) \
+ -initialfile $var(file) \
+ -parent $ds9(top)} result]} {
+
+ # must have a bad file name, just clear and try again
+ set var(file) {}
+ set var(dir) {}
+ if {[catch {$which \
+ -filetypes $types \
+ -parent $ds9(top)} result]} {
+
+ #ok, something is really wrong
+ catch {$which -parent $ds9(top)} result
+ }
+ }
+
+ if {$result != {}} {
+ set var(file) [file tail $result]
+ set var(dir) [file dirname $result]
+ }
+
+ return $result
+}
+
+
+proc FileLast {varname fn} {
+ upvar #0 $varname var
+ global ds9
+
+ switch $ds9(wm) {
+ x11 {
+ set var(file) [file tail $fn]
+ set var(dir) [file dirname $fn]
+ }
+ aqua {
+ # don't conflict with native dialog
+ }
+ win32 {}
+ }
+}
diff --git a/ds9/library/stsci.tcl b/ds9/library/stsci.tcl
new file mode 100644
index 0000000..a7799d7
--- /dev/null
+++ b/ds9/library/stsci.tcl
@@ -0,0 +1,182 @@
+# 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 STSCIDef {} {
+ global stsci
+ global istsci
+
+ set istsci(top) .stsci
+ set istsci(mb) .stscimb
+
+ set stsci(sky) fk5
+ set stsci(rformat) arcmin
+ set stsci(width) 15
+ set stsci(height) 15
+ set stsci(mode) new
+ set stsci(save) 0
+ set stsci(survey) {all}
+}
+
+proc STSCIDialog {} {
+ global stsci
+ global istsci
+ global wcs
+
+ if {[winfo exists $istsci(top)]} {
+ raise $istsci(top)
+ return
+ }
+
+ set varname dstscii
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $istsci(top)
+ set var(mb) $istsci(mb)
+ set var(sky) $stsci(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $stsci(rformat)
+ set var(width) $stsci(width)
+ set var(height) $stsci(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(mode) $stsci(mode)
+ set var(save) $stsci(save)
+ set var(survey) $stsci(survey)
+
+ set w $var(top)
+ IMGSVRInit $varname "STSCI-DSS [msgcat::mc {Server}]" \
+ STSCIExec STSCIAck ARDone ARError
+
+ menu $var(mb).survey
+ $var(mb) add cascade -label Survey -menu $var(mb).survey
+ $var(mb).survey add radiobutton -label {POSS2/UKSTU Red} \
+ -variable ${varname}(survey) -value poss2ukstu_red
+ $var(mb).survey add radiobutton -label {POSS2/UKSTU Infrared} \
+ -variable ${varname}(survey) -value poss2ukstu_ir
+ $var(mb).survey add radiobutton -label {POSS2/UKSTU Blue} \
+ -variable ${varname}(survey) -value poss2ukstu_blue
+ $var(mb).survey add radiobutton \
+ -label {POSS1 (First Generation) Blue} \
+ -variable ${varname}(survey) -value poss1_blue
+ $var(mb).survey add radiobutton \
+ -label {POSS1 (First Generation) Red} \
+ -variable ${varname}(survey) -value poss1_red
+ $var(mb).survey add radiobutton \
+ -label {Best of a combined list of all plates} \
+ -variable ${varname}(survey) -value all
+ $var(mb).survey add radiobutton \
+ -label {Quick-V Survey} \
+ -variable ${varname}(survey) -value quickv
+ $var(mb).survey add radiobutton \
+ -label {HST Phase 2 Target Positioning (GSC 2)} \
+ -variable ${varname}(survey) -value phase2_gsc2
+ $var(mb).survey add radiobutton \
+ -label {HST Phase 2 Target Positioning (GSC 1)} \
+ -variable ${varname}(survey) -value phase2_gsc1
+
+ IMGSVRUpdate $varname
+}
+
+proc STSCIExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set compress none
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set compress gz
+ set var(fn) [tmpnam {.fits.gz}]
+ }
+
+ # size - convert to arcmin
+ switch -- $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcmin {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcsec {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ }
+ if {$ww>60} {
+ set ww 60
+ }
+ if {$hh>60} {
+ set hh 60
+ }
+
+ # query
+ set var(query) [http::formatQuery r $var(x) d $var(y) e J2000 w $ww h $hh f fits c $compress v $var(survey)]
+ set url "http://stdatu.stsci.edu/cgi-bin/dss_search"
+ IMGSVRGetURL $varname $url
+}
+
+proc STSCIAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the DSS-STSCI
+
+The Digitized Sky Surveys were produced at the Space Telescope Science
+Institute under U.S. Government grant NAG W-2166. The images of these
+surveys are based on photographic data obtained using the Oschin
+Schmidt Telescope on Palomar Mountain and the UK Schmidt Telescope.
+The plates were processed into the present compressed digital form
+with the permission of these institutions.
+
+The National Geographic Society - Palomar Observatory Sky Atlas
+(POSS-I) was made by the California Institute of Technology with
+grants from the National Geographic Society.
+
+The Second Palomar Observatory Sky Survey (POSS-II) was made by the
+California Institute of Technology with funds from the National
+Science Foundation, the National Geographic Society, the Sloan
+Foundation, the Samuel Oschin Foundation, and the Eastman Kodak
+Corporation.
+
+The Oschin Schmidt Telescope is operated by the California Institute
+of Technology and Palomar Observatory.
+
+The UK Schmidt Telescope was operated by the Royal Observatory
+Edinburgh, with funding from the UK Science and Engineering Research
+Council (later the UK Particle Physics and Astronomy Research Council),
+until 1988 June, and thereafter by the Anglo-Australian
+Observatory. The blue plates of the southern Sky Atlas and its
+Equatorial Extension (together known as the SERC-J), as well as the
+Equatorial Red (ER), and the Second Epoch [red] Survey (SES) were all
+taken with the UK Schmidt.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc ProcessSTSCICmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ STSCIDialog
+ IMGSVRProcessCmd $varname $iname dstscii
+}
+
+proc ProcessSendSTSCICmd {proc id param} {
+ STSCIDialog
+ IMGSVRProcessSendCmd $proc $id $param dstscii
+}
diff --git a/ds9/library/template.tcl b/ds9/library/template.tcl
new file mode 100644
index 0000000..107dcbf
--- /dev/null
+++ b/ds9/library/template.tcl
@@ -0,0 +1,130 @@
+# 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 TemplateDef {} {
+ global itemplate
+
+ # chandra
+ set itemplate(chandra,acis,acis-i) {chandra/acis/acis-i.tpl}
+ set itemplate(chandra,acis,acis-s) {chandra/acis/acis-s.tpl}
+ set itemplate(chandra,acis,acis-is) {chandra/acis/acis-is.tpl}
+ set itemplate(chandra,acis,acis-si) {chandra/acis/acis-si.tpl}
+ set itemplate(chandra,hrc,hrc-i) {chandra/hrc/hrc-i.tpl}
+ set itemplate(chandra,hrc,hrc-s) {chandra/hrc/hrc-s.tpl}
+
+ # xmm
+ set itemplate(xmm,epicmos1) {xmm/epicmos1.tpl}
+ set itemplate(xmm,epicmos2) {xmm/epicmos2.tpl}
+ set itemplate(xmm,epicpn) {xmm/epicpn.tpl}
+
+ # heasarc
+ # suzaku
+ set itemplate(heasarc,suzaku,hxd) {heasarc/suzaku/hxd.tpl}
+ set itemplate(heasarc,suzaku,xis) {heasarc/suzaku/xis.tpl}
+ set itemplate(heasarc,suzaku,xrs) {heasarc/suzaku/xrs.tpl}
+
+ # mmt
+ # megacam
+ set itemplate(mmt,megacam,megacam-amp) {mmt/megacam/megacam-amp.tpl}
+ set itemplate(mmt,megacam,megacam-amp-guide) {mmt/megacam/megacam-amp-guide.tpl}
+ set itemplate(mmt,megacam,megacam-chip) {mmt/megacam/megacam-chip.tpl}
+ set itemplate(mmt,megacam,megacam-chip-guide) {mmt/megacam/megacam-chip-guide.tpl}
+ # hecto
+ set itemplate(mmt,hecto,hectospec) {mmt/hecto/hectospec.tpl}
+ set itemplate(mmt,hecto,hectochelle) {mmt/hecto/hectochelle.tpl}
+ # mmirs
+ set itemplate(mmt,mmirs,image) {mmt/mmirs/image.tpl}
+ set itemplate(mmt,mmirs,longslit) {mmt/mmirs/longslit.tpl}
+ set itemplate(mmt,mmirs,mask) {mmt/mmirs/mask.tpl}
+ # others
+ set itemplate(mmt,swirc) {mmt/swirc.tpl}
+ set itemplate(mmt,binospec) {mmt/binospec.tpl}
+}
+
+proc CreateFOVMenu {} {
+ global ds9
+ global itemplate
+ global marker
+
+ set mm $ds9(mb).region.fov
+ menu $mm
+
+ set l0 {}
+ set l1 {}
+ set l2 {}
+
+ foreach t [lsort [array names itemplate]] {
+ set tt [split $t ","]
+ set t0 [lindex $tt 0]
+ set t1 [lindex $tt 1]
+ set t2 [lindex $tt 2]
+
+ if {$l0 != $t0} {
+ menu $mm.$t0
+ $mm add cascade -label [string toupper $t0] -menu $mm.$t0
+ set l0 $t0
+ set l1 {}
+ set l2 {}
+ }
+
+ if {$l1 != $t1} {
+ if {$t2 != {}} {
+ menu $mm.$t0.$t1
+ $mm.$t0 add cascade -label [string toupper $t1] \
+ -menu $mm.$t0.$t1
+ set l1 $t1
+ set l2 {}
+ } else {
+ $mm.$t0 add radiobutton \
+ -label [string toupper $t1] -variable marker(shape) \
+ -value $t
+ continue
+ }
+ }
+
+ $mm.$t0.$t1 add radiobutton -label [string toupper $t2] \
+ -variable marker(shape) -value $t
+ }
+}
+
+proc OpenTemplateMarker {} {
+ LoadTemplateMarker [OpenFileDialog templatefbox]
+}
+
+proc LoadTemplateMarker {fn} {
+ global ds9
+ global current
+
+ if {$current(frame) != {} && $fn != {}} {
+ set cc [$ds9(canvas) coords $current(frame)]
+ set ww [lindex [$current(frame) configure -width] 4]
+ set hh [lindex [$current(frame) configure -height] 4]
+ set xx [expr [lindex $cc 0]+$ww/2.0]
+ set yy [expr [lindex $cc 1]+$hh/2.0]
+
+ catch {$current(frame) marker create template "\{$fn\}" $xx $yy}
+ }
+}
+
+proc LoadTemplateMarkerAt {fn ra dec sys sky} {
+ global current
+
+ if {$current(frame) != {} && $fn != {}} {
+ catch {$current(frame) marker create template "\{$fn\}" $sys $sky $ra $dec}
+ }
+}
+
+proc SaveAsTemplateMarker {} {
+ global current
+
+ if {$current(frame) != {}} {
+ set fn [SaveFileDialog templatefbox]
+
+ if {$fn != {}} {
+ $current(frame) marker save template "\{$fn\}"
+ }
+ }
+}
diff --git a/ds9/library/text.tcl b/ds9/library/text.tcl
new file mode 100644
index 0000000..0ada0a6
--- /dev/null
+++ b/ds9/library/text.tcl
@@ -0,0 +1,93 @@
+# 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 TextDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set var(canrotate) [$var(frame) get marker $var(id) text rotate]
+
+ # procs
+ set var(which) text
+ set var(proc,apply) TextApply
+ set var(proc,close) TextClose
+ set var(proc,coordCB) TextCoordCB
+
+ # base
+ MarkerBaseCenterDialog $varname
+
+ # init
+ MarkerBaseCenterRotateCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback rotate MarkerBaseCenterRotateCB \
+ $varname
+
+ set f $var(top).param
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ # Rotate
+ ttk::label $f.trotate -text [msgcat::mc {Rotate}]
+ ttk::checkbutton $f.rotate -variable ${varname}(canrotate) \
+ -command "TextRotate $varname"
+
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+ grid $f.trotate $f.rotate -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc TextClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback rotate MarkerBaseCenterRotateCB
+
+ MarkerBaseCenterClose $varname
+}
+
+proc TextApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ MarkerBaseCenterRotate $varname
+ MarkerBaseCenterApply $varname
+}
+
+proc TextRotate {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) text rotate $var(canrotate)
+}
+
+# callbacks
+
+proc TextCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "TextCoordCB"
+ }
+
+ MarkerBaseCoordCB $varname
+ MarkerBaseCenterMoveCB $varname
+ MarkerBaseCenterRotateCB $varname
+}
+
diff --git a/ds9/library/tkfbox.tcl b/ds9/library/tkfbox.tcl
new file mode 100644
index 0000000..66cd74e
--- /dev/null
+++ b/ds9/library/tkfbox.tcl
@@ -0,0 +1,1247 @@
+# tkfbox.tcl --
+#
+# Implements the "TK" standard file selection dialog box. This dialog
+# box is used on the Unix platforms whenever the tk_strictMotif flag is
+# not set.
+#
+# The "TK" standard file selection dialog box is similar to the file
+# selection dialog box on Win95(TM). The user can navigate the
+# directories by clicking on the folder icons or by selecting the
+# "Directory" option menu. The user can select files by clicking on the
+# file icons or by entering a filename in the "Filename:" entry.
+#
+# Copyright (c) 1994-1998 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+namespace eval ::tk::dialog {}
+namespace eval ::tk::dialog::file {
+ namespace import -force ::tk::msgcat::*
+ variable showHiddenBtn 0
+ variable showHiddenVar 1
+
+ # Create the images if they did not already exist.
+ if {![info exists ::tk::Priv(updirImage)]} {
+ set ::tk::Priv(updirImage) [image create photo -data {
+ iVBORw0KGgoAAAANSUhEUgAAABYAAAAWCAYAAADEtGw7AAAABmJLR0QA/gD+AP7rGN
+ SCAAAACXBIWXMAAA3WAAAN1gGQb3mcAAAACXZwQWcAAAAWAAAAFgDcxelYAAAENUlE
+ QVQ4y7WUbWiVZRjHf/f9POcc9+Kc5bC2aIq5sGG0XnTzNU13zAIlFMNc9CEhTCKwCC
+ JIgt7AglaR0RcrolAKg14+GBbiGL6xZiYyy63cmzvu7MVznnOe537rw7bDyvlBoT/c
+ n+6L3/3nf13XLZLJJP+HfICysjKvqqpq+rWKysvLR1tbW+11g+fPn/+bEGIe4KYqCs
+ Owu66u7oG2trah6wJrrRc0NTVhjME5h7Vj5pxzCCE4duxYZUdHx/aGhoZmgJ+yb+wF
+ uCO19RmAffv25f8LFslkktraWtvU1CS6u7vRWmOtxVpbAPu+T0tLS04pFU/J34Wd3S
+ cdFtlfZWeZBU4IcaS5uXn1ZLAEMMY4ay1aa4wx/zpKKYIgoL6+vmjxqoXe5ZLTcsPq
+ bTyycjODpe1y3WMrvDAMV14jCuW0VhhjiJQpOJ5w7Zwjk8/y9R+vsHHNNq6oFMrkeX
+ BxI+8d2sktap3YvOPD0lRQrH+Z81fE7t3WB4gihVKazsuaA20aKSUgAG/seQdy2l6W
+ 37+EyopqTv39I6HJUT2zlnlza2jLdgiTaxwmDov6alLHcZUTzXPGGAauWJbfO4dHl9
+ bgJs3HyfNf0N4ZsOa+jbT3/ownY/hO09p1kBULtjBw+Tvq7xzwauds4dWPDleAcP5E
+ xlprgtBRUZRgYCRPTzoHwEi2g6OnX+eFrW/RM9qBE4p43CeTz5ATaU6nDrFm2cPs/+
+ E1SopqkZ7MFJqntXZaa7IKppckwIEvJbg8LWd28OT6nVihCPQQ8UScWCLGqO4hXuQx
+ qDtJ204eWrqWb1ufRspwtABWaqx5gRKUFSdwDnxPcuLcyyxbuIyaqntIBV34MY9YzC
+ Owg+S9YeJFkniRpGPkCLMrZzG3+jbktA/KClMxFoUhiKC0OAbAhd79CO8i6xe/STyW
+ 4O7KVRgUJ/sP0heeJV4kEVKw/vZd40sFKxat4mLvp6VLdvnb/XHHGGPIKwBBpC1/9n
+ 3DpfRZnn9/AwCxRII9O79kVPdjvByxuET6Ai8mePeTt4lyheXzhOSpCcdWa00uckTG
+ kckbGu76nEhbIm2xznH4VB3OWYaiXqQn8GKSWGIMHuXyPL76LBcupmhp69pz4uMnXi
+ w4VloTGcdQRtGdzmHs1f+RdYZslMZJhzUOHVnceN1ooEiP5JUzdqCQMWCD0JCIeQzn
+ NNpO+clhrCYf5rC+A2cxWmDUWG2oHEOZMEKIwclgMnnLrTeXUV7sUzpNXgU9DmijWV
+ v9LEKCkAIhKIBnlvpks6F21qUZ31u/sbExPa9h0/RzwzMov2nGlG5TmW1YOzzlnSfL
+ mVnyGf19Q7lwZHBp+1fPtflAIgiC7389n9qkihP+lWyeqfUO15ZwQTqlw9H+o2cOvN
+ QJCAHEgEqgYnI0NyALjAJdyWQy7wMa6AEujUdzo3LjcAXwD/XCTKIRjWytAAAAJXRF
+ WHRjcmVhdGUtZGF0ZQAyMDA5LTA0LTA2VDIxOjI1OjQxLTAzOjAw8s+uCAAAACV0RV
+ h0bW9kaWZ5LWRhdGUAMjAwOC0wMS0wM1QxNTowODoyMS0wMjowMJEc/44AAAAZdEVY
+ dFNvZnR3YXJlAHd3dy5pbmtzY2FwZS5vcmeb7jwaAAAAAElFTkSuQmCC
+ }]
+ }
+ if {![info exists ::tk::Priv(folderImage)]} {
+ set ::tk::Priv(folderImage) [image create photo -data {
+ iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABHNCSVQICAgIfAhkiA
+ AAAAlwSFlzAAAN1wAADdcBQiibeAAAABl0RVh0U29mdHdhcmUAd3d3Lmlua3NjYXBl
+ Lm9yZ5vuPBoAAAHCSURBVDiNpZAxa5NRFIafc+9XLCni4BC6FBycMnbrLpkcgtDVX6
+ C70D/g4lZX/4coxLlgxFkpiiSSUGm/JiXfveee45AmNlhawXc53HvPee55X+l2u/yP
+ qt3d3Tfu/viatwt3fzIYDI5uBJhZr9fr3TMzzAx3B+D09PR+v98/7HQ6z5fNOWdCCG
+ U4HH6s67oAVDlnV1UmkwmllBUkhMD29nYHeLuEAkyn06qU8qqu64MrgIyqYmZrkHa7
+ 3drc3KTVahFjJITAaDRiPB4/XFlQVVMtHH5IzJo/P4EA4MyB+erWPQB7++zs7ccYvl
+ U5Z08pMW2cl88eIXLZeDUpXzsBkNQ5eP1+p0opmaoCTgzw6fjs6gLLsp58FB60t0Dc
+ K1Ul54yIEIMQ43Uj68pquDmCeJVztpwzuBNE2LgBoMVpslHMCUEAFgDVxQbzVAiA+a
+ K5uGPmmDtZF3VpoUm2ArhqQaRiUjcMf81p1G60UEVhcjZfAFTVUkrgkS+jc06mDX9n
+ vq4YhJ9nlxZExMwMEaHJRutOdWuIIsJFUoBSuTvHJ4YIfP46unV4qdlsjsBRZRtb/X
+ fHd5+C8+P7+J8BIoxFwovfRxYhnhxjpzEAAAAASUVORK5CYII=
+ }]
+ }
+ if {![info exists ::tk::Priv(fileImage)]} {
+ set ::tk::Priv(fileImage) [image create photo -data {
+ iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gva
+ eTAAAACXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1QQWFA84umAmQgAAANpJREFU
+ OMutkj1uhDAQhb8HSLtbISGfgZ+zbJkix0HmFhwhUdocBnMBGvqtTIqIFSReWKK8ai
+ x73nwzHrVt+zEMwwvH9FrX9TsA1trpqKy10+yUzME4jnjvAZB0LzXHkojjmDRNVyh3
+ A+89zrlVwlKSqKrqVy/J8lAUxSZBSMny4ZLgp54iyPM8UPHGNJ2IomibAKDv+9VlWZ
+ bABbgB5/0WQgSSkC4PF2JF4JzbHN430c4vhAm0TyCJruuClefph4yCBCGT3T3Isoy/
+ KDHGfDZNcz2SZIx547/0BVRRX7n8uT/sAAAAAElFTkSuQmCC
+ }]
+ }
+}
+
+# ::tk::dialog::file:: --
+#
+# Implements the TK file selection dialog. This dialog is used when the
+# tk_strictMotif flag is set to false. This procedure shouldn't be
+# called directly. Call tk_getOpenFile or tk_getSaveFile instead.
+#
+# Arguments:
+# type "open" or "save"
+# args Options parsed by the procedure.
+#
+
+proc ::tk::dialog::file:: {type args} {
+ variable ::tk::Priv
+ variable showHiddenBtn
+ set dataName __tk_filedialog
+ upvar ::tk::dialog::file::$dataName data
+
+ Config $dataName $type $args
+
+ if {$data(-parent) eq "."} {
+ set w .$dataName
+ } else {
+ set w $data(-parent).$dataName
+ }
+
+ # (re)create the dialog box if necessary
+ #
+ if {![winfo exists $w]} {
+ Create $w TkFDialog
+ } elseif {[winfo class $w] ne "TkFDialog"} {
+ destroy $w
+ Create $w TkFDialog
+ } else {
+ set data(dirMenuBtn) $w.contents.f1.menu
+ set data(dirMenu) $w.contents.f1.menu.menu
+ set data(upBtn) $w.contents.f1.up
+ set data(icons) $w.contents.icons
+ set data(ent) $w.contents.f2.ent
+ set data(typeMenuLab) $w.contents.f2.lab2
+ set data(typeMenuBtn) $w.contents.f2.menu
+ set data(typeMenu) $data(typeMenuBtn).m
+ set data(okBtn) $w.contents.f2.ok
+ set data(cancelBtn) $w.contents.f2.cancel
+ set data(hiddenBtn) $w.contents.f2.hidden
+ SetSelectMode $w $data(-multiple)
+ }
+ if {$showHiddenBtn} {
+ $data(hiddenBtn) configure -state normal
+ grid $data(hiddenBtn)
+ } else {
+ $data(hiddenBtn) configure -state disabled
+ grid remove $data(hiddenBtn)
+ }
+
+ # Make sure subseqent uses of this dialog are independent [Bug 845189]
+ unset -nocomplain data(extUsed)
+
+ # Dialog boxes should be transient with respect to their parent, so that
+ # they will always stay on top of their parent window. However, some
+ # window managers will create the window as withdrawn if the parent window
+ # is withdrawn or iconified. Combined with the grab we put on the window,
+ # this can hang the entire application. Therefore we only make the dialog
+ # transient if the parent is viewable.
+
+ if {[winfo viewable [winfo toplevel $data(-parent)]]} {
+ wm transient $w $data(-parent)
+ }
+
+ # Add traces on the selectPath variable
+ #
+
+ trace add variable data(selectPath) write \
+ [list ::tk::dialog::file::SetPath $w]
+ $data(dirMenuBtn) configure \
+ -textvariable ::tk::dialog::file::${dataName}(selectPath)
+
+ # Cleanup previous menu
+ #
+ $data(typeMenu) delete 0 end
+ $data(typeMenuBtn) configure -state normal -text ""
+
+ # Initialize the file types menu
+ #
+ if {[llength $data(-filetypes)]} {
+ # Default type and name to first entry
+ set initialtype [lindex $data(-filetypes) 0]
+ set initialTypeName [lindex $initialtype 0]
+ if {$data(-typevariable) ne ""} {
+ upvar #0 $data(-typevariable) typeVariable
+ if {[info exists typeVariable]} {
+ set initialTypeName $typeVariable
+ }
+ }
+ foreach type $data(-filetypes) {
+ set title [lindex $type 0]
+ set filter [lindex $type 1]
+ $data(typeMenu) add command -label $title \
+ -command [list ::tk::dialog::file::SetFilter $w $type]
+ # [string first] avoids glob-pattern char issues
+ if {[string first ${initialTypeName} $title] == 0} {
+ set initialtype $type
+ }
+ }
+ SetFilter $w $initialtype
+ $data(typeMenuBtn) configure -state normal
+ $data(typeMenuLab) configure -state normal
+ } else {
+ set data(filter) "*"
+ $data(typeMenuBtn) configure -state disabled -takefocus 0
+ $data(typeMenuLab) configure -state disabled
+ }
+ UpdateWhenIdle $w
+
+ # Withdraw the window, then update all the geometry information
+ # so we know how big it wants to be, then center the window in the
+ # display (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $w widget $data(-parent)
+ wm title $w $data(-title)
+
+ # Set a grab and claim the focus too.
+
+ ::tk::SetFocusGrab $w $data(ent)
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $data(selectFile)
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+
+ # Wait for the user to respond, then restore the focus and return the
+ # index of the selected button. Restore the focus before deleting the
+ # window, since otherwise the window manager may take the focus away so we
+ # can't redirect it. Finally, restore any grab that was in effect.
+
+ vwait ::tk::Priv(selectFilePath)
+
+ ::tk::RestoreFocusGrab $w $data(ent) withdraw
+
+ # Cleanup traces on selectPath variable
+ #
+
+ foreach trace [trace info variable data(selectPath)] {
+ trace remove variable data(selectPath) {*}$trace
+ }
+ $data(dirMenuBtn) configure -textvariable {}
+
+ return $Priv(selectFilePath)
+}
+
+# ::tk::dialog::file::Config --
+#
+# Configures the TK filedialog according to the argument list
+#
+proc ::tk::dialog::file::Config {dataName type argList} {
+ upvar ::tk::dialog::file::$dataName data
+
+ set data(type) $type
+
+ # 0: Delete all variable that were set on data(selectPath) the
+ # last time the file dialog is used. The traces may cause troubles
+ # if the dialog is now used with a different -parent option.
+
+ foreach trace [trace info variable data(selectPath)] {
+ trace remove variable data(selectPath) {*}$trace
+ }
+
+ # 1: the configuration specs
+ #
+ set specs {
+ {-defaultextension "" "" ""}
+ {-filetypes "" "" ""}
+ {-initialdir "" "" ""}
+ {-initialfile "" "" ""}
+ {-parent "" "" "."}
+ {-title "" "" ""}
+ {-typevariable "" "" ""}
+ }
+
+ # The "-multiple" option is only available for the "open" file dialog.
+ #
+ if {$type eq "open"} {
+ lappend specs {-multiple "" "" "0"}
+ }
+
+ # The "-confirmoverwrite" option is only for the "save" file dialog.
+ #
+ if {$type eq "save"} {
+ lappend specs {-confirmoverwrite "" "" "1"}
+ }
+
+ # 2: default values depending on the type of the dialog
+ #
+ if {![info exists data(selectPath)]} {
+ # first time the dialog has been popped up
+ set data(selectPath) [pwd]
+ set data(selectFile) ""
+ }
+
+ # 3: parse the arguments
+ #
+ tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
+
+ if {$data(-title) eq ""} {
+ if {$type eq "open"} {
+ set data(-title) [mc "Open"]
+ } else {
+ set data(-title) [mc "Save As"]
+ }
+ }
+
+ # 4: set the default directory and selection according to the -initial
+ # settings
+ #
+ if {$data(-initialdir) ne ""} {
+ # Ensure that initialdir is an absolute path name.
+ if {[file isdirectory $data(-initialdir)]} {
+ set old [pwd]
+ cd $data(-initialdir)
+ set data(selectPath) [pwd]
+ cd $old
+ } else {
+ set data(selectPath) [pwd]
+ }
+ }
+ set data(selectFile) $data(-initialfile)
+
+ # 5. Parse the -filetypes option
+ #
+ set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)]
+
+ if {![winfo exists $data(-parent)]} {
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
+ }
+
+ # Set -multiple to a one or zero value (not other boolean types like
+ # "yes") so we can use it in tests more easily.
+ if {$type eq "save"} {
+ set data(-multiple) 0
+ } elseif {$data(-multiple)} {
+ set data(-multiple) 1
+ } else {
+ set data(-multiple) 0
+ }
+}
+
+proc ::tk::dialog::file::Create {w class} {
+ set dataName [lindex [split $w .] end]
+ upvar ::tk::dialog::file::$dataName data
+ variable ::tk::Priv
+ global tk_library
+
+ toplevel $w -class $class
+ if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
+ pack [ttk::frame $w.contents] -expand 1 -fill both
+ #set w $w.contents
+
+ # f1: the frame with the directory option menu
+ #
+ set f1 [ttk::frame $w.contents.f1]
+ bind [::tk::AmpWidget ttk::label $f1.lab -text [mc "&Directory:"]] \
+ <<AltUnderlined>> [list focus $f1.menu]
+
+ set data(dirMenuBtn) $f1.menu
+ if {![info exists data(selectPath)]} {
+ set data(selectPath) ""
+ }
+ set data(dirMenu) $f1.menu.menu
+ ttk::menubutton $f1.menu -menu $data(dirMenu) -direction flush \
+ -textvariable [format %s(selectPath) ::tk::dialog::file::$dataName]
+ menu $data(dirMenu) -tearoff 0
+ $data(dirMenu) add radiobutton -label "" -variable \
+ [format %s(selectPath) ::tk::dialog::file::$dataName]
+ set data(upBtn) [ttk::button $f1.up]
+ $data(upBtn) configure -image $Priv(updirImage)
+
+ $f1.menu configure -takefocus 1;# -highlightthickness 2
+
+ pack $data(upBtn) -side right -padx 4 -fill both
+ pack $f1.lab -side left -padx 4 -fill both
+ pack $f1.menu -expand yes -fill both -padx 4
+
+ # data(icons): the IconList that list the files and directories.
+ #
+ if {$class eq "TkFDialog"} {
+ if { $data(-multiple) } {
+ set fNameCaption [mc "File &names:"]
+ } else {
+ set fNameCaption [mc "File &name:"]
+ }
+ set fTypeCaption [mc "Files of &type:"]
+ set iconListCommand [list ::tk::dialog::file::OkCmd $w]
+ } else {
+ set fNameCaption [mc "&Selection:"]
+ set iconListCommand [list ::tk::dialog::file::chooseDir::DblClick $w]
+ }
+ set data(icons) [::tk::IconList $w.contents.icons \
+ -command $iconListCommand -multiple $data(-multiple)]
+ bind $data(icons) <<ListboxSelect>> \
+ [list ::tk::dialog::file::ListBrowse $w]
+
+ # f2: the frame with the OK button, cancel button, "file name" field
+ # and file types field.
+ #
+ set f2 [ttk::frame $w.contents.f2]
+ bind [::tk::AmpWidget ttk::label $f2.lab -text $fNameCaption -anchor e]\
+ <<AltUnderlined>> [list focus $f2.ent]
+ # -pady 0
+ set data(ent) [ttk::entry $f2.ent]
+
+ # The font to use for the icons. The default Canvas font on Unix is just
+ # deviant.
+ set ::tk::$w.contents.icons(font) [$data(ent) cget -font]
+
+ # Make the file types bits only if this is a File Dialog
+ if {$class eq "TkFDialog"} {
+ set data(typeMenuLab) [::tk::AmpWidget ttk::label $f2.lab2 \
+ -text $fTypeCaption -anchor e]
+ # -pady [$f2.lab cget -pady]
+ set data(typeMenuBtn) [ttk::menubutton $f2.menu \
+ -menu $f2.menu.m]
+ # -indicatoron 1
+ set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0]
+ # $data(typeMenuBtn) configure -takefocus 1 -relief raised -anchor w
+ bind $data(typeMenuLab) <<AltUnderlined>> [list \
+ focus $data(typeMenuBtn)]
+ }
+
+ # The hidden button is displayed when ::tk::dialog::file::showHiddenBtn is
+ # true. Create it disabled so the binding doesn't trigger if it isn't
+ # shown.
+ if {$class eq "TkFDialog"} {
+ set text [mc "Show &Hidden Files and Directories"]
+ } else {
+ set text [mc "Show &Hidden Directories"]
+ }
+ set data(hiddenBtn) [::tk::AmpWidget ttk::checkbutton $f2.hidden \
+ -text $text -state disabled \
+ -variable ::tk::dialog::file::showHiddenVar \
+ -command [list ::tk::dialog::file::UpdateWhenIdle $w]]
+# -anchor w -padx 3
+
+ # the okBtn is created after the typeMenu so that the keyboard traversal
+ # is in the right order, and add binding so that we find out when the
+ # dialog is destroyed by the user (added here instead of to the overall
+ # window so no confusion about how much <Destroy> gets called; exactly
+ # once will do). [Bug 987169]
+
+ set data(okBtn) [::tk::AmpWidget ttk::button $f2.ok \
+ -text [mc "&OK"] -default active];# -pady 3]
+ bind $data(okBtn) <Destroy> [list ::tk::dialog::file::Destroyed $w]
+ set data(cancelBtn) [::tk::AmpWidget ttk::button $f2.cancel \
+ -text [mc "&Cancel"] -default normal];# -pady 3]
+
+ # grid the widgets in f2
+ #
+ grid $f2.lab $f2.ent $data(okBtn) -padx 4 -pady 3 -sticky ew
+ grid configure $f2.ent -padx 2
+ if {$class eq "TkFDialog"} {
+ grid $data(typeMenuLab) $data(typeMenuBtn) $data(cancelBtn) \
+ -padx 4 -sticky ew
+ grid configure $data(typeMenuBtn) -padx 0
+ grid $data(hiddenBtn) -columnspan 2 -padx 4 -sticky ew
+ } else {
+ grid $data(hiddenBtn) - $data(cancelBtn) -padx 4 -sticky ew
+ }
+ grid columnconfigure $f2 1 -weight 1
+
+ # Pack all the frames together. We are done with widget construction.
+ #
+ pack $f1 -side top -fill x -pady 4
+ pack $f2 -side bottom -pady 4 -fill x
+ pack $data(icons) -expand yes -fill both -padx 4 -pady 1
+
+ # Set up the event handlers that are common to Directory and File Dialogs
+ #
+
+ wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w]
+ $data(upBtn) configure -command [list ::tk::dialog::file::UpDirCmd $w]
+ $data(cancelBtn) configure -command [list ::tk::dialog::file::CancelCmd $w]
+ bind $w <KeyPress-Escape> [list $data(cancelBtn) invoke]
+ bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A]
+
+ # Set up event handlers specific to File or Directory Dialogs
+ #
+ if {$class eq "TkFDialog"} {
+ bind $data(ent) <Return> [list ::tk::dialog::file::ActivateEnt $w]
+ $data(okBtn) configure -command [list ::tk::dialog::file::OkCmd $w]
+ bind $w <Alt-t> [format {
+ if {[%s cget -state] eq "normal"} {
+ focus %s
+ }
+ } $data(typeMenuBtn) $data(typeMenuBtn)]
+ } else {
+ set okCmd [list ::tk::dialog::file::chooseDir::OkCmd $w]
+ bind $data(ent) <Return> $okCmd
+ $data(okBtn) configure -command $okCmd
+ bind $w <Alt-s> [list focus $data(ent)]
+ bind $w <Alt-o> [list $data(okBtn) invoke]
+ }
+ bind $w <Alt-h> [list $data(hiddenBtn) invoke]
+ bind $data(ent) <Tab> [list ::tk::dialog::file::CompleteEnt $w]
+
+ # Build the focus group for all the entries
+ #
+ ::tk::FocusGroup_Create $w
+ ::tk::FocusGroup_BindIn $w $data(ent) [list \
+ ::tk::dialog::file::EntFocusIn $w]
+ ::tk::FocusGroup_BindOut $w $data(ent) [list \
+ ::tk::dialog::file::EntFocusOut $w]
+}
+
+# ::tk::dialog::file::SetSelectMode --
+#
+# Set the select mode of the dialog to single select or multi-select.
+#
+# Arguments:
+# w The dialog path.
+# multi 1 if the dialog is multi-select; 0 otherwise.
+#
+# Results:
+# None.
+
+proc ::tk::dialog::file::SetSelectMode {w multi} {
+ set dataName __tk_filedialog
+ upvar ::tk::dialog::file::$dataName data
+ if { $multi } {
+ set fNameCaption [mc "File &names:"]
+ } else {
+ set fNameCaption [mc "File &name:"]
+ }
+ set iconListCommand [list ::tk::dialog::file::OkCmd $w]
+ ::tk::SetAmpText $w.contents.f2.lab $fNameCaption
+ $data(icons) configure -multiple $multi -command $iconListCommand
+ return
+}
+
+# ::tk::dialog::file::UpdateWhenIdle --
+#
+# Creates an idle event handler which updates the dialog in idle time.
+# This is important because loading the directory may take a long time
+# and we don't want to load the same directory for multiple times due to
+# multiple concurrent events.
+#
+proc ::tk::dialog::file::UpdateWhenIdle {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {[info exists data(updateId)]} {
+ return
+ }
+ set data(updateId) [after idle [list ::tk::dialog::file::Update $w]]
+}
+
+# ::tk::dialog::file::Update --
+#
+# Loads the files and directories into the IconList widget. Also sets up
+# the directory option menu for quick access to parent directories.
+#
+proc ::tk::dialog::file::Update {w} {
+ # This proc may be called within an idle handler. Make sure that the
+ # window has not been destroyed before this proc is called
+ if {![winfo exists $w]} {
+ return
+ }
+ set class [winfo class $w]
+ if {($class ne "TkFDialog") && ($class ne "TkChooseDir")} {
+ return
+ }
+
+ set dataName [winfo name $w]
+ upvar ::tk::dialog::file::$dataName data
+ variable ::tk::Priv
+ variable showHiddenVar
+ global tk_library
+ unset -nocomplain data(updateId)
+
+ set folder $Priv(folderImage)
+ set file $Priv(fileImage)
+
+ set appPWD [pwd]
+ if {[catch {
+ cd $data(selectPath)
+ }]} then {
+ # We cannot change directory to $data(selectPath). $data(selectPath)
+ # should have been checked before ::tk::dialog::file::Update is
+ # called, so we normally won't come to here. Anyways, give an error
+ # and abort action.
+ tk_messageBox -type ok -parent $w -icon warning -message [mc \
+ "Cannot change to the directory \"%1\$s\".\nPermission denied."\
+ $data(selectPath)]
+ cd $appPWD
+ return
+ }
+
+ # Turn on the busy cursor. BUG?? We haven't disabled X events, though,
+ # so the user may still click and cause havoc ...
+ #
+ set entCursor [$data(ent) cget -cursor]
+ set dlgCursor [$w cget -cursor]
+ $data(ent) configure -cursor watch
+ $w configure -cursor watch
+ update idletasks
+
+ $data(icons) deleteall
+
+ set showHidden $showHiddenVar
+
+ # Make the dir list. Note that using an explicit [pwd] (instead of '.') is
+ # better in some VFS cases.
+ $data(icons) add $folder [GlobFiltered [pwd] d 1]
+
+ if {$class eq "TkFDialog"} {
+ # Make the file list if this is a File Dialog, selecting all but
+ # 'd'irectory type files.
+ #
+ $data(icons) add $file [GlobFiltered [pwd] {f b c l p s}]
+ }
+
+ # Update the Directory: option menu
+ #
+ set list ""
+ set dir ""
+ foreach subdir [file split $data(selectPath)] {
+ set dir [file join $dir $subdir]
+ lappend list $dir
+ }
+
+ $data(dirMenu) delete 0 end
+ set var [format %s(selectPath) ::tk::dialog::file::$dataName]
+ foreach path $list {
+ $data(dirMenu) add command -label $path -command [list set $var $path]
+ }
+
+ # Restore the PWD to the application's PWD
+ #
+ cd $appPWD
+
+ if {$class eq "TkFDialog"} {
+ # Restore the Open/Save Button if this is a File Dialog
+ #
+ if {$data(type) eq "open"} {
+ ::tk::SetAmpText $data(okBtn) [mc "&Open"]
+ } else {
+ ::tk::SetAmpText $data(okBtn) [mc "&Save"]
+ }
+ }
+
+ # turn off the busy cursor.
+ #
+ $data(ent) configure -cursor $entCursor
+ $w configure -cursor $dlgCursor
+}
+
+# ::tk::dialog::file::SetPathSilently --
+#
+# Sets data(selectPath) without invoking the trace procedure
+#
+proc ::tk::dialog::file::SetPathSilently {w path} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set cb [list ::tk::dialog::file::SetPath $w]
+ trace remove variable data(selectPath) write $cb
+ set data(selectPath) $path
+ trace add variable data(selectPath) write $cb
+}
+
+
+# This proc gets called whenever data(selectPath) is set
+#
+proc ::tk::dialog::file::SetPath {w name1 name2 op} {
+ if {[winfo exists $w]} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ UpdateWhenIdle $w
+ # On directory dialogs, we keep the entry in sync with the currentdir.
+ if {[winfo class $w] eq "TkChooseDir"} {
+ $data(ent) delete 0 end
+ $data(ent) insert end $data(selectPath)
+ }
+ }
+}
+
+# This proc gets called whenever data(filter) is set
+#
+proc ::tk::dialog::file::SetFilter {w type} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set data(filterType) $type
+ set data(filter) [lindex $type 1]
+ $data(typeMenuBtn) configure -text [lindex $type 0] ;#-indicatoron 1
+
+ # If we aren't using a default extension, use the one suppled by the
+ # filter.
+ if {![info exists data(extUsed)]} {
+ if {[string length $data(-defaultextension)]} {
+ set data(extUsed) 1
+ } else {
+ set data(extUsed) 0
+ }
+ }
+
+ if {!$data(extUsed)} {
+ # Get the first extension in the list that matches {^\*\.\w+$} and
+ # remove all * from the filter.
+ set index [lsearch -regexp $data(filter) {^\*\.\w+$}]
+ if {$index >= 0} {
+ set data(-defaultextension) \
+ [string trimleft [lindex $data(filter) $index] "*"]
+ } else {
+ # Couldn't find anything! Reset to a safe default...
+ set data(-defaultextension) ""
+ }
+ }
+
+ $data(icons) see 0
+
+ UpdateWhenIdle $w
+}
+
+# tk::dialog::file::ResolveFile --
+#
+# Interpret the user's text input in a file selection dialog. Performs:
+#
+# (1) ~ substitution
+# (2) resolve all instances of . and ..
+# (3) check for non-existent files/directories
+# (4) check for chdir permissions
+# (5) conversion of environment variable references to their
+# contents (once only)
+#
+# Arguments:
+# context: the current directory you are in
+# text: the text entered by the user
+# defaultext: the default extension to add to files with no extension
+# expandEnv: whether to expand environment variables (yes by default)
+#
+# Return vaue:
+# [list $flag $directory $file]
+#
+# flag = OK : valid input
+# = PATTERN : valid directory/pattern
+# = PATH : the directory does not exist
+# = FILE : the directory exists by the file doesn't exist
+# = CHDIR : Cannot change to the directory
+# = ERROR : Invalid entry
+#
+# directory : valid only if flag = OK or PATTERN or FILE
+# file : valid only if flag = OK or PATTERN
+#
+# directory may not be the same as context, because text may contain a
+# subdirectory name
+#
+proc ::tk::dialog::file::ResolveFile {context text defaultext {expandEnv 1}} {
+ set appPWD [pwd]
+
+ set path [JoinFile $context $text]
+
+ # If the file has no extension, append the default. Be careful not to do
+ # this for directories, otherwise typing a dirname in the box will give
+ # back "dirname.extension" instead of trying to change dir.
+ if {
+ ![file isdirectory $path] && ([file ext $path] eq "") &&
+ ![string match {$*} [file tail $path]]
+ } then {
+ set path "$path$defaultext"
+ }
+
+ # we want to strip any filtering/ext/blocking instructions
+ # from the file name
+
+ set aa [string first "\[" $path]
+ if {$aa > 0} {
+ set fn [string range $path 0 [expr $aa-1]]
+ } else {
+ set fn $path
+ }
+
+ if {[catch {file exists $fn}]} {
+ # This "if" block can be safely removed if the following code stop
+ # generating errors.
+ #
+ # file exists ~nonsuchuser
+ #
+ return [list ERROR $path ""]
+ }
+
+ if {[file exists $fn]} {
+ if {[file isdirectory $path]} {
+ if {[catch {cd $path}]} {
+ return [list CHDIR $path ""]
+ }
+ set directory [pwd]
+ set file ""
+ set flag OK
+ cd $appPWD
+ } else {
+ if {[catch {cd [file dirname $path]}]} {
+ return [list CHDIR [file dirname $path] ""]
+ }
+ set directory [pwd]
+ set file [file tail $path]
+ set flag OK
+ cd $appPWD
+ }
+ } else {
+ set dirname [file dirname $path]
+ if {[file exists $dirname]} {
+ if {[catch {cd $dirname}]} {
+ return [list CHDIR $dirname ""]
+ }
+ set directory [pwd]
+ cd $appPWD
+ set file [file tail $path]
+ # It's nothing else, so check to see if it is an env-reference
+ if {$expandEnv && [string match {$*} $file]} {
+ set var [string range $file 1 end]
+ if {[info exist ::env($var)]} {
+ return [ResolveFile $context $::env($var) $defaultext 0]
+ }
+ }
+ if {[regexp {[*?]} $file]} {
+ set flag PATTERN
+ } else {
+ set flag FILE
+ }
+ } else {
+ set directory $dirname
+ set file [file tail $path]
+ set flag PATH
+ # It's nothing else, so check to see if it is an env-reference
+ if {$expandEnv && [string match {$*} $file]} {
+ set var [string range $file 1 end]
+ if {[info exist ::env($var)]} {
+ return [ResolveFile $context $::env($var) $defaultext 0]
+ }
+ }
+ }
+ }
+
+ return [list $flag $directory $file]
+}
+
+
+# Gets called when the entry box gets keyboard focus. We clear the selection
+# from the icon list . This way the user can be certain that the input in the
+# entry box is the selection.
+#
+proc ::tk::dialog::file::EntFocusIn {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {[$data(ent) get] ne ""} {
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+ } else {
+ $data(ent) selection clear
+ }
+
+ if {[winfo class $w] eq "TkFDialog"} {
+ # If this is a File Dialog, make sure the buttons are labeled right.
+ if {$data(type) eq "open"} {
+ ::tk::SetAmpText $data(okBtn) [mc "&Open"]
+ } else {
+ ::tk::SetAmpText $data(okBtn) [mc "&Save"]
+ }
+ }
+}
+
+proc ::tk::dialog::file::EntFocusOut {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ $data(ent) selection clear
+}
+
+
+# Gets called when user presses Return in the "File name" entry.
+#
+proc ::tk::dialog::file::ActivateEnt {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set text [$data(ent) get]
+ if {$data(-multiple)} {
+ foreach t $text {
+ VerifyFileName $w $t
+ }
+ } else {
+ VerifyFileName $w $text
+ }
+}
+
+# Verification procedure
+#
+proc ::tk::dialog::file::VerifyFileName {w filename} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set list [ResolveFile $data(selectPath) $filename $data(-defaultextension)]
+ foreach {flag path file} $list {
+ break
+ }
+
+ switch -- $flag {
+ OK {
+ if {$file eq ""} {
+ # user has entered an existing (sub)directory
+ set data(selectPath) $path
+ $data(ent) delete 0 end
+ } else {
+ SetPathSilently $w $path
+ if {$data(-multiple)} {
+ lappend data(selectFile) $file
+ } else {
+ set data(selectFile) $file
+ }
+ Done $w
+ }
+ }
+ PATTERN {
+ set data(selectPath) $path
+ set data(filter) $file
+ }
+ FILE {
+ if {$data(type) eq "open"} {
+ tk_messageBox -icon warning -type ok -parent $w \
+ -message [mc "File \"%1\$s\" does not exist." \
+ [file join $path $file]]
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+ } else {
+ SetPathSilently $w $path
+ if {$data(-multiple)} {
+ lappend data(selectFile) $file
+ } else {
+ set data(selectFile) $file
+ }
+ Done $w
+ }
+ }
+ PATH {
+ tk_messageBox -icon warning -type ok -parent $w \
+ -message [mc "Directory \"%1\$s\" does not exist." $path]
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+ }
+ CHDIR {
+ tk_messageBox -type ok -parent $w -icon warning -message \
+ [mc "Cannot change to the directory\
+ \"%1\$s\".\nPermission denied." $path]
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+ }
+ ERROR {
+ tk_messageBox -type ok -parent $w -icon warning -message \
+ [mc "Invalid file name \"%1\$s\"." $path]
+ $data(ent) selection range 0 end
+ $data(ent) icursor end
+ }
+ }
+}
+
+# Gets called when user presses the Alt-s or Alt-o keys.
+#
+proc ::tk::dialog::file::InvokeBtn {w key} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {[$data(okBtn) cget -text] eq $key} {
+ $data(okBtn) invoke
+ }
+}
+
+# Gets called when user presses the "parent directory" button
+#
+proc ::tk::dialog::file::UpDirCmd {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {$data(selectPath) ne "/"} {
+ set data(selectPath) [file dirname $data(selectPath)]
+ }
+}
+
+# Join a file name to a path name. The "file join" command will break if the
+# filename begins with ~
+#
+proc ::tk::dialog::file::JoinFile {path file} {
+ if {[string match {~*} $file] && [file exists $path/$file]} {
+ return [file join $path ./$file]
+ } else {
+ return [file join $path $file]
+ }
+}
+
+# Gets called when user presses the "OK" button
+#
+proc ::tk::dialog::file::OkCmd {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set filenames {}
+ foreach item [$data(icons) selection get] {
+ lappend filenames [$data(icons) get $item]
+ }
+
+ if {
+ ([llength $filenames] && !$data(-multiple)) ||
+ ($data(-multiple) && ([llength $filenames] == 1))
+ } then {
+ set filename [lindex $filenames 0]
+ set file [JoinFile $data(selectPath) $filename]
+ if {[file isdirectory $file]} {
+ ListInvoke $w [list $filename]
+ return
+ }
+ }
+
+ ActivateEnt $w
+}
+
+# Gets called when user presses the "Cancel" button
+#
+proc ::tk::dialog::file::CancelCmd {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ variable ::tk::Priv
+
+ bind $data(okBtn) <Destroy> {}
+ set Priv(selectFilePath) ""
+}
+
+# Gets called when user destroys the dialog directly [Bug 987169]
+#
+proc ::tk::dialog::file::Destroyed {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ variable ::tk::Priv
+
+ set Priv(selectFilePath) ""
+}
+
+# Gets called when user browses the IconList widget (dragging mouse, arrow
+# keys, etc)
+#
+proc ::tk::dialog::file::ListBrowse {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set text {}
+ foreach item [$data(icons) selection get] {
+ lappend text [$data(icons) get $item]
+ }
+ if {[llength $text] == 0} {
+ return
+ }
+ if {$data(-multiple)} {
+ set newtext {}
+ foreach file $text {
+ set fullfile [JoinFile $data(selectPath) $file]
+ if { ![file isdirectory $fullfile] } {
+ lappend newtext $file
+ }
+ }
+ set text $newtext
+ set isDir 0
+ } else {
+ set text [lindex $text 0]
+ set file [JoinFile $data(selectPath) $text]
+ set isDir [file isdirectory $file]
+ }
+ if {!$isDir} {
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $text
+
+ if {[winfo class $w] eq "TkFDialog"} {
+ if {$data(type) eq "open"} {
+ ::tk::SetAmpText $data(okBtn) [mc "&Open"]
+ } else {
+ ::tk::SetAmpText $data(okBtn) [mc "&Save"]
+ }
+ }
+ } elseif {[winfo class $w] eq "TkFDialog"} {
+ ::tk::SetAmpText $data(okBtn) [mc "&Open"]
+ }
+}
+
+# Gets called when user invokes the IconList widget (double-click, Return key,
+# etc)
+#
+proc ::tk::dialog::file::ListInvoke {w filenames} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {[llength $filenames] == 0} {
+ return
+ }
+
+ set file [JoinFile $data(selectPath) [lindex $filenames 0]]
+
+ set class [winfo class $w]
+ if {$class eq "TkChooseDir" || [file isdirectory $file]} {
+ set appPWD [pwd]
+ if {[catch {cd $file}]} {
+ tk_messageBox -type ok -parent $w -icon warning -message \
+ [mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $file]
+ } else {
+ cd $appPWD
+ set data(selectPath) $file
+ }
+ } else {
+ if {$data(-multiple)} {
+ set data(selectFile) $filenames
+ } else {
+ set data(selectFile) $file
+ }
+ Done $w
+ }
+}
+
+# ::tk::dialog::file::Done --
+#
+# Gets called when user has input a valid filename. Pops up a dialog
+# box to confirm selection when necessary. Sets the
+# tk::Priv(selectFilePath) variable, which will break the "vwait" loop
+# in ::tk::dialog::file:: and return the selected filename to the script
+# that calls tk_getOpenFile or tk_getSaveFile
+#
+proc ::tk::dialog::file::Done {w {selectFilePath ""}} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ variable ::tk::Priv
+
+ if {$selectFilePath eq ""} {
+ if {$data(-multiple)} {
+ set selectFilePath {}
+ foreach f $data(selectFile) {
+ lappend selectFilePath [JoinFile $data(selectPath) $f]
+ }
+ } else {
+ set selectFilePath [JoinFile $data(selectPath) $data(selectFile)]
+ }
+
+ set Priv(selectFile) $data(selectFile)
+ set Priv(selectPath) $data(selectPath)
+
+ if {($data(type) eq "save") && $data(-confirmoverwrite) && [file exists $selectFilePath]} {
+ set reply [tk_messageBox -icon warning -type yesno -parent $w \
+ -message [mc "File \"%1\$s\" already exists.\nDo you want\
+ to overwrite it?" $selectFilePath]]
+ if {$reply eq "no"} {
+ return
+ }
+ }
+ if {
+ [info exists data(-typevariable)] && $data(-typevariable) ne ""
+ && [info exists data(-filetypes)] && [llength $data(-filetypes)]
+ && [info exists data(filterType)] && $data(filterType) ne ""
+ } then {
+ upvar #0 $data(-typevariable) typeVariable
+ set typeVariable [lindex $data(filterType) 0]
+ }
+ }
+ bind $data(okBtn) <Destroy> {}
+ set Priv(selectFilePath) $selectFilePath
+}
+
+# ::tk::dialog::file::GlobFiltered --
+#
+# Gets called to do globbing, returning the results and filtering them
+# according to the current filter (and removing the entries for '.' and
+# '..' which are never shown). Deals with evil cases such as where the
+# user is supplying a filter which is an invalid list or where it has an
+# unbalanced brace. The resulting list will be dictionary sorted.
+#
+# Arguments:
+# dir Which directory to search
+# type List of filetypes to look for ('d' or 'f b c l p s')
+# overrideFilter Whether to ignore the filter for this search.
+#
+# NB: Assumes that the caller has mapped the state variable to 'data'.
+#
+proc ::tk::dialog::file::GlobFiltered {dir type {overrideFilter 0}} {
+ variable showHiddenVar
+ upvar 1 data(filter) filter
+
+ if {$filter eq "*" || $overrideFilter} {
+ set patterns [list *]
+ if {$showHiddenVar} {
+ lappend patterns .*
+ }
+ } elseif {[string is list $filter]} {
+ set patterns $filter
+ } else {
+ # Invalid list; assume we can use non-whitespace sequences as words
+ set patterns [regexp -inline -all {\S+} $filter]
+ }
+
+ set opts [list -tails -directory $dir -type $type -nocomplain]
+
+ set result {}
+ catch {
+ # We have a catch because we might have a really bad pattern (e.g.,
+ # with an unbalanced brace); even [glob -nocomplain] doesn't like it.
+ # Using a catch ensures that it just means we match nothing instead of
+ # throwing a nasty error at the user...
+ foreach f [glob {*}$opts -- {*}$patterns] {
+ if {$f eq "." || $f eq ".."} {
+ continue
+ }
+ # See ticket [1641721], $f might be a link pointing to a dir
+ if {$type != "d" && [file isdir [file join $dir $f]]} {
+ continue
+ }
+ lappend result $f
+ }
+ }
+ return [lsort -dictionary -unique $result]
+}
+
+proc ::tk::dialog::file::CompleteEnt {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ set f [$data(ent) get]
+ if {$data(-multiple)} {
+ if {![string is list $f] || [llength $f] != 1} {
+ return -code break
+ }
+ set f [lindex $f 0]
+ }
+
+ # Get list of matching filenames and dirnames
+ set files [if {[winfo class $w] eq "TkFDialog"} {
+ GlobFiltered $data(selectPath) {f b c l p s}
+ }]
+ set dirs2 {}
+ foreach d [GlobFiltered $data(selectPath) d] {lappend dirs2 $d/}
+
+ set targets [concat \
+ [lsearch -glob -all -inline $files $f*] \
+ [lsearch -glob -all -inline $dirs2 $f*]]
+
+ if {[llength $targets] == 1} {
+ # We have a winner!
+ set f [lindex $targets 0]
+ } elseif {$f in $targets || [llength $targets] == 0} {
+ if {[string length $f] > 0} {
+ bell
+ }
+ return
+ } elseif {[llength $targets] > 1} {
+ # Multiple possibles
+ if {[string length $f] == 0} {
+ return
+ }
+ set t0 [lindex $targets 0]
+ for {set len [string length $t0]} {$len>0} {} {
+ set allmatch 1
+ foreach s $targets {
+ if {![string equal -length $len $s $t0]} {
+ set allmatch 0
+ break
+ }
+ }
+ incr len -1
+ if {$allmatch} break
+ }
+ set f [string range $t0 0 $len]
+ }
+
+ if {$data(-multiple)} {
+ set f [list $f]
+ }
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $f
+ return -code break
+}
diff --git a/ds9/library/tsv.tcl b/ds9/library/tsv.tcl
new file mode 100644
index 0000000..628d1e9
--- /dev/null
+++ b/ds9/library/tsv.tcl
@@ -0,0 +1,162 @@
+# 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 TSVRead {t fn} {
+ upvar #0 $t T
+ global $t
+
+ global debug
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "TSVRead"
+ }
+
+ if {$fn == {}} {
+ return
+ }
+
+ catch {
+ set fp [open $fn r]
+
+
+ # init db
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+
+ # ok, get first non comment line
+ while (true) {
+ if {[gets $fp line] == -1} {
+ return
+ }
+
+ # skip any comments
+ if {[string range $line 0 0] != "#"} {
+ break;
+ }
+ }
+
+ # reduce number of spaces
+ regsub -all { +} $line { } line
+
+ # strip any quotes
+ regsub -all {\"} $line {} line
+
+ # determine separator
+ if {[llength [split $line "\t"]] > 1} {
+ set ss "\t"
+ } elseif {[llength [split $line ","]] > 1} {
+ set ss ","
+ } elseif {[llength [split $line ":"]] > 1} {
+ set ss ":"
+ } else {
+ set ss " "
+ }
+
+ # determine header
+ set first {}
+ set foo [split $line $ss]
+ if {([string is integer [lindex $foo 0]] || [string is double [lindex $foo 0]]) && ([string is integer [lindex $foo 1]] || [string is double [lindex $foo 1]])} {
+ # determine num cols
+ set cnt [llength $foo]
+
+ # we need to build an header
+ set first $line
+
+ set line "X${ss}Y"
+ for {set ii 2} {$ii<$cnt} {incr ii} {
+ append line "${ss}column[expr $ii+3]"
+ }
+ }
+
+ # process header
+ # cols
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) $line
+ set T(Header) [split $T(H_$n) $ss]
+
+ # dashes
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+ set T(Ndshs) [llength $T(Dashes)]
+ starbase_colmap $t
+
+ # process table
+ if {$first == {}} {
+ gets $fp line
+ } else {
+ set line $first
+ }
+
+ while {![eof $fp]} {
+ # skip any comments
+ if {[string range $line 0 0] == "#"} {
+ set line {}
+ }
+
+ # reduce number of spaces
+ regsub -all { +} $line { } line
+ set line [string trim $line]
+
+ # do we have something?
+ if {$line != {}} {
+ # ok, save it
+ incr ${t}(Nrows)
+ set r $T(Nrows)
+
+ set NCols [starbase_ncols $t]
+ set c 1
+ foreach val [split $line $ss] {
+ set T($r,$c) $val
+ incr c
+ }
+ for {} {$c <= $NCols} {incr c} {
+ set T($r,$c) {}
+ }
+ }
+
+ gets $fp line
+ }
+
+ close $fp
+ }
+}
+
+proc TSVWrite {t fn} {
+ upvar #0 $t T
+ global $t
+
+ global debug
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "TSVWrite"
+ }
+
+ if {$fn == {}} {
+ return
+ }
+
+ set fp [open $fn w]
+
+ set nr $T(Nrows)
+ set nc $T(Ncols)
+
+ # header
+ for {set cc 1} {$cc < $nc} {incr cc} {
+ puts -nonewline $fp "[lindex $T(Header) [expr $cc-1]]\t"
+ }
+ puts $fp "[lindex $T(Header) [expr $nc-1]]"
+
+ # data
+ for {set rr 1} {$rr <= $nr} {incr rr} {
+ for {set cc 1} {$cc < $nc} {incr cc} {
+ puts -nonewline $fp "$T($rr,$cc)\t"
+ }
+ puts $fp "$T($rr,$nc)"
+ }
+
+ close $fp
+}
+
diff --git a/ds9/library/url.tcl b/ds9/library/url.tcl
new file mode 100644
index 0000000..60a5a62
--- /dev/null
+++ b/ds9/library/url.tcl
@@ -0,0 +1,334 @@
+# 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
+
+# get generic file via url
+# used by Analysis and SAMP
+
+proc GetFileURL {url fname} {
+ upvar $fname fn
+
+ ParseURL $url rr
+ switch -- $rr(scheme) {
+ ftp {GetFileFTP $rr(authority) $rr(path) $fn}
+ file {set fn $rr(path)}
+ http -
+ default {GetFileHTTP $url $fn}
+ }
+}
+
+proc GetFileFTP {host path fn} {
+ global debug
+
+ set ftp [ftp::Open $host {ftp} {-ds9@} -mode passive]
+ if {$ftp > -1} {
+ set ftp::VERBOSE $debug(tcl,ftp)
+ set "ftp::ftp${ftp}(Output)" FTPLog
+ ftp::Type $ftp binary
+ ftp::Get $ftp $path $fn
+ ftp::Close $ftp
+
+ # clear error from tcllib ftp
+ global errorInfo
+ set errorInfo {}
+ }
+}
+
+proc GetFileHTTP {url fn} {
+ global ihttp
+
+ set ch [open $fn w]
+ if {[catch {http::geturl $url \
+ -timeout $ihttp(timeout) \
+ -channel $ch \
+ -binary 1 \
+ -headers "[ProxyHTTP]"} token]} {
+ close $ch
+ return
+ }
+
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ close $ch
+ if {[info exists token]} {
+ HTTPLog $token
+ http::cleanup $token
+ }
+}
+
+# Load fits via url
+# sync with redirection
+# used by command line, SAMP, SIA
+
+proc OpenURLFits {{layer {}} {mode {}}} {
+ global fitsurl
+
+ set url $fitsurl
+ if {[EntryDialog [msgcat::mc {URL}] [msgcat::mc {Enter URL}] 80 url]} {
+ StartLoad
+ LoadURLFits $url $layer $mode
+ FinishLoad
+
+ set fitsurl $url
+ }
+}
+
+proc LoadURLFits {url layer mode} {
+ if {[string length $url] == 0} {
+ return
+ }
+
+ ParseURL $url r
+ switch -- $r(scheme) {
+ ftp {LoadURLFitsFTP $r(authority) $r(path) $layer $mode}
+ file {LoadURLFitsFile $r(path) $layer $mode}
+ http -
+ default {LoadURLFitsHTTP $url $layer $mode}
+ }
+}
+
+proc LoadURLFitsFTP {host path layer mode} {
+ global loadParam
+ global ds9
+ global debug
+
+ set ftp [ftp::Open $host "ftp" "-ds9@" -mode passive]
+ if {$ftp > -1} {
+ set fn [tmpnam [file extension $path]]
+ set ftp::VERBOSE $debug(tcl,ftp)
+ set "ftp::ftp${ftp}(Output)" FTPLog
+ ftp::Type $ftp binary
+ if {[ftp::Get $ftp $path $fn]} {
+ LoadURLFitsFile $fn $layer $mode
+ }
+
+ ftp::Close $ftp
+
+ if {[file exists $fn]} {
+ catch {file delete -force $fn}
+ }
+ }
+}
+
+proc LoadURLFitsFile {fn layer mode} {
+ global loadParam
+
+ # alloc it because we can't assume it will last
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $loadParam(file,name)
+ set loadParam(load,layer) $layer
+
+ ProcessLoad
+}
+
+proc LoadURLFitsHTTP {url layer mode} {
+ global ds9
+ global ihttp
+
+ ParseURL $url r
+ set fn [tmpnam [file extension $r(path)]]
+
+ set ch [open $fn w]
+ set token [http::geturl $url \
+ -timeout $ihttp(timeout) \
+ -channel $ch \
+ -binary 1 \
+ -headers "[ProxyHTTP]"]
+
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ catch {close $ch}
+
+ upvar #0 $token t
+
+ # Code
+ set code [http::ncode $token]
+
+ # Meta
+ set meta $t(meta)
+
+ # Mime-type
+ # we want to strip and extra info after ';'
+ regexp -nocase {([^;])*} $t(type) mime
+
+ # Content-Encoding
+ set encoding {}
+ foreach {name value} $meta {
+ if {[regexp -nocase ^content-encoding $name]} {
+ switch -- [string tolower $value] {
+ compress -
+ bzip2 {set encoding bzip2}
+ Z {set encoding compress}
+ pack -
+ z {set encoding pack}
+ default {}
+ }
+ }
+ }
+
+ HTTPLog $token
+ # Result?
+ switch -- $code {
+ 200 -
+ 203 {}
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $meta {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,http)} {
+ puts stderr "LoadURLFitsHTTP redirect $code to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset token
+
+ if {[file exists $fn]} {
+ catch {file delete -force $fn}
+ }
+ set url $value
+ LoadURLFitsHTTP $url $layer $mode
+ return
+ }
+ }
+ }
+
+ default {
+ Error "HTTP [msgcat::mc {Error}] $code"
+ return
+ }
+ }
+
+ http::cleanup $token
+
+ global debug
+ if {$debug(tcl,http)} {
+ puts stderr "LoadURLFitsHTTP: fn $fn : code $code : meta $meta : mime $mime : encoding $encoding"
+ }
+
+ switch -- [string tolower $mime] {
+ "application/octet-stream" {
+ # its never fails, someone can't get there mime types correct.
+ # Override the mime type based on path
+ switch -- [file extension $fn] {
+ .bz2 {set var(encoding) bzip2}
+ .Z {set var(encoding) compress}
+ .z {set var(encoding) pack}
+ }
+ }
+
+ "image/fits" -
+ "application/fits" {}
+
+ "application/fits-image" -
+ "application/fits-table" -
+ "application/fits-group" {}
+
+ "image/x-fits" -
+ "binary/x-fits" -
+ "application/x-fits" {}
+
+ "image/x-gfits" -
+ "binary/x-gfits" -
+ "image/gz-fits" -
+ "application/x-gzip" -
+ "display/gz-fits" {}
+
+ "image/fits-hcompress" -
+ "image/x-fits-h" {}
+
+ "image/bz2-fits" -
+ "display/bz2-fits" {set encoding bzip2}
+
+ "image/x-cfits" -
+ "binary/x-cfits" {set encoding compress}
+
+ "image/x-zfits" -
+ "binary/x-zfits" {set encoding pack}
+
+ "text/html" -
+ "text/plain" -
+ default {
+ Error "[msgcat::mc {File not Found or Unable to load FITS data MIME type}] $mime"
+ return
+ }
+ }
+
+ # alloc it because we are going to delete it after load
+ StartLoad
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) allocgz
+ set loadParam(file,name) $fn
+ set loadParam(file,fn) $loadParam(file,name)
+ set loadParam(load,layer) $layer
+
+ # may have to convert the file, based on content-encoding
+ switch -- "$encoding" {
+ bzip2 {
+ catch {set ch [open "| bunzip2 < $fn " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ compress {
+ catch {set ch [open "| uncompress < $fn " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ pack {
+ catch {set ch [open "| pcat $fn " r]}
+ set loadParam(load,type) channel
+ set loadParam(channel,name) $ch
+ }
+ }
+
+ ProcessLoad
+ FinishLoad
+
+ if {[file exists $fn]} {
+ catch {file delete -force $fn}
+ }
+}
+
+proc ProcessURLFitsCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ set layer {}
+ set mode {}
+
+ switch -- [string tolower [lindex $var $i]] {
+ new {
+ incr i
+ CreateFrame
+ }
+ mask {
+ incr i
+ set layer mask
+ }
+ slice {
+ incr i
+ set mode slice
+ }
+ }
+
+ LoadURLFits [lindex $var $i] $layer $mode
+}
+
diff --git a/ds9/library/util.tcl b/ds9/library/util.tcl
new file mode 100644
index 0000000..c71ef83
--- /dev/null
+++ b/ds9/library/util.tcl
@@ -0,0 +1,1555 @@
+# 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 CurrentDef {} {
+ global current
+ global pcurrent
+ global ds9
+
+ set current(frame) {}
+ set current(ext) {}
+ set current(colorbar) {}
+ set current(cursor) {}
+ set current(rgb) red
+
+ set current(display) single
+ set current(mode) none
+ set current(zoom) { 1 1 }
+ set current(rotate) 0
+ set current(orient) none
+ set current(align) 0
+
+ set pcurrent(display) $current(display)
+ set pcurrent(mode) $current(mode)
+ set pcurrent(zoom) $current(zoom)
+ set pcurrent(rotate) $current(rotate)
+ set pcurrent(orient) $current(orient)
+ set pcurrent(align) $current(align)
+}
+
+proc CursorDef {} {
+ global icursor
+
+ set icursor(save) {}
+ set icursor(id) 0
+ set icursor(timer) 0
+ set icursor(timer,abort) 0
+}
+
+proc GetNumCores {} {
+ global tcl_platform
+ global env
+
+ switch $tcl_platform(os) {
+ Linux {
+ if {![catch {open "/proc/cpuinfo"} f]} {
+ set cores [regexp -all -line {^processor\s} [read $f]]
+ close $f
+ if {$cores > 0} {
+ return $cores
+ }
+ }
+ }
+ Darwin {
+ if {![catch {exec sysctl -n "hw.ncpu"} cores]} {
+ return $cores
+ }
+ }
+ {Windows NT} {
+ return $env(NUMBER_OF_PROCESSORS)
+ }
+ }
+
+ return 1
+}
+
+proc UpdateDS9Static {} {
+ # This routine is only called when an frame is added or deleted
+ # we only change menu items which require at least one frame
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateDS9Static begin..."
+ }
+
+ UpdateFileMenuStatic
+ UpdateFrameMenuStatic
+ UpdateZoomMenuStatic
+ UpdateAnalysisMenuStatic
+
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateDS9Static end...\n"
+ }
+}
+
+proc UpdateDS9 {} {
+ global ds9
+ global current
+
+ # This routine is called when ever there is a state change within ds9
+ # for example, a image is loaded, current(frame) is changed, etc
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateDS9 begin..."
+ }
+
+ UpdateFileMenu
+ UpdateEditMenu
+ UpdateFrameMenu
+ UpdateBinMenu
+ UpdateZoomMenu
+ UpdateScaleMenu
+ UpdateColorMenu
+ UpdateRegionMenu
+ # wcs(system) set here
+ UpdateWCSMenu
+ UpdateAnalysisMenu
+
+ UpdateTaskMenu
+ UpdateMaskMenu
+ UpdateContourMenu
+ UpdateGridMenu
+ UpdateBlockMenu
+ UpdateSmoothMenu
+ UpdateCubeMenu
+ UpdateRGBMenu
+ UpdatePanZoomMenu
+
+ UpdateBinDialog
+ UpdatePanZoomDialog
+ UpdateCrosshairDialog
+ UpdateCropDialog
+ UpdateScaleDialog
+ UpdateColorDialog
+ UpdateWCSDialog
+
+ UpdateGroupDialog
+ UpdateCATDialog
+ UpdateCentroidDialog
+ UpdateCubeDialog
+ UpdateRGBDialog
+ Update3DDialog
+ UpdateContourDialog
+ UpdateGridDialog
+
+ UpdateGraphXAxis $current(frame)
+ UpdateGraphYAxis $current(frame)
+
+ RefreshInfoBox $current(frame)
+ UpdateColormapLevel
+
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateDS9 end...\n"
+ }
+}
+
+# changes to other dialogs can affect the infobox and pixeltable
+proc UpdateMain {} {
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateMain"
+ }
+
+ RefreshInfoBox $current(frame)
+ UpdateColormapLevel
+ switch -- $current(mode) {
+ crosshair -
+ analysis {
+ if {$current(frame) != {}} {
+ set coord [$current(frame) get crosshair canvas]
+ set x [lindex $coord 0]
+ set y [lindex $coord 1]
+
+ # just in case we hae a mosaic
+ UpdateColormapLevelMosaic $current(frame) $x $y canvas
+ UpdatePixelTableDialog $current(frame) $x $y canvas
+ UpdateGraph $current(frame) $x $y canvas
+ }
+ }
+ none -
+ pointer -
+ region -
+ catalog -
+ colorbar -
+ pan -
+ zoom -
+ rotate -
+ crop -
+ examine -
+ iexam {}
+ }
+}
+
+proc ProcessSend {proc id sock fn ext rr} {
+ if {$sock != {}} {
+ # not implemented
+ } elseif {$fn != {}} {
+ append fn $ext
+ set ch [open $fn w]
+ puts $ch $rr
+ close $ch
+ $proc $id {} $fn
+ } else {
+ $proc $id $rr
+ }
+}
+
+proc Toplevel {w mb style title proc} {
+ global ds9
+
+ toplevel $w
+ switch $ds9(wm) {
+ x11 {}
+ aqua {
+ switch $style {
+ 6 {::tk::unsupported::MacWindowStyle style $w document "closeBox collapseBox"}
+ 7 {::tk::unsupported::MacWindowStyle style $w document "closeBox fullZoom collapseBox resizable"}
+ }
+ }
+ win32 {}
+ }
+
+ wm title $w $title
+ wm iconname $w $title
+ wm group $w $ds9(top)
+ wm protocol $w WM_DELETE_WINDOW $proc
+
+ # we need this first, before the configure command
+ menu $mb
+ AppleMenu $mb
+ $w configure -menu $mb
+
+ global pds9
+ if {$pds9(dialog,center)} {
+ DialogCenter $w
+ }
+}
+
+proc SourceInitFileDir {ext} {
+ global ds9
+
+ foreach pp {{.} {}} {
+ set fn $pp$ds9(app)$ext
+ set ff [file join [GetEnvHome] $fn]
+ switch [SourceInitFile $ff] {
+ 1 {return 1}
+ default {return 0}
+ }
+ }
+ return 0
+}
+
+proc SourceInitFile {fn} {
+ global tcl_platform
+
+ # do this cause old scripts may assume access during source command
+ global ds9
+
+ if {[file exist $fn] && [file isfile $fn]} {
+ # check permissions
+ switch $tcl_platform(platform) {
+ unix {
+ set pp [split [file attributes $fn -perm] {}]
+ if {![ValidReadOnly [lindex $pp 3]] ||
+ ![ValidReadOnly [lindex $pp 4]]} {
+ set msg "[msgcat::mc {Invalid file permissions detected}]: $fn [msgcat::mc {Please change the file's permission to disable other users write access. Use anyway?}]"
+
+ if {[tk_messageBox -type yesno -icon question -message $msg] != {yes}} {
+ # failed to execute
+ return 0
+ }
+ }
+ }
+ windows {}
+ }
+
+ # can't make this a debug command line option
+ # prefs set before options parsed
+ if {[catch {source $fn}]} {
+ Error "[msgcat::mc {An error has occurred while executing}] $fn. [msgcat::mc {DS9 will complete the initialization process}]"
+ # failed to execute
+ return 0
+ }
+ # success execute
+ return 1
+ }
+
+ # not found
+ return -1
+}
+
+proc ValidReadOnly {perm} {
+ if {[string is integer $perm]} {
+ switch $perm {
+ 0 -
+ 1 -
+ 4 -
+ 5 {return 1}
+ default {return 0}
+ }
+ }
+ return 0;
+}
+
+proc LanguageToName {which} {
+ switch $which {
+ locale {return {Locale}}
+ cs {return "\u010Cesky"}
+ da {return {Dansk}}
+ de {return {Deutsch}}
+ en {return {English}}
+ es {return {Español}}
+ fr {return {Français}}
+ ja {return [encoding convertfrom euc-jp "\xc6\xfc\xcb\xdc\xb8\xec"]}
+ pt {return {Português}}
+ zh {return [encoding convertfrom big5 "\xA4\xA4\xA4\xE5"]}
+ }
+}
+
+proc SetLanguage {ll} {
+ global ds9
+ global pds9
+
+ set pds9(language,name) [LanguageToName $ll]
+
+ set x 0
+ msgcat::mclocale $ll
+
+ msgcat::mcload [file join $::tk_library msgs]
+
+ # we need to find if we support this language
+ if {[msgcat::mcload [file join $ds9(root) msgs]]} {
+ incr x
+ }
+ if {$pds9(language,dir) != {}} {
+ if {[msgcat::mcload $pds9(language,dir)]} {
+ incr x
+ }
+ }
+
+ # if english, always return found
+ if {[string equal [string range $ll 0 1] {en}]} {
+ incr x
+ }
+
+ if {$x} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc GetEnvHome {} {
+ global env
+ global tcl_platform
+
+ switch $tcl_platform(platform) {
+ unix {
+ if {[info exists env(HOME)]} {
+ return $env(HOME)
+ }
+ }
+ windows {
+ if {[info exists env(HOME)]} {
+ set hh [file normalize [file nativename $env(HOME)]]
+ if {[file isdirectory $hh]} {
+ return $hh
+ }
+ }
+ # this is just a backup, the above should always work
+ if {[info exists env(HOMEDRIVE)] && [info exists env(HOMEPATH)]} {
+ return "$env(HOMEDRIVE)$env(HOMEPATH)"
+ }
+ }
+ }
+ return {}
+}
+
+proc InitTempDir {} {
+ global ds9
+ global env
+
+ # check environment vars first
+ # windows is very picky as to file name format
+ if {[info exists env(TEMP)]} {
+ set ds9(tmpdir) [file normalize [file nativename $env(TEMP)]]
+ } elseif {[info exists env(TMP)]} {
+ set ds9(tmpdir) [file normalize [file nativename $env(TMP)]]
+ }
+
+ # nothing so far, go with defaults
+ if {$ds9(tmpdir) == {}} {
+ global tcl_platform
+ switch $tcl_platform(platform) {
+ unix {set ds9(tmpdir) "/tmp"}
+ windows {set ds9(tmpdir) "C:/WINDOWS/Temp"}
+ }
+ }
+
+ # see if it is valid, else current directory
+ if {![file isdirectory $ds9(tmpdir)]} {
+ set ds9(tmpdir) {.}
+ }
+}
+
+proc tmpnam {ext} {
+ global ds9
+
+ for {set ii 0} {$ii<10} {incr ii} {
+ set fn "$ds9(tmpdir)/ds9[clock clicks]$ext"
+ if {![file exists $fn]} {
+ return $fn
+ }
+ }
+
+ # give up
+ return "$ds9(tmpdir)/ds9$ext"
+}
+
+# which compiler do we use for filtering?
+proc InitFilterCompiler {} {
+ global ds9
+ global env
+ global argv0
+
+ # if the user did not explicitly specify one ...
+ if {![info exists env(FILTER_CC)]} {
+ switch -- $ds9(wm) {
+ x11 {}
+ aqua {
+ if {![file exists /usr/bin/gcc]} {
+ # pcc is hardwired to be installed in /tmp
+ set pccroot "/tmp/pcc"
+ set pcc "$pccroot/bin/pcc"
+ set tar "pcc-i386-snowleopard.tar.gz"
+
+ if {[file readable "$ds9(root)/$tar"]} {
+ exec cp "$ds9(root)/$tar" "/tmp/$tar"
+ exec tar xfPz "/tmp/$tar" -C /tmp
+ exec rm -f "/tmp/$tar"
+ }
+
+ if {[file exists $pcc]} {
+ set env(FILTER_CC) $pcc
+ set env(FILTER_CFLAGS) "-isystem $pccroot/lib/pcc"
+ set env(PATH) "$pccroot/bin:$env(PATH)"
+ }
+ }
+ }
+ win32 {
+ set tcc [file join [file dirname $argv0] tcc/tcc.exe]
+ if {[file exists $tcc]} {
+ set env(FILTER_CC) [file nativename [file attributes [file normalize $tcc] -shortname]]
+ set env(FILTER_TMPDIR) [file nativename [file attributes [file normalize $ds9(tmpdir)] -shortname]]
+ }
+ }
+ }
+ }
+}
+
+proc ToYesNo {value} {
+ if {$value == 1} {
+ return "yes\n"
+ } else {
+ return "no\n"
+ }
+}
+
+proc FromYesNo {value} {
+ set v [string tolower $value]
+
+ if {$v == "no" || $v == "false" || $v == "off" || $v == 0} {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+proc ProcessRealizeDS9 {} {
+ global ds9
+ global current
+
+ # this can really slow down scripts so use ds9(last)
+ # to remember last update
+ if {$ds9(last) != $current(frame)} {
+ RealizeDS9
+ set ds9(last) $current(frame)
+ }
+}
+
+proc RealizeDS9 {{preserve 0}} {
+ # this has to come first, to realize the canvas
+ global debug
+ if {$debug(tcl,idletasks)} {
+ puts stderr "RealizeDS9"
+ }
+
+ # update all frames
+ global ds9
+ foreach ff $ds9(frames) {
+ if {$preserve} {
+ $ff 3d preserve
+ }
+ $ff update now
+ }
+
+# idletasks fails for windows. we need to process all events to make
+# sure all windows are realized
+# update idletasks
+ update
+}
+
+proc Sex2H {str} {
+ scan $str "%d:%d:%f" h m s
+ return [expr $h+($m/60.)+($s/(60.*60.))]
+}
+
+proc Sex2Hs {str} {
+ scan $str "%d %d %f" h m s
+ return [expr $h+($m/60.)+($s/(60.*60.))]
+}
+
+proc Sex2D {str} {
+ set sign 1
+ set degree 0
+ set min 0
+ set sec 0
+ scan $str "%d:%f:%f" degree min sec
+
+ if {$degree != 0} {
+ if {$degree < 0} {
+ set sign -1
+ }
+ } else {
+ if {[string range $str 0 0] == {-}} {
+ set sign -1
+ }
+ }
+
+ return [expr $sign * (abs($degree)+($min/60.)+($sec/(60.*60.)))]
+}
+
+proc SetCursor {cursor} {
+ global ds9
+ global iis
+ global current
+
+ # if init phase, don't change cursor
+ if {$ds9(init)} {
+ return
+ }
+
+ # if iis cursor mode, don't change cursor
+ if {$iis(state)} {
+ return
+ }
+
+ if {($current(cursor) != $cursor)} {
+ set current(cursor) $cursor
+ if {$cursor != {}} {
+ $ds9(canvas) configure -cursor $cursor
+ } else {
+ $ds9(canvas) configure -cursor {}
+ }
+ }
+}
+
+proc SetWatchCursor {} {
+ global ds9
+ global icursor
+
+ # we don't want to update during initialization
+ if {$ds9(init)} {
+ return
+ }
+
+ set icursor(save) [$ds9(canvas) cget -cursor]
+ $ds9(canvas) configure -cursor {}
+ $ds9(main) configure -cursor watch
+
+ update
+}
+
+proc ResetWatchCursor {} {
+ global ds9
+ global icursor
+
+ # we don't want to update during initialization
+ if {$ds9(init)} {
+ return
+ }
+
+ $ds9(main) configure -cursor {}
+ $ds9(canvas) configure -cursor $icursor(save)
+}
+
+proc CursorTimer {} {
+ global ds9
+ global icursor
+
+ switch -- $icursor(timer) {
+ 0 {
+ set icursor(timer,abort) 0
+ set icursor(timer) 0
+ set icursor(id) 0
+ $ds9(canvas) configure -cursor {}
+ }
+ 1 {
+ $ds9(canvas) configure -cursor circle
+ set icursor(timer) 2
+ set icursor(id) [after 1000 CursorTimer]
+ }
+ 2 {
+ $ds9(canvas) configure -cursor dot
+ set icursor(timer) 1
+ set icursor(id) [after 1000 CursorTimer]
+ }
+ }
+}
+
+proc AboutBox {} {
+ global help
+ global ds9
+ global ed
+
+ set w {.abt}
+
+ set ed(ok) 0
+
+ DialogCreate $w [msgcat::mc {About SAOImage DS9}] ed(ok)
+
+ # Param
+ set f [frame $w.param -background white]
+ canvas $f.c -background white -height 450 -width 500
+ pack $f.c -fill both -expand true
+
+ # can't use -file for zvfs
+ # set ed(sun) [image create photo -format gif -file $ds9(root)/doc/sun.gif]
+ set ch [open $ds9(root)/doc/sun.gif r]
+ fconfigure $ch -translation binary -encoding binary
+ set dd [read $ch]
+ close $ch
+ unset ch
+
+ set ed(sun) [image create photo -format gif -data "$dd"]
+ unset dd
+
+ $f.c create image 0 0 -image $ed(sun) -anchor nw
+ $f.c create text 120 22 -text $help(about) -anchor nw -width 350
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.ok -text [msgcat::mc {OK}] -command {set ed(ok) 1} \
+ -default active
+ pack $f.ok -padx 2 -pady 2
+
+ bind $w <Return> {set ed(ok) 1}
+
+ # 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
+
+ DialogCenter $w
+ DialogWait $w ed(ok)
+ DialogDismiss $w
+
+ image delete $ed(sun)
+ unset ed
+}
+
+proc QuitDS9 {} {
+ global ds9
+
+ # shutdown SAMP
+ global samp
+ if {[info exists samp]} {
+ catch {SAMPDisconnect}
+ }
+
+ # close IIS ports
+ catch {IISClose}
+
+ # close out XPA
+ global xpa
+ if {[info exists xpa]} {
+ catch {xpafree $xpa}
+ }
+
+ # close all HV windows, they may have tmp files
+ global ihv
+ foreach hh $ihv(windows) {
+ if {[winfo exists $hh]} {
+ catch {HVDestroy $hh}
+ }
+ }
+
+ focus {}
+ exit
+}
+
+proc OpenSource {} {
+ set filename [OpenFileDialog tclfbox]
+ if {$filename != {}} {
+ uplevel #0 "source \{$filename\}"
+ }
+}
+
+proc OpenConsole {} {
+ if {[winfo exists ".tkcon"]} {
+ tkcon show
+ } else {
+ set ::tkcon::OPT(exec) {}
+ set ::tkcon::OPT(font) [font actual TkFixedFont]
+ tkcon::Init
+ }
+}
+
+proc ToggleBindEvents {} {
+ global ds9
+
+ if {$ds9(freeze)} {
+ set ds9(freeze) 0
+ BindEventsCanvas
+ BindEventsPanner
+ } else {
+ set ds9(freeze) 1
+ UnBindEventsCanvas
+ UnBindEventsPanner
+ }
+}
+
+proc ChangeMode {} {
+ global ds9
+ global current
+
+ bind $ds9(canvas) <Button-1> {}
+ bind $ds9(canvas) <B1-Motion> {}
+ bind $ds9(canvas) <ButtonRelease-1> {}
+
+ foreach ff $ds9(frames) {
+ $ff crosshair off
+ $ff analysis reset
+ $ff marker catalog unselect all
+ $ff marker catalog unhighlite all
+ $ff marker unselect all
+ $ff marker unhighlite all
+ }
+
+ UpdateRegionMenu
+
+ RefreshInfoBox $current(frame)
+ PixelTableClearDialog
+ ClearGraphData
+
+ switch -- $current(mode) {
+ none -
+ pointer -
+ region -
+ catalog {SetCursor {}}
+ crosshair {
+ foreach ff $ds9(frames) {
+ $ff crosshair on
+ }
+ SetCursor crosshair
+ }
+ colorbar {SetCursor center_ptr}
+ zoom {SetCursor sizing}
+ pan {SetCursor fleur}
+ rotate {SetCursor exchange}
+ crop {SetCursor {}}
+ analysis {
+ foreach ff $ds9(frames) {
+ $ff crosshair on
+ }
+ SetCursor crosshair
+ IMEChangeShape
+ }
+ examine {SetCursor target}
+ iexam {}
+ }
+}
+
+# Font procs
+
+proc InitDefaultFont {} {
+ global ds9
+ global pds9
+
+ set pds9(font) helvetica
+ set pds9(font,weight) normal
+ set pds9(font,slant) roman
+
+ switch $ds9(wm) {
+ x11 {set pds9(font,size) 9}
+ aqua {set pds9(font,size) 13}
+ win32 {set pds9(font,size) 10}
+ }
+}
+
+proc InitDefaultTextFont {} {
+ global ds9
+ global pds9
+
+ set pds9(text,font) courier
+ set pds9(text,font,weight) normal
+ set pds9(text,font,slant) roman
+
+ switch $ds9(wm) {
+ x11 {set pds9(text,font,size) 9}
+ aqua {set pds9(text,font,size) 12}
+ win32 {set pds9(text,font,size) 10}
+ }
+}
+
+proc ResetDefaultFont {} {
+ InitDefaultFont
+ SetDefaultFont true
+}
+
+proc ResetDefaultTextFont {} {
+ InitDefaultTextFont
+ SetDefaultTextFont true
+}
+
+proc SetDefaultFont {which} {
+ global ds9
+ global pds9
+
+ font configure TkDefaultFont -family $ds9($pds9(font)) \
+ -size $pds9(font,size) -weight $pds9(font,weight) \
+ -slant $pds9(font,slant)
+
+ switch $ds9(wm) {
+ x11 {
+ font configure TkMenuFont -family $ds9($pds9(font)) \
+ -size $pds9(font,size) -weight $pds9(font,weight) \
+ -slant $pds9(font,slant)
+ }
+ aqua -
+ win32 {
+ # can't change font defs, see font configure doc
+ }
+ }
+
+ if {$which} {
+ UpdateScaleDialogFont
+ UpdateGraphFont
+ CATUpdateFont
+ }
+}
+
+proc SetDefaultTextFont {which} {
+ global ds9
+ global pds9
+
+ font configure TkFixedFont -family $ds9($pds9(text,font)) \
+ -size $pds9(text,font,size) -weight $pds9(text,font,weight) \
+ -slant $pds9(text,font,slant)
+
+ if {$which} {
+ SimpleTextUpdateFont
+ }
+}
+
+proc PrefsBgColor {} {
+ global ds9
+ global pds9
+
+ foreach ff $ds9(frames) {
+ $ff bg color $pds9(bg)
+ }
+}
+
+proc PrefsNanColor {} {
+ global ds9
+ global pds9
+
+ foreach ff $ds9(frames) {
+ $ff nan color $pds9(nan)
+ }
+}
+
+proc ChangeThreads {} {
+ global ds9
+
+ foreach ff $ds9(frames) {
+ $ff threads $ds9(threads)
+ }
+}
+
+proc PrefsIRAFAlign {} {
+ global ds9
+ global pds9
+
+ foreach ff $ds9(frames) {
+ $ff iraf align $pds9(iraf)
+ }
+}
+
+proc DisplayLog {item} {
+ SimpleTextDialog ftptxt [msgcat::mc {Message Log}] 80 40 append bottom $item
+}
+
+proc ParseURL {url varname} {
+ upvar $varname r
+
+ set r(scheme) {}
+ set r(authority) {}
+ set r(path) {}
+ set r(query) {}
+ set r(fragment) {}
+ set exp {^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?}
+
+ if {![regexp -nocase $exp $url x a r(scheme) c r(authority) r(path) f r(query) h r(fragment)]} {
+ return 0
+ }
+
+ # check for windows disk drives
+ global tcl_platform
+ switch $tcl_platform(platform) {
+ unix {
+ switch -- $r(scheme) {
+ ftp {
+ # strip any username/passwd
+ set id [string first {@} $r(authority)]
+ if { $id != -1} {
+ set r(authority) [string range $r(authority) [expr $id+1] end]
+ }
+ }
+ }
+ }
+ windows {
+ switch -- $r(scheme) {
+ {} -
+ ftp -
+ http -
+ file {
+ if {[regexp {/([A-Z]:)(/.*)} $r(path) a b c]} {
+ set r(path) "$b$c"
+ }
+ }
+ default {
+ set r(path) "$r(scheme):$r(path)"
+ set r(scheme) {}
+ }
+ }
+ }
+ }
+
+ return 1
+}
+
+proc BreakUp {str} {
+ set r {}
+ set l [string length $str]
+ for {set i 0} {$i < $l} {incr i} {
+ set c [string index $str $i]
+ append r $c
+ if {$c=="\}"} {
+ append r "\n"
+ }
+ }
+ return $r
+}
+
+proc InPath {which} {
+ global env
+ global tcl_platform
+
+ switch $tcl_platform(platform) {
+ unix {
+ set target ${which}
+ set paths [split $env(PATH) :]
+ }
+ windows {
+ set target ${which}.exe
+ set paths [split $env(PATH) \;]
+ }
+ }
+
+ foreach p $paths {
+ if {[file executable [file join $p $target]]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc FTPLog {s msg state} {
+ global debug
+
+ if {$debug(tcl,ftp)} {
+ DisplayLog "$s $msg $state\n"
+ }
+}
+
+proc HTTPLog {token} {
+ global debug
+
+ if {$debug(tcl,http)} {
+ upvar #0 $token t
+
+ DisplayLog "url: $t(url)\n"
+ DisplayLog "http: $t(http)\n"
+ DisplayLog "type: $t(type)\n"
+ DisplayLog "currentsize: $t(currentsize)\n"
+ DisplayLog "totalsize: $t(totalsize)\n"
+ DisplayLog "status: $t(status)\n"
+ if {[info exists t(error)]} {
+ DisplayLog "error: $t(error)\n"
+ }
+ DisplayLog "meta: [BreakUp $t(meta)]\n"
+ }
+}
+
+proc ConfigHTTP {} {
+ global phttp
+
+ # set the User-Agent
+ http::config -useragent ds9
+
+ # set the proxy if requested
+ if {$phttp(proxy)} {
+ http::config -proxyhost $phttp(proxy,host) -proxyport $phttp(proxy,port)
+ }
+}
+
+proc ProxyHTTP {} {
+ global phttp
+
+ set auth {}
+ if {$phttp(proxy) && $phttp(auth)} {
+ set auth [list "Proxy-Authorization" [concat "Basic" [base64::encode $phttp(auth,user):$phttp(auth,passwd)]]]
+ }
+
+ return $auth
+}
+
+proc FixSpec {sysname skyname formatname defsys defsky defformat} {
+ upvar $sysname sys
+ upvar $skyname sky
+ upvar $formatname format
+
+ set rr 0
+
+ switch -- $sys {
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {incr rr}
+
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {
+ set format $sky
+ set sky $sys
+ set sys wcs
+ }
+
+ default {
+ set format $sky
+ set sky $sys
+ set sys $defsys
+ }
+ }
+
+ switch -- $sky {
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {incr rr}
+
+ default {
+ set format $sky
+ set sky $defsky
+ }
+ }
+
+ switch -- $format {
+ degrees -
+ arcmin -
+ arcsec -
+ sexagesimal {incr rr}
+
+ default {
+ set format $defformat
+ }
+ }
+
+ return $rr
+}
+
+proc FixSpecSystem {sysname defsys} {
+ upvar $sysname sys
+
+ set rr 0
+
+ switch -- $sys {
+ image -
+ physical -
+ detector -
+ amplifier -
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {incr rr}
+ default {
+ set sys $defsys
+ }
+ }
+
+ return $rr
+}
+
+proc DS9Backup {ch which} {
+ global pds9
+
+ puts $ch "$which bg color $pds9(bg)"
+ puts $ch "$which nan color $pds9(nan)"
+}
+
+# Process Cmds
+
+proc ProcessPrefsCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global pds9
+ global ds9
+
+ switch -- [string tolower [lindex $var $i]] {
+ clear {ClearPrefs}
+ bgcolor {
+ # backward compatibility
+ incr i
+ set pds9(bg) [lindex $var $i]
+ PrefsBgColor
+ }
+ nancolor {
+ # backward compatibility
+ incr i
+ set pds9(nan) [lindex $var $i]
+ PrefsNanColor
+ }
+ threads {
+ # backward compatibility
+ incr i
+ set ds9(threads) [lindex $var $i]
+ ChangeThreads
+ }
+ irafalign {
+ incr i
+ set pds9(iraf) [FromYesNo [lindex $var $i]]
+ PrefsIRAFAlign
+ }
+ }
+}
+
+proc ProcessSendPrefsCmd {proc id param} {
+ global pds9
+ global ds9
+
+ # backward compatibility
+ switch -- [string tolower [lindex $param 0]] {
+ bgcolor {$proc $id "$pds9(bg)\n"}
+ nancolor {$proc $id "$pds9(nan)\n"}
+ threads {$proc $id "$ds9(threads)\n"}
+ irafalign {$proc $id [ToYesNo $pds9(iraf)]}
+ }
+}
+
+proc ProcessBgCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global pds9
+ set pds9(bg) [lindex $var $i]
+ PrefsBgColor
+}
+
+proc ProcessSendBgCmd {proc id param} {
+ global pds9
+
+ $proc $id "$pds9(bg)\n"
+}
+
+proc ProcessNanCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global pds9
+ set pds9(nan) [lindex $var $i]
+ PrefsNanColor
+}
+
+proc ProcessSendNanCmd {proc id param} {
+ global pds9
+
+ $proc $id "$pds9(nan)\n"
+}
+
+proc ProcessThreadsCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ set ds9(threads) [lindex $var $i]
+ ChangeThreads
+}
+
+proc ProcessSendThreadsCmd {proc id param} {
+ global ds9
+
+ $proc $id "$ds9(threads)\n"
+}
+
+proc ProcessIRAFAlignCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global pds9
+ set pds9(iraf) [FromYesNo [lindex $var $i]]
+ PrefsIRAFAlign
+}
+
+proc ProcessSendIRAFAlignCmd {proc id param} {
+ global pds9
+
+ $proc $id [ToYesNo $pds9(iraf)]
+}
+
+proc ProcessCDCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ cd [lindex $var $i]
+}
+
+proc ProcessSendCDCmd {proc id param} {
+ $proc $id "[pwd]\n"
+}
+
+proc ProcessConsoleCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ OpenConsole
+
+ # ignore error message about ActiveTcl
+ global ds9
+ InitError $ds9(msg,src)
+}
+
+proc ProcessCursorCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+
+ if {$current(frame) != {}} {
+ set x [lindex $var $i]
+ incr i
+ set y [lindex $var $i]
+
+ switch -- $current(mode) {
+ none {$current(frame) warp $x $y}
+ pointer -
+ region {MarkerArrowKey $current(frame) $x $y}
+ catalog {MarkerArrowKey $current(frame) $x $y}
+ crosshair {CrosshairArrowKey $current(frame) $x $y}
+ colorbar {}
+ pan {Pan $x $y canvas}
+ zoom -
+ rotate -
+ crop {}
+ analysis {IMEArrowKey $current(frame) $x $y}
+ examine -
+ iexam {}
+ }
+ }
+}
+
+proc ProcessSendDataCmd {proc id param sock fn} {
+ global cube
+ global blink
+ global current
+
+ if {$current(frame) != {}} {
+ set sys [lindex $param 0]
+ set sky [lindex $param 1]
+ set x [lindex $param 2]
+ set y [lindex $param 3]
+ set w [lindex $param 4]
+ set h [lindex $param 5]
+ set strip [lindex $param 6]
+ switch -- $sys {
+ image -
+ physical -
+ detector -
+ amplifier {
+ set strip $h
+ set h $w
+ set w $y
+ set y $x
+ set x $sky
+ set sky fk5
+ }
+
+ fk4 -
+ b1950 -
+ fk5 -
+ j2000 -
+ icrs -
+ galactic -
+ ecliptic {
+ set strip $h
+ set h $w
+ set w $y
+ set y $x
+ set x $sky
+ set sky $sys
+ set sys wcs
+ }
+ }
+ set strip [FromYesNo $strip]
+
+ $current(frame) get data $sys $sky $x $y $w $h rr
+ set ss {}
+ foreach ii [array names rr] {
+ if {$strip} {
+ append ss "$rr($ii)\n"
+ } else {
+ append ss "$ii = $rr($ii)\n"
+ }
+ }
+ ProcessSend $proc $id $sock $fn {.dat} $ss
+ }
+}
+
+proc ProcessIconifyCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+
+ switch -- [string tolower [lindex $var $i]] {
+ yes -
+ true -
+ on -
+ 1 {wm iconify $ds9(top)}
+
+ no -
+ false -
+ off -
+ 0 {wm deiconify $ds9(top)}
+
+ default {
+ wm iconify $ds9(top)
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendIconifyCmd {proc id param} {
+ global ds9
+ if {[wm state $ds9(top)] == "normal"} {
+ $proc $id "no\n"
+ } else {
+ $proc $id "yes\n"
+ }
+}
+
+proc ProcessLowerCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ lower $ds9(top)
+}
+
+proc ProcessModeCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+
+ set current(mode) [string tolower [lindex $var $i]]
+ # backward compatibility
+ switch $current(mode) {
+ pointer {set current(mode) region}
+ }
+ ChangeMode
+}
+
+proc ProcessQuitCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ QuitDS9
+}
+
+proc ProcessSendModeCmd {proc id param} {
+ global current
+
+ $proc $id "$current(mode)\n"
+}
+
+proc ProcessRaiseCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ raise $ds9(top)
+}
+
+proc ProcessSleepCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # yes, we need this
+ UpdateDS9
+ RealizeDS9
+
+ set sec 1
+ if {[lindex $var $i] != {} && [string range [lindex $var $i] 0 0] != {-}} {
+ set sec [lindex $var $i]
+ } else {
+ incr i -1
+ }
+ after [expr int($sec*1000)]
+}
+
+proc ProcessSourceCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ # we need to be realized
+ # you never know what someone will try to do
+ ProcessRealizeDS9
+
+ set fn [lindex $var $i]
+ uplevel #0 "source $fn"
+}
+
+proc ProcessTclCmd {varname iname buf fn} {
+ upvar $varname var
+ upvar $iname i
+
+ # backward compatibility
+ switch -- [string tolower [lindex $var $i]] {
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ return
+ }
+ }
+
+ if {$buf != {}} {
+ uplevel #0 $buf
+ } elseif {$fn != {}} {
+ if {[file exists $fn]} {
+ set ch [open $fn r]
+ set cmd [read $ch]
+ close $ch
+ uplevel #0 $cmd
+ }
+ } elseif {[lindex $var $i] != {}} {
+ # special case
+ uplevel #0 [lindex $var $i]
+ }
+}
+
+# backward compatibility
+proc ProcessThemeCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+}
+
+# backward compatibility
+proc ProcessSendThemeCmd {proc id param} {
+ global pds9
+ $proc $id "native\n"
+}
+
+proc ProcessSendVersionCmd {proc id param} {
+ global ds9
+ $proc $id "$ds9(title) [lindex $ds9(version) 0]\n"
+}
+
+proc XMLQuote {val} {
+ return [string map {& &amp; < &lt; > &gt; \' &apos; \" &quot;} $val]
+}
+
+proc XMLUnQuote {val} {
+ return [string map {&amp; & &lt; < &gt; > &apos; \' &quot; \"} $val]
+}
+
diff --git a/ds9/library/var.tcl b/ds9/library/var.tcl
new file mode 100644
index 0000000..549756f
--- /dev/null
+++ b/ds9/library/var.tcl
@@ -0,0 +1,21 @@
+# 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 LoadVar {varname fn layer mode} {
+ global loadParam
+
+ set loadParam(file,type) fits
+ set loadParam(file,mode) $mode
+ set loadParam(load,type) var
+ set loadParam(var,name) $varname
+ set loadParam(file,name) "$fn"
+
+ # mask not supported
+ set loadParam(load,layer) {}
+
+ ProcessLoad
+}
+
diff --git a/ds9/library/vector.tcl b/ds9/library/vector.tcl
new file mode 100644
index 0000000..13876e4
--- /dev/null
+++ b/ds9/library/vector.tcl
@@ -0,0 +1,165 @@
+# 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 VectorDialog {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pmarker
+
+ # see if we already have a header window visible
+ if {[winfo exists $var(top)]} {
+ raise $var(top)
+ return
+ }
+
+ # variables
+ set rr [$var(frame) get wcs]
+ set var(dcoord) [lindex $rr 0]
+ set var(dformat) $pmarker(dformat)
+ AdjustCoordSystem $varname dcoord
+
+ set var(arrow) [$var(frame) get marker $var(id) vector arrow]
+
+ # procs
+ set var(which) vector
+ set var(proc,apply) VectorApply
+ set var(proc,close) VectorClose
+ set var(proc,coordCB) VectorCoordCB
+ set var(proc,editCB) VectorEditCB
+ set var(proc,distCB) VectorDistCB
+
+ # base
+ MarkerBaseDialog $varname
+
+ # analysis
+ $var(mb) add cascade -label [msgcat::mc {Analysis}] -menu $var(mb).analysis
+ menu $var(mb).analysis
+
+ # plot2d
+ MarkerAnalysisPlot2dDialog $varname
+ # raise plot?
+ global marker
+ set var(plot2d) $marker(plot2d)
+
+ # init
+ VectorDistCB $varname
+
+ # callbacks
+ $var(frame) marker $var(id) callback move "VectorEditCB" $varname
+ $var(frame) marker $var(id) callback edit "VectorEditCB" $varname
+
+ set f $var(top).param
+
+ # Point
+ ttk::label $f.tpt -text [msgcat::mc {Point}]
+ ttk::entry $f.x -textvariable ${varname}(x) -width 13
+ ttk::entry $f.y -textvariable ${varname}(y) -width 13
+ CoordMenuButton $f.upt $varname system 1 sky skyformat \
+ [list $var(proc,coordCB) $varname]
+
+ # Length
+ ttk::label $f.tdist -text [msgcat::mc {Length}]
+ ttk::entry $f.dist -textvariable ${varname}(dist) -width 13
+ DistMenuButton $f.udist $varname dcoord 1 dformat \
+ [list VectorDistCB $varname]
+ DistMenuEnable $f.udist.menu $varname dcoord 1 dformat
+
+ # Angle
+ ttk::label $f.tangle -text [msgcat::mc {Angle}]
+ ttk::entry $f.angle -textvariable ${varname}(angle) -width 13
+ ttk::label $f.uangle -text [msgcat::mc {Degrees}]
+
+ # Arrow
+ ttk::label $f.tarrow -text [msgcat::mc {Arrow}]
+ ttk::checkbutton $f.arrow -variable ${varname}(arrow) \
+ -command "VectorArrow $varname"
+
+ grid $f.tpt $f.x $f.y $f.upt -padx 2 -pady 2 -sticky w
+ grid $f.tdist $f.dist $f.udist -padx 2 -pady 2 -sticky w
+ grid $f.tangle $f.angle $f.uangle -padx 2 -pady 2 -sticky w
+ grid $f.tarrow $f.arrow -padx 2 -pady 2 -sticky w
+}
+
+# actions
+
+proc VectorClose {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) delete callback move "VectorEditCB"
+ $var(frame) marker $var(id) delete callback edit "VectorEditCB"
+
+ MarkerBaseClose $varname
+}
+
+proc VectorApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) vector point $var(system) $var(sky) \
+ $var(x) $var(y) $var(dcoord) $var(dformat) $var(dist) $var(angle)
+
+ MarkerBaseLineApply $varname
+}
+
+proc VectorArrow {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ $var(frame) marker $var(id) vector arrow $var(arrow)
+}
+
+# callbacks
+
+proc VectorCoordCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "VectorCoordCB"
+ }
+
+ MarkerAnalysisPlot2dSystem $varname
+ MarkerBaseCoordCB $varname
+ VectorEditCB $varname
+}
+
+proc VectorEditCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "VectorEditCB"
+ }
+
+ set p [$var(frame) get marker $var(id) vector point \
+ $var(system) $var(sky) $var(skyformat)]
+
+ set var(x) [lindex $p 0]
+ set var(y) [lindex $p 1]
+
+ set var(dist) [$var(frame) get marker $var(id) vector length \
+ $var(dcoord) $var(dformat)]
+
+ set var(angle) [$var(frame) get marker $var(id) angle \
+ $var(system) $var(sky)]
+}
+
+proc VectorDistCB {varname {dummy {}}} {
+ upvar #0 $varname var
+ global $varname
+
+ global debug
+ if {$debug(tcl,marker)} {
+ puts stderr "VectorDistCB"
+ }
+
+ set var(dist) [$var(frame) get marker $var(id) vector length \
+ $var(dcoord) $var(dformat)]
+}
diff --git a/ds9/library/vla.tcl b/ds9/library/vla.tcl
new file mode 100644
index 0000000..fab32bb
--- /dev/null
+++ b/ds9/library/vla.tcl
@@ -0,0 +1,173 @@
+# 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 VLADef {} {
+ global vla
+ global ivla
+
+ set ivla(top) .vla
+ set ivla(mb) .vlatmb
+
+ set vla(sky) fk5
+ set vla(rformat) arcmin
+ set vla(width) 15
+ set vla(height) 15
+ set vla(mode) new
+ set vla(save) 0
+ set vla(survey) first
+}
+
+proc VLADialog {} {
+ global vla
+ global ivla
+ global wcs
+
+ if {[winfo exists $ivla(top)]} {
+ raise $ivla(top)
+ return
+ }
+
+ set varname dvla
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $ivla(top)
+ set var(mb) $ivla(mb)
+ set var(sky) $vla(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $vla(rformat)
+ set var(width) $vla(width)
+ set var(height) $vla(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(mode) $vla(mode)
+ set var(save) $vla(save)
+ set var(survey) $vla(survey)
+
+ set w $var(top)
+ IMGSVRInit $varname "VLA [msgcat::mc {Server}]" \
+ VLAExec VLAAck ARDone ARError
+
+ menu $var(mb).survey
+ $var(mb) add cascade -label Survey -menu $var(mb).survey
+ $var(mb).survey add radiobutton -label {First} \
+ -variable ${varname}(survey) -value first
+ $var(mb).survey add radiobutton -label {Stripe 82} \
+ -variable ${varname}(survey) -value stripe82
+ $var(mb).survey add radiobutton -label {GPS} \
+ -variable ${varname}(survey) -value gps
+
+ IMGSVRUpdate $varname
+}
+
+proc VLAExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set var(fn) [tmpnam {.fits}]
+ }
+
+ # skyformat
+ switch -- $var(skyformat) {
+ degrees {
+ set xx [uformat d h: $var(x)]
+ set yy [uformat d d: $var(y)]
+ }
+ sexagesimal {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ }
+
+ # size - convert to arcmin
+ switch -- $var(rformat) {
+ degrees {
+ set ww [expr $var(width)*60.]
+ set hh [expr $var(height)*60.]
+ }
+ arcmin {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcsec {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ }
+
+ # now to radius
+ set rr [expr sqrt($ww*$ww+$hh*$hh)/2.]
+ if {$rr>60} {
+ set rr 60
+ }
+
+ set var(query) [http::formatQuery .submit "Extract the Cutout" RA "$xx $yy" Equinox J2000 ImageSize $rr MaxInt 10 .cgifields ImageType ImageType "FITS Image"]
+ set url "http://third.ucllnl.org/cgi-bin/$var(survey)cutout"
+ IMGSVRGetURL $varname $url
+}
+
+proc VLAAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the VLA
+
+This major undertaking has received the generous technical and
+scientific support of many individuals. The NRAO staff has provided
+extremely valuable assistance in many aspects of the observations
+themselves and in the area of software support; in particular, we are
+grateful to Rick Perley, Ken Sowinski, Barry Clark, and Bill Cotton in
+this regard. The support of the NRAO Director, Paul van den Bout, and
+the yeoman service provided by Frazer Owen as Chair of the Survey
+Oversight Committee are also greatly appreciated. We also thank the
+members of the Oversight Committee (Ken Chambers, Eric Feigelson,
+Jackie Hewitt, Gillian Knapp, and Rogier Windhorst) for their time and
+wise counsel in this enterprise.
+
+Acknowledgment is also due our colleagues who are involved in the
+ongoing FIRST effort, including Richard McMahon and Isobel Hook. This
+work is supported in part under the auspices of the Department of
+Energy by Lawrence Livermore National Laboratory under contract
+No. W-7405-ENG-48 and the Institute for Geophysics and Planetary
+Physics, whose director Charles Alcock has been particularly
+supportive. We also acknowledge a generous planning grant from the
+CalSpace Institute; support from the STScI archive group, STScI
+director Bob Williams, and the STScI Director's Discretionary Research
+Fund; computing resources from Columbia University; a grant from the
+National Science Foundation; a gift of computing equipment from Sun
+Microsystems; a NATO travel grant to support our collaboration with
+Richard McMahon; and an award from the National Geographic Society
+which, in the spirit of their support 40 years ago for the Palomar
+Observatory Sky Survey, will be providing funds to continue our
+charting of the Universe.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc ProcessVLACmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ VLADialog
+ IMGSVRProcessCmd $varname $iname dvla
+}
+
+proc ProcessSendVLACmd {proc id param} {
+ VLADialog
+ IMGSVRProcessSendCmd $proc $id $param dvla
+}
diff --git a/ds9/library/vlss.tcl b/ds9/library/vlss.tcl
new file mode 100644
index 0000000..d6f0a50
--- /dev/null
+++ b/ds9/library/vlss.tcl
@@ -0,0 +1,132 @@
+# 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 VLSSDef {} {
+ global vlss
+ global ivlss
+
+ set ivlss(top) .vlss
+ set ivlss(mb) .vlsstmb
+
+ set vlss(sky) fk5
+ set vlss(rformat) arcmin
+ set vlss(width) 15
+ set vlss(height) 15
+ set vlss(mode) new
+ set vlss(save) 0
+}
+
+proc VLSSDialog {} {
+ global vlss
+ global ivlss
+ global wcs
+
+ if {[winfo exists $ivlss(top)]} {
+ raise $ivlss(top)
+ return
+ }
+
+ set varname dvlss
+ upvar #0 $varname var
+ global $varname
+
+ set var(top) $ivlss(top)
+ set var(mb) $ivlss(mb)
+ set var(sky) $vlss(sky)
+ set var(skyformat) $wcs(skyformat)
+ set var(rformat) $vlss(rformat)
+ set var(width) $vlss(width)
+ set var(height) $vlss(height)
+ # not used
+ set var(width,pixels) 300
+ set var(height,pixels) 300
+ set var(mode) $vlss(mode)
+ set var(save) $vlss(save)
+
+ set w $var(top)
+ IMGSVRInit $varname "VLSS [msgcat::mc {Server}]" \
+ VLSSExec VLSSAck ARDone ARError
+
+ IMGSVRUpdate $varname
+}
+
+proc VLSSExec {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ if {$var(save)} {
+ set var(fn) [SaveFileDialog savefitsfbox]
+ if {$var(fn) == {}} {
+ ARDone $varname
+ return
+ }
+ } else {
+ set var(fn) [tmpnam {.fits}]
+ }
+
+ # skyformat
+ switch -- $var(skyformat) {
+ degrees {
+ set xx [uformat d h: $var(x)]
+ set yy [uformat d d: $var(y)]
+ }
+ sexagesimal {
+ set xx $var(x)
+ set yy $var(y)
+ }
+ }
+ regsub -all {:} $xx { } xx
+ regsub -all {:} $yy { } yy
+
+ # size - convert to arcmin
+ switch -- $var(rformat) {
+ degrees {
+ set ww $var(width)
+ set hh $var(height)
+ }
+ arcmin {
+ set ww [expr $var(width)/60.]
+ set hh [expr $var(height)/60.]
+ }
+ arcsec {
+ set ww [expr $var(width)/60./60.]
+ set hh [expr $var(height)/60./60.]
+ }
+ }
+
+ set var(query) [http::formatQuery submit Submit Equinox J2000 RA $xx Dec $yy Size "$ww $hh" Cells "25.0 25.0" MAPROJ SIN rotate 0.0 Type image/x-fits]
+ set url "http://www.cv.nrao.edu/cgi-bin/newVLSSpostage.pl"
+ IMGSVRGetURL $varname $url
+}
+
+proc VLSSAck {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set msg {Acknowledgments for the VLSS
+
+The VLSS survey is being carried out by the NRAO and the
+Naval Research Lab.
+ }
+
+ SimpleTextDialog ${varname}ack [msgcat::mc {Acknowledgment}] \
+ 80 40 insert top $msg
+}
+
+# Process Cmds
+
+proc ProcessVLSSCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ VLSSDialog
+ IMGSVRProcessCmd $varname $iname dvlss
+}
+
+proc ProcessSendVLSSCmd {proc id param} {
+ VLSSDialog
+ IMGSVRProcessSendCmd $proc $id $param dvlss
+}
diff --git a/ds9/library/vo.tcl b/ds9/library/vo.tcl
new file mode 100644
index 0000000..c7a397d
--- /dev/null
+++ b/ds9/library/vo.tcl
@@ -0,0 +1,613 @@
+# 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 VODef {} {
+ global ivo
+ global pvo
+
+ set ivo(top) .vo
+ set ivo(mb) .vomb
+
+ set ivo(server,host) {}
+ set ivo(server,title) {}
+ set ivo(server,url) {}
+ set ivo(server,button) {}
+
+ set ivo(ka,id) {}
+
+ # prefs only
+ set pvo(server) {http://cxc.harvard.edu/chandraed/list.txt}
+ set pvo(hv) 1
+ set pvo(method) mime
+ set pvo(delay) 15
+}
+
+proc VOKeepAlive {doka} {
+ global ivo
+ global pvo
+ global xpa
+
+ # if not xpa, return
+ if {$pvo(method) != {xpa}} {
+ return
+ }
+
+ # if keep-alive turned off, return
+ if {$pvo(delay) <= 0} {
+ return
+ }
+
+ # count the connections
+ set n 0
+ for {set ii 0} {$ii < [llength $ivo(server,button)]} {incr ii} {
+ if {$ivo(b$ii)} {
+ incr n
+ break
+ }
+ }
+
+ # no connections => kill existing keep-alive, if necessary
+ if {$n == 0} {
+ if {$ivo(ka,id) != {}} {
+ after cancel $ivo(ka,id)
+ set ivo(ka,id) {}
+ }
+ } else {
+ # yes connections
+ # send a keep-alive, if necessary
+ if {$doka} {
+ # puts [format "send keepalive: %s (%d)" [exec date] $pvo(delay)]
+ xpanskeepalive $xpa
+ }
+ # arrange for the next one
+ set ivo(ka,id) [after [expr $pvo(delay) * 60 * 1000] VOKeepAlive 1]
+ }
+}
+
+proc VOCancel {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # set state to 0 so that we don't process the finish proc
+ set var(active) 0
+
+ if {[info exists var(token)]} {
+ http::reset $var(token)
+ }
+}
+
+proc VODestroy {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ VOCancel $varname
+
+ if {[winfo exists $var(top)]} {
+ destroy $var(top)
+ destroy $var(mb)
+ }
+
+ unset $varname
+}
+
+proc VOReset {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ set var(active) 0
+
+ if {[info exists var(token)]} {
+ http::cleanup $var(token)
+ unset var(token)
+ }
+}
+
+proc VODone {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ VOReset $varname
+}
+
+proc VOCancelled {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ VOReset $varname
+}
+
+proc VOError {varname message} {
+ upvar #0 $varname var
+ global $varname
+
+ Error $message
+ VOReset $varname
+}
+
+proc VODialog {{sync 0}} {
+ global ivo
+ global pvo
+
+ global ds9
+
+ if {[winfo exists $ivo(top)]} {
+ raise $ivo(top)
+ return
+ }
+
+ set varname voi
+ upvar #0 $varname var
+ global $varname
+
+ # variables
+ set var(top) $ivo(top)
+ set var(mb) $ivo(mb)
+ set var(sync) $sync
+ set var(url) {}
+
+ # create the window
+ set w $var(top)
+ set mb $var(mb)
+
+ Toplevel $w $mb 6 [msgcat::mc {Virtual Observatory}] "VODestroy $varname"
+
+ $mb add cascade -label [msgcat::mc {File}] -menu $mb.file
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] \
+ -command "VOApply $varname"
+ $mb.file add command -label [msgcat::mc {Cancel}] \
+ -command "VOCancel $varname"
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Help Me Choose}] \
+ -command HelpVO
+ $mb.file add command -label [msgcat::mc {Configure}] \
+ -command [list PrefsDialog http]
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] \
+ -command "VODestroy $varname"
+
+ # Sites
+ ttk::labelframe $w.param -text [msgcat::mc {Sites}] -padding 2
+
+ # Browser
+ set f [ttk::labelframe $w.opt -text [msgcat::mc {Browser}] -padding 2]
+ set var(hv,button) [ttk::checkbutton $w.opt.hv \
+ -text [msgcat::mc {Use Internal Web Browser}] \
+ -variable pvo(hv) \
+ -command SavePrefs]
+ ttk::radiobutton $w.opt.xpa \
+ -text [msgcat::mc {Connect Directly}] \
+ -variable pvo(method) -value xpa -command PrefsVOMethod
+ ttk::radiobutton $w.opt.http \
+ -text [msgcat::mc {Connect Using Web Proxy}] \
+ -variable pvo(method) -value mime -command PrefsVOMethod
+ grid $w.opt.hv -padx 2 -pady 2 -sticky w
+ grid $w.opt.xpa $w.opt.http -padx 2 -pady 2 -sticky w
+
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.help -text [msgcat::mc {Help Me Choose}] \
+ -command HelpVO
+ ttk::button $f.proxy -text [msgcat::mc {Configure}] \
+ -command [list PrefsDialog http]
+ ttk::button $f.close -text [msgcat::mc {Close}] \
+ -command "VODestroy $varname"
+ pack $f.help $f.proxy $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ grid $w.param -sticky news
+ grid $w.opt -sticky news
+ grid $w.buttons -sticky ew
+ grid rowconfigure $w 0 -weight 1
+ grid rowconfigure $w 1 -weight 1
+ grid columnconfigure $w 0 -weight 1
+
+ if {[string length $ivo(server,host)] == 0} {
+ VOApply $varname
+ } else {
+ set l [llength $ivo(server,host)]
+ for {set ii 0} {$ii<$l} {incr ii} {
+ set b [lindex $ivo(server,button) $ii]
+ ttk::checkbutton $b -text "[lindex $ivo(server,title) $ii] ([lindex $ivo(server,url) $ii])" -variable ivo(b$ii) -command "VOCheck $varname $ii"
+ pack $b -anchor w -padx 2 -pady 2
+ }
+ }
+}
+
+proc VOApply {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ivo
+ global pvo
+ global xpa
+
+ set w $var(top)
+
+ # delete old servers
+ for {set ii 0} {$ii < [llength $ivo(server,button)]} {incr ii} {
+ catch {xparemote $xpa [lindex $ivo(server,host) $ii] - -proxy}
+ catch {destroy [lindex $ivo(server,button) $ii]}
+ catch {unset ivo(b$ii)}
+ }
+ set ivo(server,host) {}
+ set ivo(server,title) {}
+ set ivo(server,url) {}
+ set ivo(server,button) {}
+
+ VOFindServer $varname
+ if {$var(url) != {}} {
+ VOLoad $varname
+ } else {
+ VOLoadDefault $varname
+ }
+
+ # start or stop the keep-alive, as needed
+ VOKeepAlive 0
+}
+
+proc VOLoadDefault {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ # hardcode
+ VOError $varname "Unable to access VO server list, please verify internet connection. Using default list."
+
+ set rr {chandra-ed.cfa.harvard.edu:28571 CFA Chandra-Ed Archive Server http://chandra-ed.cfa.harvard.edu/archive.html
+xray1.physics.rutgers.edu:28571 Rutgers Primary MOOC X-ray Analysis Server http://xray1.physics.rutgers.edu/archive.html
+rinzai.rutgers.edu:28571 Rutgers X-ray Analysis Server #2 http://rinzai.rutgers.edu/archive.html}
+
+ VOParse $varname $rr
+}
+
+proc VOFindServer {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global pvo
+ if {[VOCheckServer $varname $pvo(server)]} {
+ return
+ }
+ if {[VOCheckServer $varname {http://cxc.harvard.edu/chandraed/list.txt}]} {
+ return
+ }
+ if {[VOCheckServer $varname {http://cxc.harvard.edu/chandraed/test.txt}]} {
+ return
+ }
+ if {[VOCheckServer $varname {http://chandra-ed.rutgers.edu/vo/list.txt}]} {
+ return
+ }
+ if {[VOCheckServer $varname {http://chandra-ed.cfa.harvard.edu/vo/list.txt}]} {
+ return
+ }
+}
+
+proc VOCheckServer {varname url} {
+ upvar #0 $varname var
+ global $varname
+
+ ParseURL $url rr
+ set var(url) $url
+
+ if {[checkdns $rr(authority) 3 1] == 0} {
+ set var(url) $url
+ return 1
+ } else {
+ set var(url) {}
+ return 0
+ }
+}
+
+proc VOLoad {varname} {
+ upvar #0 $varname var
+ global $varname
+
+ global ihttp
+ if {$var(sync)} {
+ if {![catch {set var(token) [http::geturl $var(url) \
+ -timeout $ihttp(timeout) \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ VOFinish $varname $var(token)
+ } else {
+ VOLoadDefault $varname
+ }
+ } else {
+ if {![catch {set var(token) [http::geturl $var(url) \
+ -timeout $ihttp(timeout) \
+ -command [list VOFinish $varname] \
+ -headers "[ProxyHTTP]"]
+ }]} {
+ # reset errorInfo (may be set in http::geturl)
+ global errorInfo
+ set errorInfo {}
+
+ set var(active) 1
+ } else {
+ VOLoadDefault $varname
+ }
+ }
+}
+
+proc VOFinish {varname token} {
+ upvar #0 $varname var
+ global $varname
+
+ if {!($var(active))} {
+ VOCancelled $varname
+ return
+ }
+
+ upvar #0 $token t
+
+ # Code
+ set code [http::ncode $token]
+
+ # Meta
+ set meta $t(meta)
+
+ # Log it
+ HTTPLog $token
+
+ # Result?
+ switch -- $code {
+ 200 -
+ 203 -
+ 503 {
+ VOParse $varname [http::data $var(token)]
+ VODone $varname
+ }
+
+ 201 -
+ 300 -
+ 301 -
+ 302 -
+ 303 -
+ 305 -
+ 307 {
+ foreach {name value} $meta {
+ if {[regexp -nocase ^location$ $name]} {
+ global debug
+ if {$debug(tcl,http)} {
+ puts stderr "VOFinish redirect $code to $value"
+ }
+ # clean up and resubmit
+ http::cleanup $token
+ unset var(token)
+
+ set var(url) $value
+ VOLoad $varname
+ }
+ }
+ }
+
+ default {VOError $varname [msgcat::mc {An error has occurred while updating VO server list}]}
+ }
+}
+
+proc VOParse {varname rr} {
+ upvar #0 $varname var
+ global $varname
+
+ global ivo
+
+ set w $var(top)
+
+ set data [string trimright $rr \n]
+ set lines [split $data \n]
+ set len [llength $lines]
+ for {set ii 0} {$ii<$len} {incr ii} {
+ set line [lindex $lines $ii]
+ set b "$w.param.b$ii"
+
+ set ll [split $line \t]
+ lappend ivo(server,host) [lindex $ll 0]
+ lappend ivo(server,title) [lindex $ll 1]
+ lappend ivo(server,url) [lindex $ll 2]
+ lappend ivo(server,button) $b
+ set ivo(b$ii) 0
+ ttk::checkbutton $b -text "[lindex $ivo(server,title) $ii] ([lindex $ivo(server,url) $ii])" -variable ivo(b$ii) -command "VOCheck $varname $ii"
+ pack $b -anchor w -padx 2 -pady 2
+ }
+}
+
+proc VOCheck {varname ii} {
+ upvar #0 $varname var
+ global $varname
+
+ global ivo
+ global pvo
+
+ global xpa
+
+ set w $var(top)
+ set b "$w.param.b$ii"
+
+ if {$ivo(b$ii)} {
+ switch $pvo(method) {
+ mime {}
+ xpa {
+ if {[info exists xpa]} {
+ if {[catch {xparemote $xpa [lindex $ivo(server,host) $ii] + -proxy}]} {
+ Info [msgcat::mc {Unable to connect directly: using Web Proxy}]
+ set pvo(method) mime
+ }
+ }
+ }
+ }
+
+ if {$pvo(hv)} {
+ set url [lindex $ivo(server,url) $ii]
+ ParseURL $url r
+ HV "vo$ii" "$r(authority)" $url {} $var(sync)
+ }
+ } else {
+ switch $pvo(method) {
+ mime {}
+ xpa {
+ catch {xparemote $xpa [lindex $var(server,host) $ii] - -proxy}
+ }
+ }
+ }
+
+ # start or stop the keep-alive, as needed
+ VOKeepAlive 0
+}
+
+proc PrefsVOMethod {} {
+ global pvo
+
+ switch $pvo(method) {
+ mime {set pvo(hv) 1}
+ xpa {}
+ }
+}
+
+proc PrefsDialogVO {} {
+ global dprefs
+
+ set w $dprefs(tab)
+
+ $dprefs(list) insert end [msgcat::mc {VO}]
+ lappend dprefs(tabs) [ttk::frame $w.vo]
+
+ # Browser
+ set f [ttk::labelframe $w.vo.browser -text [msgcat::mc {Browser}]]
+
+ ttk::checkbutton $f.web -text [msgcat::mc {Use Internal Web Browser}] \
+ -variable pvo(hv)
+ ttk::radiobutton $f.xpa -text [msgcat::mc {Connect Directly}] \
+ -variable pvo(method) -value xpa -command PrefsVOMethod
+ ttk::radiobutton $f.mime -text [msgcat::mc {Connect Using Web Proxy}] \
+ -variable pvo(method) -value mime -command PrefsVOMethod
+
+ grid $f.web -padx 2 -pady 2 -sticky w
+ grid $f.xpa $f.mime -padx 2 -pady 2 -sticky w
+
+ # Server
+ set f [ttk::labelframe $w.vo.server -text [msgcat::mc {VO Server}]]
+
+ ttk::label $f.stitle -text [msgcat::mc {Default}]
+ ttk::entry $f.server -textvariable pvo(server) -width 50
+
+ grid $f.stitle $f.server -padx 2 -pady 2 -sticky w
+
+ # Keep-Alive
+ set f [ttk::labelframe $w.vo.keep -text [msgcat::mc {Keep-Alive}]]
+
+ ttk::label $f.dtitle -text [msgcat::mc {Minutes}]
+ ttk::entry $f.delay -textvariable pvo(delay) -width 5
+
+ grid $f.dtitle $f.delay -padx 2 -pady 2 -sticky w
+
+ pack $w.vo.browser $w.vo.server $w.vo.keep -side top -fill both -expand true
+}
+
+proc ProcessVOCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ set vvarname voi
+ upvar #0 $vvarname vvar
+ global $vvarname
+
+ global ivo
+ global pvo
+
+ switch -- [string tolower [lindex $var $i]] {
+ open {VODialog}
+ close {VODestroy $vvarname}
+ method {
+ incr i
+ set pvo(method) [lindex $var $i]
+ }
+ server {
+ incr i
+ set pvo(server) [lindex $var $i]
+ }
+ internal {
+ incr i
+ set pvo(hv) [FromYesNo [lindex $var $i]]
+ }
+ delay {
+ incr i
+ set pvo(delay) [lindex $var $i]
+ }
+ connect {
+ incr i
+
+ VODialog 1
+
+ # find best match
+ set ii [lsearch $ivo(server,url) "*[lindex $var $i]*"]
+ if {$ii>=0} {
+ set ivo(b$ii) 1
+ VOCheck $vvarname $ii
+ }
+ }
+ disconnect {
+ incr i
+
+ VODialog 1
+
+ # find best match
+ set ii [lsearch $ivo(server,url) "*[lindex $var $i]*"]
+ if {$ii>=0} {
+ set ivo(b$ii) 0
+ VOCheck $vvarname $ii
+ }
+ }
+ default {
+ VODialog 1
+
+ # find best match
+ set ii [lsearch $ivo(server,url) "*[lindex $var $i]*"]
+ if {$ii>=0} {
+ set ivo(b$ii) 1
+ VOCheck $vvarname $ii
+ }
+ }
+ }
+}
+
+proc ProcessSendVOCmd {proc id param} {
+ global ivo
+ global pvo
+
+ switch -- [string tolower $param] {
+ method {$proc $id "$pvo(method)\n"}
+ server {$proc $id "$pvo(server)\n"}
+ internal {$proc $id [ToYesNo $pvo(hv)]}
+ delay {$proc $id "$pvo(delay)\n"}
+ connect {
+ # current connections
+ set len [llength $ivo(server,button)]
+ set rr {}
+ for {set ii 0} {$ii<$len} {incr ii} {
+ if {$ivo(b$ii)} {
+ append rr "[lindex $ivo(server,host) $ii] [lindex $ivo(server,title) $ii] [lindex $ivo(server,url) $ii] $ivo(b$ii)\n"
+ }
+ }
+ $proc $id $rr
+ }
+ default {
+ VODialog 1
+ # all possible connections
+ set len [llength $ivo(server,button)]
+ set rr {}
+ for {set ii 0} {$ii<$len} {incr ii} {
+ append rr "[lindex $ivo(server,host) $ii] [lindex $ivo(server,title) $ii] [lindex $ivo(server,url) $ii] $ivo(b$ii)\n"
+ }
+ $proc $id $rr
+ }
+ }
+}
+
diff --git a/ds9/library/vot.tcl b/ds9/library/vot.tcl
new file mode 100644
index 0000000..da7bc80
--- /dev/null
+++ b/ds9/library/vot.tcl
@@ -0,0 +1,386 @@
+# 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 VOTParse {t token} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ global debug
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "VOTParse"
+ }
+
+# set fp [open debug.xml w]
+# puts $fp [http::data $token]
+# close $fp
+
+ set xml [xml::parser \
+ -characterdatacommand [list VOTCharCB $t] \
+ -elementstartcommand [list VOTElemStartCB $t] \
+ -elementendcommand [list VOTElemEndCB $t] \
+ -ignorewhitespace 1 \
+ ]
+
+ set T(tree,state) {}
+ set T(tree,prev) {}
+ if {[catch {$xml parse [http::data $token]} err]} {
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "VOTParse: $err"
+ }
+ }
+
+ $xml free
+}
+
+proc VOTRead {t fn} {
+ upvar #0 $t T
+ global $t
+
+ global debug
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "VOTRead"
+ }
+
+ if {$fn == {}} {
+ return
+ }
+
+ catch {
+ set fp [open $fn r]
+
+ set xml [xml::parser \
+ -characterdatacommand [list VOTCharCB $t]\
+ -elementstartcommand [list VOTElemStartCB $t] \
+ -elementendcommand [list VOTElemEndCB $t] \
+ -ignorewhitespace 1 \
+ ]
+
+ set T(tree,state) {}
+ set T(tree,prev) {}
+ if {[catch {$xml parse [read $fp]} err]} {
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "VOTRead: $err"
+ }
+ }
+
+ $xml free
+
+ close $fp
+ }
+}
+
+proc VOTWrite {t fn} {
+ upvar #0 $t T
+ global $t
+
+ global debug
+ if {$debug(tcl,cat) || $debug(tcl,sia)} {
+ puts stderr "VOTWrite"
+ }
+
+ if {$fn == {}} {
+ return
+ }
+
+ set fp [open $fn w]
+
+ set nr $T(Nrows)
+ set nc $T(Ncols)
+
+ puts $fp {<?xml version="1.0" encoding="UTF-8"?>}
+ puts $fp {<VOTABLE version="1.1">}
+ puts $fp {<RESOURCE>}
+ puts $fp {<TABLE>}
+
+ # header
+ puts -nonewline $fp {<DESCRIPTION>}
+ set nh [expr $T(HLines)-1]
+ for {set hh 1} {$hh < $nh} {incr hh} {
+ puts $fp [XMLQuote "$T(H_$hh)"]
+ }
+ puts $fp {</DESCRIPTION>}
+
+ # cols
+ for {set cc 1} {$cc <= $nc} {incr cc} {
+ puts -nonewline $fp {<FIELD }
+ # required
+ puts -nonewline $fp "name=\"[XMLQuote [lindex $T(Header) [expr $cc-1]]]\" "
+ # required
+ if {[info exists ${t}(DataType)]} {
+ puts -nonewline $fp "datatype=\"[XMLQuote [lindex $T(DataType) [expr $cc-1]]]\" "
+ } else {
+ puts -nonewline $fp "datatype=\"char\" arraysize=\"*\" "
+ }
+
+ if {[info exists ${t}(Id)]} {
+ if {[lindex $T(Id) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "ID=\"[XMLQuote [lindex $T(Id) [expr $cc-1]]]\" "
+ }
+ }
+ if {[info exists ${t}(ArraySize)]} {
+ if {[lindex $T(ArraySize) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "arraysize=\"[XMLQuote [lindex $T(ArraySize) [expr $cc-1]]]\" "
+ }
+ }
+ if {[info exists ${t}(Width)]} {
+ if {[lindex $T(Width) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "width=\"[XMLQuote [lindex $T(Width) [expr $cc-1]]]\" "
+ }
+ }
+ if {[info exists ${t}(Precision)]} {
+ if {[lindex $T(Precision) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "precision=\"[XMLQuote [lindex $T(Precision) [expr $cc-1]]]\" "
+ }
+ }
+ if {[info exists ${t}(Unit)]} {
+ if {[lindex $T(Unit) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "unit=\"[XMLQuote [lindex $T(Unit) [expr $cc-1]]]\" "
+ }
+ }
+ if {[info exists ${t}(Ref)]} {
+ if {[lindex $T(Ref) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "ref=\"[XMLQuote [lindex $T(Ref) [expr $cc-1]]]\" "
+ }
+ }
+ if {[info exists ${t}(Ucd)]} {
+ if {[lindex $T(Ucd) [expr $cc-1]] != {}} {
+ puts -nonewline $fp "ucd=\"[XMLQuote [lindex $T(Ucd) [expr $cc-1]]]\" "
+ }
+ }
+
+ puts $fp {>}
+
+ if {[info exists ${t}(Description)]} {
+ if {[lindex $T(Description) [expr $cc-1]] != {}} {
+ puts -nonewline $fp {<DESCRIPTION>}
+ puts -nonewline $fp "[XMLQuote [lindex $T(Description) [expr $cc-1]]]"
+ puts $fp {</DESCRIPTION>}
+ }
+ }
+
+ puts $fp {</FIELD>}
+ }
+
+ # data
+ puts $fp {<DATA>}
+ puts $fp {<TABLEDATA>}
+
+ for {set rr 1} {$rr <= $nr} {incr rr} {
+ puts -nonewline $fp {<TR>}
+ for {set cc 1} {$cc <= $nc} {incr cc} {
+ puts -nonewline $fp "<TD>[XMLQuote $T($rr,$cc)]</TD>"
+ }
+ puts $fp {</TR>}
+ }
+
+ # clean up
+ puts $fp {</TABLEDATA>}
+ puts $fp {</DATA>}
+ puts $fp {</TABLE>}
+ puts $fp {</RESOURCE>}
+ puts $fp {</VOTABLE>}
+
+ close $fp
+}
+
+# Callbacks
+
+proc VOTCharCB {t data} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ switch -- $T(tree,state) {
+ TD {
+ set r $T(Nrows)
+ set c $T(cnt)
+ set T($r,$c) [string trim $data]
+ }
+ DESCRIPTION {
+ set data [string trim $data]
+ if {$data != {}} {
+ switch -- $T(tree,prev) {
+ VOTABLE -
+ RESOURCE -
+ TABLE {
+ foreach ll [split [string trim $data] "\n"] {
+ incr ${t}(HLines)
+ set n $T(HLines)
+ if {[string range $ll 0 0] == {#}} {
+ set T(H_$n) "$ll"
+ } else {
+ set T(H_$n) "# $ll"
+ }
+ }
+ }
+ FIELD {
+ set T(Description) \
+ [lreplace $T(Description) end end $data]
+ }
+ }
+ }
+ }
+ }
+
+ # sometimes, we get a bogus call, (ignore whitespace does not work)
+ set T(tree,state) {}
+ return {}
+}
+
+proc VOTElemStartCB {t name attlist args} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ switch -- $name {
+ VOTABLE {
+ # init db
+ set T(Nrows) 0
+ set T(Ncols) 0
+ set T(Header) {}
+ set T(HLines) 0
+ set T(tree,prev) $name
+ }
+ FIELD {
+ set fname {}
+ set id {}
+ set datatype {}
+ set arraysize {}
+ set width {}
+ set precision {}
+ set unit {}
+ set ref {}
+ set ucd {}
+ foreach {key value} $attlist {
+ switch -- [string tolower $key] {
+ name {set fname "$value"}
+ id {set id "$value"}
+ datatype {set datatype $value}
+ arraysize {set arraysize $value}
+ width {set width $value}
+ precision {set precision $value}
+ unit {set unit "$value"}
+ ref {set ref "$value"}
+ ucd {set ucd "$value"}
+ }
+ }
+ if {$fname != {}} {
+ lappend ${t}(Header) "$fname"
+ } else {
+ lappend ${t}(Header) "$id"
+ }
+ lappend ${t}(Id) "$id"
+ lappend ${t}(DataType) $datatype
+ lappend ${t}(ArraySize) $arraysize
+ lappend ${t}(Width) $width
+ lappend ${t}(Precision) $precision
+ lappend ${t}(Unit) "$unit"
+ lappend ${t}(Ref) "$ref"
+ lappend ${t}(Ucd) "$ucd"
+
+ # filled in later
+ lappend ${t}(Description) {}
+
+ set T(tree,prev) $name
+ }
+ TABLEDATA {
+ # ok, we now need to build the header
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) [join $T(Header)]
+
+ set T(Dashes) [regsub -all {[A-Za-z0-9]} $T(H_$n) {-}]
+ set T(Ndshs) [llength $T(Header)]
+
+ incr ${t}(HLines)
+ set n $T(HLines)
+ set T(H_$n) [join $T(Dashes)]
+
+ starbase_colmap $t
+ }
+ TR {
+ incr ${t}(Nrows)
+ set T(cnt) 0
+ }
+ TD {
+ incr ${t}(cnt)
+
+ set r $T(Nrows)
+ set c $T(cnt)
+ set T($r,$c) {}
+ }
+
+ RESOURCE -
+ TABLE {
+ set T(tree,prev) $name
+ }
+
+ FIELDref -
+ DESCRIPTION -
+ COOSYS -
+ PARAM -
+ PARAMref -
+ INFO -
+ LINK -
+ GROUP -
+ DATA -
+ BINARY -
+ STREAM -
+ FITS -
+ VALUES -
+ MIN -
+ MAX -
+ OPTION -
+ DEFINITIONS {}
+
+ default {return -code error}
+ }
+
+ set ${t}(tree,state) $name
+ return {}
+}
+
+proc VOTElemEndCB {t name args} {
+ upvar #0 $t T
+ global $t
+ global debug
+
+ # we can't count on this being called for all end-tags
+ switch -- $name {
+ TABLEDATA {
+ # ok, we're done
+ return -code break
+ }
+ VOTABLE -
+ FIELD -
+ FIELDref -
+ TR -
+ TD -
+ RESOURCE -
+ TABLE -
+ DESCRIPTION -
+ COOSYS -
+ PARAM -
+ PARAMref -
+ INFO -
+ LINK -
+ GROUP -
+ DATA -
+ BINARY -
+ STREAM -
+ FITS -
+ VALUES -
+ MIN -
+ MAX -
+ OPTION -
+ DEFINITIONS {}
+
+ default {return -code error}
+ }
+ return {}
+}
+
diff --git a/ds9/library/wcs.tcl b/ds9/library/wcs.tcl
new file mode 100644
index 0000000..d6f80e6
--- /dev/null
+++ b/ds9/library/wcs.tcl
@@ -0,0 +1,1296 @@
+# 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 WCSDef {} {
+ global wcs
+ global pwcs
+ global iwcs
+
+ set iwcs(top) .wcs
+ set iwcs(mb) .wcsmb
+
+ set wcs(system) wcs
+ set wcs(sky) fk5
+ set wcs(skyformat) sexagesimal
+
+ array set pwcs [array get wcs]
+}
+
+proc UpdateWCS {} {
+ global wcs
+ global ds9
+ global current
+
+ # frame
+ if {$current(frame) != {}} {
+ $current(frame) wcs $wcs(system) $wcs(sky) $wcs(skyformat)
+
+ AlignWCSFrame
+ set wcs(frame) $current(frame)
+ if {[$current(frame) has fits]} {
+ CoordMenuEnable $ds9(mb).wcs wcs system 0 sky skyformat
+ } else {
+ CoordMenuReset $ds9(mb).wcs wcs system 0 sky skyformat
+ }
+ UpdateWCSInfoBox $current(frame)
+ }
+
+ # grid
+ global grid
+ set grid(system) $wcs(system)
+ set grid(sky) $wcs(sky)
+ set grid(skyformat) $wcs(skyformat)
+ GridUpdateCurrent
+
+ # panzoom dialog
+ global panzoom
+ set panzoom(system) $wcs(system)
+ set panzoom(sky) $wcs(sky)
+ set panzoom(skyformat) $wcs(skyformat)
+ UpdatePanZoomDialog
+
+ # crosshair dialog
+ global crosshair
+ set crosshair(system) $wcs(system)
+ set crosshair(sky) $wcs(sky)
+ set crosshair(skyformat) $wcs(skyformat)
+ UpdateCrosshairDialog
+
+ # crop dialog
+ global crop
+ set crop(system) $wcs(system)
+ set crop(sky) $wcs(sky)
+ set crop(skyformat) $wcs(skyformat)
+ UpdateCropDialog
+
+ # cube
+ global cube
+ set cube(system) $wcs(system)
+ UpdateCubeDialog
+
+ # rgb
+ global rgb
+ set rgb(system) $wcs(system)
+ RGBSystem
+
+ # regions
+ global marker
+ set marker(system) $wcs(system)
+ set marker(sky) $wcs(sky)
+ set marker(skyformat) $wcs(skyformat)
+ AdjustCoordSystem marker system
+}
+
+proc UpdateWCSInfoBox {which} {
+ global wcs
+ global view
+
+ # if one wcs coord system is visible, change it
+ set cnt 0
+ set vv {}
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ if {$view(info,wcs$ll)} {
+ incr cnt
+ set vv wcs$ll
+ }
+ }
+ if {$cnt == 1} {
+ set ww [lindex [$which get wcs] 0]
+ if {$view(info,$vv) != $view(info,$ww)} {
+ foreach ll {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set view(info,wcs$ll) 0
+ }
+ set view(info,$ww) 1
+ LayoutInfoPanel
+ }
+ }
+}
+
+proc WCSBackup {ch which fdir rdir} {
+ # simple case
+ puts $ch "$which wcs [$which get wcs]"
+ if {[$which has wcs alt]} {
+ set fn $fdir/ds9.wcs
+ set rfn $rdir/ds9.wcs
+
+ catch {file delete -force $fn}
+ WCSToVar [$which get fits header wcs 1]
+ WCSSaveFile $fn
+ puts $ch "WCSLoadFile $rfn"
+ puts $ch "$which wcs replace text 1 \\\{\[WCSFromVar\]\\\}"
+ }
+}
+
+proc WCSDialog {} {
+ global wcs
+ global iwcs
+ global dwcs
+ global ds9
+
+ # see if we already have a window visible
+ if {[winfo exists $iwcs(top)]} {
+ raise $iwcs(top)
+ return
+ }
+
+ # create the window
+ set w $iwcs(top)
+ set mb $iwcs(mb)
+
+ # vars
+ set dwcs(system) $wcs(system)
+ set dwcs(ext) 1
+ set dwcs(prev) {}
+
+ Toplevel $w $mb 6 [msgcat::mc {WCS Parameters}] WCSDestroyDialog
+
+ $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 {WCS}] -menu $mb.wcs
+ $mb add cascade -label [msgcat::mc {Extention}] -menu $mb.ext
+
+ menu $mb.file
+ $mb.file add command -label [msgcat::mc {Apply}] -command WCSApplyDialog
+ $mb.file add command -label [msgcat::mc {Reset}] -command WCSResetDialog
+ $mb.file add separator
+ $mb.file add command -label "[msgcat::mc {Load}]..." -command WCSLoadDialog
+ $mb.file add command -label "[msgcat::mc {Save}]..." -command WCSSaveDialog
+ $mb.file add separator
+ $mb.file add command -label [msgcat::mc {Close}] -command WCSDestroyDialog
+
+ EditMenu $mb iwcs
+
+ menu $mb.wcs
+ $mb.wcs add radiobutton -label [msgcat::mc {WCS}] \
+ -variable dwcs(system) -value wcs -command ConfigWCSDialog
+ $mb.wcs add separator
+ foreach l {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ $mb.wcs add radiobutton -label "[msgcat::mc {WCS}] $l" \
+ -variable dwcs(system) -value "wcs$l" -command ConfigWCSDialog
+ }
+
+ # configured later
+ menu $mb.ext
+
+ # Param
+ set tt [ttk::notebook $w.param]
+ set base [ttk::frame $tt.base]
+ set pv00 [ttk::frame $tt.pv00]
+ set pv12 [ttk::frame $tt.pv12]
+ set pv24 [ttk::frame $tt.pv24]
+ set ab0 [ttk::frame $tt.ab0]
+ set ab2 [ttk::frame $tt.ab2]
+ set ab4 [ttk::frame $tt.ab4]
+ set apbp0 [ttk::frame $tt.apbp0]
+ set apbp2 [ttk::frame $tt.apbp2]
+ set apbp4 [ttk::frame $tt.apbp4]
+ $tt add $base -text {Keyword}
+ $tt add $pv00 -text {PVi_00}
+ $tt add $pv12 -text {PVi_12}
+ $tt add $pv24 -text {PVi_24}
+ $tt add $ab0 -text {A_0}
+ $tt add $ab2 -text {A_2}
+ $tt add $ab4 -text {A_4}
+ $tt add $apbp0 -text {AP_0}
+ $tt add $apbp2 -text {AP_2}
+ $tt add $apbp4 -text {AP_4}
+ $tt select $base
+
+ ttk::label $base.tmjdobs -text "MJD-OBS"
+ ttk::entry $base.mjdobs -textvariable dwcs(mjd-obs) -width 14
+
+ ttk::label $base.tdateobs -text "DATE-OBS"
+ ttk::entry $base.dateobs -textvariable dwcs(date-obs) -width 14
+
+ ttk::label $base.tdate -text "DATE"
+ ttk::entry $base.date -textvariable dwcs(date) -width 14
+
+ ttk::label $base.tepoch -text "EPOCH"
+ ttk::entry $base.epoch -textvariable dwcs(epoch) -width 14
+
+ foreach aa {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set bb [string toupper $aa]
+
+ ttk::label $base.twcsname${aa} -text "WCSNAME${bb}"
+ ttk::entry $base.wcsname${aa} \
+ -textvariable dwcs(wcsname${aa}) -width 14
+
+ ttk::label $base.tradesys${aa} -text "RADESYS${bb}"
+ ttk::entry $base.radesys${aa} \
+ -textvariable dwcs(radesys${aa}) -width 14
+
+ ttk::label $base.tequinox${aa} -text "EQUINOX${bb}"
+ ttk::entry $base.equinox${aa} \
+ -textvariable dwcs(equinox${aa}) -width 14
+
+ ttk::label $base.tlatpole${aa} -text "LATPOLE${bb}"
+ ttk::entry $base.latpole${aa} \
+ -textvariable dwcs(latpole${aa}) -width 14
+
+ ttk::label $base.tlonpole${aa} -text "LONPOLE${bb}"
+ ttk::entry $base.lonpole${aa} \
+ -textvariable dwcs(lonpole${aa}) -width 14
+
+ for {set ii 1} {$ii<=3} {incr ii} {
+ ttk::label $base.tctype${ii}${aa} -text "CTYPE${ii}${bb}"
+ ttk::entry $base.ctype${ii}${aa} \
+ -textvariable dwcs(ctype${ii}${aa}) -width 14
+
+ ttk::label $base.tcrpix${ii}${aa} -text "CRPIX${ii}${bb}"
+ ttk::entry $base.crpix${ii}${aa} \
+ -textvariable dwcs(crpix${ii}${aa}) -width 14
+
+ ttk::label $base.tcrval${ii}${aa} -text "CRVAL${ii}${bb}"
+ ttk::entry $base.crval${ii}${aa} \
+ -textvariable dwcs(crval${ii}${aa}) -width 14
+
+ ttk::label $base.tcunit${ii}${aa} -text "CUNIT${ii}${bb}"
+ ttk::entry $base.cunit${ii}${aa} \
+ -textvariable dwcs(cunit${ii}${aa}) -width 14
+
+ ttk::label $base.tcdelt${ii}${aa} -text "CDELT${ii}${bb}"
+ ttk::entry $base.cdelt${ii}${aa} \
+ -textvariable dwcs(cdelt${ii}${aa}) -width 14
+ }
+
+ for {set ii 1} {$ii<=2} {incr ii} {
+ for {set jj 1} {$jj<=2} {incr jj} {
+ ttk::label $base.tcd${ii}_${jj}${aa} -text "CD${ii}_${jj}${bb}"
+ ttk::entry $base.cd${ii}_${jj}${aa} \
+ -textvariable dwcs(cd${ii}_${jj}${aa}) -width 14
+ }
+ for {set jj 1} {$jj<=2} {incr jj} {
+ ttk::label $base.tpc${ii}_${jj}${aa} \
+ -text "PC${ii}_${jj}${bb}"
+ ttk::entry $base.pc${ii}_${jj}${aa} \
+ -textvariable dwcs(pc${ii}_${jj}${aa}) -width 14
+ }
+
+ for {set mm 0} {$mm<12} {incr mm} {
+ ttk::label $pv00.tpv${ii}_${mm}${aa} \
+ -text "PV${ii}_${mm}${bb}"
+ ttk::entry $pv00.pv${ii}_${mm}${aa} \
+ -textvariable dwcs(pv${ii}_${mm}${aa}) -width 14
+ }
+ for {set mm 12} {$mm<24} {incr mm} {
+ ttk::label $pv12.tpv${ii}_${mm}${aa} \
+ -text "PV${ii}_${mm}${bb}"
+ ttk::entry $pv12.pv${ii}_${mm}${aa} \
+ -textvariable dwcs(pv${ii}_${mm}${aa}) -width 14
+ }
+ for {set mm 24} {$mm<36} {incr mm} {
+ ttk::label $pv24.tpv${ii}_${mm}${aa} \
+ -text "PV${ii}_${mm}${bb}"
+ ttk::entry $pv24.pv${ii}_${mm}${aa} \
+ -textvariable dwcs(pv${ii}_${mm}${aa}) -width 14
+ }
+ }
+
+ ttk::label $base.tcd3_3${aa} -text "CD3_3${bb}"
+ ttk::entry $base.cd3_3${aa} -textvariable dwcs(cd3_3${aa}) -width 14
+ ttk::label $base.tpc3_3${aa} -text "PC3_3${bb}"
+ ttk::entry $base.pc3_3${aa} -textvariable dwcs(pc3_3${aa}) -width 14
+ }
+
+ # only in primary
+ ttk::label $ab0.ta -text "A_ORDER"
+ ttk::entry $ab0.a -textvariable dwcs(a_order) -width 14
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $ab0.ta_${mm}_${nn} -text "A_${mm}_${nn}"
+ ttk::entry $ab0.a_${mm}_${nn} \
+ -textvariable dwcs(a_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $ab2.ta_${mm}_${nn} -text "A_${mm}_${nn}"
+ ttk::entry $ab2.a_${mm}_${nn} \
+ -textvariable dwcs(a_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $ab4.ta_${mm}_${nn} -text "A_${mm}_${nn}"
+ ttk::entry $ab4.a_${mm}_${nn} \
+ -textvariable dwcs(a_${mm}_${nn}) -width 14
+ }
+ }
+
+ ttk::label $ab0.tb -text "B_ORDER"
+ ttk::entry $ab0.b -textvariable dwcs(b_order) -width 14
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $ab0.tb_${mm}_${nn} -text "B_${mm}_${nn}"
+ ttk::entry $ab0.b_${mm}_${nn} \
+ -textvariable dwcs(b_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $ab2.tb_${mm}_${nn} -text "B_${mm}_${nn}"
+ ttk::entry $ab2.b_${mm}_${nn} \
+ -textvariable dwcs(b_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $ab4.tb_${mm}_${nn} -text "B_${mm}_${nn}"
+ ttk::entry $ab4.b_${mm}_${nn} \
+ -textvariable dwcs(b_${mm}_${nn}) -width 14
+ }
+ }
+
+ ttk::label $apbp0.tap -text "AP_ORDER"
+ ttk::entry $apbp0.ap -textvariable dwcs(ap_order) -width 14
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $apbp0.tap_${mm}_${nn} -text "AP_${mm}_${nn}"
+ ttk::entry $apbp0.ap_${mm}_${nn} \
+ -textvariable dwcs(ap_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $apbp2.tap_${mm}_${nn} -text "AP_${mm}_${nn}"
+ ttk::entry $apbp2.ap_${mm}_${nn} \
+ -textvariable dwcs(ap_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $apbp4.tap_${mm}_${nn} -text "AP_${mm}_${nn}"
+ ttk::entry $apbp4.ap_${mm}_${nn} \
+ -textvariable dwcs(ap_${mm}_${nn}) -width 14
+ }
+ }
+
+ ttk::label $apbp0.tbp -text "BP_ORDER"
+ ttk::entry $apbp0.bp -textvariable dwcs(bp_order) -width 14
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $apbp0.tbp_${mm}_${nn} -text "BP_${mm}_${nn}"
+ ttk::entry $apbp0.bp_${mm}_${nn} \
+ -textvariable dwcs(bp_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $apbp2.tbp_${mm}_${nn} -text "BP_${mm}_${nn}"
+ ttk::entry $apbp2.bp_${mm}_${nn} \
+ -textvariable dwcs(bp_${mm}_${nn}) -width 14
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ ttk::label $apbp4.tbp_${mm}_${nn} -text "BP_${mm}_${nn}"
+ ttk::entry $apbp4.bp_${mm}_${nn} \
+ -textvariable dwcs(bp_${mm}_${nn}) -width 14
+ }
+ }
+
+ # Buttons
+ set f [ttk::frame $w.buttons]
+ ttk::button $f.apply -text [msgcat::mc {Apply}] -command WCSApplyDialog
+ ttk::button $f.reset -text [msgcat::mc {Reset}] -command WCSResetDialog
+ ttk::button $f.close -text [msgcat::mc {Close}] -command WCSDestroyDialog
+ pack $f.apply $f.reset $f.close -side left -expand true -padx 2 -pady 4
+
+ # Fini
+ pack $w.buttons -side bottom -fill x
+ pack $w.param -side top -fill both -expand true
+
+ ConfigWCSDialog
+ UpdateWCSDialog
+}
+
+proc WCSApplyDialog {} {
+ global dwcs
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLock rgb(lock,wcs) $current(frame) "$current(frame) wcs replace text $dwcs(ext) \{\{[WCSFromVar]\}\}"
+ UpdateWCS
+ CATUpdateWCS
+ }
+}
+
+proc WCSResetDialog {} {
+ global dwcs
+ global current
+ global rgb
+
+ if {$current(frame) != {}} {
+ RGBEvalLock rgb(lock,wcs) $current(frame) [list $current(frame) wcs reset $dwcs(ext)]
+ UpdateWCS
+ CATUpdateWCS
+ UpdateWCSDialog
+ }
+}
+
+proc WCSDestroyDialog {} {
+ global iwcs
+ global dwcs
+
+ if {[winfo exists $iwcs(top)]} {
+ destroy $iwcs(top)
+ destroy $iwcs(mb)
+ }
+
+ unset dwcs
+}
+
+proc WCSSaveDialog {} {
+ global dwcs
+
+ set fn [SaveFileDialog wcsfbox]
+ WCSSaveFile $fn
+}
+
+# used by backup
+proc WCSSaveFile {fn} {
+ if {[catch {open $fn w} fp]} {
+ Error "[msgcat::mc {Unable to open file}] $fn: $fp"
+ return
+ }
+ puts $fp [WCSFromVar]
+ catch {close $fp}
+}
+
+proc WCSLoadDialog {} {
+ global dwcs
+
+ set fn [OpenFileDialog wcsfbox]
+ WCSLoadFile $fn
+}
+
+# used by backup
+proc WCSLoadFile {fn} {
+ if {$fn != {}} {
+ if {[catch {open $fn r} fp]} {
+ Error "[msgcat::mc {Unable to open file}] $fn: $fp"
+ return
+ }
+ WCSToVar [read -nonewline $fp]
+ catch {close $fp}
+ }
+}
+
+proc UpdateWCSDialog {} {
+ global iwcs
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "UpdateWCSDialog"
+ }
+
+ if {![winfo exists $iwcs(top)]} {
+ return
+ }
+
+ ConfigWCSDialogExtMenu
+ UpdateWCSVars
+}
+
+proc UpdateWCSVars {} {
+ global dwcs
+ global current
+
+ if {$current(frame) != {}} {
+ if {[$current(frame) has fits]} {
+ WCSToVar [$current(frame) get fits header wcs $dwcs(ext)]
+ return
+ }
+ }
+
+ WCSToVar {}
+}
+
+proc ConfigWCSDialog {{force {0}}} {
+ global wcs
+ global iwcs
+ global dwcs
+ global current
+
+ global debug
+ if {$debug(tcl,update)} {
+ puts stderr "ConfigWCSDialog"
+ }
+
+ if {![winfo exists $iwcs(top)]} {
+ return
+ }
+
+ # do we need to re-grid wcs vars?
+ if {!$force && $dwcs(prev) == $dwcs(system)} {
+ return
+ }
+
+ set tt $iwcs(top).param
+ set base $tt.base
+ set pv00 $tt.pv00
+ set pv12 $tt.pv12
+ set pv24 $tt.pv24
+ set ab0 $tt.ab0
+ set ab2 $tt.ab2
+ set ab4 $tt.ab4
+ set apbp0 $tt.apbp0
+ set apbp2 $tt.apbp2
+ set apbp4 $tt.apbp4
+
+ grid forget $base.tmjdobs $base.mjdobs
+ grid forget $base.tdateobs $base.dateobs
+ grid forget $base.tdate $base.date
+ grid forget $base.tepoch $base.epoch
+
+ # forget current sys vars
+ set aa [string tolower [string range $dwcs(prev) 3 3]]
+
+ grid forget $base.twcsname${aa} $base.wcsname${aa}
+ grid forget $base.tradesys${aa} $base.radesys${aa}
+ grid forget $base.tequinox${aa} $base.equinox${aa}
+ grid forget $base.tlatpole${aa} $base.latpole${aa}
+ grid forget $base.tlonpole${aa} $base.lonpole${aa}
+
+ for {set ii 1} {$ii<=3} {incr ii} {
+ grid forget $base.tctype${ii}${aa} $base.ctype${ii}${aa}
+ grid forget $base.tcunit${ii}${aa} $base.cunit${ii}${aa}
+ grid forget $base.tcrpix${ii}${aa} $base.crpix${ii}${aa}
+ grid forget $base.tcrval${ii}${aa} $base.crval${ii}${aa}
+ grid forget $base.tcdelt${ii}${aa} $base.cdelt${ii}${aa}
+ }
+
+ for {set ii 1} {$ii<=2} {incr ii} {
+ for {set jj 1} {$jj<=2} {incr jj} {
+ grid forget $base.tcd${ii}_${jj}${aa} $base.cd${ii}_${jj}${aa}
+ grid forget $base.tpc${ii}_${jj}${aa} $base.pc${ii}_${jj}${aa}
+ }
+
+ for {set mm 0} {$mm<12} {incr mm} {
+ grid forget $pv00.tpv${ii}_${mm}${aa} $pv00.pv${ii}_${mm}${aa}
+ }
+ for {set mm 12} {$mm<24} {incr mm} {
+ grid forget $pv12.tpv${ii}_${mm}${aa} $pv12.pv${ii}_${mm}${aa}
+ }
+ for {set mm 24} {$mm<36} {incr mm} {
+ grid forget $pv24.tpv${ii}_${mm}${aa} $pv24.pv${ii}_${mm}${aa}
+ }
+ }
+
+ grid forget $base.tcd3_3${aa} $base.cd3_3${aa}
+ grid forget $base.tpc3_3${aa} $base.pc3_3${aa}
+
+ # only in primary
+ grid forget $ab0.ta $ab0.a
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $ab0.ta_${mm}_${nn} $ab0.a_${mm}_${nn}
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $ab2.ta_${mm}_${nn} $ab2.a_${mm}_${nn}
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $ab4.ta_${mm}_${nn} $ab4.a_${mm}_${nn}
+ }
+ }
+
+ grid forget $ab0.tb $ab0.b
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $ab0.tb_${mm}_${nn} $ab0.b_${mm}_${nn}
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $ab2.tb_${mm}_${nn} $ab2.b_${mm}_${nn}
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $ab4.tb_${mm}_${nn} $ab4.b_${mm}_${nn}
+ }
+ }
+
+ grid forget $apbp0.tap $apbp0.ap
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $apbp0.tap_${mm}_${nn} $apbp0.ap_${mm}_${nn}
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $apbp2.tap_${mm}_${nn} $apbp2.ap_${mm}_${nn}
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $apbp4.tap_${mm}_${nn} $apbp4.ap_${mm}_${nn}
+ }
+ }
+
+ grid forget $apbp0.tbp $apbp0.bp
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $apbp0.tbp_${mm}_${nn} $apbp0.bp_${mm}_${nn}
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $apbp2.tbp_${mm}_${nn} $apbp2.bp_${mm}_${nn}
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid forget $apbp4.tbp_${mm}_${nn} $apbp4.bp_${mm}_${nn}
+ }
+ }
+
+ # display new sys vars
+ set dwcs(prev) $dwcs(system)
+ set aa [string tolower [string range $dwcs(system) 3 3]]
+
+ grid $base.twcsname${aa} $base.wcsname${aa} -padx 2 -pady 2 -sticky w
+ grid $base.tradesys${aa} $base.radesys${aa} -padx 2 -pady 2 -sticky w
+
+ grid $base.tequinox${aa} $base.equinox${aa} \
+ $base.tepoch $base.epoch -padx 2 -pady 2 -sticky w
+ grid $base.tmjdobs $base.mjdobs \
+ $base.tdateobs $base.dateobs \
+ $base.tdate $base.date \
+ -padx 2 -pady 2 -sticky w
+
+ grid $base.tctype1${aa} $base.ctype1${aa} \
+ $base.tctype2${aa} $base.ctype2${aa} \
+ $base.tctype3${aa} $base.ctype3${aa} \
+ -padx 2 -pady 2 -sticky w
+ grid $base.tcrpix1${aa} $base.crpix1${aa} \
+ $base.tcrpix2${aa} $base.crpix2${aa} \
+ $base.tcrpix3${aa} $base.crpix3${aa} \
+ -padx 2 -pady 2 -sticky w
+ grid $base.tcrval1${aa} $base.crval1${aa} \
+ $base.tcrval2${aa} $base.crval2${aa} \
+ $base.tcrval3${aa} $base.crval3${aa} \
+ -padx 2 -pady 2 -sticky w
+ grid $base.tcunit1${aa} $base.cunit1${aa} \
+ $base.tcunit2${aa} $base.cunit2${aa} \
+ $base.tcunit3${aa} $base.cunit3${aa} \
+ -padx 2 -pady 2 -sticky w
+ grid $base.tcdelt1${aa} $base.cdelt1${aa} \
+ $base.tcdelt2${aa} $base.cdelt2${aa} \
+ $base.tcdelt3${aa} $base.cdelt3${aa} \
+ -padx 2 -pady 2 -sticky w
+
+ grid $base.tcd1_1${aa} $base.cd1_1${aa} \
+ $base.tcd2_1${aa} $base.cd2_1${aa} \
+ -padx 2 -pady 2 -sticky w
+ grid $base.tcd1_2${aa} $base.cd1_2${aa} \
+ $base.tcd2_2${aa} $base.cd2_2${aa} \
+ $base.tcd3_3${aa} $base.cd3_3${aa} \
+ -padx 2 -pady 2 -sticky w
+
+ grid $base.tpc1_1${aa} $base.pc1_1${aa} \
+ $base.tpc2_1${aa} $base.pc2_1${aa} \
+ -padx 2 -pady 2 -sticky w
+ grid $base.tpc1_2${aa} $base.pc1_2${aa} \
+ $base.tpc2_2${aa} $base.pc2_2${aa} \
+ $base.tpc3_3${aa} $base.pc3_3${aa} \
+ -padx 2 -pady 2 -sticky w
+
+ grid $base.tlatpole${aa} $base.latpole${aa} \
+ $base.tlonpole${aa} $base.lonpole${aa} -padx 2 -pady 2 -sticky w
+
+ for {set mm 0} {$mm<12} {incr mm} {
+ grid $pv00.tpv1_${mm}${aa} $pv00.pv1_${mm}${aa} \
+ $pv00.tpv2_${mm}${aa} $pv00.pv2_${mm}${aa} \
+ -padx 2 -pady 2 -sticky w
+ }
+ for {set mm 12} {$mm<24} {incr mm} {
+ grid $pv12.tpv1_${mm}${aa} $pv12.pv1_${mm}${aa} \
+ $pv12.tpv2_${mm}${aa} $pv12.pv2_${mm}${aa} \
+ -padx 2 -pady 2 -sticky w
+ }
+ for {set mm 24} {$mm<36} {incr mm} {
+ grid $pv24.tpv1_${mm}${aa} $pv24.pv1_${mm}${aa} \
+ $pv24.tpv2_${mm}${aa} $pv24.pv2_${mm}${aa} \
+ -padx 2 -pady 2 -sticky w
+ }
+
+ # only in primary
+ grid $ab0.ta $ab0.a $ab0.tb $ab0.b -padx 2 -pady 2 -sticky w
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid $ab0.ta_${mm}_${nn} $ab0.a_${mm}_${nn} \
+ $ab0.tb_${mm}_${nn} $ab0.b_${mm}_${nn} \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid $ab2.ta_${mm}_${nn} $ab2.a_${mm}_${nn} \
+ $ab2.tb_${mm}_${nn} $ab2.b_${mm}_${nn} \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid $ab4.ta_${mm}_${nn} $ab4.a_${mm}_${nn} \
+ $ab4.tb_${mm}_${nn} $ab4.b_${mm}_${nn} \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+
+ grid $apbp0.tap $apbp0.ap $apbp0.tbp $apbp0.bp -padx 2 -pady 2 -sticky w
+ for {set mm 0} {$mm<2} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid $apbp0.tap_${mm}_${nn} $apbp0.ap_${mm}_${nn} \
+ $apbp0.tbp_${mm}_${nn} $apbp0.bp_${mm}_${nn} \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+ for {set mm 2} {$mm<4} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid $apbp2.tap_${mm}_${nn} $apbp2.ap_${mm}_${nn} \
+ $apbp2.tbp_${mm}_${nn} $apbp2.bp_${mm}_${nn} \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+ for {set mm 4} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ grid $apbp4.tap_${mm}_${nn} $apbp4.ap_${mm}_${nn} \
+ $apbp4.tbp_${mm}_${nn} $apbp4.bp_${mm}_${nn} \
+ -padx 2 -pady 2 -sticky w
+ }
+ }
+}
+
+proc ConfigWCSDialogExtMenu {} {
+ global iwcs
+ global dwcs
+ global ds9
+ global current
+
+ $iwcs(mb).ext delete $ds9(menu,start) end
+ set dwcs(ext) 1
+
+ set nn 0
+ set last {}
+ set cnt [$current(frame) get fits count]
+
+ for {set ii 1} {$ii <= $cnt} {incr ii} {
+ set fn [$current(frame) get fits file name $ii]
+ if {$fn != $last} {
+ incr nn
+ set item($nn) $fn
+ set val($nn) $ii
+ set last $fn
+ }
+ }
+
+ if {$nn > 1} {
+ $iwcs(mb) entryconfig [msgcat::mc {Extention}] -state normal
+
+ for {set ii 1} {$ii<=$nn} {incr ii} {
+ $iwcs(mb).ext add radiobutton -label $item($ii) \
+ -variable dwcs(ext) -value $val($ii) -command UpdateWCSVars
+ }
+ } else {
+ $iwcs(mb) entryconfig [msgcat::mc {Extention}] -state disabled
+ }
+}
+
+# used by backup
+proc WCSToVar {txt} {
+ global wcs
+ global dwcs
+ global iwcs
+
+ # clear all
+ set dwcs(mjd-obs) {}
+ set dwcs(date-obs) {}
+ set dwcs(date) {}
+ set dwcs(epoch) {}
+
+ foreach aa {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set dwcs(wcsname${aa}) {}
+ set dwcs(radesys${aa}) {}
+ set dwcs(equinox${aa}) {}
+ set dwcs(latpole${aa}) {}
+ set dwcs(lonpole${aa}) {}
+
+ for {set ii 1} {$ii<=3} {incr ii} {
+ set dwcs(ctype${ii}${aa}) {}
+ set dwcs(cunit${ii}${aa}) {}
+ set dwcs(crpix${ii}${aa}) {}
+ set dwcs(crval${ii}${aa}) {}
+ set dwcs(cdelt${ii}${aa}) {}
+ }
+
+ for {set ii 1} {$ii<=2} {incr ii} {
+ for {set jj 1} {$jj<=2} {incr jj} {
+ set dwcs(cd${ii}_${jj}${aa}) {}
+ set dwcs(pc${ii}_${jj}${aa}) {}
+ }
+
+ for {set mm 0} {$mm<36} {incr mm} {
+ set dwcs(pv${ii}_${mm}${aa}) {}
+ }
+ }
+
+ set dwcs(cd3_3${aa}) {}
+ set dwcs(pc3_3${aa}) {}
+ }
+
+ # primary only
+ set dwcs(a_order) {}
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ set dwcs(a_${mm}_${nn}) {}
+ }
+ }
+ set dwcs(b_order) {}
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ set dwcs(b_${mm}_${nn}) {}
+ }
+ }
+ set dwcs(ap_order) {}
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ set dwcs(ap_${mm}_${nn}) {}
+ }
+ }
+ set dwcs(bp_order) {}
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ set dwcs(bp_${mm}_${nn}) {}
+ }
+ }
+
+ set lines [split $txt "\n"]
+
+ # check for fits header, do it the hard way
+ if {[llength $lines] == 1} {
+ set lines {}
+ while {"$txt" != {}} {
+ lappend lines "[string range $txt 0 79]"
+ set txt "[string replace $txt 0 79]"
+ }
+ }
+
+ for {set ll 0} {$ll<[llength $lines]} {incr ll} {
+ set line [lindex $lines $ll]
+ set pp [split $line {=}]
+ set key [string tolower [string trim [lindex $pp 0]]]
+
+ # drop comments
+ # some keywords can have '/' in the value (such as a date)
+ # try the easy approach first
+ set ee [lindex $pp 1]
+ set dd [split $ee {/}]
+ switch [llength $dd] {
+ 0 -
+ 1 -
+ 2 {set aa [lindex $dd 0]}
+ default {
+ set ff [string first { /} $ee]
+ if {$ff > 0} {
+ set aa [string range $ee 0 $ff]
+ } else {
+ set aa [lindex $dd 0]
+ }
+ }
+ }
+
+ # drop any white space
+ set bb [string trim $aa]
+ # drop any single quotes
+ set cc [string trim $bb {'}]
+ # drop any white space
+ set val [string trim $cc]
+
+ # sanity check
+ if {$key == {longpole}} {
+ set key lonpole
+ }
+ if {$key == {radecsys}} {
+ set key radesys
+ }
+
+ switch [string range $key 0 6] {
+ mjd-obs -
+ date-ob {
+ set dwcs($key) $val
+ }
+ }
+ switch [string range $key 0 5] {
+ wcsnam -
+ radesy -
+ equino -
+ latpol -
+ lonpol -
+ ctype1 -
+ ctype2 -
+ ctype3 -
+ cunit1 -
+ cunit2 -
+ cunit3 -
+ crpix1 -
+ crpix2 -
+ crpix3 -
+ crval1 -
+ crval2 -
+ crval3 -
+ cdelt1 -
+ cdelt2 -
+ cdelt3 -
+ cd3_3 -
+ pc3_3 -
+ a_orde -
+ b_orde -
+ ap_ord -
+ bp_ord {
+ set dwcs($key) $val
+ }
+ }
+ switch [string range $key 0 3] {
+ epoc -
+ date -
+ cd1_ -
+ cd1_ -
+ cd2_ -
+ cd2_ -
+ pc1_ -
+ pc1_ -
+ pc2_ -
+ pc2_ -
+ pv1_ -
+ pv2_ {
+ set dwcs($key) $val
+ }
+ }
+ switch [string range $key 0 2] {
+ ap_ -
+ bp_ {
+ set dwcs($key) $val
+ }
+ }
+ switch [string range $key 0 1] {
+ a_ -
+ b_ {
+ set dwcs($key) $val
+ }
+ }
+ }
+}
+
+# used by backup
+proc WCSFromVar {} {
+ global wcs
+ global dwcs
+ global iwcs
+
+ set rr {}
+
+ if {$dwcs(mjd-obs) != {}} {
+ append rr "MJD-OBS = $dwcs(mjd-obs)\n"
+ }
+ if {$dwcs(date-obs) != {}} {
+ append rr "DATE-OBS = '$dwcs(date-obs)'\n"
+ }
+ if {$dwcs(date) != {}} {
+ append rr "DATE = '$dwcs(date)'\n"
+ }
+ if {$dwcs(epoch) != {}} {
+ append rr "EPOCH = $dwcs(epoch)\n"
+ }
+
+ foreach aa {{} a b c d e f g h i j k l m n o p q r s t u v w x y z} {
+ set bb [string toupper $aa]
+
+ if {$dwcs(wcsname${aa}) != {}} {
+ append rr "WCSNAME${bb} = '$dwcs(wcsname${aa})'\n"
+ }
+ if {$dwcs(radesys${aa}) != {}} {
+ append rr "RADESYS${bb} = '$dwcs(radesys${aa})'\n"
+ }
+ if {$dwcs(equinox${aa}) != {}} {
+ append rr "EQUINOX${bb} = $dwcs(equinox${aa})\n"
+ }
+ if {$dwcs(latpole${aa}) != {}} {
+ append rr "LATPOLE${bb} = $dwcs(latpole${aa})\n"
+ }
+ if {$dwcs(lonpole${aa}) != {}} {
+ append rr "LONPOLE${bb} = $dwcs(lonpole${aa})\n"
+ }
+
+ for {set ii 1} {$ii<=3} {incr ii} {
+ if {$dwcs(ctype${ii}${aa}) != {}} {
+ append rr "CTYPE${ii}${bb} = '$dwcs(ctype${ii}${aa})'\n"
+ }
+ if {$dwcs(cunit${ii}${aa}) != {}} {
+ append rr "CUNIT${ii}${bb} = '$dwcs(cunit${ii}${aa})'\n"
+ }
+ if {$dwcs(crpix${ii}${aa}) != {}} {
+ append rr "CRPIX${ii}${bb} = $dwcs(crpix${ii}${aa})\n"
+ }
+ if {$dwcs(crval${ii}${aa}) != {}} {
+ append rr "CRVAL${ii}${bb} = $dwcs(crval${ii}${aa})\n"
+ }
+ if {$dwcs(cdelt${ii}${aa}) != {}} {
+ append rr "CDELT${ii}${bb} = $dwcs(cdelt${ii}${aa})\n"
+ }
+ }
+
+ for {set ii 1} {$ii<=2} {incr ii} {
+ for {set jj 1} {$jj<=2} {incr jj} {
+ if {$dwcs(cd${ii}_${jj}${aa}) != {}} {
+ append rr "CD${ii}_${jj}${bb} = $dwcs(cd${ii}_${jj}${aa})\n"
+ }
+ if {$dwcs(pc${ii}_${jj}${aa}) != {}} {
+ append rr "PC${ii}_${jj}${bb} = $dwcs(pc${ii}_${jj}${aa})\n"
+ }
+ }
+
+ for {set mm 0} {$mm<36} {incr mm} {
+ if {$dwcs(pv${ii}_${mm}${aa}) != {}} {
+ append rr "PV${ii}_${mm}${bb} = $dwcs(pv${ii}_${mm}${aa})\n"
+ }
+ }
+ }
+
+ if {$dwcs(cd3_3${aa}) != {}} {
+ append rr "CD3_3${bb} = $dwcs(cd3_3${aa})\n"
+ }
+ if {$dwcs(pc3_3${aa}) != {}} {
+ append rr "PC3_3${bb} = $dwcs(pc3_3${aa})\n"
+ }
+ }
+
+ if {$dwcs(a_order) != {}} {
+ append rr "A_ORDER = $dwcs(a_order)\n"
+ }
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ if {$dwcs(a_${mm}_${nn}) != {}} {
+ append rr "A_${mm}_${nn} = $dwcs(a_${mm}_${nn})\n"
+ }
+ }
+ }
+ if {$dwcs(b_order) != {}} {
+ append rr "B_ORDER = $dwcs(b_order)\n"
+ }
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ if {$dwcs(b_${mm}_${nn}) != {}} {
+ append rr "B_${mm}_${nn} = $dwcs(b_${mm}_${nn})\n"
+ }
+ }
+ }
+
+ if {$dwcs(ap_order) != {}} {
+ append rr "AP_ORDER = $dwcs(ap_order)\n"
+ }
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ if {$dwcs(ap_${mm}_${nn}) != {}} {
+ append rr "AP_${mm}_${nn} = $dwcs(ap_${mm}_${nn})\n"
+ }
+ }
+ }
+ if {$dwcs(bp_order) != {}} {
+ append rr "BP_ORDER = $dwcs(bp_order)\n"
+ }
+ for {set mm 0} {$mm<6} {incr mm} {
+ for {set nn 0} {$nn<6} {incr nn} {
+ if {$dwcs(bp_${mm}_${nn}) != {}} {
+ append rr "BP_${mm}_${nn} = $dwcs(bp_${mm}_${nn})\n"
+ }
+ }
+ }
+
+ return $rr
+}
+
+# Process Cmds
+
+proc ProcessWCSCmd {varname iname sock fn} {
+ upvar $varname var
+ upvar $iname i
+
+ global wcs
+ global current
+ global rgb
+
+ set item [string tolower [lindex $var $i]]
+ switch -- $item {
+ open {WCSDialog}
+ close {WCSDestroyDialog}
+ system {
+ incr i
+ set wcs(system) [string tolower [lindex $var $i]]
+ UpdateWCS
+ }
+ sky {
+ incr i
+ set wcs(sky) [string tolower [lindex $var $i]]
+ UpdateWCS
+ }
+ format -
+ skyformat {
+ incr i
+ switch -- [string tolower [lindex $var $i]] {
+ deg -
+ degree -
+ degrees {set wcs(skyformat) degrees}
+ default {set wcs(skyformat) [string tolower [lindex $var $i]]}
+ }
+ UpdateWCS
+ }
+ align {
+ incr i
+ set current(align) [FromYesNo [lindex $var $i]]
+ AlignWCSFrame
+ }
+ reset {
+ set ext 1
+ set nn [lindex $var [expr $i+1]]
+ if {[string is integer -strict $nn]} {
+ incr i
+ set ext $nn
+ }
+
+ RGBEvalLock rgb(lock,wcs) $current(frame) [list $current(frame) wcs reset $ext]
+ UpdateWCS
+ }
+ replace -
+ append {
+ set ext 1
+ set nn [lindex $var [expr $i+1]]
+ if {[string is integer -strict $nn]} {
+ incr i
+ set ext $nn
+ }
+
+ if {$sock != {}} {
+ incr i
+ if {[lindex $var $i] == {}} {
+ RGBEvalLock rgb(lock,wcs) $current(frame) [list $current(frame) wcs $item $ext $sock]
+ incr i -1
+ } else {
+ RGBEvalLock rgb(lock,wcs) $current(frame) "$current(frame) wcs $item $ext \{\{[lindex $var $i]\}\}"
+ }
+ } elseif {$fn != {}} {
+ RGBEvalLock rgb(lock,wcs) $current(frame) "$current(frame) wcs $item $ext \{\{$fn\}\}"
+ } else {
+ incr i
+ if {[lindex $var $i] == "file"} {
+ incr i
+ }
+ RGBEvalLock rgb(lock,wcs) $current(frame) "$current(frame) wcs $item $ext \{\{[lindex $var $i]\}\}"
+ }
+ UpdateWCS
+ }
+
+ fk4 -
+ fk5 -
+ icrs -
+ galactic -
+ ecliptic {
+ set wcs(sky) $item
+ UpdateWCS
+ }
+
+ degrees -
+ sexagesimal {
+ set wcs(skyformat) $item
+ UpdateWCS
+ }
+
+ wcs -
+ wcsa -
+ wcsb -
+ wcsc -
+ wcsd -
+ wcse -
+ wcsf -
+ wcsg -
+ wcsh -
+ wcsi -
+ wcsj -
+ wcsk -
+ wcsl -
+ wcsm -
+ wcsn -
+ wcso -
+ wcsp -
+ wcsq -
+ wcsr -
+ wcss -
+ wcst -
+ wcsu -
+ wcsv -
+ wcsw -
+ wcsx -
+ wcsy -
+ wcsz {
+ set wcs(system) $item
+ UpdateWCS
+ }
+ }
+}
+
+proc ProcessSendWCSCmd {proc id param} {
+ global current
+ global wcs
+
+ switch -- [string tolower $param] {
+ align {$proc $id [ToYesNo $current(align)]}
+ system {$proc $id "$wcs(system)\n"}
+ sky {$proc $id "$wcs(sky)\n"}
+ format -
+ skyformat {$proc $id "$wcs(skyformat)\n"}
+ default {$proc $id "$wcs(system)\n"}
+ }
+}
+
+# backward compatibilty
+proc ProcessAlignCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global current
+ switch -- [string tolower [lindex $var $i]] {
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {
+ set current(align) [FromYesNo [lindex $var $i]]
+ AlignWCSFrame
+ }
+ default {
+ set current(align) 1
+ AlignWCSFrame
+ incr i -1
+ }
+ }
+}
+
+proc ProcessSendAlignCmd {proc id param} {
+ global current
+
+ $proc $id [ToYesNo $current(align)]
+}
+
diff --git a/ds9/library/win32.tcl b/ds9/library/win32.tcl
new file mode 100755
index 0000000..32a8a86
--- /dev/null
+++ b/ds9/library/win32.tcl
@@ -0,0 +1,27 @@
+# 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 Win32Print {} {
+ global ds9
+
+ # we need to be realized
+ RealizeDS9
+ # need the colorbar levels updated
+ UpdateColormapLevel
+
+ if {[win32 pm print begin [winfo width $ds9(canvas)] [winfo height $ds9(canvas)] yes]} {
+ foreach f $ds9(frames) {
+ $f win32 print
+ }
+ colorbar win32 print
+ colorbarrgb win32 print
+ win32 pm print end
+ }
+}
+
+proc Win32PageSetup {} {
+ win32 pm pagesetup
+}
diff --git a/ds9/library/xmfbox.tcl b/ds9/library/xmfbox.tcl
new file mode 100644
index 0000000..fb821c8
--- /dev/null
+++ b/ds9/library/xmfbox.tcl
@@ -0,0 +1,998 @@
+# xmfbox.tcl --
+#
+# Implements the "Motif" style file selection dialog for the
+# Unix platform. This implementation is used only if the
+# "::tk_strictMotif" flag is set.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-2000 Scriptics Corporation
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::tk::dialog {}
+namespace eval ::tk::dialog::file {}
+
+
+# ::tk::MotifFDialog --
+#
+# Implements a file dialog similar to the standard Motif file
+# selection box.
+#
+# Arguments:
+# type "open" or "save"
+# args Options parsed by the procedure.
+#
+# Results:
+# When -multiple is set to 0, this returns the absolute pathname
+# of the selected file. (NOTE: This is not the same as a single
+# element list.)
+#
+# When -multiple is set to > 0, this returns a Tcl list of absolute
+# pathnames. The argument for -multiple is ignored, but for consistency
+# with Windows it defines the maximum amount of memory to allocate for
+# the returned filenames.
+
+proc ::tk::MotifFDialog {type args} {
+ variable ::tk::Priv
+ set dataName __tk_filedialog
+ upvar ::tk::dialog::file::$dataName data
+
+ set w [MotifFDialog_Create $dataName $type $args]
+
+ # Set a grab and claim the focus too.
+
+ ::tk::SetFocusGrab $w $data(sEnt)
+ $data(sEnt) selection range 0 end
+
+ # Wait for the user to respond, then restore the focus and
+ # return the index of the selected button. Restore the focus
+ # before deleting the window, since otherwise the window manager
+ # may take the focus away so we can't redirect it. Finally,
+ # restore any grab that was in effect.
+
+ vwait ::tk::Priv(selectFilePath)
+ set result $Priv(selectFilePath)
+ ::tk::RestoreFocusGrab $w $data(sEnt) withdraw
+
+ return $result
+}
+
+# ::tk::MotifFDialog_Create --
+#
+# Creates the Motif file dialog (if it doesn't exist yet) and
+# initialize the internal data structure associated with the
+# dialog.
+#
+# This procedure is used by ::tk::MotifFDialog to create the
+# dialog. It's also used by the test suite to test the Motif
+# file dialog implementation. User code shouldn't call this
+# procedure directly.
+#
+# Arguments:
+# dataName Name of the global "data" array for the file dialog.
+# type "Save" or "Open"
+# argList Options parsed by the procedure.
+#
+# Results:
+# Pathname of the file dialog.
+
+proc ::tk::MotifFDialog_Create {dataName type argList} {
+ upvar ::tk::dialog::file::$dataName data
+
+ MotifFDialog_Config $dataName $type $argList
+
+ if {$data(-parent) eq "."} {
+ set w .$dataName
+ } else {
+ set w $data(-parent).$dataName
+ }
+
+ # (re)create the dialog box if necessary
+ #
+ if {![winfo exists $w]} {
+ MotifFDialog_BuildUI $w
+ } elseif {[winfo class $w] ne "TkMotifFDialog"} {
+ destroy $w
+ MotifFDialog_BuildUI $w
+ } else {
+ set data(fEnt) $w.top.f1.ent
+ set data(dList) $w.top.f2.a.l
+ set data(fList) $w.top.f2.b.l
+ set data(sEnt) $w.top.f3.ent
+ set data(okBtn) $w.bot.ok
+ set data(filterBtn) $w.bot.filter
+ set data(cancelBtn) $w.bot.cancel
+ }
+ MotifFDialog_SetListMode $w
+
+ # Dialog boxes should be transient with respect to their parent,
+ # so that they will always stay on top of their parent window. However,
+ # some window managers will create the window as withdrawn if the parent
+ # window is withdrawn or iconified. Combined with the grab we put on the
+ # window, this can hang the entire application. Therefore we only make
+ # the dialog transient if the parent is viewable.
+
+ if {[winfo viewable [winfo toplevel $data(-parent)]] } {
+ wm transient $w $data(-parent)
+ }
+
+ MotifFDialog_FileTypes $w
+ MotifFDialog_Update $w
+
+ # Withdraw the window, then update all the geometry information
+ # so we know how big it wants to be, then center the window in the
+ # display (Motif style) and de-iconify it.
+
+ ::tk::PlaceWindow $w
+ wm title $w $data(-title)
+
+ return $w
+}
+
+# ::tk::MotifFDialog_FileTypes --
+#
+# Checks the -filetypes option. If present this adds a list of radio-
+# buttons to pick the file types from.
+#
+# Arguments:
+# w Pathname of the tk_get*File dialogue.
+#
+# Results:
+# none
+
+proc ::tk::MotifFDialog_FileTypes {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set f $w.top.f3.types
+ destroy $f
+
+ # No file types: use "*" as the filter and display no radio-buttons
+ if {$data(-filetypes) eq ""} {
+ set data(filter) *
+ return
+ }
+
+ # The filetypes radiobuttons
+ # set data(fileType) $data(-defaulttype)
+ # Default type to first entry
+ set initialTypeName [lindex $data(-filetypes) 0 0]
+ if {$data(-typevariable) ne ""} {
+ upvar #0 $data(-typevariable) typeVariable
+ if {[info exists typeVariable]} {
+ set initialTypeName $typeVariable
+ }
+ }
+ set ix 0
+ set data(fileType) 0
+ foreach fltr $data(-filetypes) {
+ set fname [lindex $fltr 0]
+ if {[string first $initialTypeName $fname] == 0} {
+ set data(fileType) $ix
+ break
+ }
+ incr ix
+ }
+
+ MotifFDialog_SetFilter $w [lindex $data(-filetypes) $data(fileType)]
+
+ #don't produce radiobuttons for only one filetype
+ if {[llength $data(-filetypes)] == 1} {
+ return
+ }
+
+ ttk::frame $f
+ set cnt 0
+ if {$data(-filetypes) ne {}} {
+ foreach type $data(-filetypes) {
+ set title [lindex [lindex $type 0] 0]
+ set filter [lindex $type 1]
+ ttk::radiobutton $f.b$cnt \
+ -text $title \
+ -variable ::tk::dialog::file::[winfo name $w](fileType) \
+ -value $cnt \
+ -command [list tk::MotifFDialog_SetFilter $w $type]
+ pack $f.b$cnt -side left
+ incr cnt
+ }
+ }
+ $f.b$data(fileType) invoke
+
+ pack $f -side bottom -fill both
+
+ return
+}
+
+# This proc gets called whenever data(filter) is set
+#
+proc ::tk::MotifFDialog_SetFilter {w type} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+ variable ::tk::Priv
+
+ set data(filter) [lindex $type 1]
+ set Priv(selectFileType) [lindex [lindex $type 0] 0]
+
+ MotifFDialog_Update $w
+}
+
+# ::tk::MotifFDialog_Config --
+#
+# Iterates over the optional arguments to determine the option
+# values for the Motif file dialog; gives default values to
+# unspecified options.
+#
+# Arguments:
+# dataName The name of the global variable in which
+# data for the file dialog is stored.
+# type "Save" or "Open"
+# argList Options parsed by the procedure.
+
+proc ::tk::MotifFDialog_Config {dataName type argList} {
+ upvar ::tk::dialog::file::$dataName data
+
+ set data(type) $type
+
+ # 1: the configuration specs
+ #
+ set specs {
+ {-defaultextension "" "" ""}
+ {-filetypes "" "" ""}
+ {-initialdir "" "" ""}
+ {-initialfile "" "" ""}
+ {-parent "" "" "."}
+ {-title "" "" ""}
+ {-typevariable "" "" ""}
+ }
+ if {$type eq "open"} {
+ lappend specs {-multiple "" "" "0"}
+ }
+ if {$type eq "save"} {
+ lappend specs {-confirmoverwrite "" "" "1"}
+ }
+
+ set data(-multiple) 0
+ set data(-confirmoverwrite) 1
+ # 2: default values depending on the type of the dialog
+ #
+ if {![info exists data(selectPath)]} {
+ # first time the dialog has been popped up
+ set data(selectPath) [pwd]
+ set data(selectFile) ""
+ }
+
+ # 3: parse the arguments
+ #
+ tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
+
+ if {$data(-title) eq ""} {
+ if {$type eq "open"} {
+ if {$data(-multiple) != 0} {
+ set data(-title) "[mc {Open Multiple Files}]"
+ } else {
+ set data(-title) [mc "Open"]
+ }
+ } else {
+ set data(-title) [mc "Save As"]
+ }
+ }
+
+ # 4: set the default directory and selection according to the -initial
+ # settings
+ #
+ if {$data(-initialdir) ne ""} {
+ if {[file isdirectory $data(-initialdir)]} {
+ set data(selectPath) [lindex [glob $data(-initialdir)] 0]
+ } else {
+ set data(selectPath) [pwd]
+ }
+
+ # Convert the initialdir to an absolute path name.
+
+ set old [pwd]
+ cd $data(selectPath)
+ set data(selectPath) [pwd]
+ cd $old
+ }
+ set data(selectFile) $data(-initialfile)
+
+ # 5. Parse the -filetypes option. It is not used by the motif
+ # file dialog, but we check for validity of the value to make sure
+ # the application code also runs fine with the TK file dialog.
+ #
+ set data(-filetypes) [::tk::FDGetFileTypes $data(-filetypes)]
+
+ if {![info exists data(filter)]} {
+ set data(filter) *
+ }
+ if {![winfo exists $data(-parent)]} {
+ return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
+ "bad window path name \"$data(-parent)\""
+ }
+}
+
+# ::tk::MotifFDialog_BuildUI --
+#
+# Builds the UI components of the Motif file dialog.
+#
+# Arguments:
+# w Pathname of the dialog to build.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_BuildUI {w} {
+ set dataName [lindex [split $w .] end]
+ upvar ::tk::dialog::file::$dataName data
+
+ # Create the dialog toplevel and internal frames.
+ #
+ toplevel $w -class TkMotifFDialog
+ set top [ttk::frame $w.top -relief raised -borderwidth 1]
+ set bot [ttk::frame $w.bot -relief raised -borderwidth 1]
+
+ pack $w.bot -side bottom -fill x
+ pack $w.top -side top -expand yes -fill both
+
+ set f1 [ttk::frame $top.f1]
+ set f2 [ttk::frame $top.f2]
+ set f3 [ttk::frame $top.f3]
+
+ pack $f1 -side top -fill x
+ pack $f3 -side bottom -fill x
+ pack $f2 -expand yes -fill both
+
+ set f2a [ttk::frame $f2.a]
+ set f2b [ttk::frame $f2.b]
+
+ grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
+ -sticky news
+ grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
+ -sticky news
+ grid rowconfigure $f2 0 -minsize 0 -weight 1
+ grid columnconfigure $f2 0 -minsize 0 -weight 1
+ grid columnconfigure $f2 1 -minsize 150 -weight 2
+
+ # The Filter box
+ #
+ bind [::tk::AmpWidget ttk::label $f1.lab -text [mc "Fil&ter:"] -anchor w] \
+ <<AltUnderlined>> [list focus $f1.ent]
+ ttk::entry $f1.ent
+ pack $f1.lab -side top -fill x -padx 6 -pady 4
+ pack $f1.ent -side top -fill x -padx 4 -pady 0
+ set data(fEnt) $f1.ent
+
+ # The file and directory lists
+ #
+ set data(dList) [MotifFDialog_MakeSList $w $f2a \
+ [mc "&Directory:"] DList]
+ set data(fList) [MotifFDialog_MakeSList $w $f2b \
+ [mc "Fi&les:"] FList]
+
+ # The Selection box
+ #
+ bind [::tk::AmpWidget ttk::label $f3.lab -text [mc "&Selection:"] -anchor w] \
+ <<AltUnderlined>> [list focus $f3.ent]
+ ttk::entry $f3.ent
+ pack $f3.lab -side top -fill x -padx 6 -pady 0
+ pack $f3.ent -side top -fill x -padx 4 -pady 4
+ set data(sEnt) $f3.ent
+
+ # The buttons
+ #
+ set maxWidth [::tk::mcmaxamp &OK &Filter &Cancel]
+ set maxWidth [expr {$maxWidth<6?6:$maxWidth}]
+ set data(okBtn) [::tk::AmpWidget ttk::button $bot.ok -text [mc "&OK"] \
+ -width $maxWidth \
+ -command [list tk::MotifFDialog_OkCmd $w]]
+ set data(filterBtn) [::tk::AmpWidget ttk::button $bot.filter -text [mc "&Filter"] \
+ -width $maxWidth \
+ -command [list tk::MotifFDialog_FilterCmd $w]]
+ set data(cancelBtn) [::tk::AmpWidget ttk::button $bot.cancel -text [mc "&Cancel"] \
+ -width $maxWidth \
+ -command [list tk::MotifFDialog_CancelCmd $w]]
+
+ pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \
+ -side left
+
+ # Create the bindings:
+ #
+ bind $w <Alt-Key> [list ::tk::AltKeyInDialog $w %A]
+
+ bind $data(fEnt) <Return> [list tk::MotifFDialog_ActivateFEnt $w]
+ bind $data(sEnt) <Return> [list tk::MotifFDialog_ActivateSEnt $w]
+ bind $w <Escape> [list tk::MotifFDialog_CancelCmd $w]
+ bind $w.bot <Destroy> {set ::tk::Priv(selectFilePath) {}}
+
+ wm protocol $w WM_DELETE_WINDOW [list tk::MotifFDialog_CancelCmd $w]
+}
+
+proc ::tk::MotifFDialog_SetListMode {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {$data(-multiple) != 0} {
+ set selectmode extended
+ } else {
+ set selectmode browse
+ }
+ set f $w.top.f2.b
+ $f.l configure -selectmode $selectmode
+}
+
+# ::tk::MotifFDialog_MakeSList --
+#
+# Create a scrolled-listbox and set the keyboard accelerator
+# bindings so that the list selection follows what the user
+# types.
+#
+# Arguments:
+# w Pathname of the dialog box.
+# f Frame widget inside which to create the scrolled
+# listbox. This frame widget already exists.
+# label The string to display on top of the listbox.
+# under Sets the -under option of the label.
+# cmdPrefix Specifies procedures to call when the listbox is
+# browsed or activated.
+
+proc ::tk::MotifFDialog_MakeSList {w f label cmdPrefix} {
+ bind [::tk::AmpWidget ttk::label $f.lab -text $label -anchor w] \
+ <<AltUnderlined>> [list focus $f.l]
+ listbox $f.l -width 12 -height 5 -exportselection 0\
+ -xscrollcommand [list $f.h set] -yscrollcommand [list $f.v set]
+ ttk::scrollbar $f.v -orient vertical -takefocus 0 -command [list $f.l yview]
+ ttk::scrollbar $f.h -orient horizontal -takefocus 0 -command [list $f.l xview]
+ grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \
+ -padx 2 -pady 2
+ grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
+ grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news
+ grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news
+
+ grid rowconfigure $f 0 -weight 0 -minsize 0
+ grid rowconfigure $f 1 -weight 1 -minsize 0
+ grid columnconfigure $f 0 -weight 1 -minsize 0
+
+ # bindings for the listboxes
+ #
+ set list $f.l
+ bind $list <<ListboxSelect>> [list tk::MotifFDialog_Browse$cmdPrefix $w]
+ bind $list <Double-ButtonRelease-1> \
+ [list tk::MotifFDialog_Activate$cmdPrefix $w]
+ bind $list <Return> "tk::MotifFDialog_Browse$cmdPrefix [list $w]; \
+ tk::MotifFDialog_Activate$cmdPrefix [list $w]"
+
+ bindtags $list [list Listbox $list [winfo toplevel $list] all]
+ ListBoxKeyAccel_Set $list
+
+ return $f.l
+}
+
+# ::tk::MotifFDialog_InterpFilter --
+#
+# Interpret the string in the filter entry into two components:
+# the directory and the pattern. If the string is a relative
+# pathname, give a warning to the user and restore the pattern
+# to original.
+#
+# Arguments:
+# w pathname of the dialog box.
+#
+# Results:
+# A list of two elements. The first element is the directory
+# specified # by the filter. The second element is the filter
+# pattern itself.
+
+proc ::tk::MotifFDialog_InterpFilter {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set text [string trim [$data(fEnt) get]]
+
+ # Perform tilde substitution
+ #
+ set badTilde 0
+ if {[string index $text 0] eq "~"} {
+ set list [file split $text]
+ set tilde [lindex $list 0]
+ if {[catch {set tilde [glob $tilde]}]} {
+ set badTilde 1
+ } else {
+ set text [eval file join [concat $tilde [lrange $list 1 end]]]
+ }
+ }
+
+ # If the string is a relative pathname, combine it
+ # with the current selectPath.
+
+ set relative 0
+ if {[file pathtype $text] eq "relative"} {
+ set relative 1
+ } elseif {$badTilde} {
+ set relative 1
+ }
+
+ if {$relative} {
+ tk_messageBox -icon warning -type ok \
+ -message "\"$text\" must be an absolute pathname"
+
+ $data(fEnt) delete 0 end
+ $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
+ $data(filter)]
+
+ return [list $data(selectPath) $data(filter)]
+ }
+
+ set resolved [::tk::dialog::file::JoinFile [file dirname $text] [file tail $text]]
+
+ if {[file isdirectory $resolved]} {
+ set dir $resolved
+ set fil $data(filter)
+ } else {
+ set dir [file dirname $resolved]
+ set fil [file tail $resolved]
+ }
+
+ return [list $dir $fil]
+}
+
+# ::tk::MotifFDialog_Update
+#
+# Load the files and synchronize the "filter" and "selection" fields
+# boxes.
+#
+# Arguments:
+# w pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_Update {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ $data(fEnt) delete 0 end
+ $data(fEnt) insert 0 \
+ [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
+ $data(sEnt) delete 0 end
+ $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
+ $data(selectFile)]
+
+ MotifFDialog_LoadFiles $w
+}
+
+# ::tk::MotifFDialog_LoadFiles --
+#
+# Loads the files and directories into the two listboxes according
+# to the filter setting.
+#
+# Arguments:
+# w pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_LoadFiles {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ $data(dList) delete 0 end
+ $data(fList) delete 0 end
+
+ set appPWD [pwd]
+ if {[catch {cd $data(selectPath)}]} {
+ cd $appPWD
+
+ $data(dList) insert end ".."
+ return
+ }
+
+ # Make the dir and file lists
+ #
+ # For speed we only have one glob, which reduces the file system
+ # calls (good for slow NFS networks).
+ #
+ # We also do two smaller sorts (files + dirs) instead of one large sort,
+ # which gives a small speed increase.
+ #
+ set top 0
+ set dlist ""
+ set flist ""
+ foreach f [glob -nocomplain .* *] {
+ if {[file isdir ./$f]} {
+ lappend dlist $f
+ } else {
+ foreach pat $data(filter) {
+ if {[string match $pat $f]} {
+ if {[string match .* $f]} {
+ incr top
+ }
+ lappend flist $f
+ break
+ }
+ }
+ }
+ }
+ eval [list $data(dList) insert end] [lsort -dictionary $dlist]
+ eval [list $data(fList) insert end] [lsort -dictionary $flist]
+
+ # The user probably doesn't want to see the . files. We adjust the view
+ # so that the listbox displays all the non-dot files
+ $data(fList) yview $top
+
+ cd $appPWD
+}
+
+# ::tk::MotifFDialog_BrowseDList --
+#
+# This procedure is called when the directory list is browsed
+# (clicked-over) by the user.
+#
+# Arguments:
+# w The pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_BrowseDList {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ focus $data(dList)
+ if {[$data(dList) curselection] eq ""} {
+ return
+ }
+ set subdir [$data(dList) get [$data(dList) curselection]]
+ if {$subdir eq ""} {
+ return
+ }
+
+ $data(fList) selection clear 0 end
+
+ set list [MotifFDialog_InterpFilter $w]
+ set data(filter) [lindex $list 1]
+
+ switch -- $subdir {
+ . {
+ set newSpec [::tk::dialog::file::JoinFile $data(selectPath) $data(filter)]
+ }
+ .. {
+ set newSpec [::tk::dialog::file::JoinFile [file dirname $data(selectPath)] \
+ $data(filter)]
+ }
+ default {
+ set newSpec [::tk::dialog::file::JoinFile [::tk::dialog::file::JoinFile \
+ $data(selectPath) $subdir] $data(filter)]
+ }
+ }
+
+ $data(fEnt) delete 0 end
+ $data(fEnt) insert 0 $newSpec
+}
+
+# ::tk::MotifFDialog_ActivateDList --
+#
+# This procedure is called when the directory list is activated
+# (double-clicked) by the user.
+#
+# Arguments:
+# w The pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_ActivateDList {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {[$data(dList) curselection] eq ""} {
+ return
+ }
+ set subdir [$data(dList) get [$data(dList) curselection]]
+ if {$subdir eq ""} {
+ return
+ }
+
+ $data(fList) selection clear 0 end
+
+ switch -- $subdir {
+ . {
+ set newDir $data(selectPath)
+ }
+ .. {
+ set newDir [file dirname $data(selectPath)]
+ }
+ default {
+ set newDir [::tk::dialog::file::JoinFile $data(selectPath) $subdir]
+ }
+ }
+
+ set data(selectPath) $newDir
+ MotifFDialog_Update $w
+
+ if {$subdir ne ".."} {
+ $data(dList) selection set 0
+ $data(dList) activate 0
+ } else {
+ $data(dList) selection set 1
+ $data(dList) activate 1
+ }
+}
+
+# ::tk::MotifFDialog_BrowseFList --
+#
+# This procedure is called when the file list is browsed
+# (clicked-over) by the user.
+#
+# Arguments:
+# w The pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_BrowseFList {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ focus $data(fList)
+ set data(selectFile) ""
+ foreach item [$data(fList) curselection] {
+ lappend data(selectFile) [$data(fList) get $item]
+ }
+ if {[llength $data(selectFile)] == 0} {
+ return
+ }
+
+ $data(dList) selection clear 0 end
+
+ $data(fEnt) delete 0 end
+ $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
+ $data(filter)]
+# $data(fEnt) xview end
+
+ # if it's a multiple selection box, just put in the filenames
+ # otherwise put in the full path as usual
+ $data(sEnt) delete 0 end
+ if {$data(-multiple) != 0} {
+ $data(sEnt) insert 0 $data(selectFile)
+ } else {
+ $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \
+ [lindex $data(selectFile) 0]]
+ }
+# $data(sEnt) xview end
+}
+
+# ::tk::MotifFDialog_ActivateFList --
+#
+# This procedure is called when the file list is activated
+# (double-clicked) by the user.
+#
+# Arguments:
+# w The pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_ActivateFList {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ if {[$data(fList) curselection] eq ""} {
+ return
+ }
+ set data(selectFile) [$data(fList) get [$data(fList) curselection]]
+ if {$data(selectFile) eq ""} {
+ return
+ } else {
+ MotifFDialog_ActivateSEnt $w
+ }
+}
+
+# ::tk::MotifFDialog_ActivateFEnt --
+#
+# This procedure is called when the user presses Return inside
+# the "filter" entry. It updates the dialog according to the
+# text inside the filter entry.
+#
+# Arguments:
+# w The pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_ActivateFEnt {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set list [MotifFDialog_InterpFilter $w]
+ set data(selectPath) [lindex $list 0]
+ set data(filter) [lindex $list 1]
+
+ MotifFDialog_Update $w
+}
+
+# ::tk::MotifFDialog_ActivateSEnt --
+#
+# This procedure is called when the user presses Return inside
+# the "selection" entry. It sets the ::tk::Priv(selectFilePath)
+# variable so that the vwait loop in tk::MotifFDialog will be
+# terminated.
+#
+# Arguments:
+# w The pathname of the dialog box.
+#
+# Results:
+# None.
+
+proc ::tk::MotifFDialog_ActivateSEnt {w} {
+ variable ::tk::Priv
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ set selectFilePath [string trim [$data(sEnt) get]]
+
+ if {$selectFilePath eq ""} {
+ MotifFDialog_FilterCmd $w
+ return
+ }
+
+ if {$data(-multiple) == 0} {
+ set selectFilePath [list $selectFilePath]
+ }
+
+ if {[file isdirectory [lindex $selectFilePath 0]]} {
+ set data(selectPath) [lindex [glob $selectFilePath] 0]
+ set data(selectFile) ""
+ MotifFDialog_Update $w
+ return
+ }
+
+ set newFileList ""
+ foreach item $selectFilePath {
+ if {[file pathtype $item] ne "absolute"} {
+ set item [file join $data(selectPath) $item]
+ } elseif {![file exists [file dirname $item]]} {
+ tk_messageBox -icon warning -type ok \
+ -message [mc {Directory "%1$s" does not exist.} \
+ [file dirname $item]]
+ return
+ }
+
+ # we want to strip any filtering/ext/blocking instructions
+ # from the file name
+
+ set aa [string first "\[" $item]
+ if {$aa > 0} {
+ set fn [string range $item 0 [expr $aa-1]]
+ } else {
+ set fn $item
+ }
+
+ if {![file exists $fn]} {
+ if {$data(type) eq "open"} {
+ tk_messageBox -icon warning -type ok \
+ -message [mc {File "%1$s" does not exist.} $fn]
+ return
+ }
+ } elseif {$data(type) eq "save" && $data(-confirmoverwrite)} {
+ set message [format %s%s \
+ [mc "File \"%1\$s\" already exists.\n\n" $selectFilePath] \
+ [mc {Replace existing file?}]]
+ set answer [tk_messageBox -icon warning -type yesno \
+ -message $message]
+ if {$answer eq "no"} {
+ return
+ }
+ }
+
+ lappend newFileList $item
+ }
+
+ # Return selected filter
+ if {[info exists data(-typevariable)] && $data(-typevariable) ne ""
+ && [info exists data(-filetypes)] && $data(-filetypes) ne ""} {
+ upvar #0 $data(-typevariable) typeVariable
+ set typeVariable [lindex $data(-filetypes) $data(fileType) 0]
+ }
+
+ if {$data(-multiple) != 0} {
+ set Priv(selectFilePath) $newFileList
+ } else {
+ set Priv(selectFilePath) [lindex $newFileList 0]
+ }
+
+ # Set selectFile and selectPath to first item in list
+ set Priv(selectFile) [file tail [lindex $newFileList 0]]
+ set Priv(selectPath) [file dirname [lindex $newFileList 0]]
+}
+
+
+proc ::tk::MotifFDialog_OkCmd {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ MotifFDialog_ActivateSEnt $w
+}
+
+proc ::tk::MotifFDialog_FilterCmd {w} {
+ upvar ::tk::dialog::file::[winfo name $w] data
+
+ MotifFDialog_ActivateFEnt $w
+}
+
+proc ::tk::MotifFDialog_CancelCmd {w} {
+ variable ::tk::Priv
+
+ set Priv(selectFilePath) ""
+ set Priv(selectFile) ""
+ set Priv(selectPath) ""
+}
+
+proc ::tk::ListBoxKeyAccel_Set {w} {
+ bind Listbox <Any-KeyPress> ""
+ bind $w <Destroy> [list tk::ListBoxKeyAccel_Unset $w]
+ bind $w <Any-KeyPress> [list tk::ListBoxKeyAccel_Key $w %A]
+}
+
+proc ::tk::ListBoxKeyAccel_Unset {w} {
+ variable ::tk::Priv
+
+ catch {after cancel $Priv(lbAccel,$w,afterId)}
+ unset -nocomplain Priv(lbAccel,$w) Priv(lbAccel,$w,afterId)
+}
+
+# ::tk::ListBoxKeyAccel_Key--
+#
+# This procedure maintains a list of recently entered keystrokes
+# over a listbox widget. It arranges an idle event to move the
+# selection of the listbox to the entry that begins with the
+# keystrokes.
+#
+# Arguments:
+# w The pathname of the listbox.
+# key The key which the user just pressed.
+#
+# Results:
+# None.
+
+proc ::tk::ListBoxKeyAccel_Key {w key} {
+ variable ::tk::Priv
+
+ if { $key eq "" } {
+ return
+ }
+ append Priv(lbAccel,$w) $key
+ ListBoxKeyAccel_Goto $w $Priv(lbAccel,$w)
+ catch {
+ after cancel $Priv(lbAccel,$w,afterId)
+ }
+ set Priv(lbAccel,$w,afterId) [after 500 \
+ [list tk::ListBoxKeyAccel_Reset $w]]
+}
+
+proc ::tk::ListBoxKeyAccel_Goto {w string} {
+ variable ::tk::Priv
+
+ set string [string tolower $string]
+ set end [$w index end]
+ set theIndex -1
+
+ for {set i 0} {$i < $end} {incr i} {
+ set item [string tolower [$w get $i]]
+ if {[string compare $string $item] >= 0} {
+ set theIndex $i
+ }
+ if {[string compare $string $item] <= 0} {
+ set theIndex $i
+ break
+ }
+ }
+
+ if {$theIndex >= 0} {
+ $w selection clear 0 end
+ $w selection set $theIndex $theIndex
+ $w activate $theIndex
+ $w see $theIndex
+ event generate $w <<ListboxSelect>>
+ }
+}
+
+proc ::tk::ListBoxKeyAccel_Reset {w} {
+ variable ::tk::Priv
+
+ unset -nocomplain Priv(lbAccel,$w)
+}
+
+proc ::tk_getFileType {} {
+ variable ::tk::Priv
+
+ return $Priv(selectFileType)
+}
+
diff --git a/ds9/library/xmlrpc.tcl b/ds9/library/xmlrpc.tcl
new file mode 100644
index 0000000..c255ea8
--- /dev/null
+++ b/ds9/library/xmlrpc.tcl
@@ -0,0 +1,875 @@
+# xmlrpc0.3
+# Written by Eric Yeh
+#
+# Server API:
+# xmlrpc::serve
+# Note: all callable functions should be defined in the global scope
+#
+# Client API:
+# xmlrpc::call url methodName params
+# url is of the form "http://hostname:port"
+# methodName is the name of the method to call
+# and params is a list of arguments to the method
+# where each argument is a "typed tcl" value defined below
+# xmlrpc::buildRequest
+# return an XML-RPC client request
+# xmlrpc::marshall
+# return a marshalled "typed tcl" value
+# xmlrpc::unmarshall
+# return an unmarshalled "typed tcl" value
+# xmlrpc::assoc
+# return a cons of a list if the key matches
+#
+# Typed Tcl values:
+# Because Tcl has no types for variables, all values will be represented
+# as a 2 element tuple of the form:
+# {type, value} where value is the original value
+# and type is a string describing its type.
+# Valid types (case sensitive, must be lowercase):
+# int
+# boolean
+# string
+# double
+# dateTime.iso8601
+# base64
+# struct
+# array
+# Note:
+# When marshalling dictionaries(tcl arrays), tcl has no
+# way of creating unnamed dictionaries. Therefore,
+# the way to use a dictionary is to create it as normal,
+# and refer to its name in the "tcl type".
+# For example:
+# set dict(first) {string eric}
+# xmlrpc::marshall {struct dict}
+#
+# the marshall procedure will attempt to "find" dict
+# using upvar(yuck!) and checking the global scope.
+#
+# Unmarshalling of a dictionary results in a 2 element
+# list of the form (remaining, alist)
+# where remaining is unused marshalled data (should be empty)
+# and alist is an A-list.
+# An A-list has the form:
+# {key, datum} where key is the key and datum is its value.
+# The method "assoc" is provided to access information from
+# this data structure. It behaves like the LISP assoc, in that
+# it will return the (key, datum) pair if a match is found.
+
+# TODO:
+# -currently server functions can't return dictionaries
+# -add more error handling
+# -Check for [{}] in unmarshalling
+# -Empty dictionaries
+
+package provide xmlrpc 0.3
+
+namespace eval xmlrpc {
+ namespace export call buildRequest marshall unmarshall assoc
+ namespace export serve
+
+ variable READSIZE 4096; # read size
+
+ variable WS "\[ |\n|\t\|\r]"; # WhiteSpace
+ variable W "\[^ |\n|\t\]"; # a word with no spaces
+ variable DIGIT "\[0-9\]"; # Digit
+
+ variable response ""; # response to return
+ variable acceptfd ""; # socket to listen on
+ variable DEBUG 0; # debug
+}
+
+# Given a port, create a new socket
+# and start listening on it
+#
+proc xmlrpc::serve {port} {
+ variable acceptfd
+
+ set acceptfd [socket -server xmlrpc::serveOnce $port]
+ return $acceptfd
+}
+
+# Accept a new connection
+#
+proc xmlrpc::serveOnce {sock addr port} {
+ variable READSIZE
+
+ debug "in serveOnce: addr: $addr"
+ debug "in serveOnce: port: $port"
+ fconfigure $sock -translation {lf lf} -buffersize $READSIZE
+ fconfigure $sock -blocking off
+ fileevent $sock readable [list xmlrpc::doRequest $sock]
+}
+
+# Given a socket,
+# Handle an XML-RPC request
+#
+proc xmlrpc::doRequest {sock} {
+ variable WS
+
+ set res [readHeader $sock]
+ set headerStatus [lindex $res 0]; # Header + Status
+ set body [lindex $res 1]; # Body, if any
+
+ set RE "\[^\n\]+\n(.*)"
+ if {![regexp $RE $headerStatus {} header]} {
+ return [errReturn "Malformed Request"]
+ }
+
+ set body [getBody $sock $header $body]
+
+ set RE "<\?xml.version=."; # xml version
+ append RE "\[^\?\]+.\?>$WS*"; # version number
+ append RE "<methodCall>$WS*"; # methodCall tag
+ append RE "<methodName>"; # methodName tag
+ append RE "(\[a-zA-Z0-9_:\/\\.\]+)"; # method Name
+ append RE "</methodName>$WS*"; # end methodName tag
+ append RE "(.*)"; # parameters, if any
+ append RE "</methodCall>.*"; # end methodCall tag
+
+ if {![regexp $RE $body {} mname params]} {
+ return [errReturn "Malformed methodCall"]
+ }
+
+ set args {}
+ set param [string range $params 8 end]
+ set param [string trim $param]
+ while {[string range $param 0 6] == "<param>" ||
+ [string range $param 0 7] == "</param>"} {
+ # check for empty element
+ if {[string range $param 0 7] == "</param>"} {
+ lappend args {}
+ set param [string range $param 8 end]
+ set param [string trim $param]
+ continue
+ }
+
+ set param [string range $param 7 end]
+ set param [string trim $param]
+
+ set res [unmarshall $param]
+ set param [lindex $res 0]
+ set el [lindex $res 1]
+ lappend args $el
+ if {[string range $param 0 7] != "</param>"} {
+ return [errReturn "Invalid End Param"]
+ }
+ set param [string range $param 8 end]
+ set param [string trim $param]
+ }
+ if {$param != "</params>"} {
+ return [errReturn "Invalid End Params"]
+ }
+ if {[catch {set result [eval ::$mname $args]}]} {
+ set response [buildFault 100 "eval() failed"]
+ } else {
+ set response [buildResponse $result]
+ }
+ debug "in doRequest: response:\n$response"
+ puts -nonewline $sock $response
+ flush $sock
+ catch {close $sock}
+}
+
+# Given a "typed tcl" value,
+# build an XML-RPC response
+#
+proc buildResponse {result} {
+ # build the body
+ set body "<?xml version=\"1.0\"?>\n"
+ append body "<methodResponse>\n"
+ append body "\t<params>\n"
+ append body "\t\t<param>\n"
+ append body [xmlrpc::marshall $result 3 2]
+ append body "\n\t\t</param>\n"
+ append body "\t</params>\n"
+ append body "</methodResponse>\n"
+
+ set lenbod [string length $body]
+
+ # build the header
+ set header "HTTP/1.1 200 OK\n"
+ append header "Content-Type: text/xml\n"
+ append header "Content-length: $lenbod\n"
+
+ set response "$header\n$body"
+ return $response
+ #return [string trim $response]
+}
+
+# Given an error code (integer)
+# and an errmsg (string)
+# build an XML-RPC fault
+#
+proc buildFault {errcode errmsg} {
+ set err(faultCode) [list int $errcode]
+ set err(faultString) [list string $errmsg]
+
+ # build the body
+ set body "<?xml version=\"1.0\"?>\n"
+ append body "<methodResponse>\n"
+ append body "\t<fault>\n"
+ append body [xmlrpc::marshall {struct err} 2]
+ append body "\t</fault>\n"
+ append body "</methodResponse>\n"
+
+ set lenbod [string length $body]
+
+ # build the header
+ set header "HTTP/1.1 200 OK\n"
+ append header "Content-Type: text/xml\n"
+ append header "Content-length: $lenbod\n"
+
+ set response "$header\n$body"
+ return [string trim $response]
+}
+
+# send an XML-RPC request
+#
+proc xmlrpc::call {url method methodName params {ntabs 4} {distance 3}} {
+ variable READSIZE
+ variable response
+ global readdone
+ global xmlcall
+
+ set readdone 0
+ set xmlcall 1
+ set RE {http://([^:]+):([0-9]+)}
+ if {![regexp $RE $url {} host port]} {
+ return [errReturn "Malformed URL"]
+ }
+
+ set sock [socket $host $port]
+ fconfigure $sock -translation {lf lf} -buffersize $READSIZE
+ fconfigure $sock -blocking off
+ if {[catch {set request [buildRequest $method $methodName $params $ntabs $distance]}]} {
+ return
+ }
+ puts -nonewline $sock $request
+ flush $sock
+ fileevent $sock readable [list xmlrpc::getResponse $sock]
+ vwait readdone
+ catch {close $sock}
+ if {$readdone > 0} {
+ return $response
+ } else {
+ return [errReturn "xmlrpc::call failed"]
+ }
+}
+
+# Given a socket to read on,
+# get and parse the response from the server
+#
+proc xmlrpc::getResponse {sock} {
+ variable response
+ global readdone
+
+ set res [readHeader $sock]
+ set headerStatus [lindex $res 0]; # Header + Status
+ set body [lindex $res 1]; # Body, if any
+
+ set header [parseHTTPCode $headerStatus]
+ set body [getBody $sock $header $body]
+ set response [parseResponse $body]
+ set readdone 1
+}
+
+# Given a socket to read on,
+# a string of header information
+# and a string, body,
+# return a string representing the entire body
+#
+proc xmlrpc::getBody {sock header body} {
+ set res [parseHTTPHeaders $header]
+ set headersl [lindex $res 1]; # A-list of headers
+
+ set expLenl [assoc "Content-Length" $headersl]
+ if {$expLenl == {}} {
+ return [errReturn "No Content-Length found"]
+ }
+ set expLen [lindex $expLenl 1]
+ set body [readBody $body $expLen $sock]
+ return $body
+}
+
+# Given a socket to read on,
+# Return a 2 element list of the form:
+# {header, body} where both are strings
+# Note: header will include the first line which is the status
+#
+proc xmlrpc::readHeader {sock} {
+ set buffer ""
+ while {1} {
+ if {[catch {set buff [nbRead $sock]}]} {
+ return [errReturn "Premature eof"]
+ }
+ append buffer $buff
+ set nindex [string first "\n\n" $buffer]
+ if {$nindex > 0} {
+ break
+ }
+ set bindex [string first "\r\n\r\n" $buffer]
+ if {$bindex > 0} {
+ break
+ }
+ }
+ if {$nindex > 0} {
+ set header [string range $buffer 0 [expr $nindex - 1]]
+ set body [string range $buffer [expr $nindex + 2] end]
+ } elseif {$bindex > 0} {
+ set header [string range $buffer 0 [expr $bindex - 1]]
+ set body [string range $buffer [expr $bindex + 4] end]
+ }
+ return [list $header $body]
+}
+
+# Given the body buffer,
+# the number of bytes expected in the body (Content-Length)
+# and a socket to read on,
+# return the entire body buffer
+#
+proc xmlrpc::readBody {body expLen sock} {
+ set newbody $body
+ while {1} {
+ if {[catch {set buff [nbRead $sock]}]} {
+ return [errReturn "Premature eof"]
+ }
+ append newbody $buff
+ set bodLen [string length $newbody]
+ if {$bodLen == $expLen} {
+ break
+ } elseif {$bodLen > $expLen} {
+ return [errReturn "Content-length:$expLen does not match Body Length:$bodLen"]
+ }
+ }
+ return $newbody
+}
+
+# Given a string, str,
+# check the HTTP status
+# and return the unused portion of str
+#
+proc xmlrpc::parseHTTPCode {str} {
+ variable DIGIT
+
+ set RE "HTTP/"; # HTTP message
+ append RE "($DIGIT+\\.*$DIGIT*)."; # version
+ append RE "($DIGIT+)."; # status code
+ append RE "(\[^\n\]+)\n(.*)"; # status message
+
+ if {![regexp $RE $str {} vern status code rest]} {
+ return [errReturn "Unrecognized HTTP code:\n$str"]
+ }
+ if {$status != "200"} {
+ return [errReturn "Bad HTTP status: $status"]
+ }
+ return $rest
+}
+
+# Given a string, str,
+# return a 2 element list of the form:
+# {remaining, alist}
+# where remaining is the unused portion of str
+# and alist is an A-list of header information
+#
+proc xmlrpc::parseHTTPHeaders {str} {
+ set headers {}
+ set remain {}
+ set remainp 0
+ set RE {([^:]+):(.*)}
+
+ set parts [split $str "\n"]
+ foreach {part} $parts {
+ if {$part == ""
+ && !$remainp} {
+ set remainp 1
+ continue
+ }
+ if {$remainp} {
+ lappend remain $part
+ continue
+ }
+ if {![regexp $RE $part {} key value]} {
+ return [errReturn "Unrecognized HTTP Header format: $part"]
+ }
+ set value [string trim $value]
+ lappend headers [list $key $value]
+ }
+ set rest [join $remain "\n"]
+ return [list $rest $headers]
+}
+
+# Given a string, str
+# parse the response from the server
+# returning the unmarshalled data
+#
+proc xmlrpc::parseResponse {str} {
+ variable WS
+
+ set RE "<\?xml.version=."; # xml version
+ append RE "(\[^\?\]+).\?>$WS*"; # version number
+ append RE "<methodResponse>$WS*"; # method response tag
+ append RE "<params>$WS*"; # params tag
+ append RE "<param>$WS*"; # param tag
+ append RE "(<value>.*)"; # value
+ append RE "</param>$WS*"; # end param tag
+ append RE "</params>$WS*"; # end params tag
+ append RE "</methodResponse>"; # end method response tag
+
+ if {![regexp $RE $str {} vern value]} {
+ set RE "<\?xml.version=."; # xml version
+ append RE "(\[^\?\]+).\?>$WS*"; # version number
+ append RE "<methodResponse>$WS*"; # method response tag
+ append RE "<fault>$WS*"; # fault tag
+ append RE "(.*)$WS*"; # fault values
+ append RE "</fault>$WS*"; # end fault tag
+ append RE "</methodResponse>"; # end method response tag
+
+ if {![regexp $RE $str {} vern value]} {
+ return [errReturn "Unrecognized response from server"]
+ }
+ }
+ set result [unmarshall $value]
+ return $result
+}
+
+# Given a non-blocking file descriptor, fd
+# do a read
+#
+proc xmlrpc::nbRead {fd} {
+ variable READSIZE
+
+ fileevent $fd readable ""
+ set buffer ""
+ while {1} {
+ if {[eof $fd]} {
+ catch {close $fd}
+ break
+ }
+ set temp [read $fd $READSIZE]
+ if {$temp == ""} {
+ break
+ }
+ append buffer $temp
+ }
+ return $buffer
+}
+
+# Given a methodName,
+# and a list of parameters,
+# return an XML-RPC request
+#
+proc xmlrpc::buildRequest {method methodName params {ntabs 4} {distance 2}} {
+ # build the body
+ set body "<?xml version=\"1.0\"?>\n"
+ append body "<methodCall>\n"
+ append body "\t<methodName>$methodName</methodName>\n"
+ if {$params != {}} {
+ append body "\t\t<params>\n"
+ foreach {param} $params {
+ append body "\t\t\t<param>\n"
+ append body [xmlrpc::marshall $param $ntabs $distance]
+ append body "\n\t\t\t</param>\n"
+ }
+ append body "\t\t</params>\n"
+ }
+ append body "</methodCall>\n"
+# set body [regsub -all "\n" $body "\r\n"]
+ set lenbod [string length $body]
+
+ # build the header
+ set header "POST /$method HTTP/1.0\n"
+ append header "Content-Type: text/xml\n"
+ append header "Content-length: $lenbod\n"
+# set header [regsub -all "\n" $header "\r\n"]
+
+# set request "$header\r\n$body"
+ set request "$header\n$body"
+ return $request
+}
+
+# Given a "typed tcl" value
+# return the marshalled representation
+#
+proc xmlrpc::marshall {param {ntabs 0} {distance 1}} {
+ if {![validParam $param]} {
+ return [errReturn "Malformed Parameter: $param"]
+ }
+
+ set strtabs ""
+ for {set x 0} {$x < $ntabs} {incr x} {
+ append strtabs "\t"
+ }
+
+ set type [lindex $param 0]
+ set val [lindex $param 1]
+
+ if {$type == "int"} {
+ return "$strtabs<value><int>$val</int></value>"
+ } elseif {$type == "i4"} {
+ return "$strtabs<value><i4>$val</i4></value>"
+ } elseif {$type == "boolean"} {
+ return "$strtabs<value><boolean>$val</boolean></value>"
+ } elseif {$type == "string"} {
+ return "$strtabs<value><string>$val</string></value>"
+ } elseif {$type == "double"} {
+ return "$strtabs<value><double>$val</double></value>"
+ } elseif {$type == "dateTime.iso8601"} {
+ return "$strtabs<value><dateTime.iso8601>$val</dateTime.iso8601></value>"
+ } elseif {$type == "base64"} {
+ return "$strtabs<value><base64>$val</base64></value>"
+ } elseif {$type == "struct"} {
+ # get the original caller's scope
+ upvar $distance $val dict
+ # try the global scope
+ if {![array exists dict]} {
+ upvar #0 $val dict
+ }
+
+ set str "$strtabs<value>\n"
+ append str "$strtabs\t<struct>\n"
+ foreach {k v} [array get dict] {
+ append str "$strtabs\t\t<member>\n"
+ append str "$strtabs\t\t\t<name>$k</name>\n"
+ append str [marshall $v [expr $ntabs + 3] [expr $distance + 1]]
+ append str "\n$strtabs\t\t</member>\n"
+ }
+ append str "$strtabs\t</struct>\n"
+ append str "$strtabs</value>\n"
+ return $str
+ } elseif {$type == "array"} {
+ set str "$strtabs<value>\n"
+ append str "$strtabs\t<array>\n"
+ append str "$strtabs\t\t<data>\n"
+ foreach el $val {
+ append str [marshall $el [expr $ntabs + 3] [expr $distance + 1]]
+ append str "\n"
+ }
+ append str "$strtabs\t\t</data>\n"
+ append str "$strtabs\t</array>\n"
+ append str "$strtabs</value>\n"
+ return $str
+ } else {
+ return [errReturn "Unknown type: $type"]
+ }
+}
+
+# Given a value param,
+# return 1 if it a valid parameter
+# return 0 if not
+# A valid parameter is a 2 element tuple
+#
+proc xmlrpc::validParam {param} {
+ if {[llength $param] != 2} {
+ return 0
+ }
+ return 1
+}
+
+# Given a marshalled value,
+# unmarshall it and return it
+#
+proc xmlrpc::unmarshall {str} {
+ set str [string trim $str]
+ if {[string range $str 0 6] != "<value>"} {
+ # check for empty element
+ if {[string range $str 0 7] != "</value>"} {
+ return [errReturn "Bad value tag"]
+ }
+ set rest [string range $str 8 end]
+ set rest [string trim $rest]
+ return [list $rest {}]
+ }
+
+ set str [string range $str 7 end]
+ set str [string trimleft $str]
+ set RE {<([^>]+)>}
+ if {![regexp $RE $str {} btag]} {
+ return [errReturn "No beginning tag found: $str"]
+ }
+
+ if {$btag == "int" || $btag == "i4"} {
+ set res [umInt $str]
+ } elseif {$btag== "boolean"} {
+ set res [umBool $str]
+ } elseif {$btag == "string"} {
+ set res [umString $str]
+ } elseif {$btag == "double"} {
+ set res [umDouble $str]
+ } elseif {$btag == "dateTime.iso8601"} {
+ set res [umDateTime $str]
+ } elseif {$btag == "base64"} {
+ set res [umBase64 $str]
+ } elseif {$btag == "array"} {
+ set res [umArray $str]
+ } elseif {$btag == "struct"} {
+ set res [umStruct $str]
+ } else {
+ #check for empty element
+ if {[string range $btag 0 1]=={/}} {
+ set id [string first "]" $str ]
+ if {$id != -1} {
+ set rest [string range $str $id end]
+ set rest [string trim $rest]
+ return [list $rest {}]
+ }
+ }
+
+ # return [errReturn "Unknown type: $str"]
+ # assume string
+ set id [string first "<" $str ]
+ if {$id != -1} {
+ set vv [string range $str 0 [expr $id-1]]
+ set rr [string range $str $id end]
+ set str "<string>${vv}</string>${rr}"
+ set res [umString $str]
+ } else {
+ return [errReturn "Unknown type: $str"]
+ }
+ }
+
+ set rest [lindex $res 0]
+ set val [lindex $res 1]
+
+ if {[string range $rest 0 7] != "</value>"} {
+ return [errReturn "Invalid close of value tag"]
+ }
+ set rest [string range $rest 8 end]
+ set rest [string trim $rest]
+ return [list $rest $val]
+}
+
+proc xmlrpc::umInt {str} {
+ variable WS
+ variable DIGIT
+
+ set RE "<(int|i4)>$WS*"; # int tag
+ append RE "(-*)($DIGIT+)$WS*"; # int value
+ append RE "</(int|i4)>$WS*"; # end int tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} tag negp digits engtag rest]} {
+ return [errReturn "Invalid Integer"]
+ }
+ if {$negp != ""} {
+ set digits [expr -1 * $digits]
+ } else {
+ set digits [expr 1 * $digits]
+ }
+ set rest [string trim $rest]
+ return [list $rest $digits]
+}
+
+proc xmlrpc::umBool {str} {
+ variable WS
+
+ set RE "<boolean>$WS*"; # boolean tag
+ append RE "(0|1)$WS*"; # boolean value
+ append RE "</boolean>$WS*"; # end boolean tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} bool rest]} {
+ return [errReturn "Invalid Boolean"]
+ }
+ set rest [string trim $rest]
+ return [list $rest $bool]
+}
+
+proc xmlrpc::umString {str} {
+ variable WS
+
+ set RE "<string>"; # string tag
+ append RE "(\[^<\]*)"; # string value
+ append RE "</string>$WS*"; # end string tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} s rest]} {
+ return [errReturn "Invalid String"]
+ }
+ set rest [string trim $rest]
+ return [list $rest $s]
+}
+
+proc xmlrpc::umDouble {str} {
+ variable WS
+ variable DIGIT
+
+ set RE "<double>$WS*"; # double tag
+ append RE "(-*)($DIGIT*\.?$DIGIT*)$WS*"; # double value
+ append RE "</double>$WS*"; # end double tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} negp d rest]} {
+ return [errReturn "Invalid Double"]
+ }
+ if {$negp != ""} {
+ set d [expr -1 * $d]
+ } else {
+ set d [expr 1 * $d]
+ }
+ set rest [string trim $rest]
+ return [list $rest $d]
+}
+
+proc xmlrpc::umDateTime {str} {
+ variable WS
+ variable DIGIT
+
+ set RE "<dateTime\\.iso8601>$WS*"; # dateTime tag
+ append RE "($DIGIT+T$DIGIT+:$DIGIT+:$DIGIT+)$WS*"; # dateTime value
+ append RE "</dateTime\\.iso8601>$WS*"; # end string tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} dateTime rest]} {
+ return [errReturn "Invalid DateTime"]
+ }
+ set rest [string trim $rest]
+ return [list $rest $dateTime]
+}
+
+proc xmlrpc::umBase64 {str} {
+ variable WS
+
+ set RE "<base64>"; # string tag
+ append RE "(\[^<\]*)"; # string value
+ append RE "</base64>$WS*"; # end string tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} s rest]} {
+ return [errReturn "Invalid Base64"]
+ }
+ set rest [string trim $rest]
+ return [list $rest $s]
+}
+
+proc xmlrpc::umArray {str} {
+ variable WS
+
+ set RE "<array>$WS*"; # array tag
+ append RE "<data>$WS*"; # data tag
+ append RE "(.*)"; # leftover
+
+ if {![regexp $RE $str {} rest]} {
+ return [errReturn "Invalid Array"]
+ }
+ set l {}
+ while {[string range $rest 0 6] == "<value>"} {
+ set res [unmarshall $rest]
+ set rest [lindex $res 0]
+ set el [lindex $res 1]
+ lappend l $el
+ }
+
+ set REAREND "</data>$WS*"; # end data tag
+ append REAREND "</array>$WS*"; # end array tag
+ append REAREND "(.*)"; # leftover
+
+ if {![regexp $REAREND $rest {} leftover]} {
+ return [errReturn "Invalid End Array"]
+ }
+ return [list $leftover $l]
+}
+
+proc xmlrpc::umStruct {str} {
+ variable WS
+ variable W
+
+ if {[string range $str 0 7] != "<struct>"} {
+ return [errReturn "Invalid Struct"]
+ }
+
+ set RE "<name>$WS*"; # name tag
+ append RE "($W+?)$WS*"; # key
+ append RE "</name>$WS*"; # end name tag
+ append RE "(<value>.*)"; # value tag
+
+ set l {}
+ set str [string range $str 8 end]
+ set str [string trim $str]
+ while {[string range $str 0 7] == "<member>"} {
+ set str [string range $str 8 end]
+ set str [string trim $str]
+ if {![regexp $RE $str {} key val]} {
+ return [errReturn "Invalid Struct Member"]
+ }
+ set res [unmarshall $val]
+ set str [lindex $res 0]
+ set el [lindex $res 1]
+ lappend l [list $key $el]
+ if {[string range $str 0 8] != "</member>"} {
+ return [errReturn "Invalid End Struct Member"]
+ }
+ set str [string range $str 9 end]
+ set str [string trim $str]
+ }
+ if {[string range $str 0 8] != "</struct>"} {
+ return [errReturn "Invalid End Struct"]
+ }
+ set str [string range $str 9 end]
+ set str [string trim $str]
+ return [list $str $l]
+}
+
+# Given a key, and a list of elements where each element is of the form:
+# {key, datum}, return {key, datum} if the requested key matches
+# a key in the list.
+# Returns the first match found in the list.
+# Return {} on failure
+#
+proc xmlrpc::assoc {key list} {
+ foreach {cons} $list {
+ set tkey [lindex $cons 0]
+ if {[string tolower $key] == [string tolower $tkey]} {
+ return $cons
+ }
+ }
+ return {}
+}
+
+proc xmlrpc::warn {msg} {
+ puts stderr $msg
+}
+
+proc xmlrpc::debug {msg} {
+ variable DEBUG
+
+ if {$DEBUG} {
+ puts "$msg"
+ }
+}
+
+proc xmlrpc::errReturn {msg} {
+ warn $msg
+ return -code error
+}
+
+proc xmlrpc::test {} {
+ set person(first) {string "eric m"}
+ set person(last) {string yeh}
+ set employed(programmer) {struct person}
+
+ #set xml [marshall {struct employed}]
+ #set w [list {int 1}]
+ #set q [list "array \{$w\}" {int 2} {string eric}]
+ #puts [marshall "array \{$q\}"]
+
+ #set xml [marshall {array {{int 1} {string {hello everybody}}}}]
+ set xml [marshall {struct person}]
+ debug "xml:\n$xml"
+ set data [unmarshall $xml]
+ debug "data: $data"
+ set data [lindex $data 1]
+ debug "data: $data"
+ puts [assoc "first" $data]
+}
+
+#proc bgerror {error} {
+# global xmlcall
+# if {$xmlcall} {
+# global readdone
+# set readdone -1
+# set xmlcall 0
+# }
+#}
+
+#xmlrpc::test
diff --git a/ds9/library/xpa.tcl b/ds9/library/xpa.tcl
new file mode 100644
index 0000000..8e587d9
--- /dev/null
+++ b/ds9/library/xpa.tcl
@@ -0,0 +1,2251 @@
+# 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 InitXPA {} {
+ global ds9
+ global pds9
+ global env
+
+ if {!$pds9(xpa)} {
+ return
+ }
+
+ # this is needed
+ # if there is a problem (usually with VPN), XPA will hang
+ # so preempt and set to local before XPAINIT
+ if {[info exists env(XPA_METHOD)]} {
+ if {$env(XPA_METHOD) != {local}} {
+ if {[checkdns {} 5]} {
+ set env(XPA_METHOD) local
+ Error [msgcat::mc {XPA unable to verify hostname, setting XPA_METHOD to LOCAL}]
+ }
+ }
+ } else {
+ if {[checkdns {} 5]} {
+ set env(XPA_METHOD) local
+ Error [msgcat::mc {XPA unable to verify hostname, setting XPA_METHOD to LOCAL}]
+ }
+ }
+
+ switch -- $ds9(wm) {
+ x11 -
+ win32 {}
+ aqua {set env(PATH) "$ds9(root):$env(PATH)"}
+ }
+
+ catch {CreateXPA}
+ UpdateFileMenu
+}
+
+proc CreateXPA {} {
+ global xpa
+ global ds9
+
+ set xpa [xpacmdnew "DS9" $ds9(title)]
+
+ xpacmdadd $xpa 2mass \
+ {} \
+ XPASend2MASS {} {} \
+ XPARcvd2MASS {} "fillbuf=false"
+
+ xpacmdadd $xpa 3d \
+ {} \
+ XPASend3D {} {} \
+ XPARcvd3D {} "fillbuf=false"
+
+ xpacmdadd $xpa 3D \
+ {} \
+ XPASend3D {} {} \
+ XPARcvd3D {} "fillbuf=false"
+
+ xpacmdadd $xpa about \
+ {} \
+ XPASendAbout {} {} \
+ {} {} {}
+
+ xpacmdadd $xpa align \
+ {} \
+ XPASendAlign {} {} \
+ XPARcvdAlign {} {}
+
+ xpacmdadd $xpa analysis \
+ {} \
+ XPASendAnalysis {} {} \
+ XPARcvdAnalysis {} {}
+
+ xpacmdadd $xpa array \
+ {} \
+ XPASendArray {} {} \
+ XPARcvdArray {} "fillbuf=false"
+
+ xpacmdadd $xpa background \
+ {} \
+ XPASendBg {} {} \
+ XPARcvdBg {} {}
+
+ xpacmdadd $xpa backup \
+ {} \
+ {} {} {} \
+ XPARcvdBackup {} {}
+
+ xpacmdadd $xpa bg \
+ {} \
+ XPASendBg {} {} \
+ XPARcvdBg {} {}
+
+ xpacmdadd $xpa blink \
+ {} \
+ XPASendBlink {} {} \
+ XPARcvdBlink {} "fillbuf=false"
+
+ xpacmdadd $xpa bin \
+ {} \
+ XPASendBin {} {} \
+ XPARcvdBin {} "fillbuf=false"
+
+ xpacmdadd $xpa block \
+ {} \
+ XPASendBlock {} {} \
+ XPARcvdBlock {} "fillbuf=false"
+
+ xpacmdadd $xpa cat \
+ {} \
+ XPASendCAT {} {} \
+ XPARcvdCAT {} "fillbuf=false"
+
+ xpacmdadd $xpa catalog \
+ {} \
+ XPASendCAT {} {} \
+ XPARcvdCAT {} "fillbuf=false"
+
+ xpacmdadd $xpa cd \
+ {} \
+ XPASendCD {} {} \
+ XPARcvdCD {} "fillbuf=false"
+
+ xpacmdadd $xpa cmap \
+ {} \
+ XPASendCmap {} {} \
+ XPARcvdCmap {} "fillbuf=false"
+
+ xpacmdadd $xpa colorbar \
+ {} \
+ XPASendColorbar {} {} \
+ XPARcvdColorbar {} "fillbuf=false"
+
+ xpacmdadd $xpa console \
+ {} \
+ {} {} {} \
+ XPARcvdConsole {} "fillbuf=false"
+
+ xpacmdadd $xpa contour \
+ {} \
+ XPASendContour {} {} \
+ XPARcvdContour {} "fillbuf=false"
+
+ xpacmdadd $xpa contours \
+ {} \
+ XPASendContour {} {} \
+ XPARcvdContour {} "fillbuf=false"
+
+ xpacmdadd $xpa crop \
+ {} \
+ XPASendCrop {} {} \
+ XPARcvdCrop {} "fillbuf=false"
+
+ xpacmdadd $xpa crosshair \
+ {} \
+ XPASendCrosshair {} {} \
+ XPARcvdCrosshair {} "fillbuf=false"
+
+ xpacmdadd $xpa cube \
+ {} \
+ XPASendCube {} {} \
+ XPARcvdCube {} "fillbuf=false"
+
+ xpacmdadd $xpa cursor \
+ {} \
+ {} {} {} \
+ XPARcvdCursor {} "fillbuf=false"
+
+ xpacmdadd $xpa data \
+ {} \
+ XPASendData {} {} \
+ {} {} {}
+
+ xpacmdadd $xpa datacube \
+ {} \
+ XPASendCube {} {} \
+ XPARcvdCube {} "fillbuf=false"
+
+ xpacmdadd $xpa dss \
+ {} \
+ XPASendSAO {} {} \
+ XPARcvdSAO {} "fillbuf=false"
+
+ xpacmdadd $xpa dsssao \
+ {} \
+ XPASendSAO {} {} \
+ XPARcvdSAO {} "fillbuf=false"
+
+ xpacmdadd $xpa dsseso \
+ {} \
+ XPASendESO {} {} \
+ XPARcvdESO {} "fillbuf=false"
+
+ xpacmdadd $xpa dssstsci \
+ {} \
+ XPASendSTSCI {} {} \
+ XPARcvdSTSCI {} "fillbuf=false"
+
+ xpacmdadd $xpa envi \
+ {} \
+ {} {} {} \
+ XPARcvdENVI {} "fillbuf=false"
+
+ xpacmdadd $xpa exit \
+ {} \
+ {} {} {} \
+ XPARcvdExit {} "fillbuf=false"
+
+ xpacmdadd $xpa export \
+ {} \
+ {} {} {} \
+ XPARcvdExport {} "fillbuf=false"
+
+ xpacmdadd $xpa file \
+ {} \
+ XPASendFile {} {} \
+ XPARcvdFile {} "fillbuf=false"
+
+ xpacmdadd $xpa first \
+ {} \
+ XPASendVLA {} {} \
+ XPARcvdVLA {} "fillbuf=false"
+
+ xpacmdadd $xpa fits \
+ {} \
+ XPASendFits {} "fillbuf=false" \
+ XPARcvdFits {} "fillbuf=false"
+
+ xpacmdadd $xpa frame \
+ {} \
+ XPASendFrame {} {} \
+ XPARcvdFrame {} "fillbuf=false"
+
+ xpacmdadd $xpa gif \
+ {} \
+ XPASendGIF {} {} \
+ XPARcvdGIF {} "fillbuf=false"
+
+ xpacmdadd $xpa grid \
+ {} \
+ XPASendGrid {} {} \
+ XPARcvdGrid {} "fillbuf=false"
+
+ xpacmdadd $xpa header \
+ {} \
+ {} {} {} \
+ XPARcvdHeader {} "fillbuf=false"
+
+ xpacmdadd $xpa height \
+ {} \
+ XPASendHeight {} {} \
+ XPARcvdHeight {} "fillbuf=false"
+
+ xpacmdadd $xpa iconify \
+ {} \
+ XPASendIconify {} {} \
+ XPARcvdIconify {} "fillbuf=false"
+
+ xpacmdadd $xpa iexam \
+ {} \
+ XPASendIExam {} {} \
+ {} {} {}
+
+ xpacmdadd $xpa iis \
+ {} \
+ XPASendIIS {} {} \
+ XPARcvdIIS {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa imexam \
+ {} \
+ XPASendIExam {} {} \
+ {} {} {}
+
+ xpacmdadd $xpa jpg \
+ {} \
+ XPASendJPEG {} {} \
+ XPARcvdJPEG {} "fillbuf=false"
+
+ xpacmdadd $xpa jpeg \
+ {} \
+ XPASendJPEG {} {} \
+ XPARcvdJPEG {} "fillbuf=false"
+
+ xpacmdadd $xpa lock \
+ {} \
+ XPASendLock {} {} \
+ XPARcvdLock {} "fillbuf=false"
+
+ xpacmdadd $xpa lower \
+ {} \
+ {} {} {} \
+ XPARcvdLower {} "fillbuf=false"
+
+ xpacmdadd $xpa magnifier \
+ {} \
+ XPASendMagnifier {} {} \
+ XPARcvdMagnifier {} "fillbuf=false"
+
+ xpacmdadd $xpa mask \
+ {} \
+ XPASendMask {} {} \
+ XPARcvdMask {} "fillbuf=false"
+
+ xpacmdadd $xpa match \
+ {} \
+ {} {} {} \
+ XPARcvdMatch {} "fillbuf=false"
+
+ xpacmdadd $xpa mecube \
+ {} \
+ XPASendMECube {} "fillbuf=false" \
+ XPARcvdMECube {} "fillbuf=false"
+
+ xpacmdadd $xpa memf \
+ {} \
+ {} {} {} \
+ XPARcvdMultiFrame {} "fillbuf=false"
+
+ xpacmdadd $xpa minmax \
+ {} \
+ XPASendMinMax {} {} \
+ XPARcvdMinMax {} "fillbuf=false"
+
+ xpacmdadd $xpa mode \
+ {} \
+ XPASendMode {} {} \
+ XPARcvdMode {} "fillbuf=false"
+
+ xpacmdadd $xpa mosaic \
+ {} \
+ XPASendMosaic {} {} \
+ XPARcvdMosaic {} "fillbuf=false"
+
+ xpacmdadd $xpa mosaicimage \
+ {} \
+ XPASendMosaicImage {} {} \
+ XPARcvdMosaicImage {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa mosaicwcs \
+ {} \
+ XPASendMosaicWCS {} {} \
+ XPARcvdMosaicWCS {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa mosaiciraf \
+ {} \
+ {} {} {} \
+ XPARcvdMosaicIRAF {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa mosaicimagewcs \
+ {} \
+ XPASendMosaicImageWCS {} {} \
+ XPARcvdMosaicImageWCS {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa mosaicimageiraf \
+ {} \
+ {} {} {} \
+ XPARcvdMosaicImageIRAF {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa mosaicimagewfpc2 \
+ {} \
+ {} {} {} \
+ XPARcvdMosaicImageWFPC2 {} "fillbuf=false"
+
+ xpacmdadd $xpa multiframe \
+ {} \
+ {} {} {} \
+ XPARcvdMultiFrame {} "fillbuf=false"
+
+ xpacmdadd $xpa movie \
+ {} \
+ {} {} {} \
+ XPARcvdMovie {} "fillbuf=false"
+
+ xpacmdadd $xpa nameserver \
+ {} \
+ XPASendNRES {} {} \
+ XPARcvdNRES {} "fillbuf=false"
+
+ xpacmdadd $xpa nan \
+ {} \
+ XPASendNan {} {} \
+ XPARcvdNan {} {}
+
+ xpacmdadd $xpa nrrd \
+ {} \
+ XPASendNRRD {} {} \
+ XPARcvdNRRD {} "fillbuf=false"
+
+ xpacmdadd $xpa nvss \
+ {} \
+ XPASendNVSS {} {} \
+ XPARcvdNVSS {} "fillbuf=false"
+
+ xpacmdadd $xpa orient \
+ {} \
+ XPASendOrient {} {} \
+ XPARcvdOrient {} "fillbuf=false"
+
+ xpacmdadd $xpa {page setup} \
+ {} \
+ XPASendPageSetup {} {} \
+ XPARcvdPageSetup {} "fillbuf=false"
+
+ xpacmdadd $xpa pagesetup \
+ {} \
+ XPASendPageSetup {} {} \
+ XPARcvdPageSetup {} "fillbuf=false"
+
+ xpacmdadd $xpa pspagesetup \
+ {} \
+ XPASendPSPageSetup {} {} \
+ XPARcvdPSPageSetup {} "fillbuf=false"
+
+ xpacmdadd $xpa pan \
+ {} \
+ XPASendPan {} {} \
+ XPARcvdPan {} "fillbuf=false"
+
+ xpacmdadd $xpa pixeltable \
+ {} \
+ XPASendPixelTable {} {} \
+ XPARcvdPixelTable {} "fillbuf=false"
+
+ xpacmdadd $xpa plot \
+ {} \
+ XPASendPlot {} {} \
+ XPARcvdPlot {} {}
+
+ xpacmdadd $xpa png \
+ {} \
+ XPASendPNG {} {} \
+ XPARcvdPNG {} "fillbuf=false"
+
+ xpacmdadd $xpa prefs \
+ {} \
+ XPASendPrefs {} {} \
+ XPARcvdPrefs {} "fillbuf=false"
+
+ xpacmdadd $xpa preserve \
+ {} \
+ XPASendPreserve {} {} \
+ XPARcvdPreserve {} "fillbuf=false"
+
+ xpacmdadd $xpa print \
+ {} \
+ XPASendPrint {} {} \
+ XPARcvdPrint {} "fillbuf=false"
+
+ xpacmdadd $xpa psprint \
+ {} \
+ XPASendPSPrint {} {} \
+ XPARcvdPSPrint {} "fillbuf=false"
+
+ xpacmdadd $xpa quit \
+ {} \
+ {} {} {} \
+ XPARcvdExit {} "fillbuf=false"
+
+ xpacmdadd $xpa raise \
+ {} \
+ {} {} {} \
+ XPARcvdRaise {} "fillbuf=false"
+
+ xpacmdadd $xpa region \
+ {} \
+ XPASendRegions {} {} \
+ XPARcvdRegions {} "fillbuf=false"
+
+ xpacmdadd $xpa regions \
+ {} \
+ XPASendRegions {} {} \
+ XPARcvdRegions {} "fillbuf=false"
+
+ xpacmdadd $xpa restore \
+ {} \
+ {} {} {} \
+ XPARcvdRestore {} {}
+
+ xpacmdadd $xpa rgb \
+ {} \
+ XPASendRGB {} {} \
+ XPARcvdRGB {} "fillbuf=false"
+
+ xpacmdadd $xpa rgbarray \
+ {} \
+ XPASendRGBArray {} {} \
+ XPARcvdRGBArray {} "fillbuf=false"
+
+ xpacmdadd $xpa rgbcube \
+ {} \
+ XPASendRGBCube {} {} \
+ XPARcvdRGBCube {} "fillbuf=false"
+
+ xpacmdadd $xpa rgbimage \
+ {} \
+ XPASendRGBImage {} {} \
+ XPARcvdRGBImage {} "fillbuf=false"
+
+ xpacmdadd $xpa rotate \
+ {} \
+ XPASendRotate {} {} \
+ XPARcvdRotate {} "fillbuf=false"
+
+ xpacmdadd $xpa save \
+ {} \
+ {} {} {} \
+ XPARcvdSave {} "fillbuf=false"
+
+ xpacmdadd $xpa saveimage \
+ {} \
+ {} {} {} \
+ XPARcvdSaveImage {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa savefits \
+ {} \
+ {} {} {} \
+ XPARcvdSave {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa savempeg \
+ {} \
+ {} {} {} \
+ XPARcvdMovie {} "fillbuf=false"
+
+ xpacmdadd $xpa scale \
+ {} \
+ XPASendScale {} {} \
+ XPARcvdScale {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa sfits \
+ {} \
+ {} {} {} \
+ XPARcvdSFits {} "fillbuf=false"
+
+ xpacmdadd $xpa sia \
+ {} \
+ XPASendSIA {} {} \
+ XPARcvdSIA {} "fillbuf=false"
+
+ xpacmdadd $xpa single \
+ {} \
+ XPASendSingle {} {} \
+ XPARcvdSingle {} "fillbuf=false"
+
+ xpacmdadd $xpa shm \
+ {} \
+ XPASendShm {} {} \
+ XPARcvdShm {} "fillbuf=false"
+
+ xpacmdadd $xpa skyview \
+ {} \
+ XPASendSkyView {} {} \
+ XPARcvdSkyView {} "fillbuf=false"
+
+ xpacmdadd $xpa sleep \
+ {} \
+ {} {} {} \
+ XPARcvdSleep {} "fillbuf=false"
+
+ xpacmdadd $xpa slice \
+ {} \
+ XPASendCube {} {} \
+ XPARcvdCube {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa smosaic \
+ {} \
+ {} {} {} \
+ XPARcvdSMosaic {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa smosaicwcs \
+ {} \
+ {} {} {} \
+ XPARcvdSMosaicWCS {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa smosaiciraf \
+ {} \
+ {} {} {} \
+ XPARcvdSMosaicIRAF {} "fillbuf=false"
+
+ xpacmdadd $xpa smooth \
+ {} \
+ XPASendSmooth {} {} \
+ XPARcvdSmooth {} "fillbuf=false"
+
+ xpacmdadd $xpa source \
+ {} \
+ {} {} {} \
+ XPARcvdSource {} "fillbuf=false"
+
+ # backward compatibility
+ xpacmdadd $xpa srgbcube \
+ {} \
+ {} {} {} \
+ XPARcvdSRGBCube {} "fillbuf=false"
+
+ xpacmdadd $xpa tcl \
+ {} \
+ {} {} {} \
+ XPARcvdTcl {} {}
+
+ # backward compatibility
+ xpacmdadd $xpa theme \
+ {} \
+ XPASendTheme {} {} \
+ XPARcvdTheme {} "fillbuf=false"
+
+ xpacmdadd $xpa threads \
+ {} \
+ XPASendThreads {} {} \
+ XPARcvdThreads {} {}
+
+ xpacmdadd $xpa tif \
+ {} \
+ XPASendTIFF {} {} \
+ XPARcvdTIFF {} "fillbuf=false"
+
+ xpacmdadd $xpa tiff \
+ {} \
+ XPASendTIFF {} {} \
+ XPARcvdTIFF {} "fillbuf=false"
+
+ xpacmdadd $xpa tile \
+ {} \
+ XPASendTile {} {} \
+ XPARcvdTile {} "fillbuf=false"
+
+ xpacmdadd $xpa update \
+ {} \
+ {} {} {} \
+ XPARcvdUpdate {} "fillbuf=false"
+
+ xpacmdadd $xpa url \
+ {} \
+ {} {} {} \
+ XPARcvdURLFits {} {}
+
+ xpacmdadd $xpa version \
+ {} \
+ XPASendVersion {} {} \
+ {} {} {}
+
+ xpacmdadd $xpa view \
+ {} \
+ XPASendView {} {} \
+ XPARcvdView {} "fillbuf=false"
+
+ xpacmdadd $xpa vla \
+ {} \
+ XPASendVLA {} {} \
+ XPARcvdVLA {} "fillbuf=false"
+
+ xpacmdadd $xpa vlss \
+ {} \
+ XPASendVLSS {} {} \
+ XPARcvdVLSS {} "fillbuf=false"
+
+ xpacmdadd $xpa vo \
+ {} \
+ XPASendVO {} {} \
+ XPARcvdVO {} "fillbuf=false"
+
+ xpacmdadd $xpa wcs \
+ {} \
+ XPASendWCS {} {} \
+ XPARcvdWCS {} "fillbuf=false"
+
+ xpacmdadd $xpa web \
+ {} \
+ XPASendWeb {} {} \
+ XPARcvdWeb {} "fillbuf=false"
+
+ xpacmdadd $xpa width \
+ {} \
+ XPASendWidth {} {} \
+ XPARcvdWidth {} "fillbuf=false"
+
+ xpacmdadd $xpa xpa \
+ {} \
+ XPASendXPA {} {} \
+ XPARcvdXPA {} "fillbuf=false"
+
+ xpacmdadd $xpa zscale \
+ {} \
+ XPASendZScale {} {} \
+ XPARcvdZScale {} "fillbuf=false"
+
+ xpacmdadd $xpa zoom \
+ {} \
+ XPASendZoom {} {} \
+ XPARcvdZoom {} "fillbuf=false"
+}
+
+proc XPASend2MASS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSend2MASSCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvd2MASS {xpa cdata param buf len} {
+ XPADebug "XPARcvd2MASS" $param
+ InitError xpa
+ catch {set i 0; Process2MASSCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASend3D {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSend3DCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvd3D {xpa cdata param buf len} {
+ XPADebug "XPARcvd3D" $param
+ InitError xpa
+ catch {set i 0; Process3DCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendAbout {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendAboutCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPASendAlign {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendAlignCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdAlign {xpa cdata param buf len} {
+ XPADebug "XPARcvdAlign" $param
+ InitError xpa
+ catch {set i 0; ProcessAlignCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendAnalysis {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendAnalysisCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdAnalysis {xpa cdata param buf len} {
+ XPADebug "XPARcvdAnalysis" $param
+ InitError xpa
+ catch {set i 0; ProcessAnalysisCmd param i $buf {}}
+ XPACatchError $xpa
+}
+
+proc XPASendArray {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendArrayCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdArray {xpa cdata param buf len} {
+ XPADebug "XPARcvdArray" $param
+ InitError xpa
+ catch {set i 0; ProcessArrayCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendBg {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendBgCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdBg {xpa cdata param buf len} {
+ XPADebug "XPARcvdBg" $param
+ InitError xpa
+ catch {set i 0; ProcessBgCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdBackup {xpa cdata param buf len} {
+ XPADebug "XPARcvdBackup" $param
+ InitError xpa
+ catch {set i 0; ProcessBackupCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendBlink {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendBlinkCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdBlink {xpa cdata param buf len} {
+ XPADebug "XPARcvdBlink" $param
+ InitError xpa
+ catch {set i 0; ProcessBlinkCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendBin {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendBinCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdBin {xpa cdata param buf len} {
+ XPADebug "XPARcvdBin" $param
+ InitError xpa
+ catch {set i 0; ProcessBinCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendBlock {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendBlockCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdBlock {xpa cdata param buf len} {
+ XPADebug "XPARcvdBlock" $param
+ InitError xpa
+ catch {set i 0; ProcessBlockCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendCAT {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendCatalogCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCAT {xpa cdata param buf len} {
+ XPADebug "XPARcvdCat" $param
+ InitError xpa
+ catch {set i 0; ProcessCatalogCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendCD {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendCDCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCD {xpa cdata param buf len} {
+ XPADebug "XPARcvdCD" $param
+ InitError xpa
+ catch {set i 0; ProcessCDCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdConsole {xpa cdata param buf len} {
+ XPADebug "XPARcvdConsole" $param
+ InitError xpa
+ catch {set i 0; ProcessConsoleCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendContour {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendContourCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdContour {xpa cdata param buf len} {
+ XPADebug "XPARcvdContour" $param
+ InitError xpa
+ catch {set i 0; ProcessContourCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendCmap {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendCmapCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCmap {xpa cdata param buf len} {
+ XPADebug "XPARcvdCmap" $param
+ InitError xpa
+ catch {set i 0; ProcessCmapCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendColorbar {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendColorbarCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdColorbar {xpa cdata param buf len} {
+ XPADebug "XPARcvdColorbar" $param
+ InitError xpa
+ catch {set i 0; ProcessColorbarCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendCrop {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendCropCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCrop {xpa cdata param buf len} {
+ XPADebug "XPARcvdCrop" $param
+ InitError xpa
+ catch {set i 0; ProcessCropCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendCrosshair {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendCrosshairCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCrosshair {xpa cdata param buf len} {
+ XPADebug "XPARcvdCrosshair" $param
+ InitError xpa
+ catch {set i 0; ProcessCrosshairCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendCube {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendCubeCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCube {xpa cdata param buf len} {
+ XPADebug "XPARcvdCube" $param
+ InitError xpa
+ catch {set i 0; ProcessCubeCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdCursor {xpa cdata param buf len} {
+ XPADebug "XPARcvdCursor" $param
+ InitError xpa
+ catch {set i 0; ProcessCursorCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendData {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendDataCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPASendSAO {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendSAOCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSAO {xpa cdata param buf len} {
+ XPADebug "XPARcvdSAO" $param
+ InitError xpa
+ catch {set i 0; ProcessSAOCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendESO {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendESOCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdESO {xpa cdata param buf len} {
+ XPADebug "XPARcvdESO" $param
+ InitError xpa
+ catch {set i 0; ProcessESOCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendSTSCI {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendSTSCICmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSTSCI {xpa cdata param buf len} {
+ XPADebug "XPARcvdSTSCI" $param
+ InitError xpa
+ catch {set i 0; ProcessSTSCICmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdENVI {xpa cdata param buf len} {
+ XPADebug "XPARcvdENVI" $param
+ InitError xpa
+ catch {set i 0; ProcessENVICmd param i {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdExit {xpa cdata param buf len} {
+ XPADebug "XPARcvdExit" $param
+ InitError xpa
+ catch {set i 0; ProcessQuitCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdExport {xpa cdata param buf len} {
+ XPADebug "XPARcvdExport" $param
+ InitError xpa
+ catch {set i 0; ProcessExportCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendFile {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendFileCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdFile {xpa cdata param buf len} {
+ XPADebug "XPARcvdFile" $param
+ InitError xpa
+ catch {
+ # do not send socket as it does not contain data, only filenames
+ set i 0
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessFileCmd param i {} [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessFileCmd param i {} dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendFits {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendFitsCmd xpasetbuf $xpa $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdFits {xpa cdata param buf len} {
+ XPADebug "XPARcvdFits" $param
+ InitError xpa
+ catch {set i 0; ProcessFitsCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendFrame {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendFrameCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdFrame {xpa cdata param buf len} {
+ XPADebug "XPARcvdFrame" $param
+ InitError xpa
+ catch {set i 0; ProcessFrameCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendGIF {xpa cdata param} {
+ InitError xpa
+ catch {
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessSendGIFCmd {} {} $param [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessSendGIFCmd {} {} $param dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPARcvdGIF {xpa cdata param buf len} {
+ XPADebug "XPARcvdGIF" $param
+ InitError xpa
+ catch {
+ set i 0
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessGIFCmd param i [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessGIFCmd param i dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendGrid {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendGridCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdGrid {xpa cdata param buf len} {
+ XPADebug "XPARcvdGrid" $param
+ InitError xpa
+ catch {set i 0; ProcessGridCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdHeader {xpa cdata param buf len} {
+ XPADebug "XPARcvdHeader" $param
+ InitError xpa
+ catch {set i 0; ProcessHeaderCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendHeight {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendHeightCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdHeight {xpa cdata param buf len} {
+ XPADebug "XPARcvdHeight" $param
+ InitError xpa
+ catch {set i 0; ProcessHeightCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendIconify {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendIconifyCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdIconify {xpa cdata param buf len} {
+ XPADebug "XPARcvdIconify" $param
+ InitError xpa
+ catch {set i 0; ProcessIconifyCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendIExam {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendIExamCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPASendIIS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendIISCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdIIS {xpa cdata param buf len} {
+ XPADebug "XPARcvdIIS" $param
+ InitError xpa
+ catch {set i 0; ProcessIISCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendJPEG {xpa cdata param} {
+ InitError xpa
+ catch {
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessSendJPEGCmd {} {} $param [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessSendJPEGCmd {} {} $param dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPARcvdJPEG {xpa cdata param buf len} {
+ XPADebug "XPARcvdJPEG" $param
+ InitError xpa
+ catch {
+ set i 0
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessJPEGCmd param i [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessJPEGCmd param i dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendLock {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendLockCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdLock {xpa cdata param buf len} {
+ XPADebug "XPARcvdLock" $param
+ InitError xpa
+ catch {set i 0; ProcessLockCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdLower {xpa cdata param buf len} {
+ XPADebug "XPARcvdLower" $param
+ InitError xpa
+ catch {set i 0; ProcessLowerCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendMagnifier {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMagnifierCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMagnifier {xpa cdata param buf len} {
+ XPADebug "XPARcvdMagnifier" $param
+ InitError xpa
+ catch {set i 0; ProcessMagnifierCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendMask {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMaskCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMask {xpa cdata param buf len} {
+ XPADebug "XPARcvdMask" $param
+ InitError xpa
+ catch {set i 0; ProcessMaskCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMatch {xpa cdata param buf len} {
+ XPADebug "XPARcvdMatch" $param
+ InitError xpa
+ catch {set i 0; ProcessMatchCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendMECube {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMECubeCmd xpasetbuf $xpa $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMECube {xpa cdata param buf len} {
+ XPADebug "XPARcvdMECube" $param
+ InitError xpa
+ catch {set i 0; ProcessMECubeCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendMinMax {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMinMaxCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMinMax {xpa cdata param buf len} {
+ XPADebug "XPARcvdMinMax" $param
+ InitError xpa
+ catch {set i 0; ProcessMinMaxCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendMode {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendModeCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMode {xpa cdata param buf len} {
+ XPADebug "XPARcvdMode" $param
+ InitError xpa
+ catch {set i 0; ProcessModeCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendMosaic {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMosaicCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMosaic {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaic" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendMosaicImage {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMosaicImageCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMosaicImage {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaicImage" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicImageCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPASendMosaicWCS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMosaicWCSCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdMosaicWCS {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaicWCS" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicWCSCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdMosaicIRAF {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaicIRAF" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicIRAFCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPASendMosaicImageWCS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendMosaicImageWCSCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdMosaicImageWCS {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaicImageWCS" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicImageWCSCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdMosaicImageIRAF {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaicImageIRAF" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicImageIRAFCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdMosaicImageWFPC2 {xpa cdata param buf len} {
+ XPADebug "XPARcvdMosaicImageWFPC2" $param
+ InitError xpa
+ catch {set i 0; ProcessMosaicImageWFPC2Cmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMovie {xpa cdata param buf len} {
+ XPADebug "XPARcvdMovie" $param
+ InitError xpa
+ catch {set i 0; ProcessMovieCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdMultiFrame {xpa cdata param buf len} {
+ XPADebug "XPARcvdMultiFrame" $param
+ InitError xpa
+ catch {
+ set i 0
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessMultiFrameCmd param i [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessMultiFrameCmd param i dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendNan {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendNanCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdNan {xpa cdata param buf len} {
+ XPADebug "XPARcvdNan" $param
+ InitError xpa
+ catch {set i 0; ProcessNanCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendNRES {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendNRESCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdNRES {xpa cdata param buf len} {
+ XPADebug "XPARcvdNRES" $param
+ InitError xpa
+ catch {set i 0; ProcessNRESCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendNRRD {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendNRRDCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdNRRD {xpa cdata param buf len} {
+ XPADebug "XPARcvdNRRD" $param
+ InitError xpa
+ catch {set i 0; ProcessNRRDCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendNVSS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendNVSSCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdNVSS {xpa cdata param buf len} {
+ XPADebug "XPARcvdNVSS" $param
+ InitError xpa
+ catch {set i 0; ProcessNVSSCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendOrient {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendOrientCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdOrient {xpa cdata param buf len} {
+ XPADebug "XPARcvdOrient" $param
+ InitError xpa
+ catch {set i 0; ProcessOrientCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPageSetup {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPageSetupCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPageSetup {xpa cdata param buf len} {
+ XPADebug "XPARcvdPageSetup" $param
+ InitError xpa
+ catch {set i 0; ProcessPageSetupCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPSPageSetup {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPSPageSetupCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPSPageSetup {xpa cdata param buf len} {
+ XPADebug "XPARcvdPSPageSetup" $param
+ InitError xpa
+ catch {set i 0; ProcessPSPageSetupCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPan {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPanCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPan {xpa cdata param buf len} {
+ XPADebug "XPARcvdPan" $param
+ InitError xpa
+ catch {set i 0; ProcessPanCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPixelTable {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPixelTableCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPixelTable {xpa cdata param buf len} {
+ XPADebug "XPARcvdPixelTable" $param
+ InitError xpa
+ catch {set i 0; ProcessPixelTableCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPlot {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPlotCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPlot {xpa cdata param buf len} {
+ XPADebug "XPARcvdPlot" $param
+ InitError xpa
+ catch {set i 0; ProcessPlotCmd param i $buf {}}
+ XPACatchError $xpa
+}
+
+proc XPASendPNG {xpa cdata param} {
+ InitError xpa
+ catch {
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessSendPNGCmd {} {} $param [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessSendPNGCmd {} {} $param dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPARcvdPNG {xpa cdata param buf len} {
+ XPADebug "XPARcvdPNG" $param
+ InitError xpa
+ catch {
+ set i 0
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessPNGCmd param i [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessPNGCmd param i dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendPrefs {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPrefsCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPrefs {xpa cdata param buf len} {
+ XPADebug "XPARcvdPrefs" $param
+ InitError xpa
+ catch {set i 0; ProcessPrefsCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPreserve {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPreserveCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPreserve {xpa cdata param buf len} {
+ XPADebug "XPARcvdPreserve" $param
+ InitError xpa
+ catch {set i 0; ProcessPreserveCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendPrint {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPrintCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPrint {xpa cdata param buf len} {
+ XPADebug "XPARcvdPrint" $param
+ InitError xpa
+ catch {
+ if {[XPAIsLocal]} {
+ set i 0
+ ProcessPrintCmd param i
+ } else {
+ Error [msgcat::mc {This function is not available.}]
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendPSPrint {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendPSPrintCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdPSPrint {xpa cdata param buf len} {
+ XPADebug "XPARcvdPSPrint" $param
+ InitError xpa
+ catch {
+ if {[XPAIsLocal]} {
+ set i 0
+ ProcessPSPrintCmd param i
+ } else {
+ Error [msgcat::mc {This function is not available.}]
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPARcvdRaise {xpa cdata param buf len} {
+ XPADebug "XPARcvdRaise" $param
+ InitError xpa
+ catch {set i 0; ProcessRaiseCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendRegions {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendRegionsCmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRegions {xpa cdata param buf len} {
+ XPADebug "XPARcvdRegions" $param
+ InitError xpa
+ catch {set i 0; ProcessRegionsCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRestore {xpa cdata param buf len} {
+ XPADebug "XPARcvdRestore" $param
+ InitError xpa
+ catch {set i 0; ProcessRestoreCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendRGB {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendRGBCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRGB {xpa cdata param buf len} {
+ XPADebug "XPARcvdRGB" $param
+ InitError xpa
+ catch {set i 0; ProcessRGBCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendRGBArray {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendRGBArrayCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRGBArray {xpa cdata param buf len} {
+ XPADebug "XPARcvdRGBArray" $param
+ InitError xpa
+ catch {set i 0; ProcessRGBArrayCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendRGBCube {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendRGBCubeCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRGBCube {xpa cdata param buf len} {
+ XPADebug "XPARcvdRGBCube" $param
+ InitError xpa
+ catch {set i 0; ProcessRGBCubeCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendRGBImage {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendRGBImageCmd {} {} $param [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRGBImage {xpa cdata param buf len} {
+ XPADebug "XPARcvdRGBImage" $param
+ InitError xpa
+ catch {set i 0; ProcessRGBImageCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendRotate {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendRotateCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdRotate {xpa cdata param buf len} {
+ XPADebug "XPARcvdRotate" $param
+ InitError xpa
+ catch {set i 0; ProcessRotateCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSave {xpa cdata param buf len} {
+ XPADebug "XPARcvdSave" $param
+ InitError xpa
+ catch {set i 0; ProcessSaveCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSaveImage {xpa cdata param buf len} {
+ XPADebug "XPARcvdSaveImage" $param
+ InitError xpa
+ catch {set i 0; ProcessSaveImageCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendScale {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendScaleCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdScale {xpa cdata param buf len} {
+ XPADebug "XPARcvdScale" $param
+ InitError xpa
+ catch {set i 0; ProcessScaleCmd param i}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdSFits {xpa cdata param buf len} {
+ XPADebug "XPARcvdSFits" $param
+ InitError xpa
+ catch {set i 0; ProcessSFitsCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendSIA {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendSIACmd xpasetbuf $xpa $param {} {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSIA {xpa cdata param buf len} {
+ XPADebug "XPARcvdSIA" $param
+ InitError xpa
+ catch {set i 0; ProcessSIACmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendSingle {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendSingleCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSingle {xpa cdata param buf len} {
+ XPADebug "XPARcvdSingle" $param
+ InitError xpa
+ catch {set i 0; ProcessSingleCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendShm {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendShmCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdShm {xpa cdata param buf len} {
+ XPADebug "XPARcvdShm" $param
+ InitError xpa
+ catch {set i 0; ProcessShmCmd param i 0}
+ XPACatchError $xpa
+}
+
+proc XPASendSkyView {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendSkyViewCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSkyView {xpa cdata param buf len} {
+ XPADebug "XPARcvdSkyView" $param
+ InitError xpa
+ catch {set i 0; ProcessSkyViewCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSleep {xpa cdata param buf len} {
+ XPADebug "XPARcvdSleep" $param
+ InitError xpa
+ catch {set i 0; ProcessSleepCmd param i}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdSMosaic {xpa cdata param buf len} {
+ XPADebug "XPARcvdSMosaic" $param
+ InitError xpa
+ catch {set i 0; ProcessSMosaicCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdSMosaicWCS {xpa cdata param buf len} {
+ XPADebug "XPARcvdSMosaicWCS" $param
+ InitError xpa
+ catch {set i 0; ProcessSMosaicWCSCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdSMosaicIRAF {xpa cdata param buf len} {
+ XPADebug "XPARcvdSMosaicIRAF" $param
+ InitError xpa
+ catch {set i 0; ProcessSMosaicIRAFCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendSmooth {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendSmoothCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSmooth {xpa cdata param buf len} {
+ XPADebug "XPARcvdSmooth" $param
+ InitError xpa
+ catch {set i 0; ProcessSmoothCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdSource {xpa cdata param buf len} {
+ XPADebug "XPARcvdSource" $param
+ InitError xpa
+ catch {
+ if {[XPAIsLocal]} {
+ set i 0
+ ProcessSourceCmd param i
+ } else {
+ Error [msgcat::mc {This function is not available.}]
+ }
+ }
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdSRGBCube {xpa cdata param buf len} {
+ XPADebug "XPARcvdSRGBCube" $param
+ InitError xpa
+ catch {set i 0; ProcessSRGBCubeCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPARcvdTcl {xpa cdata param buf len} {
+ XPADebug "XPARcvdTcl" $param
+ InitError xpa
+ catch {
+ if {[XPAIsLocal]} {
+ set i 0
+ ProcessTclCmd param i $buf {}
+ } else {
+ Error [msgcat::mc {This function is not available.}]
+ }
+ }
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPASendTheme {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendThemeCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+# backward compatibility
+proc XPARcvdTheme {xpa cdata param buf len} {
+ XPADebug "XPARcvdTheme" $param
+ InitError xpa
+ catch {set i 0; ProcessThemeCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendThreads {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendThreadsCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdThreads {xpa cdata param buf len} {
+ XPADebug "XPARcvdThreads" $param
+ InitError xpa
+ catch {set i 0; ProcessThreadsCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendTIFF {xpa cdata param} {
+ InitError xpa
+ catch {
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessSendTIFFCmd {} {} $param [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessSendTIFFCmd {} {} $param dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPARcvdTIFF {xpa cdata param buf len} {
+ XPADebug "XPARcvdTIFF" $param
+ InitError xpa
+ catch {
+ set i 0
+ global tcl_platform
+ switch $tcl_platform(os) {
+ Linux -
+ Darwin -
+ SunOS {ProcessTIFFCmd param i [xparec $xpa datachan] {}}
+ {Windows NT} {ProcessTIFFCmd param i dummy {}}
+ }
+ }
+ XPACatchError $xpa
+}
+
+proc XPASendTile {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendTileCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdTile {xpa cdata param buf len} {
+ XPADebug "XPARcvdTile" $param
+ InitError xpa
+ catch {set i 0; ProcessTileCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdUpdate {xpa cdata param buf len} {
+ XPADebug "XPARcvdUpdate" $param
+ InitError xpa
+ catch {set i 0; ProcessUpdateCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPARcvdURLFits {xpa cdata param buf len} {
+ XPADebug "XPARcvdURLFits" $param
+ InitError xpa
+ catch {set i 0; ProcessURLFitsCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendVersion {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendVersionCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPASendView {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendViewCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdView {xpa cdata param buf len} {
+ XPADebug "XPARcvdView" $param
+ InitError xpa
+ catch {set i 0; ProcessViewCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendVLA {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendVLACmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdVLA {xpa cdata param buf len} {
+ XPADebug "XPARcvdVLA" $param
+ InitError xpa
+ catch {set i 0; ProcessVLACmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendVLSS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendVLSSCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdVLSS {xpa cdata param buf len} {
+ XPADebug "XPARcvdVLSS" $param
+ InitError xpa
+ catch {set i 0; ProcessVLSSCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendVO {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendVOCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdVO {xpa cdata param buf len} {
+ XPADebug "XPARcvdVO" $param
+ InitError xpa
+ catch {set i 0; ProcessVOCmd param i}
+ # someone is setting the error state
+ InitError xpa
+}
+
+proc XPASendWCS {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendWCSCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdWCS {xpa cdata param buf len} {
+ XPADebug "XPARcvdWCS" $param
+ InitError xpa
+ catch {set i 0; ProcessWCSCmd param i [xparec $xpa datafd] {}}
+ XPACatchError $xpa
+}
+
+proc XPASendWeb {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendWebCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdWeb {xpa cdata param buf len} {
+ XPADebug "XPARcvdWeb" $param
+ InitError xpa
+ catch {set i 0; ProcessWebCmd param i}
+ # someone is setting an error state
+ InitError xpa
+}
+
+proc XPASendWidth {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendWidthCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdWidth {xpa cdata param buf len} {
+ XPADebug "XPARcvdWidth" $param
+ InitError xpa
+ catch {set i 0; ProcessWidthCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendXPA {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendXPACmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdXPA {xpa cdata param buf len} {
+ XPADebug "XPARcvdXPA" $param
+ InitError xpa
+ catch {set i 0; ProcessXPACmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendZoom {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendZoomCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdZoom {xpa cdata param buf len} {
+ XPADebug "XPARcvdZoom" $param
+ InitError xpa
+ catch {set i 0; ProcessZoomCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPASendZScale {xpa cdata param} {
+ InitError xpa
+ catch {ProcessSendZScaleCmd xpasetbuf $xpa $param}
+ XPACatchError $xpa
+}
+
+proc XPARcvdZScale {xpa cdata param buf len} {
+ XPADebug "XPARcvdZScale" $param
+ InitError xpa
+ catch {set i 0; ProcessZScaleCmd param i}
+ XPACatchError $xpa
+}
+
+proc XPAConnect {} {
+ global xpa
+
+ if {[info exists xpa]} {
+ catch {xpafree $xpa}
+ unset xpa
+ }
+ InitXPA
+
+ UpdateFileMenu
+}
+
+proc XPADisconnect {} {
+ global xpa
+
+ if {[info exists xpa]} {
+ if {[catch {xpafree $xpa} result]} {
+ Error "$result"
+ }
+ unset xpa
+ } else {
+ Error "[msgcat::mc {XPA not initialized}]"
+ }
+
+ UpdateFileMenu
+}
+
+proc XPAInfo {} {
+ global xpa
+
+ if {[info exists xpa]} {
+ SimpleTextDialog xpatxt "[msgcat::mc {XPA Information}]" \
+ 80 20 append bottom "[XPAInfoResult]"
+ } else {
+ Error "[msgcat::mc {XPA not initialized}]"
+ }
+}
+
+proc XPAInfoResult {} {
+ global xpa
+
+ set rr {}
+ if {[info exists xpa]} {
+ append rr "[format "XPA_VERSION:\t%s" [xparec $xpa version]]\n"
+ append rr "[format "XPA_CLASS:\t%s" [xparec $xpa class]]\n"
+ append rr "[format "XPA_NAME:\t%s" [xparec $xpa name]]\n"
+ append rr "[format "XPA_METHOD:\t%s" [xparec $xpa method]]\n"
+ }
+
+ return $rr
+}
+
+# unwind xpa errors
+# requires catch {} to allow a check to take place
+proc XPADebug {which param} {
+ global debug
+
+ if {$debug(tcl,xpa)} {
+ puts stderr "$which $param"
+ }
+}
+
+proc XPACatchError {xpa} {
+ global ds9
+ global icursor
+
+ global errorInfo
+ if {$errorInfo != {} || $ds9(msg) != {}} {
+ if {$ds9(msg) != {}} {
+ xpaerror $xpa $ds9(msg)
+ } else {
+ xpaerror $xpa [lindex [split $errorInfo "\n"] 0]
+ }
+ InitError xpa
+ }
+}
+
+proc XPAMethod {} {
+ global xpa
+
+ if {[info exists xpa]} {
+ return [xparec $xpa method]
+ } else {
+ return {}
+ }
+}
+
+proc XPAIsLocal {} {
+ global xpa
+ global env
+
+ if {[info exists env(XPA_METHOD)]} {
+ switch $env(XPA_METHOD) {
+ unix -
+ local {return 1}
+ }
+ }
+ return 0;
+}
+
+# Process Cmds
+
+proc ProcessXPAFirstCmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ global pds9
+ global env
+
+ switch -- [string tolower [lindex $var $i]] {
+ unix -
+ inet -
+ local -
+ localhost {set env(XPA_METHOD) [lindex $var $i]}
+ noxpans {set env(XPA_NSREGISTER) false}
+
+ yes -
+ true -
+ on -
+ 1 -
+ no -
+ false -
+ off -
+ 0 {set pds9(xpa) [FromYesNo [lindex $var $i]]}
+ }
+}
+
+proc ProcessXPACmd {varname iname} {
+ upvar $varname var
+ upvar $iname i
+
+ global ds9
+ global pds9
+
+ switch -- [string tolower [lindex $var $i]] {
+ tcl {
+ # backward compatibility
+ incr i
+ }
+
+ connect {XPAConnect}
+ disconnect {XPADisconnect}
+ info {XPAInfo}
+ }
+}
+
+proc ProcessSendXPACmd {proc id param} {
+ switch -- [string tolower [lindex $param 0]] {
+ info {$proc $id [XPAInfoResult]}
+ }
+}