diff options
Diffstat (limited to 'ds9/library/fits.tcl')
-rw-r--r-- | ds9/library/fits.tcl | 408 |
1 files changed, 408 insertions, 0 deletions
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 +} + |