\n"
- append result "| User | " [SplitReply [user]] " |
|---|
\n"
- append result "| Title | "
- append result [SplitReply [title]] " |
|---|
\n"
- append result "| Status | "
- append result [SplitReply [status]] " |
|---|
\n"
- append result "| Mode | "
- if {$mode == 1} {
- append result "time-of-flight"
- } else {
- append result "scan mode"
- }
- append result " |
|---|
\n"
- append result "
\n"
-}
-#-------------------------------------------------------------------------
-proc wwwgetaxis {} {
- global mode
- if {$mode == 1} {
- return time-of-flight
- } else {
- set res [scan info]
- set l [split $res ,]
- return [lindex $l 2]
- }
-}
-
-
diff --git a/ati.tcl b/ati.tcl
deleted file mode 100644
index e274d886..00000000
--- a/ati.tcl
+++ /dev/null
@@ -1,7 +0,0 @@
-drive mom 3.
-scan var a2t 0. .2
-scan var som 0. .1
-scan preset 1
-scan mode timer
-scan np 20
-scan run
diff --git a/autofile.tcl b/autofile.tcl
deleted file mode 100644
index 608adaa6..00000000
--- a/autofile.tcl
+++ /dev/null
@@ -1,211 +0,0 @@
-#----------------------------------------------------------------------------
-# This is part of the WWW-interface to SICS. This interface allows to
-# create batch files to be run automatically by SICS. These files are
-# stored in a special directory as files with the ending .sip by the
-# CGI-scripts or servlets creating them. Now, a system is needed which
-# checks this directory regularly for new files and executes them in SICS.
-# This is the purpose of the SICS-Tcl macros defined in this file.
-#
-# First edition: Mark Koennecke, December 1999
-#----------------------------------------------------------------------------
-
-#----------- !!!! the path where the automatic files reside
-set autofpath "/data/koenneck/tmp/auto"
-
-#------- a variable which defines if we should operate and the current file.
-set __autofile_run 0
-set __auto_exe_file ""
-
-#!!!!!!!!!!!!!! WARNING !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-# There is a name command between the Tcl internal scan command and the
-# SICS scan command. The Tcl internal has to be renamed. The following
-# variable defines the name of the Tcl scan command
-set tclscan stscan
-
-#---------- do initializing things when called first time
-set ret [catch [catch {autofile} msg]
-if {$ret != 0} {
- VarMake autofilepath Text Mugger
- autofilepath $autofpath
- autofilepath lock
- Publish autofileexecute User
- Publish autofile Mugger
- Publish autostart User
- Publish autoadd User
- Publish autoend User
-#------- for automatic file name creation
- catch {MakeDataNumber autonumber $autofpath/autonumber.dat}
-#------- check any 30 seconds
- sicscron 30 autofileexecute
-}
-
-#--------------------------------------------------------------------------
-proc autofile { {action null} } {
- upvar #0 __autofile_run ar
-
- if { [string compare $action start] == 0} {
- set ar 1
- return OK
- } elseif { [string compare $action stop] == 0 } {
- set ar 0
- return OK
- } else {
- if {$ar == 1} {
- return on
- } else {
- return off
- }
- }
-}
-
-#--------------------------------------------------------------------------
-proc autofileexecute { } {
- upvar #0 __autofile_run ar
- upvar #0 __auto_exe_file aef
- upvar #0 tclscan filescan
-#--------- no operation if not activated
- if {$ar != 1} {
- return
- }
-#--------- aquire a list of candidate batch files
- set tmp [autofilepath]
- set ltmp [split $tmp =]
- set tmp [lindex $ltmp 1]
- set tmp2 [string trim $tmp]/*.inp
- set ret [catch {set filelist [glob $tmp2]} msg]
- if {$ret != 0} {
- return "Nothing to do"
- }
- if { [llength $filelist] < 1 } {
- return "Nothing to do"
- }
-#--------- now, in each file the second line contains the order number,
-# find the lowest one which is the next one to execute
- set minnum 999999
- set file2exe null
- foreach fil $filelist {
- set f [open $fil r]
- gets $f
- set numline [gets $f]
- set ret [catch {$filescan $numline "# %d" numi} msg]
- close $f
- if { $ret == 0 } {
- if { $numi < $minnum } {
- set minnum $numi
- set file2exe $fil
- }
- } else {
- ClientPut $msg
- }
- }
-#------------ having found an input file, execute it
- if { [string compare $file2exe null] != 0 } {
- set aef $file2exe
- set ret [catch {interneval $file2exe} msg]
-#------ after execution rename it with a different extension
- set fil2 [file rootname $file2exe].old
- file rename -force $file2exe $fil2
- if {$ret != 0 } {
- error $msg
- } else {
- return $msg
- }
- }
- return "Invalid autobatch files"
-}
-
-#=========================================================================
-# File management functions
-#
-# autostart creates a fresh file. The data is stored in a SICS runbuffer.
-# autoadd adds a line to the runbuffer
-# autoend writes the file to disk then.
-#=========================================================================
-
-proc autostart {} {
- catch {buf del autobuffer}
- Buf new autobuffer
-}
-
-proc autoadd args {
- autobuffer append $args
-}
-
-proc autoend {} {
- upvar #0 autofpath ap
- autonumber incr
- set txt [autonumber]
- set l [split $txt =]
- set txt [string trim [lindex $l 1]]
- set fil [format "$ap/auto%7.7d.inp" $txt]
- set filnum [format "# %d" $txt]
- autobuffer ins 1 $filnum
- autobuffer save $fil
- Buf del autobuffer
-}
-
-#============================================================================
-# file list management
-#============================================================================
-
-proc buildsortedlist {filar} {
- upvar #0 autofpath ap
- upvar $filar list
- set i 0
-#----------- build arrays of all relevant files
- set ret [catch {set l1 [glob $ap/*.inp]}]
- if { $ret == 0 } {
- foreach fil $l1 {
- set list($i)
- incr i
- set f [open $fil r]
- set $fil(title) [gets $f]
- set txt [gets $f]
- close $f
- set ret [catch {$filescan $txt "# %d" numi} msg]
- if { $ret == 0} {
- set fil(no) $numi
- }else {
- set fil(no) -10
- }
- }
- }
- set ret [catch {set l1 [glob $ap/*.old]}]
- if { $ret == 0 } {
- foreach fil $l1 {
- set list($i)
- incr i
- set f [open $fil r]
- set $fil(title) [gets $f]
- set txt [gets $f]
- close $f
- set ret [catch {$filescan $txt "# %d" numi} msg]
- if { $ret == 0} {
- set fil(no) $numi
- }else {
- set fil(no) -10
- }
- }
- }
- set nfil i
-#--------- now selection sort this list
- for {set i 0} { i < $nfil} {incr i} {
- set min $i
- set ff $list($min)
- for {set j [expr $i + 1]} {$j < $nfil} {incr j} {
- set ff $list($j)
- set fff $list($min)
- if { $ff(no) < $fff(no)} {
- set min $j
- }
- }
- set t $list($min)
- set list($min) $list($min)
- set list($i) $t
- }
-}
-
-proc autolist {} {
-
-}
-
diff --git a/backup.tcl b/backup.tcl
deleted file mode 100644
index b5dc3e50..00000000
--- a/backup.tcl
+++ /dev/null
@@ -1,137 +0,0 @@
-# RuenBuffer Renate
-Buf new Renate
-Renate append Alle Fische sind schon da
-
-Renate append Alle Nixen auch
-
-Renate append Nur die dummen Neutronen kommen nicht
-
-Renate append Und die Schluempfe kriegen es auch nicht gebacken
-
-# RuenBuffer Kunigunde
-Buf new Kunigunde
-Kunigunde append Alle Fische sind schon da
-
-Kunigunde append Alle Nixen auch
-
-Kunigunde append Nur die dummen Neutronen kommen nicht
-
-Kunigunde append Und die Schluempfe kriegen es auch nicht gebacken
-
-# RuenBuffer Walter
-Buf new Walter
-Walter append Alle Fische sind schon da
-
-Walter append Alle Nixen auch
-
-Walter append Nur die dummen Neutronen kommen nicht
-
-Walter append Und die Schluempfe kriegen es auch nicht gebacken
-
-# RuenBuffer Willi
-Buf new Willi
-Willi append Alle Nixen auch
-Willi append Und die Schluempfe kriegen es auch nicht gebacken
-# RuenBuffer Heinz
-Buf new Heinz
-Heinz append GGG Fische sind schon da
-Heinz append GGG Nixen auch
-Heinz append Nur die dummen Neutronen kommen schon
-Heinz append Und die Schluempfe kriegen es auch schon gebacken
-
-Curve SoftLowerLim 0.000000
-Curve SoftUpperLim 1000.000000
-Curve SoftZero 0.000000
-Curve Fixed -1.000000
-Curve InterruptMode 0.000000
-Curve AccessCode 2.000000
-TwoTheta SoftLowerLim -140.000000
-TwoTheta SoftUpperLim 140.000000
-TwoTheta SoftZero 0.000000
-TwoTheta Fixed -1.000000
-TwoTheta InterruptMode 0.000000
-TwoTheta AccessCode 2.000000
-Theta SoftLowerLim -70.000000
-Theta SoftUpperLim 70.000000
-Theta SoftZero 0.000000
-Theta Fixed -1.000000
-Theta InterruptMode 0.000000
-Theta AccessCode 2.000000
-bsy SoftLowerLim -50.000000
-bsy SoftUpperLim 50.000000
-bsy SoftZero 0.000000
-bsy Fixed -1.000000
-bsy InterruptMode 0.000000
-bsy AccessCode 2.000000
-bsx SoftLowerLim -50.000000
-bsx SoftUpperLim 50.000000
-bsx SoftZero 0.000000
-bsx Fixed -1.000000
-bsx InterruptMode 0.000000
-bsx AccessCode 2.000000
-dphi SoftLowerLim 0.000000
-dphi SoftUpperLim 360.000000
-dphi SoftZero 0.000000
-dphi Fixed -1.000000
-dphi InterruptMode 0.000000
-dphi AccessCode 2.000000
-dsy SoftLowerLim -50.000000
-dsy SoftUpperLim 50.000000
-dsy SoftZero 0.000000
-dsy Fixed -1.000000
-dsy InterruptMode 0.000000
-dsy AccessCode 2.000000
-dsd SoftLowerLim 0.000000
-dsd SoftUpperLim 18000.000000
-dsd SoftZero 0.000000
-dsd Fixed -1.000000
-dsd InterruptMode 0.000000
-dsd AccessCode 2.000000
-saz SoftLowerLim 0.000000
-saz SoftUpperLim 30.000000
-saz SoftZero 0.000000
-saz Fixed -1.000000
-saz InterruptMode 0.000000
-saz AccessCode 2.000000
-say SoftLowerLim -22.000000
-say SoftUpperLim 22.000000
-say SoftZero 0.000000
-say Fixed -1.000000
-say InterruptMode 0.000000
-say AccessCode 2.000000
-sax SoftLowerLim -30.000000
-sax SoftUpperLim 30.000000
-sax SoftZero 0.000000
-sax Fixed -1.000000
-sax InterruptMode 0.000000
-sax AccessCode 2.000000
-som SoftLowerLim -180.000000
-som SoftUpperLim 360.000000
-som SoftZero 0.000000
-som Fixed -1.000000
-som InterruptMode 0.000000
-som AccessCode 2.000000
-sphi SoftLowerLim -22.000000
-sphi SoftUpperLim 22.000000
-sphi SoftZero 0.000000
-sphi Fixed -1.000000
-sphi InterruptMode 0.000000
-sphi AccessCode 2.000000
-schi SoftLowerLim -22.000000
-schi SoftUpperLim 22.000000
-schi SoftZero 0.000000
-schi Fixed -1.000000
-schi InterruptMode 0.000000
-schi AccessCode 2.000000
-comment (null)
-comment setAccess 2
-environment (null)
-environment setAccess 2
-SubTitle (null)
-SubTitle setAccess 2
-User set
-User setAccess 2
-Title Alle meine Entchen sind schon da
-Title setAccess 2
-Instrument set
-Instrument setAccess 0
diff --git a/beam.tcl b/beam.tcl
deleted file mode 100644
index fc2baf2c..00000000
--- a/beam.tcl
+++ /dev/null
@@ -1,20 +0,0 @@
-#------------------------------------------------------------------------
-# install a SPS-Controller
-MakeSPS sps1 lnsp25.psi.ch 4000 7
-
-#----------------- the beam command
-proc beam {} {
-#---------- read the SPS
- set ret [catch {SPS1 adc 3} msg]
- if {$ret != 0} {
- ClientPut $msg
- ClientPut "ERROR: SPS reading failed"
- return
- }
-#--------- convert the data
- set l [split $msg "="]
- set raw [lindex $l 1]
- set val [expr $raw/13.96]
- return [format "beam = %f" $val]
-}
-Publish beam Spy
diff --git a/beamdt.tcl b/beamdt.tcl
deleted file mode 100644
index 3f30ba3a..00000000
--- a/beamdt.tcl
+++ /dev/null
@@ -1,20 +0,0 @@
-#------------------------------------------------------------------------
-# install a SPS-Controller
-MakeSPS sps1 lnsp23.psi.ch 4000 6
-
-#----------------- the beam command
-proc beam {} {
-#---------- read the SPS
- set ret [catch {SPS1 adc 7} msg]
- if {$ret != 0} {
- ClientPut $msg
- ClientPut "ERROR: SPS reading failed"
- return
- }
-#--------- convert the data
- set l [split $msg "="]
- set raw [lindex $l 1]
- set val [expr $raw/13.96]
- return [format "beam = %f" $val]
-}
-Publish beam Spy
diff --git a/coll.tcl b/coll.tcl
deleted file mode 100644
index bd6b53bc..00000000
--- a/coll.tcl
+++ /dev/null
@@ -1,229 +0,0 @@
-#----------------------------------------------------------------------------
-# This file implements the collimator commands for SANS. It requires an
-# SPS named sps2 within SICS.
-#
-# Mark Koennecke, March 1999
-#----------------------------------------------------------------------------
-proc coll args {
-#-------- set case
- if { [llength $args] > 0 ] } {
- set length [lindex $args 0]
- switch $length {
- 18 {
- set command "sps2 push 200 0"
- break
- }
- 15 {
- set command "sps2 push 200 1"
- break
- }
- 11 {
- set command "sps2 push 200 2"
- break
- }
- 8 {
- set command "sps2 push 200 3"
- break
- }
- 6 {
- set command "sps2 push 200 4"
- break
- }
- 4.5 {
- set command "sps2 push 200 5"
- break
- }
- 3 {
- set command "sps2 push 200 6"
- break
- }
- 2 {
- set command "sps2 push 200 7"
- break
- }
- 1.4 {
- set command "sps2 push 201 0"
- break
- }
- 1 {
- set command "sps2 push 201 1"
- break
- }
- default {
- append text \
- [format "ERROR: collimation length %s invalid\n" $length]
- append text "Possible length are: 18,15,11,8,6,4.5,3,2,1.4,1\n"
- append text \
- "Extraneous . or other characters will yield this error too\n"
- append text "SPS programming courtesy Enzo Manfrin\n"
- return $text
- }
-#------- command has been built, execute it!
- set ret [catch {$command} msg]
- if {$ret != 0} {
- error $msg
- }
- setstatus Driving
-#------- wait till finish, check for interrupts on the way
- set exe 1
- while {$exe} {
- set ret [catch {sps2 colli} msg]
- if {$ret != 0 } {
- setstatus Eager
- error $msg
- }
- set l [split $msg =]
- set cval [lindex $l 1]
- if { [expr $cval - $length] < 0.2 } {
- set exe 0
- }
- set rupt [getint]
- if {[string compare $rupt continue] != 0 } {
- setstatus Eager
- error "ERROR: driving collimator interrupted"
- }
- }
- setstatus Eager
- return OK
- } else {
-#-------- get case
- set ret [catch {sps2 colli} msg]
- if {$ret != 0} {
- error $msg
- }
- return $msg
- }
-}
-#--------------------------------------------------------------------------
-# Another procedure for handling the attenuator.
-#
-# Mark Koennecke, March 1999
-#--------------------------------------------------------------------------
-proc findatt { } {
-#----------- find the current attenuator
- set ret [catch {sps2 stat2 9 5} msg]
- if { $ret != 0 } {
- error $msg
- }
- set l [split $msg =]
- if { [lindex $l 1] == 1} {
- return 0
- }
- set ret [catch {sps2 stat2 9 6} msg]
- if { $ret != 0 } {
- error $msg
- }
- set l [split $msg =]
- if { [lindex $l 1] == 1} {
- return 1
- }
- set ret [catch {sps2 stat2 9 7} msg]
- if { $ret != 0 } {
- error $msg
- }
- set l [split $msg =]
- if { [lindex $l 1] == 1} {
- return 2
- }
- set ret [catch {sps2 stat2 10 0} msg]
- if { $ret != 0 } {
- error $msg
- }
- set l [split $msg =]
- if { [lindex $l 1] == 1} {
- return 3
- }
- set ret [catch {sps2 stat2 10 1} msg]
- if { $ret != 0 } {
- error $msg
- }
- set l [split $msg =]
- if { [lindex $l 1] == 1} {
- return 4
- }
- set ret [catch {sps2 stat2 10 2} msg]
- if { $ret != 0 } {
- error $msg
- }
- set l [split $msg =]
- if { [lindex $l 1] == 1} {
- return 5
- }
-}
-#--------------------------------------------------------------------------
-proc att args {
- if [ llength $args] > 0} {
-#------- set case
- set aat [lindex $args 0]
- switch $aat {
- 0 {
- set command "sps2 push 210 7"
- break
- }
- 1 {
- set command "sps2 push 220 0"
- break
- }
- 2 {
- set command "sps2 push 220 1"
- break
- }
- 3 {
- set command "sps2 push 230 0"
- break
- }
- 4 {
- set command "sps2 push 230 1"
- break
- }
- 5 {
- set command "sps2 push 230 2"
- break
- }
- default {
- error [format "ERROR: attenuator %s unknown" $aat]
- }
- }
-#-----send command
- set ret [catch {$command} msg]
- if {$ret != 0} {
- error $msg
- }
-#------ wait till done
- setstatus Driving
- set exe 1
- while {$exe} {
- set ret [catch {findatt} msg]
- if {$ret != 0 } {
- setstatus Eager
- error $msg
- }
- if { [expr $msg - $aat] < 0.2 } {
- set exe 0
- }
- set rupt [getint]
- if {[string compare $rupt continue] != 0 } {
- setstatus Eager
- error "ERROR: driving attenuator interrupted"
- }
- }
- setstatus Eager
- return OK
- } else {
-#----------- get case
- set ret [catch {findatt} msg]
- if {$ret != 0 } {
- error $msg
- } else {
- return [format "att = %s" $msg]
- }
- }
-}
-
-
-
-
-
-
-
-
diff --git a/collidertest.tcl b/collidertest.tcl
deleted file mode 100644
index 8eaa0aec..00000000
--- a/collidertest.tcl
+++ /dev/null
@@ -1,79 +0,0 @@
-#--------------------------------------------------------------------------
-# test and example script for the anticollider
-#
-# Mark Koennecke, August 2002
-#------------------------------------------------------------------------
-
-proc testlimits tg {
- upvar $tg targets
- if { abs( $targets(om) - $targets(stt)) < 30 } {
- error "!!!!! two theta - omega CRASH!!!!!!!"
- }
- if {$targets(chi) > 190.} {
- error "chi upperlimit crashed"
- }
- if { $targets(om) > -90 && $targets(om) <= -81.5 && $targets(chi) < 152} {
- error "!!!!!! chi - omega CRASH aborted !!!!!"
- }
- if { $targets(om) > -81.5 && $targets(om) <= -55 && $targets(chi) < 137} {
- error "!!!!!! chi - omega CRASH aborted !!!!!"
- }
- if { $targets(om) > -55 && $targets(om) <= -52 && $targets(chi) < 132} {
- error "!!!!!! chi - omega CRASH aborted !!!!!"
- }
- if { $targets(om) > -52 && $targets(om) <= -30 && $targets(chi) < 75} {
- error "!!!!!! chi - omega CRASH aborted !!!!!"
- }
- return
-}
-#-------------------------------------------------------------------------
-proc chiFirst? tg {
- upvar $tg targets
- set om [SplitReply [om]]
- set chi [SplitReply [chi]]
- if {$chi < $targets(chi) } {
- return 1
- } else {
- return 0
- }
-}
-#---------------------------------------------------------------------------
-proc collidertest args {
-#----------- read command line targets
- set entries [expr [llength $args] / 2]
- for {set i 0} {$i < $entries} {incr i} {
- set ind [expr $i * 2]
- set targets([lindex $args $ind]) [lindex $args [expr $ind +1]]
- }
-#--------- check if all motors are there. If not get targets from
-# current position
- if { [info exists targets(om)] == 0} {
- set targets(om) [SplitReply [om]]
- }
- if { [info exists targets(stt)] == 0} {
- set targets(stt) [SplitReply [stt]]
- }
- if { [info exists targets(chi)] == 0} {
- set targets(chi) [SplitReply [chi]]
- }
- if { [info exists targets(phi)] == 0} {
- set targets(phi) [SplitReply [phi]]
- }
-#---------- proceed to real collision detection hydraulics
-# first: test complex limits
- set ret [catch {testlimits targets} msg]
- if {$ret != 0} {
- clientput [format "ERROR %s" $msg]
- error $msg
- }
- anticollision add 1 stt $targets(stt)
-
- if { [chiFirst? targets] == 1} {
- anticollision add 2 chi $targets(chi)
- anticollision add 3 om $targets(om)
- } else {
- anticollision add 2 om $targets(om)
- anticollision add 3 chi $targets(chi)
- }
- anticollision add 3 phi $targets(phi)
-}
diff --git a/cotop.tcl b/cotop.tcl
deleted file mode 100644
index 3ab9294a..00000000
--- a/cotop.tcl
+++ /dev/null
@@ -1,37 +0,0 @@
-#--------------------------------------------------------------------------
-# A MAD lookalike co command for TOPSI
-# All arguments are optional. The current values will be used if not
-# specified
-# Dr. Mark Koennecke, November 1999
-#--------------------------------------------------------------------------
-proc SplitReply { text } {
- set l [split $text =]
- return [lindex $l 1]
-}
-#--------------------------------------------------------------------------
-proc co { {mode NULL } { preset NULL } } {
- starttime [sicstime]
-#----- deal with mode
- set mode2 [string toupper $mode]
- set mode3 [string trim $mode2]
- set mc [string index $mode2 0]
- if { [string compare $mc T] == 0 } {
- counter setMode Timer
- } elseif { [string compare $mc M] == 0 } {
- counter setMode Monitor
- }
-#------ deal with preset
- if { [string compare $preset NULL] != 0 } {
- set pre $preset
- } else {
- set pre [SplitReply [counter getpreset]]
- }
-#------ count
- set ret [catch {counter count $pre} msg]
- if { $ret != 0 } {
- error [format "Counting ended with error: %s" $msg]
- } else {
- set cts [SplitReply [counter getcounts]]
- }
- return $cts
-}
diff --git a/countf.tcl b/countf.tcl
deleted file mode 100644
index a627ae0a..00000000
--- a/countf.tcl
+++ /dev/null
@@ -1,50 +0,0 @@
-#--------------------------------------------------------------------------
-# A count command for FOCUS
-# All arguments are optional. The current values will be used if not
-# specified
-# Dr. Mark Koennecke, Juli 1997
-#--------------------------------------------------------------------------
-proc SplitReply { text } {
- set l [split $text =]
- return [lindex $l 1]
-}
-#--------------------------------------------------------------------------
-proc count { {mode NULL } { preset NULL } } {
- starttime [sicstime]
-#----- deal with mode
- set mode2 [string toupper $mode]
- set mode3 [string trim $mode2]
- set mc [string index $mode2 0]
- if { [string compare $mc T] == 0 } {
- hm CountMode Timer
- } elseif { [string compare $mc M] == 0 } {
- hm CountMode Monitor
- }
-#------ deal with preset
- if { [string compare $preset NULL] != 0 } {
- hm preset $preset
- }
-#------ prepare a count message
- set a [hm preset]
- set aa [SplitReply $a]
- set b [hm CountMode]
- set bb [SplitReply $b]
- ClientPut [format " Starting counting in %s mode with a preset of %s" \
- $bb $aa]
-#------- count
-# hm InitVal 0
- wait 1
- set ret [catch {hm countblock} msg]
-#------- StoreData
- storefocus update
-# wait 5
- if { $ret != 0 } {
- error [format "Counting ended with error: %s" $msg]
- }
-}
-#---------------- Repeat -----------------------------------------------
-proc repeat { num {mode NULL} {preset NULL} } {
- for { set i 0 } { $i < $num } { incr i } {
- count $mode $preset
- }
-}
diff --git a/dmc.tcl b/dmc.tcl
deleted file mode 100644
index 84056e5c..00000000
--- a/dmc.tcl
+++ /dev/null
@@ -1,187 +0,0 @@
-# --------------------------------------------------------------------------
-# Initialization script for DMC at SINQ, SICS server.
-#
-# Dr. Mark Koennecke Juli 1997
-#---------------------------------------------------------------------------
-# O P T I O N S
-
-set auto_path "/home/DMC/bin"
-
-# first all the server options are set
-
-ServerOption ReadTimeOut 100
-# timeout when checking for commands. In the main loop SICS checks for
-# pending commands on each connection with the above timeout, has
-# PERFORMANCE impact!
-
-ServerOption AcceptTimeOut 100
-# timeout when checking for connection req.
-# Similar to above, but for connections
-
-ServerOption ReadUserPasswdTimeout 500000
-# time to wiat for a user/passwd to be sent from a client. Increase this
-# if there is a problem connecting to a server due to network overload\
-
-ServerOption LogFileBaseName "/home/DMC/log/dmclog"
-# the path and base name of the internal server logfile to which all
-# activity will be logged.
-
-ServerOption ServerPort 3006
-# the port number the server is going to listen at. The client MUST know
-# this number in order to connect. It is in client.ini
-
-ServerOption StatusFile /home/DMC/log/status.tcl
-
-ServerOption InterruptPort 3007
-# The UDP port where the server will wait for Interrupts from clients.
-# Obviously, clients wishing to interrupt need to know this number.
-
-# Telnet Options
-ServerOption TelnetPort 1301
-ServerOption TelWord sicslogin
-
-#The UDP port for sending quieck messages, telling the world of new data
-ServerOption QuieckPort 2108
-
-#the token system + the token force grab password
-TokenInit connan
-#---------------------------------------------------------------------------
-# U S E R S
-
-# than the SICS users are specified
-# Syntax: SicsUser name password userRightsCode
-SicsUser Manager Lucas 1
-SicsUser lnsmanager lnsSICSlns 1
-SicsUser User DMC 2
-SicsUser lnsuser 98lns2 2
-SicsUser Spy 007 3
-#--------------------------------------------------------------------------
-# D E V I C E S : M O T O R S
-
-#Motor a4 EL734 LNSP22 4000 5 6
-# EL734 motor with parameters: hostname PortNumber Channel MotorID
-
-# Motor nam SIM -20. 20. 5. 1.0
-# Simulated motor with name nam, lower limit -20, upper limit +20,
-# error ratio 5% and speed 1.0. Speed may be omitted
-
-# Monochromator motors
-ClientPut "Installing Motors"
-Motor OmegaM EL734 lnsp19.psi.ch 4000 2 1
-Motor TwoThetaM EL734 lnsp19.psi.ch 4000 2 2
-Motor MonoX EL734 lnsp19.psi.ch 4000 2 5
-Motor MonoY EL734 lnsp19.psi.ch 4000 2 6
-Motor CurveM EL734 lnsp19.psi.ch 4000 2 9
-Motor MonoPhi EL734 lnsp19.psi.ch 4000 2 7
-Motor MonoChi EL734 lnsp19.psi.ch 4000 2 8
-
-# sample Table
-Motor Table EL734 lnsp19.psi.ch 4000 2 3
-Motor TwoThetaD EL734 lnsp19.psi.ch 4000 2 4
-#--------------------------------------------------------------------------
-# Configure Detector
-# needs a EL737 or simualation for count control
-ClientPut "Installing counter"
-MakeCounter counter EL737 lnsp19.psi.ch 4000 4
-counter SetExponent 6
-
-MakeHM banana SINQHM
-banana configure HistMode Normal
-banana configure OverFlowMode Ceil
-banana configure Rank 1
-banana configure Length 400
-banana configure BinWidth 4
-banana preset 100.
-banana CountMode Timer
-banana configure HMComputer lnse01.psi.ch
-banana configure HMPort 2400
-banana configure Counter counter
-banana init
-banana exponent 6
-
-#--------------------------------------------------------------------------
-# V A R I A B L E S
-
-# now a few general variables are created
-# Syntax: VarMake name type access
-# type can be one of: Text, Int, Float
-#access can be one of: Internal, Mugger, User, Spy
-
-
-VarMake SicsDataPath Text Internal
-SicsDataPath "/home/DMC/data/"
-VarMake DetStepWidth Float Internal
-DetStepWidth 0.2
-DetStepWidth lock
-
-
-VarMake Instrument Text Internal
-Instrument "DMC"
-Instrument lock
-#initialisation
-
-VarMake Title Text User
-VarMake User Text User
-VarMake Collimation Text User
-VarMake Sample Text User
-Sample Kellerit
-VarMake comment1 Text User
-VarMake comment2 Text User
-VarMake comment3 Text User
-
-VarMake SicsDataPrefix Text Internal
-SicsDataPrefix dmc
-#--------- make data number
-MakeDataNumber SicsDataNumber /home/DMC/data/DataNumber
-
-VarMake SicsDataPostFix Text Internal
-SicsDataPostFix ".hdf"
-VarMake Adress Text User
-VarMake phone Text User
-VarMake fax Text User
-VarMake email Text User
-VarMake sample_mur Float User
-
-
-
-# Monochromator variables
-# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2
-MakeMono Mono "Ge-111" OmegaM TwoThetaM
-Mono DD 3.3537
-# Syntax MakeWaveLength name MonochromatorToUse
-MakeWaveLength lambda Mono
-
-
-#--------------------------------------------------------------------------
-# P R O C E D U R E S
-
-# create the drive command
-MakeDrive
-#start RuenBuffer system
-MakeRuenBuffer
-
-# aliases
-SicsAlias OmegaM A1
-SicsAlias TwoThetaM A2
-SicsAlias Table A3
-SicsAlias TwoThetaD A4
-SicsAlias MonoX A5
-SicsAlias MonoY A6
-SicsAlias MonoPhi A7
-SicsAlias MonoChi A8
-SicsAlias CurveM A9
-InitDMC
-
-#----- The Logbook stuff
-source "/home/DMC/bin/log.tcl"
-Publish LogBook Spy
-#------ The count command
-source "/home/DMC/bin/count.tcl"
-Publish count User
-Publish Repeat User
-#------ The scan command for Managers
-source "/home/DMC/bin/scan.tcl"
-Publish scan Mugger
-
-#---------install beam command
-source beamdt.tcl
diff --git a/dmca.tcl b/dmca.tcl
deleted file mode 100644
index c98fca3c..00000000
--- a/dmca.tcl
+++ /dev/null
@@ -1,174 +0,0 @@
-# --------------------------------------------------------------------------
-# Initialization script for DMC at SINQ, SICS server.
-#
-# Dr. Mark Koennecke March 1997
-#---------------------------------------------------------------------------
-# O P T I O N S
-
-set auto_path "/data/koenneck/src/sics/tcl"
-source $auto_path/dmccom.tcl
-
-
-# first all the server options are set
-
-ServerOption ReadTimeOut 100
-# timeout when checking for commands. In the main loop SICS checks for
-# pending commands on each connection with the above timeout, has
-# PERFORMANCE impact!
-
-ServerOption AcceptTimeOut 100
-# timeout when checking for connection req.
-# Similar to above, but for connections
-
-ServerOption ReadUserPasswdTimeout 500000
-# time to wiat for a user/passwd to be sent from a client. Increase this
-# if there is a problem connecting to a server due to network overload\
-
-ServerOption ServerLogBaseName /data/koenneck/src/sics/server
-# the path and base name of the internal server logfile to which all
-# activity will be logged.
-
-ServerOption ServerPort 2910
-# the port number the server is going to listen at. The client MUST know
-# this number in order to connect. It is in client.ini
-
-ServerOption InterruptPort 2913
-# The UDP port where the server will wait for Interrupts from clients.
-# Obviously, clients wishing to interrupt need to know this number.
-
-ServerOption DefaultCommandFile dmccom.tcl
-# The path to the file containing common Tcl-commands and procedures.
-# Every connection is initialized with this
-
-#---------------------------------------------------------------------------
-# U S E R S
-
-# than the SICS users are specified
-# Syntax: SicsUser name password userRightsCode
-SicsUser Mugger Diethelm 1
-SicsUser User Rosy 2
-SicsUser Spy 007 3
-
-
-#--------------------------------------------------------------------------
-# D E V I C E S : M O T O R S
-
-#Motor a4 EL734 LNSP22 4000 5 6
-# EL734 motor with parameters: hostname PortNumber Channel MotorID
-
-# Motor nam SIM -20. 20. 5. 1.0
-# Simulated motor with name nam, lower limit -20, upper limit +20,
-# error ratio 5% and speed 1.0. Speed may be omitted
-
-# Monochromator motors
-Motor OmegaM SIM 20. 120. 5. 2.0
-Motor TwoThetaM SIM 20. 120. 5. 0.5
-Motor MonoX SIM -20. 20. 5. 5.0
-Motor MonoY SIM -20. 20. 5. 5.0
-Motor CurveM SIM 0. 1000. 10. 5.0
-Motor MonoPhi SIM -20. 20. 5. 5.0
-Motor MonoChi SIM -20. 20. 5. 5.0
-
-# sample Table
-Motor Table SIM -180. 180. 5. 7.0
-Motor TwoThetaD SIM 10. 330. 5. 1.0
-#--------------------------------------------------------------------------
-# Configure Detector
-# needs a EL737 or simualation for count control
-MakeCounter xxxNo SIM
-
-#MakeHM banana SINQHM
-MakeHM banana SIM
-banana configure HistMode Normal
-banana configure OverFlowMode Ceil
-banana configure Rank 1
-banana configure Length 400
-banana configure BinWidth 4
-banana configure Time 10. 12. 14 16. 17.
-banana preset 100.
-banana CountMode Timer
-#banana configure HMComputer psds02.psi.ch
-#banana configure HMport 2400
-#banana configure Counter xxxNo
-banana init
-#--------------------------------------------------------------------------
-# C O N F I G U R E D E V I C E S T O H A L T I N
-# I N T E R R U P T
-AddHalt OmegaM TwoThetaM MonoX MonoY MonoChi MonoPhi CurveM Table TwoThetaD
-#--------------------------------------------------------------------------
-# V A R I A B L E S
-
-# now a few general variables are created
-# Syntax: VarMake name type access
-# type can be one of: Text, Int, Float
-#access can be one of: Internal, Mugger, User, Spy
-
-VarMake Instrument Text Internal
-Instrument "DMC at SINQ,PSI"
-#initialisation
-
-VarMake Title Text User
-VarMake User Text User
-VarMake Collimation Text User
-VarMake Sample Text User
-VarMake comment1 Text User
-VarMake comment2 Text User
-VarMake Comment3 Text User
-
-VarMake SicsDataPath Text Internal
-SicsDataPath "/data/koenneck/src/sics/"
-VarMake SicsDataPrefix Text Internal
-SicsDataPrefix DMC
-VarMake SicsDataNumber Int Internal
-SicsDataNumber 0
-VarMake SicsDataPostFix Text Internal
-SicsDataPostFix ".hdf"
-VarMake Adress Text User
-VarMake phone Text User
-VarMake fax Text User
-VarMake email Text User
-VarMake sample_mur Float User
-VarMake DetStepWidth Float Internal
-DetStepWidth 0.02
-
-
-
-# Monochromator variables
-# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2
-MakeMono Mono "Ge-111" OmegaM TwoThetaM CurveM
-# Syntax MakeWaveLength name MonochromatorToUse
-MakeWaveLength lambda Mono
-
-
-#--------------------------------------------------------------------------
-# P R O C E D U R E S
-
-# create the drive command
-MakeDrive
-#start RuenBuffer system
-MakeRuenBuffer
-
-if { 0 } {
-
-DMCInit 5 2.0 1
-# end -------- of ------------- file -------------------------------------
-# test code for powder diagrams, merging etc.
-
-set id1 [DMCShot set 1 2 2 2 2 2 2]
-set id2 [DMCShot set 2 3 3 3 3 3 3]
-set id3 [DMCShot set 6 1 1 1 1 1 1]
-set id4 [DMCShot set 7 5 5 5 5 5 5]
-set p1 [DMCPowder merge $id1 $id2 $id3 $id4]
-ClientPut [DMCPowder info $p1]
-ClientPut [DMCPowder list $p1 0 17]
-ClientPut [DMCPowder Start $p1]
-ClientPut [DMCPowder Step $p1]
-ClientPut [DMCPowder Stop $p1]
-DMCReset
-}
-# test of alias
-SicsAlias OmegaM A1
-SicsAlias TwoThetaM A2
-SicsAlias Table A3
-SicsAlias TwoThetaD A4
-InitDMC
diff --git a/dmccom.tcl b/dmccom.tcl
deleted file mode 100644
index 6d20d388..00000000
--- a/dmccom.tcl
+++ /dev/null
@@ -1,13 +0,0 @@
-#----------------------------------------------------------------------------
-# Common Tcl-command procedures for DMC
-# Mark Koennecke February 1997
-#--------------------------------------------------------------------------
-proc Milch { n } {
- for {set i 0 } { $i < $n } { incr i} {
- ClientPut "Milch ist gesund"
- }
-}
-
-proc Kaba { text } {
- return $text
-}
\ No newline at end of file
diff --git a/dmcscan.tcl b/dmcscan.tcl
deleted file mode 100644
index c879e0e0..00000000
--- a/dmcscan.tcl
+++ /dev/null
@@ -1,8 +0,0 @@
-#----------------------------------------------------------------------------
-# Common Tcl-command procedures for DMC
-# Mark Koennecke February 1997
-#--------------------------------------------------------------------------
-source "/data/koenneck/src/sics/obtcl.tcl
-# define DMC scan class
-class DMCScanClass
-
diff --git a/dmcsim.tcl b/dmcsim.tcl
deleted file mode 100755
index d692fd06..00000000
--- a/dmcsim.tcl
+++ /dev/null
@@ -1,167 +0,0 @@
-# --------------------------------------------------------------------------
-# Initialization script for DMC at SINQ, SICS server.
-#
-# Dr. Mark Koennecke Juli 1997
-#---------------------------------------------------------------------------
-# O P T I O N S
-
-set auto_path "/home/DMC/bin"
-
-# first all the server options are set
-
-ServerOption ReadTimeOut 100
-# timeout when checking for commands. In the main loop SICS checks for
-# pending commands on each connection with the above timeout, has
-# PERFORMANCE impact!
-
-ServerOption AcceptTimeOut 100
-# timeout when checking for connection req.
-# Similar to above, but for connections
-
-ServerOption ReadUserPasswdTimeout 500000
-# time to wiat for a user/passwd to be sent from a client. Increase this
-# if there is a problem connecting to a server due to network overload\
-
-ServerOption LogFileBaseName "/home/DMC/log/dmclog"
-# the path and base name of the internal server logfile to which all
-# activity will be logged.
-
-ServerOption ServerPort 3009
-# the port number the server is going to listen at. The client MUST know
-# this number in order to connect. It is in client.ini
-
-ServerOption StatusFile /home/DMC/log/simstatus.tcl
-
-ServerOption InterruptPort 3010
-# The UDP port where the server will wait for Interrupts from clients.
-# Obviously, clients wishing to interrupt need to know this number.
-
-#---------------------------------------------------------------------------
-# U S E R S
-
-# than the SICS users are specified
-# Syntax: SicsUser name password userRightsCode
-SicsUser Manager Lucas 1
-SicsUser User DMC 2
-SicsUser Spy 007 3
-#--------------------------------------------------------------------------
-# D E V I C E S : M O T O R S
-
-#Motor a4 EL734 LNSP22 4000 5 6
-# EL734 motor with parameters: hostname PortNumber Channel MotorID
-
-# Motor nam SIM -20. 20. 5. 1.0
-# Simulated motor with name nam, lower limit -20, upper limit +20,
-# error ratio 5% and speed 1.0. Speed may be omitted
-
-# Monochromator motors
-Motor OmegaM SIM 0 120 1 2.0
-Motor TwoThetaM SIM 30 100 1 1.0
-Motor MonoX SIM -30 30 1 3.0
-Motor MonoY SIM -30 30 1 3.0
-Motor CurveM SIM 0 20 1 3.0
-Motor MonoPhi SIM -30 30 1 3.0
-Motor MonoChi SIM -30 30 1 3.0
-
-# sample Table
-Motor Table SIM -180 360 1 2.
-Motor TwoThetaD SIM -10 120 1 1.
-#--------------------------------------------------------------------------
-# Configure Detector
-# needs a EL737 or simualation for count control
-MakeCounter counter SIM
-
-MakeHM banana SIM
-banana configure HistMode Normal
-banana configure OverFlowMode Ceil
-banana configure Rank 1
-banana configure Length 400
-banana configure BinWidth 4
-banana preset 100.
-banana CountMode Timer
-#banana configure HMComputer psds04.psi.ch
-#banana configure HMPort 2400
-#banana configure Counter counter
-banana init
-#--------------------------------------------------------------------------
-# C O N F I G U R E D E V I C E S T O H A L T I N
-# I N T E R R U P T
-AddHalt OmegaM TwoThetaM MonoX MonoY MonoChi MonoPhi CurveM Table TwoThetaD
-#--------------------------------------------------------------------------
-# V A R I A B L E S
-
-# now a few general variables are created
-# Syntax: VarMake name type access
-# type can be one of: Text, Int, Float
-#access can be one of: Internal, Mugger, User, Spy
-
-
-VarMake SicsDataPath Text Internal
-SicsDataPath "/home/DMC/sim/"
-VarMake DetStepWidth Float Internal
-DetStepWidth 0.02
-
-
-VarMake Instrument Text Internal
-Instrument "DMC at SINQ,PSI"
-#initialisation
-
-VarMake Title Text User
-VarMake User Text User
-VarMake Collimation Text User
-VarMake Sample Text User
-Sample Kellerit
-VarMake Temperature Float User
-Temperature 21.3897
-VarMake comment1 Text User
-VarMake comment2 Text User
-VarMake comment3 Text User
-
-VarMake SicsDataPrefix Text Internal
-SicsDataPrefix dmc
-VarMake SicsDataNumber Int Mugger
-SicsDataNumber 0
-VarMake SicsDataPostFix Text Internal
-SicsDataPostFix "97.hdf"
-VarMake Adress Text User
-VarMake phone Text User
-VarMake fax Text User
-VarMake email Text User
-VarMake sample_mur Float User
-
-
-
-# Monochromator variables
-# Syntax MakeMono name type OmegaMotor 2ThetaMotor CurveMotor1 CurveMotor2
-MakeMono Mono "Ge-111" OmegaM TwoThetaM
-Mono DD 3.3537
-# Syntax MakeWaveLength name MonochromatorToUse
-MakeWaveLength lambda Mono
-
-
-#--------------------------------------------------------------------------
-# P R O C E D U R E S
-
-# create the drive command
-MakeDrive
-#start RuenBuffer system
-MakeRuenBuffer
-
-# aliases
-SicsAlias OmegaM A1
-SicsAlias TwoThetaM A2
-SicsAlias Table A3
-SicsAlias TwoThetaD A4
-InitDMC
-
-#----- The Logbook stuff
-source "/home/DMC/bin/log.tcl"
-Publish LogBook User
-#------ The count command
-source "/home/DMC/bin/count.tcl"
-Publish count User
-Publish Repeat User
-#------ The scan command for Managers
-source "/home/DMC/bin/scan.tcl"
-Publish scan Mugger
-
diff --git a/fcircle.tcl b/fcircle.tcl
deleted file mode 100644
index 74c2da32..00000000
--- a/fcircle.tcl
+++ /dev/null
@@ -1,355 +0,0 @@
-#----------------------------------------------------------------------------
-# fcircle is a collection of SICS-Tcl macro scripts which help with
-# the running of a four circle diffractometer. The central idea is
-# a data base file which can be manipulated both from SICS and from
-# external programs. The name of this database file is expected to live in
-# the SICS variable dbfile.
-#
-# Mark Koennecke, November 1999
-#---------------------------------------------------------------------------
-
-
-#----------- fcircleinit
-# fcircleinit must be called from the SICS initialization script and will
-# then install all necessary variables and the commands defined by this
-# script into SICS.
-
-proc fcircleinit {} {
- VarMake dbfile Text User
- Publish writepos User
- Publish writerefl User
- Publish clearrefl User
- Publish listrefl User
- Publish updateub User
- Publish setlambda User
- Publish fcentre User
-}
-
-#------------fsplit
-# returns the answer part of a SICS reply of the form something = something
-proc fsplit {text} {
- set l [split $text =]
- set t [lindex $l 1]
- return [string trim $t]
-}
-
-#----------- locate
-# This is an internal routine and tries to locate a section in the database
-# file. The database file is plain ASCII. There are sections in the file
-# separated by lines starting with ####. The #### is followed by the title
-# name of the section. Then follow lines of section specific data in variable
-# syntax. Another complication is that we need to be able to update the data
-# in the file. In order to do that the whole file is first read into an array
-# before the search is started. This is feasible as we have at max a hundred
-# lines. The array receives a member nl which is the number of lines read.
-# The parameters are:
-# ar the array of lines.
-# fd a file descriptor as created by open
-# keyword the keyword to search for
-# The function returns the line number where the keyword was found on success,
-# else -1 is returned.
-
-#proc dbfile {} {
-# return "dbfile = test.db"
-#}
-
-proc locate { data keyword} {
- upvar $data ar
-#--------- read file
- set ret [catch {open [fsplit [dbfile]] r} fd]
- if {$ret == 1} {
- set ar(nl) 0
- return -1
- }
-#----- read whole file
- set i 0
- while {[gets $fd line] > 0 } {
- set ar($i) $line
- incr i
- }
- set ar(nl) $i
- close $fd
-#----- start search
- for {set i 0} {$i < $ar(nl)} { incr i} {
-#------ look for delimiter
- set delim [string range $ar($i) 0 3]
- if {[string compare $delim ####] == 0} {
-#----------- check keyword
- if {[string first $keyword $ar($i) ] > 0} {
- return $i
- }
- }
- }
- return -1;
-}
-#--------------- writerange
-# writerange writes a range of lines from an array created by locate
-# to the file specicified by fd. Ranges are automaticcaly adjusted to
-# data limits
-
-proc writerange { data fd start end } {
- upvar $data ar
-#----- adjust ranges
- if {$start < 0} {
- set start 0
- }
- if {$start > $ar(nl) } {
- set start $ar(nl)
- }
- if { $end > $ar(nl) } {
- set end $ar(nl)
- }
-#---- write!
- for {set i $start} {$i < $end} {incr i} {
- puts $fd $ar($i)
- }
-}
-
-#----------- writepos
-# writepos writes the current positions of stt, om, ch, ph motors as a A type
-# line into the reflection section of the data base file. This is used after
-# centering an unindexed reflection.
-
-proc writepos { } {
-#----- get positions
- set ret [catch {fsplit [stt]} mystt]
- if {$ret == 1} {
- error $myom
- }
- set ret [catch {fsplit [om]} myom]
- if {$ret == 1} {
- error $myom
- }
- set ret [catch {fsplit [ch]} mych]
- if {$ret == 1} {
- error $myom
- }
- set ret [catch {fsplit [ph]} myph]
- if {$ret == 1} {
- error $myom
- }
-#----- find position in file
- set ret [catch {locate data reflections} ind]
-#----- write
- set ret [catch {open [fsplit [dbfile]] w} fd]
- if { $ret == 1} {
- error $fd
- }
- if { $ind < 0 } {
- writerange data $fd 0 $data(nl)
- puts $fd "#### reflections"
- puts $fd [format "A %8.2f %8.2f %8.2f %8.2f" \
- $mystt $myom $mych $myph]
- } else {
- incr ind
- writerange data $fd 0 $ind
- puts $fd [format "A %8.2f %8.2f %8.2f %8.2f" \
- $mystt $myom $mych $myph]
- writerange data $fd $ind $data(nl)
- }
- close $fd
- return OK
-}
-
-#------------ writerefl
-# writerefl writes a reflection with indexes. This makes an I record in
-# the reflections list of the database file. This is meant to be used
-# after centering a reflection after the UB-matrix is known
-
-proc writerefl { } {
-#----- get positions
- set ret [catch {fsplit [stt]} mystt]
- if {$ret == 1} {
- error $myom
- }
- set ret [catch {fsplit [om]} myom]
- if {$ret == 1} {
- error $myom
- }
- set ret [catch {fsplit [ch]} mych]
- if {$ret == 1} {
- error $myom
- }
- set ret [catch {fsplit [ph]} myph]
- if {$ret == 1} {
- error $myom
- }
-#------ get hkl
- set ret [catch {hkl current} txt]
- if {$ret == 1} {
- error $txt
- }
- set l [split $txt]
- set H [lindex $txt 2]
- set K [lindex $txt 3]
- set L [lindex $txt 4]
-#----- find position in file
- set ret [catch {locate data reflections} ind]
-#----- write
- set ret [catch {open [fsplit [dbfile]] w} fd]
- if { $ret == 1} {
- error $fd
- }
- if { $ind < 0 } {
- writerange data $fd 0 $data(nl)
- puts $fd "#### reflections"
- puts $fd [format "I %5.2f %5.2f %5.2f %8.2f %8.2f %8.2f %8.2f" \
- $H $K $L $mystt $myom $mych $myph]
- } else {
- incr ind
- writerange data $fd 0 $ind
- puts $fd [format "I %5.2f %5.2f %5.2f %8.2f %8.2f %8.2f %8.2f" \
- $H $K $L $mystt $myom $mych $myph]
- writerange data $fd $ind $data(nl)
- }
- close $fd
- return OK
-}
-
-#----------- clearrefl
-# clearrefl clears the list of reflections as stored in the database file
-
-proc clearrefl {} {
-#----- find position in file
- set ret [catch {locate data reflections} ind]
-#---- nothing to do if no entry
- if {$ind < 0} {
- return "Nothing to do"
- }
-#----- write
- set ret [catch {open [fsplit [dbfile]] w} fd]
- if { $ret == 1} {
- error $fd
- }
- incr ind
- writerange data $fd 0 $ind
- for {set i $ind} {$i < $data(nl)} {incr i} {
- set delim [string range $data($i) 0 3]
- if {[string compare $delim ####] == 0} {
- break
- }
- }
- set ind [expr $ind + $i - 1]
- writerange data $fd $ind $data(nl)
- close $fd
- return OK
-}
-
-#-------- listrefl
-# listrefl lists all the entries in the reflection list
-
-proc listrefl {} {
-#----- find position in file
- set ret [catch {locate data reflections} ind]
-#---- nothing to do if no entry
- if {$ind < 0} {
- return "Nothing to do"
- }
-#------ list
- incr ind
- for {set i $ind} {$i < $data(nl)} {incr i} {
- set delim [string range $data($i) 0 3]
- if {[string compare $delim ####] == 0} {
- break
- } else {
- ClientPut $data($i)
- }
- }
- return OK
-}
-
-#---------- updateub
-# updateub reads a UB matrix from the file and replaces the current SICS
-# UB matrix with the one from the file. To be used after another program
-# created a UB matrix in the first place or after refining the UB matrix
-# following a centering operation.
-# WARNING: this requires that the Tcl internal scan command has been r
-# renamed BEFORE loading the scan command to stscan. Otherwise there is
-# as conflict with the scan routine!
-
-proc updateub {} {
-#----- find position in file
- set ret [catch {locate data UB} ind]
- if { $ind < 0} {
- error "ERROR: No UB matrix in database"
- }
- incr ind
-#------ read three lines of UB
- stscan $data($ind) "%f%f%f" ub11 ub12 ub13
- ClientPut $ub11 $ub12 $ub13
- incr ind
- stscan $data($ind) "%f%f%f" ub21 ub22 ub23
- incr ind
- stscan $data($ind) "%f%f%f" ub31 ub32 ub33
- hkl setub $ub11 $ub12 $ub13 $ub21 $ub22 $ub23 $ub31 $ub32 $ub33
- return OK
-}
-
-#--------- setlambda
-# setlambda sets the wavelength
-
-proc setlambda {newval} {
- set ret [catch {hkl lambda $newval} msg]
- if {$ret == 1} {
- error $msg
- }
-#----- find position in file
- set ret [catch {locate data lambda} ind]
-#----- write
- set ret [catch {open [fsplit [dbfile]] w} fd]
- if { $ret == 1} {
- error $fd
- }
- if { $ind < 0 } {
- writerange data $fd 0 $data(nl)
- puts $fd "#### lambda"
- puts $fd [format " %12.6f" $newval]
- } else {
- incr ind
- writerange data $fd 0 $ind
- puts $fd [format " %12.6f" $newval]
- incr ind
- writerange data $fd $ind $data(nl)
- }
- close $fd
- return OK
- }
-
-#------- fcentre
-# fcentre centers a reflection
-proc fcentre {} {
-#----- rough centering
- opti clear
- opti countmode monitor
- opti preset 1000
- opti threshold 30
- opti addvar om .1 25 .10
- opti addvar stt .20 25 .25
- opti addvar ch 1.0 20 1.
- set ret [catch {opti run} msg]
- if {$ret == 1} {
- error $msg
- }
-#----- fine centering
- opti preset 5000
- opti threshold 50
- set ret [catch {opti run} msg]
- if {$ret != 0 } {
- error $msg
- }
- set txt [om]
- set l [split $txt =]
- set tom [lindex $l 1]
- set txt [stt]
- set l [split $txt =]
- set tstt [lindex $l 1]
- set txt [ch]
- set l [split $txt =]
- set tch [lindex $l 1]
- set txt [ph]
- set l [split $txt =]
- set tph [lindex $l 1]
- ClientPut "Two-Theta Omega Chi Phi"
- ClientPut [format "%-10.2f%-10.2f%-10.2f%-10.2f" $tstt $tom $tch $tph]
- storepos
-}
\ No newline at end of file
diff --git a/fetest.tcl b/fetest.tcl
deleted file mode 100644
index 7eb15024..00000000
--- a/fetest.tcl
+++ /dev/null
@@ -1,4 +0,0 @@
- cscan a4 0. .2 10 2
-for {set i 0} { $i < 5} { incr i} {
-count timer 200
-}
diff --git a/ftest.tcl b/ftest.tcl
deleted file mode 100644
index a1001324..00000000
--- a/ftest.tcl
+++ /dev/null
@@ -1,178 +0,0 @@
-# --------------------------------------------------------------------------
-# Initialization script for a simulated FOCUS instrument
-#
-#
-# Dr. Mark Koennecke November 1998
-#---------------------------------------------------------------------------
-# O P T I O N S
-ServerOption ReadTimeOut 100
-# timeout when checking for commands. In the main loop SICS checks for
-# pending commands on each connection with the above timeout, has
-# PERFORMANCE impact!
-
-ServerOption AcceptTimeOut 100
-# timeout when checking for connection req.
-# Similar to above, but for connections
-
-ServerOption ReadUserPasswdTimeout 7000
-# time to wiat for a user/passwd to be sent from a client. Increase this
-# if there is a problem connecting to a server due to network overload\
-
-ServerOption LogFileDir /data/koenneck/src/sics/tmp
-#LogFileDir is the directory where the command log is going
-
-ServerOption LogFileBaseName /data/koenneck/src/sics/tmp/server
-# the path and base name of the internal server logfile to which all
-# activity will be logged.
-
-
-ServerOption ServerPort 2911
-# the port number the server is going to listen at. The client MUST know
-# this number in order to connect. It is in client.ini
-
-ServerOption InterruptPort 2914
-# The UDP port where the server will wait for Interrupts from clients.
-# Obviously, clients wishing to interrupt need to know this number.
-
-# Telnet options
-ServerOption TelnetPort 1301
-ServerOption TelWord sicslogin
-
-ServerOption DefaultTclDirectory /data/koenneck/src/sics/tcl
-
-#------ a port for broadcasting UDP messages
-#ServerOption QuieckPort 2108
-
-TokenInit connan
-
-#---------------------------------------------------------------------------
-# U S E R S
-
-# than the SICS users are specified
-# Syntax: SicsUser name password userRightsCode
-SicsUser Mugger Diethelm 1
-SicsUser User Rosy 2
-SicsUser Spy 007 1
-
-#--------------------------------------------------------------------------
-# S I M P L E V A R I A B L E S
-
-# now a few general variables are created
-# Syntax: VarMake name type access
-# type can be one of: Text, Int, Float
-#access can be one of: Internal, Mugger, user, Spy
-
-VarMake Instrument Text Internal
-Instrument "FOCUS" #initialisation
-Instrument lock
-
-VarMake Title Text User
-VarMake sample Text User
-sample "Altorferit"
-VarMake Temperature Float User
-Temperature 21.5
-Title "Hochdestillierter Schrott"
-VarMake User Text User
-User "Stefan & Felix & Lothar"
-
-#--------- FOCUS special variables
-VarMake BeStatus Int User
-BeStatus 0
-VarMake flightpath Text Mugger
-flightpath "Standard"
-VarMake flightpathlength Float Mugger
-flightpathlength 3000
-VarMake ferminame Text Mugger
-ferminame "Dornier Fermi Chopper"
-ferminame lock
-VarMake fermidist Float Mugger
-fermidist 3000
-VarMake detectordist Float Mugger
-detectordist 2500
-VarMake sampledist Float Mugger
-sampledist 499.7
-sampledist lock
-VarMake chopperrot Float User
-chopperrot 10000
-VarMake fermirot Float User
-fermirot 12000
-VarMake fermiphase Float User
-fermiphase 22.23
-VarMake environment Text User
-environment Void
-VarMake delay Float User
-delay 155.8
-VarMake sampleangle Float User
-sampleangle 0.0
-#--------------------------------------------------------------------------
-# D E V I C E S : M O T O R S
-
-# Motor a4 EL734 LNSP22 4000 5 6
-# EL734 motor with parameters: hostname PortNumber Channel MotorID
-#Motor D1V EL734 lnsp22.psi.ch 4000 3 3
-Motor A1 SIM 30.0 120. .1 2. # Monochromator Theta
-Motor A2 SIM 30. 120. .1 1. # Monochromator 2Theta
-Motor MTL SIM -30. 30. .1 3. # mono lower translation
-Motor MTU SIM -30. 30. .1 3. # mono upper translation
-Motor MGU SIM -50. 50. .1 3. # mono upper goniometer
-Motor MGL SIM -50. 50. .1 3. # mono lower goniometer
-
-ClientPut "Motors done"
-#--------------------------------------------------------------------------
-# C O U N T E R S
-MakeCounter counter SIM
-#MakeCounter counter EL737 lnsp19.psi.ch 4000 4
-
-#--------------------------------------------------------------------------
-# M U L T I D E V I C E V A R I A B L E S
-MakeMono Mono "Ge-111" A1 A2
-MakeWaveLength lambda Mono
-MakeEnergy qi Mono
-#--------------------------------------------------------------------------
-# P R O C E D U R E S
-
-MakeDrive
-MakeRuenBuffer
-#---------------- TestVariables for Storage
-VarMake SicsDataPath Text Mugger
-SicsDataPath "/data/koenneck/src/sics/"
-SicsDataPath lock
-VarMake SicsDataPrefix Text Mugger
-SicsDataPrefix test
-SicsDataPrefix lock
-VarMake SicsDataPostFix Text Mugger
-SicsDataPostFix ".hdf"
-SicsDataPostFix lock
-
-VarMake Adress Text User
-VarMake phone Text User
-VarMake fax Text User
-VarMake email Text User
-VarMake sample_mur Float User
-
-MakeDataNumber SicsDataNumber "/data/koenneck/src/sics/danu.dat"
-
-SerialInit
-Publish serialport User
-Publish p1 User
-Publish HakleGet User
-#------------------ Focus tests
-proc chopper {text } {
- ClientPut "chopper.speed = 17050"
- ClientPut "chopper.phase = 13.33"
-}
-Publish chopper Spy
-#--------- create a time array for histogramming
-MakeHM banana SIM
-banana configure HistMode TOF
-banana configure OverFlowMode Ceil
-banana configure Rank 1
-banana configure Length 76800
-banana configure BinWidth 4
-banana preset 100.
-banana CountMode Timer
-banana genbin 120. 35. 512
-banana init
-MakeFocusAverager average banana
-
-FocusInstall banana focus.dic
diff --git a/hakle.tcl b/hakle.tcl
deleted file mode 100644
index 54164e56..00000000
--- a/hakle.tcl
+++ /dev/null
@@ -1,273 +0,0 @@
-#----------------------------------------------------------------------------
-# H A K L E
-#
-# Driver for the Haake water bath thermostat in the SINQ setup. This driver
-# is realised in Tcl and uses the tclev interface for talking to SICS.
-#
-# copyright: see copyright.h
-#
-# Mark Koennecke, February 1998
-#----------------------------------------------------------------------------
-set HakleNUM 0
-
-proc HakleSend args {
- upvar #0 [lindex $args 0] ar
- set command [lrange $args 1 end]
- set ret [catch {$ar(socket) $command} msg]
- if {$ret != 0} {
- ClientPut $msg
- error -701
- }
- return $msg
-}
-#--------------------------------------------------------------------------
-# HakleCheck tests a answer from the Hake for validity. Valid answers
-# contain a $. Errors no $ and and F as first character.
-proc HakleCheck {text } {
- if { [string match *\$ $text]} {
- return 1
- }
- if { [string match F* $text] } {
- error -703
- }
-}
-#---------------------------------------------------------------------------
-proc HakleCommand args {
- upvar #0 [lindex $args 0] ar
- set ret [catch {eval HakleSend $args} msg]
- if {$ret != 0} {
- error $msg
- }
- set ret [catch {HakleCheck $msg} msg2]
- if {$ret != 0} {
- error $msg2
- }
- return $msg
-}
-#----------------------------------------------------------------------------
-proc HakleInit {Hakle} {
- upvar $Hakle ar
- global HakleNUM
-#------ open a connection
- set nam hakle$HakleNUM
- set ret [catch {serialport $nam $ar(computer) $ar(port) \
- $ar(channel) 1} msg]
- if {$ret != 0 } {
- ClientPut $msg
- error -700
- }
- set ar(socket) $nam
- incr HakleNUM
- set ar(intern) 1
- set ar(pending) 0
- set ar(lastread) 20.00
-#----- configure
- $nam -replyterm "1\r"
- $nam -tmo 1800
-#----- block local
- set ret [catch {HakleCommand $Hakle OUT MODE 3 0} msg ]
- if {$ret != 0 } {
- error -$msg
- }
- return 1
-}
-#---------------------------------------------------------------------------
-proc HakleClose {Hakle} {
- upvar #0 $Hakle ar
- set ret [catch {HakleCommand $Hakle OUT MODE 3 1} msg]
- if {$ret != 0} {
- ClientPut "Error resettting Haake Thermostat"
- }
- rename $ar(socket) ""
- return 1
-}
-#----------------------------------------------------------------------------
-proc HakleWrapper args {
- upvar #0 [lindex $args 0] ar
- if { [llength $args] < 2 } {
- error "Insufficient number of commands"
- }
- set key [lindex $args 1]
- switch -exact $key {
- sensor {
- if { [llength $args] > 2 } {
- set val [lindex $args 2]
-#------- switch to intern
- if { [string compare $val intern] == 0 } {
- set ret [catch {HakleCommand [lindex $args 0] OUT MODE 2 0} msg]
- if {$ret != 0 } {
- error $msg
- } else {
- set ar(intern) 1
- }
-#-------- switch to extern
- } elseif { [string compare $val extern] == 0 } {
- set ret [catch {HakleCommand [lindex $args 0] OUT MODE 2 1} msg]
- if {$ret != 0 } {
- error $msg
- } else {
- set ar(intern) 0
- }
- } else {
- error -705
- }
- } else {
- if { $ar(intern) == 1 } {
- ClientPut [format "%s.sensor intern" $ar(MyName)]
- return 1
- } else {
- ClientPut [format "%s.sensor extern" $ar(MyName)]
- return 1
- }
- }
- }
- list {
- if { $ar(intern) == 1 } {
- ClientPut [format "%s.sensor intern" $ar(MyName)]
- error -700
- } else {
- ClientPut [format "%s.sensor extern" $ar(MyName)]
- error -700
- }
-
- }
- default {
- error -700
- }
- }
-}
-#----------------------------------------------------------------------------
-proc HakleSet {Hakle val} {
- upvar #0 $Hakle ar
-# ClientPut "HakleSet"
- set ret [catch {$ar(socket) [format "OUT SP 1 %f" $val]} msg]
- if {$ret != 0} {
- ClientPut $msg
- error -701
- }
- set ret [catch {HakleCheck $msg} msg2]
- if {$ret != 0} {
- error $msg2
- }
- set ar(pending) 0
- return $msg
-}
-#----------------------------------------------------------------------------
-proc HakleGet {Hakle} {
- upvar #0 $Hakle ar
- if {$ar(intern) == 1} {
- set ret [catch {eval HakleCommand $Hakle IN PV 1} msg]
- if {$ret != 0 } {
- error $msg
- }
- } else {
- set ret [catch {HakleCommand IN PV 2} msg]
- if {$ret != 0 } {
- error $msg
- }
- }
- set ans [string trim $msg \$]
- set ans2 [string trim $ans]
- set ans3 [string trim $ans2 C]
-#------ fix some pecularities of the Haake, sometimes it gives empty
-# messages or double +
- if { [string length $ans3] < 3 } {
- return $ar(lastread)
- }
- if { [string first "++" $ans3] >= 0 } {
- set ans3 [string range $ans3 1 end]
- }
- set ar(lastread) $ans3
- return $ans3
-}
-#----------------------------------------------------------------------------
-proc HakleGet2 {Hakle} {
- upvar #0 $Hakle ar
-# ClientPut "HakleGet"
- if {$ar(pending) == 0} {
- if {$ar(intern) == 1} {
- set ret [catch {$ar(socket) -put IN PV 1} msg]
- if {$ret != 0 } {
- ClientPut $msg
- error -701
- }
- } else {
- set ret [catch {$ar(socket) -put IN PV 2} msg]
- if {$ret != 0 } {
- ClientPut $msg
- error -701
- }
- }
- set ar(pending) 1
- return $ar(lastread)
- } else {
- if {[$ar(socket) -readable] == 1 } {
- set ar(pending) 0
- set ret [catch {$ar(socket) -get} msg]
- if {$ret != 0 } {
- ClientPut $msg
- error -701
- }
- set ans [string trim $msg \$]
- set ans2 [string trim $ans]
- set ans3 [string trim $ans2 C]
- set ar(lastread) $ans3
- return $ans3
- } else {
- return $ar(lastread)
- }
- }
-}
-#-----------------------------------------------------------------------------
-proc HakleError {Hakle val} {
- upvar #0 $Hakle ar
- switch -exact -- $val {
- -700 {
- return "Cannot open socket"
- }
- -701 {
- return "Error sending command"
- }
- -703 {
- return "Invalid command sent"
- }
- default {
- return "Unknown error code"
- }
- }
-}
-#-----------------------------------------------------------------------------
-proc HakleFix {Hakle val} {
- upvar #0 $Hakle ar
- switch -exact -- $val {
- -700 {
- return DEVFAIL
- }
- -701 {
- return DEVREDO
- }
- -703 {
- return DEVREDO
- }
- default {
- return DEVFAIL
- }
- }
-}
-#----------------------------------------------------------------------------
-proc inihaakearray {ar comp port chan} {
- upvar #0 $ar Hakle
- set Hakle(Init) HakleInit
- set Hakle(Close) HakleClose
- set Hakle(Send) HakleSend
- set Hakle(SetValue) HakleSet
- set Hakle(GetValue) HakleGet
- set Hakle(GetError) HakleError
- set Hakle(TryFixIt) HakleFix
- set Hakle(Wrapper) HakleWrapper
- set Hakle(computer) $comp
- set Hakle(port) $port
- set Hakle(channel) $chan
- set Hakle(num) 0
- set Hakle(lastread) 20.00
-}
diff --git a/helium.tcl b/helium.tcl
deleted file mode 100644
index 0c2a8dc3..00000000
--- a/helium.tcl
+++ /dev/null
@@ -1,34 +0,0 @@
-#--------------------------------------------------------------------------
-# helium: a script for reading the helium level from an AMI-135 Helium Level
-# Monitor.
-#
-# Mark Koennecke, December 1999
-#-------------------------------------------------------------------------
-
-#--------- some code to do proper initialization if necessary
-set ret [catch {helium} msg]
-if {$ret != 0} {
- Publish heliumport Spy
- Publish helium Spy
- Publish heliuminit Mugger
-}
-
-#--------------- initialize things
-proc heliuminit {mac chan} {
- serialport heliumport $mac 4000 $chan
- heliumport -tmo 2000
- return OK
-}
-#--------------- real work
-proc helium {} {
- set ret [catch {heliumport cm} msg]
- if {$ret != 0} {
- error $msg
- }
- set ret [catch {heliumport level} msg]
- if {$ret != 0} {
- error $msg
- } else {
- return [format "helium = %6.2f cm" $msg]
- }
-}
diff --git a/inc.tcl b/inc.tcl
deleted file mode 100644
index 90c2b88f..00000000
--- a/inc.tcl
+++ /dev/null
@@ -1,22 +0,0 @@
-#---------------------------------------------------------------------------
-# This script reads a file specified on the command line line by line.
-# Each line is than enclosed with puts " line " . You obtain a tcl file
-# which prints the text in the file
-#
-# Mark Koennecke October 1996
-#--------------------------------------------------------------------------
-
-if {$argc < 1} {
- puts "Usage: tclsh inc.tcl file_to_Convert"
- exit
-}
-
-set file [lindex $argv 0]
-
-set f [open $file r ]
-
-while { ! [eof $f] } {
- gets $f line
- set line [string trimleft $line]
- puts [format "puts \" %s \" " $line]
-}
diff --git a/inidill.tcl b/inidill.tcl
deleted file mode 100644
index 3e887fce..00000000
--- a/inidill.tcl
+++ /dev/null
@@ -1,4 +0,0 @@
-#dillution initialisation
-evfactory new temp dillu lnsp19.psi.ch 4000 1 dilu.tem
-temp lowerlimit 0
-temp upperlimit 5.
diff --git a/itc4.tcl b/itc4.tcl
deleted file mode 100644
index 6d5718d1..00000000
--- a/itc4.tcl
+++ /dev/null
@@ -1,7 +0,0 @@
-evfactory new temp ITC4 lnsp19 4000 7
-temp lowerlimit 0
-temp upperlimit 300
-temp control 2
-temp sensor 3
-temp divisor 100
-temp multiplicator 10
diff --git a/nxsupport.tcl b/nxsupport.tcl
deleted file mode 100644
index 29157c01..00000000
--- a/nxsupport.tcl
+++ /dev/null
@@ -1,96 +0,0 @@
-#===========================================================================
-# Support routines for scripting NeXus files with nxscript.
-#
-# Mark Koennecke, February 2003
-# Mark Koennecke, January 2004
-#==========================================================================
-proc makeFileName args {
- sicsdatanumber incr
- set num [SplitReply [sicsdatanumber]]
- set p [string trim [SplitReply [sicsdatapath]]]
- set pre [string trim [SplitReply [sicsdataprefix]]]
- set po [string trim [SplitReply [sicsdatapostfix]]]
- return [format "%s%s%5.5d2003%s" $p $pre $num $po]
-}
-#==========================================================================
-# new version, attending to the new 1000 grouping logic
-proc newFileName args {
- set ret [catch {nxscript makefilename} msg]
- if {$ret != 0} {
- clientput "ERROR: Misconfiguration of file writing variables"
- clientput "Defaulting filename to emergency.hdf"
- set fil emergency.hdf
- } else {
- set fil $msg
- }
- return $fil
-}
-#==========================================================================
-proc writeFloatVar {alias var} {
- set ret [catch {set val [SplitReply [$var]]} val]
- if { $ret != 0} {
- clientput [format "ERROR: failed to read %s, %s" $var $val]
- return
- } else {
- set val [string trim $val]
- set ret [catch {expr $val * 1.0} val]
- if { $ret == 0} {
- nxscript putfloat $alias [expr $val * 1.0 ]
- } else {
- clientput "ERROR: bad value $val when reading $var"
- }
- }
-}
-#==========================================================================
-proc writeIntVar {alias var} {
- set ret [catch {set val [SplitReply [$var]]} val]
- if { $ret != 0} {
- clientput [format "ERROR: failed to read %s, %s" $var $val]
- return
- } else {
- set val [string trim $val]
- set ret [catch {expr $val * 1.0} val]
- if { $ret == 0} {
- nxscript putint $alias [expr int($val * 1.0) ]
- } else {
- clientput "ERROR: bad value $val when reading $var"
- }
- }
-}
-#=========================================================================
-proc writeTextVar {alias var} {
- set ret [catch {$var} val]
- if { $ret != 0} {
- clientput [format "ERROR: failed to read %s" $var]
- return
- } else {
- set index [string first = $val]
- if {$index >= 0} {
- set txt [string trim [string range $val [expr $index + 1] end]]
- nxscript puttext $alias $txt
- } else {
- clientput [format "ERROR: failed to read %s" $var]
- }
- }
-}
-#========================================================================
-proc writeTextAttribute {attName var} {
- set ret [catch {set val [SplitReply [$var]]} val]
- if { $ret != 0} {
- clientput [format "ERROR: failed to read %s" $var]
- return
- } else {
- nxscript putglobal $attName [string trim $val]
- }
-}
-#=======================================================================
-proc writeStandardAttributes {fileName} {
- nxscript putglobal file_name $fileName
- nxscript putglobal file_time [sicstime]
- writeTextAttribute instrument instrument
- writeTextAttribute owner user
- writeTextAttribute owner_telephone_number phone
- writeTextAttribute owner_fax_number fax
- writeTextAttribute owner_email email
- writeTextAttribute owner_address adress
-}
diff --git a/object.tcl b/object.tcl
deleted file mode 100755
index e0e73b14..00000000
--- a/object.tcl
+++ /dev/null
@@ -1,305 +0,0 @@
-#
-# $Id: object.tcl,v 1.1 2000/02/25 16:21:41 cvs Exp $
-#
-# This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory.
-#
-# Redistribution and use in source and binary forms, with or without
-# modification, are permitted provided that: (1) source code distributions
-# retain the above copyright notice and this paragraph in its entirety, (2)
-# distributions including binary code include the above copyright notice and
-# this paragraph in its entirety in the documentation or other materials
-# provided with the distribution, and (3) all advertising materials mentioning
-# features or use of this software display the following acknowledgement:
-# ``This product includes software developed by the University of California,
-# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
-# the University nor the names of its contributors may be used to endorse
-# or promote products derived from this software without specific prior
-# written permission.
-#
-# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
-# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
-# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-#
-
-set object_priv(currentClass) {}
-set object_priv(objectCounter) 0
-
-#----------------------------------------------------------------------
-proc object_class {name spec} {
- global object_priv
- set object_priv(currentClass) $name
- lappend object_priv(objects) $name
- upvar #0 ${name}_priv class
- set class(__members) {}
- set class(__methods) {}
- set class(__params) {}
- set class(__class_vars) {}
- set class(__class_methods) {}
- uplevel $spec
- proc $name:config args "uplevel \[concat object_config \$args]"
- proc $name:configure args "uplevel \[concat object_config \$args]"
- proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
-}
-#---------------------------------------------------------------------
-proc method {name args body} {
- global object_priv
- set className $object_priv(currentClass)
- upvar #0 ${className}_priv class
- if {[lsearch $class(__methods) $name] < 0} {
- lappend class(__methods) $name
- }
- set methodArgs self
- append methodArgs " " $args
- proc $className:$name $methodArgs "upvar #0 \$self slot ${className}_priv class_var\n$body"
-}
-#------------------------------------------------------------------
-proc object_method {name {defaultValue {}}} [info body method]
-#------------------------------------------------------------------
-proc member {name {defaultValue {}}} {
- global object_priv
- set className $object_priv(currentClass)
- upvar #0 ${className}_priv class
- lappend class(__members) [list $name $defaultValue]
-}
-#----------------------------------------------------------------------
-proc object_member {name {defaultValue {}}} [info body member]
-#---------------------------------------------------------------------
-proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
- global object_priv
- set className $object_priv(currentClass)
- upvar #0 ${className}_priv class
- if {$resourceClass == ""} {
- set resourceClass \
- [string toupper [string index $name 0]][string range $name 1 end]
- }
- if ![info exists class(__param_info/$name)] {
- lappend class(__params) $name
- }
- set class(__param_info/$name) [list $defaultValue $resourceClass]
- if {$configCode != {}} {
- proc $className:config:$name self $configCode
- }
-}
-#-------------------------------------------------------------------------
-proc object_param {name {defaultValue {}} {resourceClass {}} {configCode {}}} \
- [info body param]
-
-#--------------------------------------------------------------------------
-proc object_class_var {name {initialValue ""}} {
- global object_priv
- set className $object_priv(currentClass)
- upvar #0 ${className}_priv class
- set class($name) $initialValue
- set class(__initial_value.$name) $initialValue
- lappend class(__class_vars) $name
-}
-#---------------------------------------------------------------------------
-proc object_class_method {name args body} {
- global object_priv
- set className $object_priv(currentClass)
- upvar #0 ${className}_priv class
- if {[lsearch $class(__class_methods) $name] < 0} {
- lappend class(__class_methods) $name
- }
- proc $className:$name $args "upvar #0 ${className}_priv class_var\n$body"
-}
-#---------------------------------------------------------------------------
-proc object_include {super_class_name} {
- global object_priv
- set className $object_priv(currentClass)
- upvar #0 ${className}_priv class
- upvar #0 ${super_class_name}_priv super_class
- foreach p $super_class(__params) {
- lappend class(__params) $p
- set class(__param_info/$p) $super_class(__param_info/$p)
- }
- set class(__members) [concat $super_class(__members) $class(__members)]
- set class(__class_vars) \
- [concat $super_class(__class_vars) $class(__class_vars)]
- foreach v $super_class(__class_vars) {
- set class($v) \
- [set class(__initial_value.$v) $super_class(__initial_value.$v)]
- }
- set class(__class_methods) \
- [concat $super_class(__class_methods) $class(__class_methods)]
- set class(__methods) \
- [concat $super_class(__methods) $class(__methods)]
- foreach m $super_class(__methods) {
- set proc $super_class_name:$m
- proc $className:$m [object_get_formals $proc] [info body $proc]
- }
- foreach m $super_class(__class_methods) {
- set proc $super_class_name:$m
- regexp "^\[^\n\]+\n(.*)" [info body $proc] dummy body
- proc $className:$m [object_get_formals $proc] \
- "upvar #0 ${className}_priv class_var\n$body"
- }
-}
-#---------------------------------------------------------------------------
-proc object_new {className {name {}}} {
- if {$name == {}} {
- global object_priv
- set name O_[incr object_priv(objectCounter)]
- }
- upvar #0 $name object
- upvar #0 ${className}_priv class
- set object(__class) $className
- foreach var $class(__params) {
- set info $class(__param_info/$var)
- set resourceClass [lindex $info 1]
- if ![catch {set val [option get $name $var $resourceClass]}] {
- if {$val == ""} {
- set val [lindex $info 0]
- }
- } else {
- set val [lindex $info 0]
- }
- set object($var) $val
- }
- foreach var $class(__members) {
- set object([lindex $var 0]) [lindex $var 1]
- }
- proc $name {method args} [format {
- upvar #0 %s object
- uplevel [concat $object(__class):$method %s $args]
- } $name $name]
- return $name
-}
-#---------------------------------------------------------------
-proc object_define_creator {windowType name spec} {
- object_class $name $spec
- if {[info procs $name:create] == {}} {
- error "widget \"$name\" must define a create method"
- }
- if {[info procs $name:reconfig] == {}} {
- error "widget \"$name\" must define a reconfig method"
- }
- proc $name {window args} [format {
- %s $window -class %s
- rename $window object_window_of$window
- upvar #0 $window object
- set object(__window) $window
- object_new %s $window
- proc %s:frame {self args} \
- "uplevel \[concat object_window_of$window \$args]"
- uplevel [concat $window config $args]
- $window create
- set object(__created) 1
- bind $window