diff --git a/tcl/drivers/OOspec.tcl b/tcl/drivers/OOspec.tcl new file mode 100644 index 0000000..f36d331 --- /dev/null +++ b/tcl/drivers/OOspec.tcl @@ -0,0 +1,47 @@ +namespace eval OOspec {} { +} +# OceanOptics spectrometer over python +proc stdConfig::OOspec {} { + controller std "\n" 15 + prop startcmd "*IDN?" + + pollperiod 15 15 + + obj OOspec -none + kids OOSpectrometer { + node peak1 rd + prop read OOspec::measure + node peak2 upd + node peak3 upd + node peak4 upd + node peak5 upd + node peak6 upd + node peak7 upd + node peak8 upd + } + +} + + + + +proc OOspec::measure {} { + sct send "AQUIRE" + return OOspec::update + } + + +proc OOspec::update {} { + set output [sct result] + set items [split $output " "] + + updateval [sct parent]/peak1 [lindex $items 0] + updateval [sct parent]/peak2 [lindex $items 1] + updateval [sct parent]/peak3 [lindex $items 2] + updateval [sct parent]/peak4 [lindex $items 3] + updateval [sct parent]/peak5 [lindex $items 4] + updateval [sct parent]/peak6 [lindex $items 5] + updateval [sct parent]/peak7 [lindex $items 6] + updateval [sct parent]/peak8 [lindex $items 7] + return idle +} diff --git a/tcl/drivers/cmnnanov.tcl b/tcl/drivers/cmnnanov.tcl new file mode 100644 index 0000000..7df96d8 --- /dev/null +++ b/tcl/drivers/cmnnanov.tcl @@ -0,0 +1,66 @@ +# keithley 2182 cmnnanovoltmeter +namespace eval cmnnanov {} { +} + +proc stdConfig::cmnnanov {} { + controller std "\n" 5 + prop startcmd "*IDN?" + + obj Keithley2182 rd -none + prop read cmnnanov::read + kids cmn_fixp { + node u1 upd + node temp upd + node u2 upd + node chan out + default 0 + prop write cmnnanov::setchan + prop enum auto,chan1,chan2 + } +} + +proc cmnnanov::read {} { + sct send ":FETCH?" + return cmnnanov::update +} + +proc cmnnanov::update {} { + set mode [hvali [sct]/chan] + if {$mode == 0} { + set chan [silent 1 sct channel] + } else { + set chan $mode + } + hupdate [sct]/u$chan [sct result] + hdelprop [sct]/u$chan geterror + set volt [hvali [sct]/u1] + if {$chan == 1} { + hupdate [sct]/temp [expr 0.001*(1.62 + 15790.0/($volt*1000. - 58.92))] + } + if {$mode != 0} { + return idle + } + set chan [expr 3-$chan] + sct send ";SENS:CHAN $chan;:SENS:CHAN?" + sct channel $chan + return stdSct::complete +} + +proc cmnnanov::setchan {} { + set mode [sct target] + if {$mode == 0} { + sct update $mode + return idle + } + set chan $mode + sct send ";SENS:CHAN $chan;:SENS:CHAN?" + sct channel $chan + return cmnnanov::updatechan +} + +proc cmnnanov::updatechan {} { + sct update [sct result] + return idle +} + + diff --git a/tcl/drivers/dilprep.tcl b/tcl/drivers/dilprep.tcl new file mode 100644 index 0000000..1e5dab3 --- /dev/null +++ b/tcl/drivers/dilprep.tcl @@ -0,0 +1,181 @@ +namespace eval dilprep { + array set score {dil2 0 dil3 0 dil4 0} + array set curves {dil2 cx198 dil3 cx262 dil4 cx078} +} + + +proc stdConfig::dilprep {} { + controller syncedprot + + obj DILPREP wr + prop enum warm=0,warmup=1,undef=-1 + default -1 + prop read dilprep::poll + prop check dilprep::check + prop write stdSct::complete + prop buffer "" + # last time when sample was warm + prop warmtime 0 + # last time when sample was cold + prop coldtime 0 + # last time when sample warming up faster than slopelimit + prop steeptime 0 + # last time when detection was undefined + prop undeftime [DoubleTime] + + kids dilprep { + node coldlimit par 280 + prop help "stick is detected cold when T < coldlimit" + node warmlimit par 290 + prop help "stick is detected warm when T > warmlimit for more than window sec" + node slopelimit par 0.1 + prop help "stick is detected warm when tslope < slopelimit for more than window sec" + node window par 600 + prop help "time window (sec)" + node dil out -int + prop enum undef=0,dil2=2,dil3=3,dil4=4 + prop check dilprep::checktype + prop write stdSct::complete + } +} + +proc dilprep::check {} { + if {[sct target] == 1} { + # reset slope + tslope node /ts + } + sct update [sct target] +} + +proc dilprep::checktype {} { + variable score + variable curves + + enum_decode [sct] [sct target] num dilname + foreach {key value} [array get score] { + set score($key) 0 + } + if {$dilname ne "undef"} { + set score($dilname) 12 + } + set crv $curves($dilname) + ts curve $crv + sct update [sct target] +} + +proc dilprep::poll {} { + variable score + variable curves + + if {[result _tmon status] eq "no response"} { + sct connected 0 + } elseif {[silent 1 sct connected] == 0} { + device name none + device makeitem action plugged + device makeitem newdevice dilprep + } + set now [DoubleTime] + set onek [silent 0 result tmon onek/raw] + set stillt [silent 0 result tmon stillt/raw] + set mix [silent 0 result tmon mix/raw] + if {$onek * $stillt * $mix == 0} { + sct update -1 + return idle + } + # guess dilution type from typical resistivities + # determine possible candidate + set dilname undef + if {abs($mix - 2200) < 50 && abs($onek - 2260) < 100 && abs($stillt - 2260) < 100} { + if {$onek > 2260} { + if {$stillt > 2260} { + set dilname dil4 + } + } elseif {$stillt < 2260} { + set dilname dil2 + } else { + set dilname dil3 + } + } + set maxscore 0 + # increase score for matching candidate, decrease for others (clamped within 0..12) + foreach {key value} [array get score] { + if {$key eq $dilname} { + set value [expr min(12, $value + 1)] + } else { + set value [expr max(0, $value - 1)] + } + if {$value > $maxscore} { + set maxscore $value + } + set score($key) $value + } + if {$dilname eq "undef"} { + sct undeftime $now + return idle + } + if {$maxscore eq 0} { + # no max score + enum_update [sct]/dil undef + } elseif {$score($dilname) >= $maxscore} { + if {$dilname ne [enum_txt [sct]/dil]} { + clientput "detected $dilname" + # highest score for $dilname + enum_update [sct]/dil $dilname + set crv $curves($dilname) + ts curve $crv + } + } + set mode [sctval [sct]] + set lim [hval [sct]/warmlimit] + set ts [silent 0 result ts] + set window [hval [sct]/window] + if {$mode == 1} { + # warming up + if {$ts < $lim} { + sct coldtime $now + } + if {[silent 999 hval /tslope] > [hval [sct]/slopelimit]} { + sct steeptime $now + } + if {$now > min([sct steeptime], [sct coldtime]) + $window} { + # warm + if {[sct steeptime] < [sct coldtime]} { + clientput "stick is warm (slope < [hval [sct]/slopelimit] for more than $window sec)" + } else { + clientput "stick is warm (T > [hval [sct]/warmlimit] for more than $window sec)" + } + sct target 0 + check + return idle + } + } elseif {$mode < 0} { + # undef + if {$ts != 0} { + if {$now > [sct undeftime] + 120} { + if {$ts > [hval [sct]/warmlimit]} { + set mode 0 + clientput "stick is warm" + } else { + set mode 1 + clientput "stick is warming up" + } + } + sct target $mode + check + return idle + } + } else { + # warm or undef + if {$ts > [hval [sct]/coldlimit]} { + sct warmtime $now + } + if {[hval [sct]/dil] != 0 && $now > [sct warmtime] + $window} { + # warmup + sct target 1 + check + return idle + } + } + sct update $mode + return idle +} diff --git a/tcl/drivers/k2601bVS.tcl b/tcl/drivers/k2601bVS.tcl new file mode 100644 index 0000000..9015a14 --- /dev/null +++ b/tcl/drivers/k2601bVS.tcl @@ -0,0 +1,62 @@ +# keithley 2601B sourcemeter Voltage Source +namespace eval k2601bVS {} { +} + +proc stdConfig::k2601bVS {} { + controller std "\n" 5 + prop startcmd "reset() display.smua.measure.func = display.MEASURE_DCAMPS smua.source.func = smua.OUTPUT_DCVOLTS smua.source.autorangev = 1 smua.source.output = 0 print(localnode.description)" + + pollperiod 1.0 1.0 + + obj k2601bVS -none + + + kids k2601bVS { + node Enable wr -int + default 0 + prop label Output + prop writecmd "smua.source.output = %d print(smua.source.output)" + prop readcmd "print(smua.source.output)" + prop readfmt "%d" + prop enum off,on + + node Ilim wr + default 2.0 + prop label Current_Limit + prop writecmd "smua.source.limiti = %g print(smua.source.limiti)" + prop readcmd "print(smua.source.limiti)" + prop readfmt "%g" + +# node Itrip rd +# prop label CurrentTrip +# prop readcmd ":SENS:AMPS:PROT:TRIP?" +# prop readfmt "%g" + + node vset wr + default 0.00 + prop label SetVoltage + prop writecmd "smua.source.levelv = %g print(smua.source.levelv)" + prop readcmd "print(smua.source.levelv)" + prop readfmt "%g" + + node Vmeas rd + prop label Voltage + prop readcmd "print(smua.measure.v())" + prop readfmt "%g" + + node Imeas rd + prop label Current + prop readcmd "print(smua.measure.i())" + prop readfmt "%g" + + node Rmeas rd + prop label Resistance + prop readcmd "print(smua.measure.r())" + prop readfmt "%g" + + node Pmeas rd + prop label Power + prop readcmd "print(smua.measure.p())" + prop readfmt "%g" + } +} diff --git a/tcl/drivers/k6487.tcl b/tcl/drivers/k6487.tcl new file mode 100644 index 0000000..e7e5493 --- /dev/null +++ b/tcl/drivers/k6487.tcl @@ -0,0 +1,19 @@ +# keithley 6487 picoammeter / voltage source +namespace eval k6487 {} { +} + +proc stdConfig::k6487 {} { + controller std "\n" 5 + prop startcmd "*IDN?" + + obj Keithley6487 wr + prop readcmd "SOUR:VOLT?" + prop writecmd "SOUR:VOLT %.12g" + kids "k6487 voltage source" { + node voltrange wr -int + prop read "SOUR:VOLT:RANGE?" + prop write "SOUR:VOLT:RANGE %d" + prop enum 10=10,50=50,500=500 + } +} + diff --git a/tcl/drivers/ls370.tcl b/tcl/drivers/ls370.tcl new file mode 100644 index 0000000..718ca39 --- /dev/null +++ b/tcl/drivers/ls370.tcl @@ -0,0 +1,75 @@ +#LS370 simple driver + +namespace eval ls370 {} { +} + +proc stdConfig::ls370 {} { + variable ctrl + controller std "\n" 5 + prop startcmd "*IDN?" + + obj calib370 rd + default 0 + prop read calib370::read + prop period 15 + prop period0 0 + kids "Sensor Channels" { + node chan1 upd + prop newline 1 + node active1 par 1 + prop enum 1 + node chan2 upd + node active2 par 1 + prop enum 1 + node chan3 upd + node active3 par 1 + prop enum 1 + node chan4 upd + node active4 par 1 + prop enum 1 + node chan5 upd + node active5 par 1 + prop enum 1 + node chan6 upd + node active6 par 1 + prop enum 1 + node chan7 upd + node active7 par 1 + prop enum 1 + node chan8 upd + node active8 par 1 + prop enum 1 + } +} + +proc ls370::read {} { + if {[sct period] ne [sct period0]} { + [sct controller] poll [sct] [sct period] read read + sct period0 [sct period] + } + if {[hvali [sct]] > 0} { + sct send "RDGK?[hvali [sct]]" + return ls370::update + } + sct update 1 + sct send "SCAN 1,0;SCAN?" + return stdSct::complete +} + +proc ls370::update {} { + set chan [hvali [sct]] + hdelprop [sct]/chan$chan geterror + hupdate [sct]/chan$chan [sct result] + for {set i 0} {$i < 8} {incr i} { + incr chan + if {$chan > 8} { + set chan 1 + } + if {[hvali [sct]/active$chan]} { + break + } + } + sct update $chan + sct send "SCAN $chan,0;SCAN?" + return stdSct::complete +} diff --git a/tcl/drivers/luft.tcl b/tcl/drivers/luft.tcl new file mode 100644 index 0000000..d876760 --- /dev/null +++ b/tcl/drivers/luft.tcl @@ -0,0 +1,52 @@ +namespace eval luft {} { +} + +proc stdConfig::luft {label} { + controller syncedprot + + pollperiod 10 10 + + obj LUFT upd + kids "luft monitor $label" { + node confirm wr -text -spy + prop write luft::writeCf + prop read luft::readCf + prop timeout [expr [clock seconds] + 600] + } +} + +proc luft::set_error {errtxt} { + updateval [sct parent]/status $errtxt + if {$errtxt eq ""} { + catch {hdelprop [sct parent] geterror} + catch {hdelprop [sct] geterror} + } else { + updateerror [sct parent]/status $errtxt 1 + } +} + +proc luft::readCf {} { + if {[clock seconds] > [sct timeout]} { + luft::set_error "luft monitor off" + } + return idle +} + +proc luft::writeCf {} { + sct cnt 0 + set errtxt [lassign [sct target] timeout val] + if {[silent 0 sct verbose]} { + clientput [sct target] + } + if {$errtxt eq ""} { + updateval [sct parent] $val + # sct print [sct]=$val + luft::set_error "" + } else { + luft::set_error "epics error: $val $errtxt" + } + if {[scan [lindex [sct target] 0] %d period]} { + sct timeout [expr [clock seconds] + $period + 10] + } + return idle +} diff --git a/tcl/drivers/magres.tcl b/tcl/drivers/magres.tcl new file mode 100644 index 0000000..6ef3a87 --- /dev/null +++ b/tcl/drivers/magres.tcl @@ -0,0 +1,139 @@ +# magnet resistivity measured with IPS + +namespace eval magres {} { +} + +proc stdConfig::magres {} { + variable hostport none + variable name + controller syncedprot + pollperiod 1 1 + + obj magres rd + prop read magres::read + prop last 0 + prop htr 0 + prop exc 0 + kids "magnet resistance" { + node active out + default 0 + prop enum 1 + prop write magres::setactive + + node coil upd + + node excitation par 0.1 + } +} + +proc magres::setactive {} { + if {[sct target]} { + sct init 1 + mf persmode 3 + } else { + sct init 11 + } + sct update [sct target] + return idle +} + +proc magres::read {} { + if {[result mf persmode] != 3} { + # switch off immedately as a run mf has been done + updateval [sct]/active 0 + return idle + } + set ramp [result mf ramp] + set ampRamp [result mf ampRamp] + if {$ramp == 0 || $ampRamp == 0} { + mf ramp 0.5 + sct init 1 + return idle + } + set fact [expr $ramp / $ampRamp] + set exc [hvali [sct]/excitation] + if {abs($exc) > 0.1} { + clientput "excitation is limited to 0.1 A" + set exc 0.1 + } + set init [sct init] + if {[hvali [sct]/active] == 0} { + sct geterror "off" + if {$init > 0} { + if {$init <= 10} { + if {abs([result mf current] - [sct exc] * $fact) > 0.001} { + clientput "bad state of power supply" + return idle + } + set init 11 + } + switch $init { + 11 { mf send C3 } + 12 { mf send H2 } + 30 { mf send I0 } + 31 { mf send A1 } + 32 { mf send H0 } + 33 { + mf send C1 + mf persmode 1 + } + 34 { return idle } + default { + } + } + incr init + sct init $init + } + return idle + } + if {$init > 10 || ($init == 10 && $exc != [sct exc])} { + set init 1 + } + if {$init < 10} { + switch $init { + 1 { + mf send C3 + } + 2 { mf send T0.5000 } + 3 { + mf send [format I%.4f $exc] + sct exc $exc + } + 4 { mf send A1 } + 5 { mf send R0 } + default { + sct init 10 + return idle + } + } + incr init + sct init $init + return idle + } + set mf [expr $fact * $exc] + set curT [result mf current] + set res [expr [result mf voltage] / $curT * $fact] + set now [DoubleTime] + if {[sct htr]} { + if {$now > [sct last] + 10} { + updateval [sct]/coil $res + if {$now > [sct last] + 20} { + sct last $now + sct htr 0 + mf send H0 + } + } + } else { + if {$now > [sct last] + 10} { + sct update $res + if {$res > 1} { + hsetprop [sct]/coil geterror off + } elseif {$now > [sct last] + 20} { + sct last $now + sct htr 1 + mf send H2 + } + } + } + return idle +} diff --git a/tcl/drivers/mirror.tcl b/tcl/drivers/mirror.tcl new file mode 100644 index 0000000..d895f8a --- /dev/null +++ b/tcl/drivers/mirror.tcl @@ -0,0 +1,46 @@ +# mirror defined list of parameters to a remote object (e.g. SECoP) +namespace eval mirror { +} + +proc stdConfig::mirror {pars} { + controller syncedprot + variable node + + pollperiod 0.25 0.25 + + obj MIRROR -text wr + default $pars + prop read mirror::update + prop write mirror::stdSct::completeUpdate + kids "mirror settings" { + } +} + +proc mirror::update {} { + if {[catch { + set vpar [hval [sct]] + set pars [hlist $vpar] + set now [DoubleTime] + set timestamp 0 + foreach par $pars { + if {$par ne "timestamp"} { + set par [string map {_ .} $par] + set value [get_var_value $par] + if {$value != [hval $vpar/$par]} { + hset $vpar/$par $value + set timestamp $now + } + } + } + if {$timestamp != 0} { + hset $vpar/timestamp $timestamp + } + + } msg]} { + hset $vpar/timestamp [DoubleTime] + hupdate [sct]/status $msg + } else { + hupdate [sct]/status "" + } + return idle +} diff --git a/tcl/drivers/motvalve.tcl b/tcl/drivers/motvalve.tcl new file mode 100644 index 0000000..8901fa3 --- /dev/null +++ b/tcl/drivers/motvalve.tcl @@ -0,0 +1,49 @@ +# motorized valve (DC-motor with endswitch) +namespace eval motvalve {} { +} + +proc stdConfig::motvalve {} { + controller std "\n" 5 + prop startcmd "t" + + obj MotValve wr + prop write motvalve::write + prop read motvalve::read + prop enum close,open,closing,opening + kids "motor valve" { + node pos upd + } +} + +proc motvalve::write {} { + if {[sct target] == 1 || [sct target] == 3} { + sct send o + } else { + sct send c + } + return motvalve::read +} + +proc motvalve::read {} { + sct send ep + return motvalve::update +} + +proc motvalve::update {} { + set pos -1 + set state -1 + set error "" + scan [sct result] "e%d p%f %s" state pos error + updateval [sct]/pos $pos + switch $state { + 0 {sct enum closed,open} + 1 {sct enum close,opened} + 2 {sct enum close,open,closing} + 3 {sct enum close,open,opening=3} + } + sct update $state + if {"$error" ne ""} { + sct geterror $error + } + return idle +} diff --git a/tcl/drivers/pfeiffermulti.tcl b/tcl/drivers/pfeiffermulti.tcl new file mode 100644 index 0000000..fd01318 --- /dev/null +++ b/tcl/drivers/pfeiffermulti.tcl @@ -0,0 +1,71 @@ +namespace eval pfeiffermulti {} { +} + +proc stdConfig::pfeiffermulti {} { + variable node + + controller std "" 5 + prop read pfeiffermulti::read + prop update pfeiffermulti::update + + obj TPGM rd + prop cmd PR1 + prop @errorcnt 0 + + kids TPG { + node p2 rd + prop cmd PR2 + + node p3 rd + prop cmd PR3 + + node p4 rd + prop cmd PR4 + + node p5 rd + prop cmd PR5 + + node p6 rd + prop cmd PR6 + + # node prx rd -text + # prop cmd PRX + + # node sp1 rd -text + # prop cmd SP1 + + # node sp2 rd -text + # prop cmd SP2 + + # node sps rd -text + # prop cmd SPS + } +} + +proc pfeiffermulti::read {} { + sct send "[sct cmd]\r\n" + return update +} + +proc pfeiffermulti::update {} { + scan [sct result] %c ack + if {$ack == 6} { + sct send "\005" + return pfeiffermulti::update2 + } + if {$ack == 21} { + error "NAK received on [sct cmd]" + } + return [pfeiffermulti::read] +} + +proc pfeiffermulti::update2 {} { + if {[string match "PR*" [sct cmd]]} { + sct update [lindex [split [sct result] ,] 1] + } else { + sct update [sct result] + } + sct @errorcnt 0 + return idle +} + diff --git a/tcl/drivers/secop_0.tcl b/tcl/drivers/secop_0.tcl new file mode 100644 index 0000000..b28f6b9 --- /dev/null +++ b/tcl/drivers/secop_0.tcl @@ -0,0 +1,675 @@ +# secop driver + +namespace eval secop {} { +} + +proc stdConfig::secop {{shownUnits ALL}} { + variable node + variable name + + set timeout 5 + controller secop timeout=$timeout + prop commerror secop::errorscript + prop connection_lost 0 + prop check secop::check + prop write secop::write + prop startcmd *IDN? + prop end_fast 0 + prop secopPath /$name + prop timeout $timeout + prop active 0 + prop shownUnits $shownUnits + + set node $node/tasks + prop start secop::start + + # the pollperiod does not really matter + pollperiod 5 5 + obj SECoP -text wr + + prop read secop::readmsg + prop test secop::test + prop check secop::checkmsg + prop write secop::writemsg + prop cmd "" + + variable ctrl + variable path + hsetprop /sics/$ctrl ignore_no_response 1 + +} + +proc secop::errorscript {} { + if {[string match {ASCERR: no response*} [sct result]]} { + sct send ping + return secop::update + } + sct connection_lost 1 + error [sct result] +} + +proc secop::checkmsg {} { +# variable MQ[sct] +# upvar 0 MQ[sct] mq +# if {![info exists mq]} { +# # create message queue +# set mq [list] +# } +# if {[llength $mq] > 0} { +# set next [lindex $mq 0] +# set mq [lrange $mq 1 end] +# lappend mq [sct target] +# sct target $next +# } + + # interrupt pending wait for update + [sct controller] timeout 0.001 + # without the following line "0.001" appears on client, why? + return "" +} + +proc secop::writemsg {} { + # we grabbed access, so restore normal timeout + [sct controller] timeout [sct timeout] + sct send [sct target] + return secop::update +} + +proc secop::readmsg {} { + if {[sct connection_lost]} { + sct connection_lost 0 + return [secop::start] + } + return [secop::get] +} + +proc secop::test {} { + clientput test + return idle +} + +proc secop::check {} { + set validator [silent {} sct validator] + eval $validator + lassign [split [hinfo [sct]] ","] type + if {$type eq "text"} { + set msg "change [sct secopar] \"[sct target]\"" + } else { + set msg "change [sct secopar] [sct target]" + } + [sct controller] que [sct secopPath] write [list secop::queuedwrite $msg] +} + +proc secop::queuedwrite {msg} { + sct changed [DoubleTime] + # send message on /secop node + sct send $msg + return secop::update +} + +proc secop::write {} { + # dummy write + # clientput "secop::write [sct] [hvali [sct]]" + return idle +} + +proc secop::get {} { + sct send "" + return secop::update +} + +proc secop::check_range {{low None} {high None}} { + [sct controller] timeout 0.001 + if {$low ne "None" && [sct target] < $low} { + error "value [sct target] must be >= $low" + } + if {$high ne "None" && [sct target] > $high} { + error "value [sct target] must be <= $high" + } +} + +proc secop::check_enum {} { + [sct controller] timeout 0.001 +} + +proc secop::check_length {{low None} {high None}} { + if {$low ne "None" && [string length [sct target]] < $low} { + error "value [sct target] must not be shorter than $low" + } + if {$high ne "None" && [string length [sct target]] > $high} { + error "value [sct target] must not be longer than $high" + } +} + +proc secop::make_par {secopar desc {kind ""}} { + set path [topath $secopar [silent "" dict get $desc group]] + array set props $desc + set validator_args [lassign [silent "" set props(datatype)] secoptype0] + if {$secoptype0 eq "tuple" && [string match *:status $secopar]} { + lassign $validator_args elements + make_par0 text ${path}_text $secopar $desc + hsetprop ${path}_text width 24 + set validator_args [lassign [lindex $elements 0] secoptype] + set status_node 1 + } else { + set secoptype $secoptype0 + set status_node 0 + } + switch -- $secoptype { + double {set type float} + int - enum {set type int} + string { + set type text + # can not use SICS drivable for string + set kind "" + } + bool {set type text} + none {set type none} + default { + clientput "unknown type for $secopar (use text): $secoptype ($props(datatype))" + set type text + } + } + make_par0 $type $path $secopar $desc $kind + hsetprop $path secoptype $secoptype0 + if {$status_node} { + hsetprop $path nonewline 1 + } + switch -- $secoptype { + enum { + set enumprop [list] + set wid 8 + foreach {name value} [lindex $validator_args 0] { + lappend enumprop "$name=$value" + set wid [expr max($wid,[string length $name])] + } + hsetprop $path enum [join $enumprop ,] + if {$wid > 8} { + hsetprop $path width $wid + } + } + bool { + hsetprop $path enum 1 + hsetprop $path validator secop::check_enum + } + double - int { + hsetprop $path validator [concat secop::check_range $validator_args] + } + string { + hsetprop $path width 16 + hsetprop $path validator [concat secop::check_range $validator_args] + } + } + return $path +} + +proc secop::make_par0 {type path secopar desc {kind std}} { + array set props $desc + # clientput "$path $desc" + set readonly [silent 0 set props(readonly)] + if {$readonly} { + set priv internal + } else { + set priv user + } + if {[silent "" hinfo $path] ne ""} { + error "$path exists already" + } + lassign [split $path /] nul obj par + if {$par eq ""} { + if {$kind eq "driv"} { + dynsctdriveobj $obj float user SECoP [sct controller] + hfactory $path link $obj + hsetprop $obj checklimits secop::checklimits + hsetprop $obj halt secop::halt + # allow start without run: + hsetprop $obj check secop::checklimits + hsetprop $obj write secop::complete_run + set readonly 0 + hsetprop $obj sicscommand "run $obj" + } else { + # clientput "OBJ $obj $type" + dynsicsobj $obj SECoP $priv $type + hfactory $path link $obj + } + hsetprop $path group $obj + hsetprop $path objectPath $path + hsetprop /sics/[sct controller] p_$secopar:value $path + } else { + if {$par eq "status"} { + set path /$obj/s_status + } + # clientput "PAR $path $type" + hfactory $path plain $priv $type + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } + hsetprop $path secopar $secopar + hsetprop /sics/[sct controller] p_$secopar $path + if {!$readonly} { + [sct controller] write $path + } else { + [sct controller] connect $path + } + logsetup $path 1 + if {[info exists props(value)]} { + clientput "VALUE in descr $path" + if {[catch {hupdate /$path $props(value)} msg]} { + clientput $msg + } + unset props(value) + } + set fmtunit "" + if {[info exists props(unit)]} { + set fmtunit [format { [%s]} $props(unit)] + if {$par eq "" || $par eq "target"} { + if {[sct shownUnits] eq "ALL" || [lsearch [sct shownUnits] $props(unit)] >= 0} { + GraphAdd $path $props(unit) [join [lrange [split $path /] 1 end] .] + } + } + } + if {[info exists props(description)]} { + hsetprop $path help "$props(description)$fmtunit" + unset props(description) + } + foreach {prop item} [array get props] { + hsetprop $path s_$prop $item + } +} + +proc secop::make_cmd {secopar desc {first 0}} { + array set props $desc + set path [topath $secopar [silent "" dict get $desc group]] + lassign [split $secopar :] obj cmd + lassign [silent "" set props(arguments)] secoptype validator + if {$secoptype eq ""} { + $obj makescriptfunc $cmd "secop::check_cmd [sct secopPath] $secopar" user + hsetprop $path newline $first + hsetprop $path secopar $secopar + hsetprop $path sicscommand "$obj $cmd" + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } else { + if {[llength $secoptype] == 1} { + set secoptype [lindex $secoptype 0] + } + clientput "MAKE_CMD $secoptype" + dict set desc datatype $secoptype + make_par $secopar $desc + lassign $secoptype maintype + if {$maintype eq "double" || $maintype eq "int" || $maintype eq "bool"} { + hsetprop $path check "secop::check_cmd_num [sct secopPath] $secopar" + } else { + hsetprop $path check "secop::check_cmd_text [sct secopPath] $secopar" + } + } +} + +proc secop::check_cmd {secopPath secopar} { + hset $secopPath "do $secopar" +} + +proc secop::check_cmd_num {secopPath secopar} { + hset $secopPath [format {do %s [%.15g]} $secopar [sct target]] + sct update [sct target] +} + +proc secop::check_cmd_text {secopPath secopar} { + hset $secopPath [format {do %s ["%s"]} $secopar [sct target]] + sct update [sct target] +} + +proc secop::make_module {obj desc} { + if {[obj_list exists $obj]} { + clientput "$obj exists already" + return + } + obj_list makeitem $obj /$obj + + array unset modprop + set parlist [list] + set cmdlist [list] + set pardict [dict create] + foreach {key item} $desc { + switch $key { + parameters { + set parlist $item + } + commands { + set cmdlist $item + } + default { + set modprop($key) $item + } + } + } + if {[dict exists $parlist value]} { + set value [dict get $parlist value] + dict unset parlist value + } else { + set value [dict create datatype none] + } + set classes [silent "" set modprop(interface_class)] + if {[string match "* Drivable *" " $classes "]} { + set path [make_par $obj $value driv] + } else { + set path [make_par $obj $value] + } + if {[info exists modprop(visibility)] && $modprop(visibility) >= 3} { + hdelprop $path group + } + foreach {prop val} [array get modprop] { + hsetprop $obj sm_$prop $val + } + device_layout makeitem /$obj [silent 0 set modprop(layoutpos)] + + set groups [dict create] + foreach {parname pardesc} [concat $parlist $cmdlist] { + if {[dict exists $pardesc group]} { + dict set groups [dict get $pardesc group] 1 + } + } + foreach g [dict keys $groups] { + clientput "GROUP $g" + hfactory $obj/$g plain user none + hsetprop $obj/$g group "group $g" + } + foreach {parname pardesc} $parlist { + make_par $obj:$parname $pardesc + } + # first commands with arguments + foreach {parname pardesc} $cmdlist { + if {[dict get $pardesc arguments] ne ""} { + make_cmd $obj:$parname $pardesc 1 + } + } + # then commands without arguments, on one line + set first 1 + foreach {parname pardesc} $cmdlist { + if {[dict get $pardesc arguments] eq ""} { + make_cmd $obj:$parname $pardesc $first + set first 0 + } + } +} + +proc secop::make_node {desc} { + array unset nodeprop + set modlist [list] + foreach {key item} $desc { + switch $key { + modules { + set modlist $item + } + default { + set nodeprop($key) $item + } + } + } + foreach {modname moddesc} $modlist { + make_module $modname $moddesc + } + foreach {prop val} [array get nodeprop] { + sct sn_$prop $val + } + sort_layout +} + +proc secop::topath {secopar {pargroup ""}} { + lassign [split [string tolower $secopar] :] module parameter + if {$parameter eq "value" || $parameter eq ""} { + return "/$module" + } + if {$parameter eq "status"} { + set parameter s_status + } + if {[string match {_*} $parameter]} { + set parameter [string range $parameter 1 end] + } + if {$pargroup ne ""} { + return "/$module/$pargroup/$parameter" + } + return "/$module/$parameter" +} + +proc secop::update {} { + set sent_message [silent 0 sct sent_message] + set message_to_client "" + + lassign [sct result] messagetype par val + set path [silent "" hgetpropval /sics/[sct controller] p_$par] + lassign [split $par :] obj + switch $messagetype { + update - changed { + #if {[sct] ne "/secop"} { + # clientput "[sct] is not /secop, why?" + #} + #if {![sct active]} { + # clientput [sct result] + #} + if {$messagetype eq "changed"} { + if {[string match *:target $par]} { + hsetprop /$obj writestatus done + } + hsetprop $path changed 0 + if {[lrange $sent_message 0 1] eq [list change $par]} { + set message_to_client [sct result] + } + # clientput "CH $path [sct result]" + } else { + if {[DoubleTime] < [silent 0 hgetpropval $path changed] + 10} { + # ignore updates of variables during change + # clientput "ignore [sct result]" + return idle + } + if {[lrange $sent_message 0 1] eq [list read $par]} { + set message_to_client [sct result] + } + } + lassign $val value qual + if {[silent 0 hgetpropval $path secoptype] eq "tuple" && + [string match *:status $par]} { + if {[llength $value] > 2} { + set text_value [lrange $value 1 end] + } else { + set text_value [lindex $value 1] + } + set objpath [sct parent $path] + set visible_old [silent true hgetpropval $objpath visible] + if {$text_value ne "disabled"} { + set visible_new true + set shown 1 + } else { + set visible_new false + set shown 0 + } + if {$visible_new ne $visible_old} { + hsetprop $objpath visible $visible_new + GraphItem shown $objpath $shown + } + lassign $value value + if {[catch {updateval ${path}_text $text_value}]} { + clientput "cannot update ${path}_text to $text_value" + clientput "MSG([sct result])" + } + if {[string match *:status $par]} { + set oldstatus [silent idle hgetpropval /$obj status] + if {[silent 0 hgetpropval /$obj writestatus] eq "start"} { + set status run + } elseif {[string match 3* $value]} { + set status run + } elseif {[string match 4* $value]} { + set status posfault + } else { + set status idle + if {[silent "" hgetpropval $obj type] eq "drivable" && $oldstatus eq "run"} { + if {[catch { + set oldvalue [silent 0 hgetpropval $obj value_before_run] + set oldtarget [silent 0 hgetpropval $obj target_before_run] + set value [hval /$obj] + set target [silent 0 hgetpropval /$obj target] + set delay [expr [DoubleTime] - [silent 0 hgetpropval $obj write_time]] + if {abs($value - $oldvalue) < abs($target - $oldtarget) * 0.1 && $delay < 10} { + # clientput "WARNING: $obj status is idle, but value has not moved: abs($value - $oldvalue) < abs($target - $oldtarget) * 0.1 delay $delay" + set status run + } + } msg]} { + clientput "WARNING: $msg" + } + } + } + hsetprop /$obj status $status + } + } + if {[catch {updateval $path $value} msg]} { + if {$value eq "None"} { + hsetprop $path geterror None + } else { + clientput "cannot update $path to $value" + clientput $msg + } + } elseif {[string match *:target $par]} { + # clientput [sct result]/[silent "" hgetpropval /$obj status] + if {[silent "" hgetpropval /$obj status] eq "idle"} { + hsetprop /$obj target $value + } + } + catch { + hsetprop $path timestamp [dict get $qual t] + } + } + pong { + if {[lindex $sent_message 0] eq "ping"} { + set message_to_client [sct result] + } + } + done { + if {[lrange $sent_message 0 2] eq [list do $par]} { + set message_to_client [sct result] + } else { + clientput "done $par $val" + } + } + active { + if {[lindex $sent_message 0] eq "activate"} { + set message_to_client [sct result] + } else { + clientput ACTIVE + } + sct active 1 + sct end_fast 0 + } + error { + lassign $val origin info + lassign $origin requesttype requestpar requestval + set path [silent "" hgetpropval /sics/[sct controller] p_$requestpar] + if {$requesttype eq "change" && $path ne ""} { + hsetprop $path changed 0 + } + set errortext [lindex [dict get $info errorinfo] 0] + if {$origin eq $sent_message} { + set message_to_client [sct result] + } else { + clientput "ERROR: $path $errortext" + } + } + default { + if {$sent_message ne ""} { + set message_to_client [sct result] + } else { + # show untreated message + clientput [sct result] + } + } + } + if {$message_to_client ne ""} { + clientput "> $sent_message\n< $message_to_client" + sct sent_message "" + sct sent_time 1e20 + } elseif {[DoubleTime] > [silent 1e20 sct sent_time] + 10} { + clientput "timeout waiting for response to $sent_message" + sct sent_message "" + sct sent_time 1e20 + } + if {[DoubleTime] < [sct end_fast]} { + return secop::get + } + [sct controller] queue [sct] read secop::get + return idle +} + +proc secop::checklimits {} { + # for whatever strange reason checklimits is called twice + # in addition again as write script of the obj node + # do this only once + if {[silent 0 sct status] ne "run" || + [sct target] != [silent "x" hgetpropval [sct]/target target]} { + sct value_before_run [hval [sct]] + sct target_before_run [hval [sct]/target] + hset [sct]/target [sct target] + sct status run + } +} + +proc secop::complete_run {} { + sct print "run [sct objectName] to [sct target]" + return idle +} + +proc secop::halt {} { + [sct objectName] stop + sct writestatus done + sct target_before_run [silent 0 sct target] + # sct status posfault + # clientput HALT:[sct] + return idle +} + +proc secop::start {} { + [sct controller] timeout [sct timeout] + sct send *IDN? + return secop::getidn +} + +proc secop::getidn {} { + clientput [sct result] + [sct controller] queue [sct secopPath] start secop::describe + sct active 0 + return idle +} + +proc secop::describe {} { + sct send describe + return secop::describing +} + +proc secop::describing {} { + lassign [sct result] messagetype par val + switch $messagetype { + describing { + do_as_manager { + make_node $val + } + } + default { + clientput "ignore $messagetype $par ..." + } + } + sct send activate + sct end_fast [expr [DoubleTime] + 5] + return secop::update +} + +proc secop_send {args} { + hset /secop $args + hsetprop /secop sent_message $args + hsetprop /secop sent_time [DoubleTime] +} + +publishLazy secop_send diff --git a/tcl/drivers/secop_1.tcl b/tcl/drivers/secop_1.tcl new file mode 100644 index 0000000..087ed54 --- /dev/null +++ b/tcl/drivers/secop_1.tcl @@ -0,0 +1,699 @@ +# secop driver + +namespace eval secop {} { +} + +proc stdConfig::secop {{shownUnits ALL}} { + variable node + variable name + + controller secop3 timeout=60 + prop commerror secop::errorscript + prop connection_lost 0 + prop check secop::check + prop write secop::write + prop startcmd *IDN? + prop end_fast 0 + prop secopPath /$name + prop active 0 + prop shownUnits $shownUnits + + set node $node/tasks + prop start secop::start + + pollperiod 0.01 0.01 + obj SECoP -text wr + + prop read secop::readmsg_ + prop test secop::test + prop check secop::checkmsg + prop write secop::writemsg + prop cmd "" + + variable ctrl + variable path + hsetprop /sics/$ctrl ignore_no_response 1 + +} + +proc secop::errorscript {} { + if {[string match {ASCERR: no response*} [sct result]]} { + sct send ping + return secop::update_ + } + sct connection_lost 1 + [sct controller] poll [sct] 1 + error [sct result] +} + +proc secop::checkmsg {} { +# variable MQ[sct] +# upvar 0 MQ[sct] mq +# if {![info exists mq]} { +# # create message queue +# set mq [list] +# } +# if {[llength $mq] > 0} { +# set next [lindex $mq 0] +# set mq [lrange $mq 1 end] +# lappend mq [sct target] +# sct target $next +# } + + return "" +} + +proc secop::writemsg {} { + sct send [sct target] + return secop::update_ +} + +proc secop::readmsg_ {} { # ending with _: invisible on debug + if {[sct connection_lost]} { + sct connection_lost 0 + return [secop::start] + } + sct send "" + return secop::update_ +} + +proc secop::test {} { + clientput test + return idle +} + +proc secop::check {} { + if {[silent "" sct secopar] eq ""} return + set validator [silent {} sct validator] + eval $validator + lassign [split [hinfo [sct]] ","] type + if {$type eq "text"} { + set msg "change [sct secopar] \"[sct target]\"" + } else { + set msg "change [sct secopar] [sct target]" + } + [sct controller] que [sct secopPath] write [list secop::queuedwrite $msg] +} + +proc secop::queuedwrite {msg} { + sct changed [DoubleTime] + # send message on /secop node + sct send $msg + return secop::update_ +} + +proc secop::write {} { + # dummy write + # clientput "secop::write [sct] [hvali [sct]]" + return idle +} + +proc secop::get {} { + error "secop::get is obsolete" + sct send "" + return secop::update_ +} + +proc secop::check_range {{low None} {high None}} { + if {$low ne "None" && [sct target] < $low} { + error "value [sct target] must be >= $low" + } + if {$high ne "None" && [sct target] > $high} { + error "value [sct target] must be <= $high" + } +} + +proc secop::check_bool {} { + switch -- [string tolower [sct target]] { + off - false - no - 0 - on - true - yes - 1 { + return + } + } + error "illegal value for boolean: [sct target]" +} + +proc secop::check_length {{low None} {high None}} { + if {$low ne "None" && [string length [sct target]] < $low} { + error "value [sct target] must not be shorter than $low" + } + if {$high ne "None" && [string length [sct target]] > $high} { + error "value [sct target] must not be longer than $high" + } +} + +proc secop::make_par {secopar desc {kind ""}} { + set path [topath $secopar [silent "" dict get $desc group]] + array set props $desc + set validator_args [lassign [silent "" set props(datatype)] secoptype0] + if {$secoptype0 eq "tuple" && [string match *:status $secopar]} { + lassign $validator_args elements + set text_path [regsub {status_code$} $path status_text] + make_par0 text $text_path $secopar $desc + hsetprop $text_path width 24 + set validator_args [lassign [lindex $elements 0] secoptype] + set status_node 1 + } else { + set secoptype $secoptype0 + set status_node 0 + } + switch -- $secoptype { + double {set type float} + int - enum {set type int} + string { + set type text + # can not use SICS drivable for string + set kind "" + } + bool {set type text} + none {set type none} + default { + clientput "unknown type for $secopar (use text): $secoptype ($props(datatype))" + set type text + } + } + make_par0 $type $path $secopar $desc $kind + hsetprop $path secoptype $secoptype0 + if {$status_node} { + hsetprop $path nonewline 1 + } + lassign [split $path /] nul obj par + set fmtunit "" + if {[lsearch [list enum int double] $secoptype0] >= 0} { + set fmtunit "" + if {[info exists props(unit)]} { + set fmtunit [format { [%s]} $props(unit)] + } + if {$par eq "" || $par eq "target"} { + set unit [silent 1 set props(unit)] + if {[sct shownUnits] eq "ALL" || [lsearch [sct shownUnits] $unit] >= 0} { + GraphAdd $path $unit + } + } + } + if {[info exists props(description)]} { + hsetprop $path help "$props(description)$fmtunit" + unset props(description) + } + switch -- $secoptype { + enum { + set enumprop [list] + set wid 8 + set sorted [list] + foreach {name value} [lindex $validator_args 0] { + lappend sorted [list $value $name] + } + foreach value_name [lsort -integer -index 0 $sorted] { + lassign $value_name value name + lappend enumprop "$name=$value" + set wid [expr max($wid,[string length $name])] + } + hsetprop $path enum [join $enumprop ,] + if {[silent "" hgetpropval $path type] eq "drivable"} { + hsetprop $path visible false + } + if {$wid > 8} { + hsetprop $path width $wid + } + } + bool { + hsetprop $path enum 1 + hsetprop $path validator secop::check_bool + } + double - int { + hsetprop $path validator [concat secop::check_range $validator_args] + } + string { + hsetprop $path width 16 + hsetprop $path validator [concat secop::check_range $validator_args] + } + } + return $path +} + +proc secop::make_par0 {type path secopar desc {kind std}} { + array set props $desc + # clientput "$path $desc" + set readonly [silent 0 set props(readonly)] + if {$readonly} { + set priv internal + } else { + set priv user + } + if {[silent "" hinfo $path] ne ""} { + error "$path exists already!" + } + lassign [split $path /] nul obj par + if {$par eq ""} { + if {$kind eq "driv"} { + dynsctdriveobj $obj float user SECoP [sct controller] + hfactory $path link $obj + hsetprop $obj checklimits secop::checklimits + hsetprop $obj checkstatus secop::checkstatus + hsetprop $obj halt secop::halt + # allow start without run: + hsetprop $obj check secop::checklimits + hsetprop $obj write secop::complete_run + set readonly 0 + hsetprop $obj sicscommand "run $obj" + } else { + # clientput "OBJ $obj $type" + dynsicsobj $obj SECoP $priv $type + hfactory $path link $obj + } + hsetprop $path group $obj + hsetprop $path s_group $obj + hsetprop $path objectPath $path + hsetprop /sics/[sct controller] p_$secopar:value $path + } else { + if {$par eq "status"} { + set path /$obj/status_code + } + # clientput "PAR $path $type [array get props]" + hfactory $path plain $priv $type + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } + hsetprop $path secopar $secopar + hsetprop /sics/[sct controller] p_$secopar $path + if {!$readonly} { + [sct controller] write $path + } else { + [sct controller] connect $path + } + logsetup $path 1 + if {[info exists props(value)]} { + clientput "VALUE in descr $path" + if {[catch {hupdate /$path $props(value)} msg]} { + clientput $msg + } + unset props(value) + } + foreach {prop item} [array get props] { + hsetprop $path s_$prop $item + } +} + +proc secop::make_cmd {secopar desc {first 0}} { + array set props $desc + set path [topath $secopar [silent "" dict get $desc group]] + set cmd [join [lassign [split $path /] _ obj] /] + lassign [lindex [silent "" set props(datatype)] 1] secoptype validator + if {$secoptype eq "None"} { + $obj makescriptfunc $cmd "secop::check_cmd [sct secopPath] $secopar" user + hsetprop $path newline $first + hsetprop $path secopar $secopar + hsetprop $path sicscommand "$obj $cmd" + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } else { + if {[llength $secoptype] == 1} { + set secoptype [lindex $secoptype 0] + } + dict set desc datatype $secoptype + make_par $secopar $desc + lassign $secoptype maintype + if {$maintype eq "double" || $maintype eq "int" || $maintype eq "bool"} { + hsetprop $path check "secop::check_cmd_num [sct secopPath] $secopar" + } else { + hsetprop $path check "secop::check_cmd_text [sct secopPath] $secopar" + } + } +} + +proc secop::check_cmd {secopPath secopar} { + hset $secopPath "do $secopar" +} + +proc secop::check_cmd_num {secopPath secopar} { + hset $secopPath [format {do %s %.15g} $secopar [sct target]] + sct update [sct target] +} + +proc secop::check_cmd_text {secopPath secopar} { + hset $secopPath [format {do %s "%s"} $secopar [sct target]] + sct update [sct target] +} + +proc secop::make_module {obj desc} { + clientput "MAKE_MODULE $obj" + if {[obj_list exists $obj]} { + clientput "$obj exists already" + return + } + obj_list makeitem $obj /$obj + + array unset modprop + set parlist [list] + set pardict [dict create] + foreach {key item} $desc { + switch $key { + accessibles { + foreach acsitm $item { + lassign $acsitm parname pardesc + dict set pardict $parname $pardesc + } + } + default { + set modprop($key) $item + } + } + } + if {[dict exists $pardict value]} { + set value [dict get $pardict value] + dict unset pardict value + } else { + set value [dict create datatype none] + } + set classes [silent "" set modprop(interface_class)] + if {[string match "* Drivable *" " $classes "]} { + set path [make_par $obj $value driv] + } else { + set path [make_par $obj $value] + } + if {[info exists modprop(visibility)] && $modprop(visibility) >= 3} { + hdelprop $path group + } + foreach {prop val} [array get modprop] { + hsetprop $obj sm_$prop $val + } + device_layout makeitem /$obj [silent 0 set modprop(layoutpos)] + + set groups [dict create] + foreach {parname pardesc} $pardict { + if {[dict exists $pardesc group]} { + dict set groups [dict get $pardesc group] 1 + } + } + foreach g [dict keys $groups] { + clientput "GROUP $g" + hfactory $obj/$g plain user none + hsetprop $obj/$g group "group $g" + } + set shortcmds [list] + foreach {parname pardesc} $pardict { + set datatype [dict get $pardesc datatype] + if {[lindex $datatype 0] eq "command"} { + if {[lindex $datatype 1] ne "None"} { + # only commands with arguments + make_cmd $obj:$parname $pardesc 1 + } else { + lappend shortcmds $parname $pardesc + } + } else { + make_par $obj:$parname $pardesc + } + } + # then commands without arguments, on one line + set first 1 + foreach {parname pardesc} $shortcmds { + make_cmd $obj:$parname $pardesc $first + set first 0 + } +} + +proc secop::make_node {desc} { + array unset nodeprop + set modlist [list] + foreach {key item} $desc { + switch $key { + modules { + set modlist $item + } + default { + set nodeprop($key) $item + } + } + } + foreach moditem $modlist { + lassign $moditem modname moddesc + make_module $modname $moddesc + } + foreach {prop val} [array get nodeprop] { + sct sn_$prop $val + } + sort_layout +} + +proc secop::topath {secopar {pargroup ""}} { + lassign [split [string tolower $secopar] :] module parameter + if {$parameter eq "value" || $parameter eq ""} { + return "/$module" + } + if {$parameter eq "status"} { + set parameter status_code + } + if {[string match {_*} $parameter]} { + set parameter [string range $parameter 1 end] + } + if {$pargroup ne ""} { + return "/$module/$pargroup/$parameter" + } + return "/$module/$parameter" +} + +proc secop::update_ {} { + if {[silent "" sct result] eq ""} { + return idle + } + set sent_message [silent "" sct sent_message] + set message_to_client "" + + lassign "[sct result]" messagetype par val + set path [silent "" hgetpropval /sics/[sct controller] p_$par] + lassign [split $par :] obj + switch $messagetype { + update - changed { + # clientput "*** [DoubleTime]: [sct result]" + #if {[sct] ne "/secop"} { + # clientput "[sct] is not /secop, why?" + #} + #if {![sct active]} { + # clientput [sct result] + #} + if {$messagetype eq "changed"} { + if {[string match *:target $par]} { + hsetprop /$obj writestatus done + } + hsetprop $path changed 0 + if {[lrange $sent_message 0 1] eq [list change $par]} { + set message_to_client [sct result] + } + # clientput "CH $path [sct result]" + } else { + if {[DoubleTime] < [silent 0 hgetpropval $path changed] + 10} { + # ignore updates of variables during change + # clientput "ignore [sct result]" + return idle + } + if {[lrange $sent_message 0 1] eq [list read $par]} { + set message_to_client [sct result] + } + } + lassign $val value qual + if {[silent 0 hgetpropval $path secoptype] eq "tuple" && + [string match *:status $par]} { + if {[llength $value] > 2} { + set text_value [lrange $value 1 end] + } else { + set text_value [lindex $value 1] + } + set objpath [sct parent $path] + lassign $value value + if {$value != 0} { + hsetprop $objpath group [hgetpropval $objpath s_group] + set shown 1 + } else { + catch {hdelprop $objpath group} + set shown 0 + } + if {$value < 100 || $value >= 400} { # error + updateerror $objpath $text_value + catch { + logsetup $objpath/target clear + } + } else { + # logsetup $objpath 1 + updateval $objpath [hvali $objpath] + } + GraphItem shown $objpath $shown + if {[silent "" hgetpropval $objpath/target logger_name] ne ""} { + GraphItem shown $objpath/target $shown + } + set text_path [regsub {status_code$} $path status_text] + if {[catch {updateval $text_path $text_value}]} { + clientput "cannot update $text_path to $text_value" + clientput "MSG([sct result])" + } + } + if {[catch {updateval $path $value} msg]} { + if {$value eq "None"} { + hsetprop $path geterror None + } else { + clientput "cannot update $path to $value" + clientput $msg + } + } elseif {[string match *:target $par]} { + if {[string match 1* [silent 0 hval /$obj/status_code]]} { + hsetprop /$obj target $value + } + } + catch { + hsetprop $path timestamp [dict get $qual t] + } + } + pong { + if {[lindex $sent_message 0] eq "ping"} { + set message_to_client [sct result] + } + } + done { + if {[lrange $sent_message 0 2] eq [list do $par]} { + set message_to_client [sct result] + } else { + clientput "done $par $val" + } + } + active { + if {[lindex $sent_message 0] eq "activate"} { + set message_to_client [sct result] + } else { + clientput ACTIVE + } + sct active 1 + sct end_fast 0 + } + error { + lassign $val origin errortext + lassign $origin requesttype requestpar requestval + set path [silent "" hgetpropval /sics/[sct controller] p_$requestpar] + if {$requesttype eq "change" && $path ne ""} { + hsetprop $path changed 0 + } + if {$origin eq $sent_message} { + set message_to_client [sct result] + } else { + clientput "ERROR: $path $errortext" + } + } + describing { + do_as_manager { + make_node $val + } + [sct controller] poll [sct] 0.01 + sct send activate + return secop::update_ + } + default { + if {[string match "*,*" $messagetype]} { + clientput IDN=[sct result] + sct send describe + sct active 0 + return secop::update_ + } + if {$sent_message ne ""} { + set message_to_client [sct result] + } else { + # show untreated message + clientput [sct result] + } + } + } + if {$message_to_client ne ""} { + clientput "> $sent_message\n< $message_to_client" + sct sent_message "" + sct sent_time 1e20 + } elseif {[DoubleTime] > [silent 1e20 sct sent_time] + 10} { + clientput "timeout waiting for response to $sent_message" + sct sent_message "" + sct sent_time 1e20 + } + #if {[DoubleTime] < [sct end_fast]} { + # return secop::get + #} + # [sct controller] queue [sct] read secop::get + return idle +} + +proc secop::checklimits {} { + # for whatever strange reason checklimits is called twice + # in addition again as write script of the obj node + # do this only once + set ws [silent 0 sct writestatus] + if {$ws ne "checked" && $ws ne "start" || + [sct target] != [silent "x" hgetpropval [sct]/target target]} { + hset [sct]/target [sct target] + sct writestatus checked + } +} + +proc secop::checkstatus {} { + set ws [silent 0 sct writestatus] + set status [hvali [sct]/status_code] + if {[string match 3* $status]} { + set result run + } elseif {[string match 4* $status]} { + set result posfault + } else { + if {$ws ne "done"} { + set result run + } else { + set result idle + } + } + sct status $result + return $result +} + +proc secop::complete_run {} { + sct print "run [sct objectName] to [sct target]" + return idle +} + +proc secop::halt {} { + [sct objectName] stop + sct writestatus done + # clientput HALT:[sct] + return idle +} + +proc secop::start {} { + sct send *IDN? + return secop::update_ +} + +proc secop::describe {} { + sct send describe + return secop::describing +} + +proc secop::describing {} { + #obsolete? + lassign [sct result] messagetype par val + switch $messagetype { + describing { + do_as_manager { + make_node $val + } + } + default { + clientput "ignore $messagetype $par ..." + } + } + sct send activate + sct end_fast [expr [DoubleTime] + 5] + return secop::update_ +} + +proc secop_send {args} { + hset /secop $args + hsetprop /secop sent_message $args + hsetprop /secop sent_time [DoubleTime] +} + +publishLazy secop_send diff --git a/tcl/drivers/secop_2.tcl b/tcl/drivers/secop_2.tcl new file mode 100644 index 0000000..b74e365 --- /dev/null +++ b/tcl/drivers/secop_2.tcl @@ -0,0 +1,752 @@ +# secop driver 2 (v1.0c): after datatype modification + +namespace eval secop {} { +} + +proc stdConfig::secop {{shownUnits ALL}} { + variable node + variable name + + controller secop3 timeout=60 + prop commerror secop::errorscript_ + prop connection_lost 0 + prop check secop::check + prop write secop::write + prop startcmd *IDN? + prop end_fast 0 + prop secopPath /$name + prop active 0 + prop shownUnits $shownUnits + + set node $node/tasks + prop start secop::start + + pollperiod 0.001 0.001 + obj SECoP -text wr + + prop read secop::readmsg_ + prop test secop::test + prop check secop::checkmsg + prop write secop::writemsg + prop cmd "" + + variable ctrl + variable path + hsetprop /sics/$ctrl ignore_no_response 1 + +} + +proc secop::errorscript_ {} { + if {[string match {ASCERR: no response*} [sct result]]} { + sct send ping + return secop::update_ + } + sct connection_lost 1 + [sct controller] poll [sct] 1 + error [sct result] +} + +proc secop::checkmsg {} { +# variable MQ[sct] +# upvar 0 MQ[sct] mq +# if {![info exists mq]} { +# # create message queue +# set mq [list] +# } +# if {[llength $mq] > 0} { +# set next [lindex $mq 0] +# set mq [lrange $mq 1 end] +# lappend mq [sct target] +# sct target $next +# } + + return "" +} + +proc secop::writemsg {} { + sct send [sct target] + return secop::update_ +} + +proc secop::readmsg_ {} { # ending with _: invisible on debug + if {[sct connection_lost]} { + sct connection_lost 0 + return [secop::start] + } + sct send "" + return secop::update_ +} + +proc secop::test {} { + clientput test + return idle +} + +proc secop::check {} { + if {[silent "" sct secopar] eq ""} return + set validator [silent {} sct validator] + eval $validator + lassign [split [hinfo [sct]] ","] type + if {$type eq "text"} { + set msg "change [sct secopar] \"[sct target]\"" + } else { + set msg "change [sct secopar] [sct target]" + } + [sct controller] que [sct secopPath] write [list secop::queuedwrite $msg] +} + +proc secop::queuedwrite {msg} { + sct changed [DoubleTime] + # send message on /secop node + sct sent_message $msg + sct send $msg + return secop::update_ +} + +proc secop::write {} { + # dummy write + # clientput "secop::write [sct] [hvali [sct]]" + return idle +} + +proc secop::get {} { + error "secop::get is obsolete" + sct send "" + return secop::update_ +} + +proc secop::check_range {min max {absolute_resolution 0} {relative_resolution 0}} { + set prec [expr max($absolute_resolution, $relative_resolution * abs([sct target]))] +clientput "*** $prec [sct target] $max" + if {[sct target] < $min} { + if {[sct target] >= $min - $prec} { + sct target $min + return + } + } elseif {[sct target] > $max} { + if {[sct target] <= $max + $prec} { + sct target $max + return + } + } else { + return + } + error "[sct] value must be within \[$min, $max\]" +} + +proc secop::check_length {min max} { + set len [string length [sct target]] + if {$len < $min || $len > $max} { + error "[sct] string length must be within \[$min, $max\]" + } +} + +proc secop::check_bool {} { + switch -- [string tolower [sct target]] { + off - false - no - 0 - on - true - yes - 1 { + return + } + } + error "illegal value for boolean: [sct target]" +} + +proc secop::check_length {{low None} {high None}} { + if {$low ne "None" && [string length [sct target]] < $low} { + error "value [sct target] must not be shorter than $low" + } + if {$high ne "None" && [string length [sct target]] > $high} { + error "value [sct target] must not be longer than $high" + } +} + +proc secop::make_par {secopar desc {kind ""}} { + set path [topath $secopar [silent "" dict get $desc group]] + array set props $desc + lassign [silent "" set props(datatype)] secoptype0 datadesc + if {$secoptype0 eq "tuple" && [string match *:status $secopar]} { + set members [dict get $datadesc members] + # lassign $validator_args members + set text_path [regsub {status_code$} $path status_text] + make_par0 text $text_path $secopar $desc + hsetprop $text_path width 24 + lassign [lindex $members 0] secoptype datadesc + set status_node 1 + } else { + set secoptype $secoptype0 + set status_node 0 + } + switch -- $secoptype { + double {set type float} + int - enum {set type int} + string { + set type text + # can not use SICS drivable for string + set kind "" + } + bool {set type text} + none {set type none} + default { + clientput "unknown type for $secopar (use text): $secoptype ($props(datatype))" + set type text + } + } + make_par0 $type $path $secopar $desc $kind + hsetprop $path secoptype $secoptype0 + if {$status_node} { + hsetprop $path nonewline 1 + } + lassign [split $path /] nul obj par + set fmtunit "" + if {[lsearch [list enum int double] $secoptype0] >= 0} { + set fmtunit "" + if {[catch {set unit [dict get $datadesc unit]}]} { + set unit 1 + } else { + set fmtunit [format { [%s]} $unit] + } + if {$par eq "" || $par eq "target"} { + if {[sct shownUnits] eq "ALL" || [lsearch [sct shownUnits] $unit] >= 0} { + GraphAdd $path $unit + } + } + } + if {[info exists props(description)]} { + hsetprop $path help "$props(description)$fmtunit" + unset props(description) + } + switch -- $secoptype { + enum { + set enumprop [list] + set wid 8 + set sorted [list] + set members [dict get $datadesc members] + + foreach {name value} $members { + lappend sorted [list $value $name] + } + foreach value_name [lsort -integer -index 0 $sorted] { + lassign $value_name value name + lappend enumprop "$name=$value" + set wid [expr max($wid,[string length $name])] + } + hsetprop $path enum [join $enumprop ,] + if {[silent "" hgetpropval $path type] eq "drivable"} { + hsetprop $path visible false + } + if {$wid > 8} { + hsetprop $path width $wid + } + } + bool { + hsetprop $path enum 1 + hsetprop $path validator secop::check_bool + } + double { + set min [silent -inf dict get $datadesc min] + set max [silent inf dict get $datadesc max] + set absolute_resolution [silent 0 dict get $datadesc absolute_resolution] + set relative_resolution [silent 1.2e-7 dict get $datadesc relative_resolution] + hsetprop $path validator [concat secop::check_range $min $max $absolute_resolution $relative_resolution] + } + int { + set min [silent -inf dict get $datadesc min] + set max [silent inf dict get $datadesc max] + hsetprop $path validator [concat secop::check_range $min $max] + } + string { + set min [silent -inf dict get $datadesc min] + set max [silent inf dict get $datadesc max] + hsetprop $path width 16 + hsetprop $path validator [concat secop::check_length $min $max] + } + } + return $path +} + +proc secop::make_par0 {type path secopar desc {kind std}} { + array set props $desc + # clientput "$path $desc" + set readonly [silent 0 set props(readonly)] + if {$readonly} { + set priv internal + } else { + set priv user + } + if {[silent "" hinfo $path] ne ""} { + error "$path exists already!" + } + lassign [split $path /] nul obj par + if {$par eq ""} { + if {$kind eq "driv"} { + dynsctdriveobj $obj float user SECoP [sct controller] + hfactory $path link $obj + hsetprop $obj checklimits secop::checklimits + # hsetprop $obj checkstatus secop::checkstatus + hsetprop $obj halt secop::halt + # allow start without run: + hsetprop $obj check secop::checklimits + hsetprop $obj write secop::complete_run + set readonly 0 + hsetprop $obj sicscommand "run $obj" + } else { + # clientput "OBJ $obj $type" + dynsicsobj $obj SECoP $priv $type + hfactory $path link $obj + } + hsetprop $path group $obj + hsetprop $path s_group $obj + hsetprop $path objectPath $path + hsetprop /sics/[sct controller] p_$secopar:value $path + } else { + if {$par eq "status"} { + set path /$obj/status_code + } + # clientput "PAR $path $type [array get props]" + hfactory $path plain $priv $type + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } + hsetprop $path secopar $secopar + hsetprop /sics/[sct controller] p_$secopar $path + if {!$readonly} { + [sct controller] write $path + } else { + [sct controller] connect $path + } + logsetup $path 1 + if {[info exists props(value)]} { + clientput "VALUE in descr $path" + if {[catch {hupdate /$path $props(value)} msg]} { + clientput $msg + } + unset props(value) + } + foreach {prop item} [array get props] { + hsetprop $path s_$prop $item + } +} + +proc secop::make_cmd {secopar desc {first 0}} { + array set props $desc + set path [topath $secopar [silent "" dict get $desc group]] + set cmd [join [lassign [split $path /] _ obj] /] + set datadesc [lindex $props(datatype) 1] + set argument None + catch { + set argument [dict get $datadesc argument] + } + if {$argument eq "None"} { + $obj makescriptfunc $cmd "secop::check_cmd [sct secopPath] $secopar" user + hsetprop $path newline $first + hsetprop $path secopar $secopar + hsetprop $path sicscommand "$obj $cmd" + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } else { + dict set desc datatype $argument + make_par $secopar $desc + lassign $argument maintype datadesc + if {$maintype eq "double" || $maintype eq "int" || $maintype eq "bool"} { + hsetprop $path check "secop::check_cmd_num [sct secopPath] $secopar" + } else { + hsetprop $path check "secop::check_cmd_text [sct secopPath] $secopar" + } + } +} + +proc secop::check_cmd {secopPath secopar} { + hset $secopPath "do $secopar" +} + +proc secop::check_cmd_num {secopPath secopar} { + hset $secopPath [format {do %s %.15g} $secopar [sct target]] + sct update [sct target] +} + +proc secop::check_cmd_text {secopPath secopar} { + hset $secopPath [format {do %s "%s"} $secopar [sct target]] + sct update [sct target] +} + +proc secop::make_module {obj desc} { + clientput "MAKE_MODULE $obj" + if {[obj_list exists $obj]} { + clientput "$obj exists already" + return + } + obj_list makeitem $obj /$obj + + array unset modprop + set parlist [list] + set pardict [dict create] + foreach {key item} $desc { + switch $key { + accessibles { + foreach acsitm $item { + lassign $acsitm parname pardesc + dict set pardict $parname $pardesc + } + } + default { + set modprop($key) $item + } + } + } + if {[dict exists $pardict value]} { + set value [dict get $pardict value] + dict unset pardict value + } else { + set value [dict create datatype none] + } + set classes [silent "" set modprop(interface_class)] + if {[string match "* Drivable *" " $classes "]} { + set path [make_par $obj $value driv] + } else { + set path [make_par $obj $value] + } + if {[info exists modprop(visibility)] && $modprop(visibility) >= 3} { + hdelprop $path group + } + foreach {prop val} [array get modprop] { + hsetprop $obj sm_$prop $val + } + device_layout makeitem /$obj [silent 0 set modprop(layoutpos)] + + set groups [dict create] + foreach {parname pardesc} $pardict { + if {[dict exists $pardesc group]} { + dict set groups [dict get $pardesc group] 1 + } + } + foreach g [dict keys $groups] { + clientput "GROUP $g" + hfactory $obj/$g plain user none + hsetprop $obj/$g group "group $g" + } + set shortcmds [list] + foreach {parname pardesc} $pardict { + set datatype [dict get $pardesc datatype] + lassign $datatype secoptype datadesc + if {$secoptype eq "command"} { + if {[catch {set argument [dict get $datadesc argument]}]} { + set argument None + } + if {$argument ne "None"} { + # only commands with arguments + make_cmd $obj:$parname $pardesc 1 + } else { + lappend shortcmds $parname $pardesc + } + } else { + make_par $obj:$parname $pardesc + } + } + # then commands without arguments, on one line + set first 1 + foreach {parname pardesc} $shortcmds { + make_cmd $obj:$parname $pardesc $first + set first 0 + } +} + +proc secop::make_node {desc} { + array unset nodeprop + set modlist [list] + foreach {key item} $desc { + switch $key { + modules { + set modlist $item + } + default { + set nodeprop($key) $item + } + } + } + foreach moditem $modlist { + lassign $moditem modname moddesc + make_module $modname $moddesc + } + foreach {prop val} [array get nodeprop] { + sct sn_$prop $val + } + sort_layout +} + +proc secop::topath {secopar {pargroup ""}} { + lassign [split [string tolower $secopar] :] module parameter + if {$parameter eq "value" || $parameter eq ""} { + return "/$module" + } + if {$parameter eq "status"} { + set parameter status_code + } + if {[string match {_*} $parameter]} { + set parameter [string range $parameter 1 end] + } + if {$pargroup ne ""} { + return "/$module/$pargroup/$parameter" + } + return "/$module/$parameter" +} + +proc secop::update_ {{wait_for {}}} { + if {$wait_for eq ""} { + set return_script idle + } else { + set return_script "secop::update_ $wait_for" + } + if {[silent "" sct result] eq ""} { + return idle + } + set sent_message [silent "" sct sent_message] + set message_to_client "" + + lassign "[sct result]" messagetype par val + set path [silent "" hgetpropval /sics/[sct controller] p_$par] + lassign [split $par :] obj + switch $messagetype { + update - changed { + # clientput "*** [DoubleTime]: [sct result]" + #if {[sct] ne "/secop"} { + # clientput "[sct] is not /secop, why?" + #} + #if {![sct active]} { + # clientput [sct result] + #} + if {$messagetype eq "changed"} { + if {[string match *:target $par]} { + hsetprop /$obj writestatus done + } + hsetprop $path changed 0 + if {[lrange $sent_message 0 1] eq [list change $par]} { + set message_to_client [sct result] + } + # clientput "CH $path [sct result]" + } else { + if {[DoubleTime] < [silent 0 hgetpropval $path changed] + 10} { + # ignore updates of variables during change + clientput "ignore [sct result]" + return idle + } + if {[lrange $sent_message 0 1] eq [list read $par]} { + set message_to_client [sct result] + } + } + lassign $val value qual + if {[silent 0 hgetpropval $path secoptype] eq "tuple" && + [string match *:status $par]} { + if {[llength $value] > 2} { + set text_value [lrange $value 1 end] + } else { + set text_value [lindex $value 1] + } + set objpath [sct parent $path] + lassign $value value + if {$value != 0} { + hsetprop $objpath group [hgetpropval $objpath s_group] + set shown 1 + } else { + catch {hdelprop $objpath group} + set shown 0 + } + if {$value < 100 || $value >= 400} { # error + updateerror $objpath $text_value + catch { + logsetup $objpath/target clear + } + if {[silent 0 hgetpropval $objpath status] eq "run"} { + hsetprop $objpath status posfault + } + } else { + if {$value >= 300} { # busy + hsetprop $objpath status run + } else { + hsetprop $objpath status idle + } + logsetup $objpath 1 + } + GraphItem shown $objpath $shown + if {[silent "" hgetpropval $objpath/target logger_name] ne ""} { + GraphItem shown $objpath/target $shown + } + set text_path [regsub {status_code$} $path status_text] + if {[catch {updateval $text_path $text_value}]} { + clientput "cannot update $text_path to $text_value" + clientput "MSG([sct result])" + } + } + if {[catch {updateval $path $value} msg]} { + if {$value eq "None"} { + hsetprop $path geterror None + } else { + clientput "cannot update $path to $value" + clientput $msg + } + } elseif {[string match *:target $par]} { + if {[string match 1* [silent 0 hval /$obj/status_code]]} { + hsetprop /$obj target $value + } + } + catch { + hsetprop $path timestamp [dict get $qual t] + } + } + pong { + if {[lindex $sent_message 0] eq "ping"} { + set message_to_client [sct result] + } + } + done { + if {[lrange $sent_message 0 2] eq [list do $par]} { + set message_to_client [sct result] + } else { + clientput "done $par $val" + } + } + active { + if {[lindex $sent_message 0] eq "activate"} { + set message_to_client [sct result] + } else { + clientput ACTIVE + } + sct active 1 + sct end_fast 0 + } + error { + lassign $val origin errortext + lassign $origin requesttype requestpar requestval + set path [silent "" hgetpropval /sics/[sct controller] p_$requestpar] + if {$requesttype eq "change" && $path ne ""} { + hsetprop $path changed 0 + } + if {$origin eq $sent_message} { + set message_to_client [sct result] + } else { + clientput "ERROR: $path $errortext" + } + } + describing { + do_as_manager { + make_node $val + } + sct send activate + [sct controller] poll [sct] 0.001 + return secop::update_ + } + default { + if {[string match "*,*" $messagetype]} { + clientput IDN=[sct result] + sct send describe + sct active 0 + return secop::update_ + } + if {$sent_message ne ""} { + set message_to_client [sct result] + } else { + # show untreated message + clientput [sct result] + } + } + } + if {$message_to_client ne ""} { + clientput "[sct]:\n> $sent_message\n< $message_to_client" + sct sent_message "" + sct sent_time 1e20 + } elseif {[DoubleTime] > [silent 1e20 sct sent_time] + 10} { + clientput "timeout waiting for response to $sent_message" + sct sent_message "" + sct sent_time 1e20 + } + #if {[DoubleTime] < [sct end_fast]} { + # return secop::get + #} + # [sct controller] queue [sct] read secop::get + return idle +} + +proc secop::checklimits {} { + # for whatever strange reason checklimits is called twice + # in addition again as write script of the obj node + # do this only once + set ws [silent 0 sct writestatus] + if {$ws ne "checked" && $ws ne "start" || + [sct target] != [silent "x" hgetpropval [sct]/target target]} { + hset [sct]/target [sct target] + sct writestatus checked + sct status run + } +} + +proc secop::checkstatus {} { + # obsolete + set ws [silent 0 sct writestatus] + set status [hvali [sct]/status_code] + if {[string match 3* $status]} { + set result run + } elseif {[string match 4* $status]} { + set result posfault + } else { + if {$ws ne "done"} { + set result run + } else { + set result idle + } + } + sct status $result + return $result +} + +proc secop::complete_run {} { + sct print "run [sct objectName] to [sct target]" + return idle +} + +proc secop::halt {} { + [sct objectName] stop + sct writestatus done + sct status idle + # clientput HALT:[sct] + return idle +} + +proc secop::start {} { + sct send *IDN? + return secop::update_ +} + +proc secop::describe {} { + sct send describe + return secop::describing +} + +proc secop::describing {} { + #obsolete? + lassign [sct result] messagetype par val + switch $messagetype { + describing { + do_as_manager { + make_node $val + } + } + default { + clientput "ignore $messagetype $par ..." + } + } + sct send activate + sct end_fast [expr [DoubleTime] + 5] + return secop::update_ +} + +proc secop_send {args} { + hset /secop $args + hsetprop /secop sent_message $args + hsetprop /secop sent_time [DoubleTime] +} + +publishLazy secop_send diff --git a/tcl/drivers/secop_3.tcl b/tcl/drivers/secop_3.tcl new file mode 100644 index 0000000..9555211 --- /dev/null +++ b/tcl/drivers/secop_3.tcl @@ -0,0 +1,754 @@ +# secop driver 3 (v1.0 RC2): modules/accesibles are JSON objects, datatype is 1-element JSON object + +namespace eval secop {} { +} + +proc stdConfig::secop {{shownUnits ALL}} { + variable node + variable name + + controller secop3 timeout=60 + prop commerror secop::errorscript_ + prop connection_lost 0 + prop check secop::check + prop write secop::write + prop startcmd *IDN? + prop end_fast 0 + prop secopPath /$name + prop active 0 + prop shownUnits $shownUnits + + set node $node/tasks + prop start secop::start + + pollperiod 0.001 0.001 + obj SECoP -text wr + + prop read secop::readmsg_ + prop test secop::test + prop check secop::checkmsg + prop write secop::writemsg + prop cmd "" + + variable ctrl + variable path + hsetprop /sics/$ctrl ignore_no_response 1 + +} + +proc secop::errorscript_ {} { + if {[string match {ASCERR: no response*} [sct result]]} { + sct send ping + return secop::update_ + } + sct connection_lost 1 + [sct controller] poll [sct] 1 + error [sct result] +} + +proc secop::checkmsg {} { +# variable MQ[sct] +# upvar 0 MQ[sct] mq +# if {![info exists mq]} { +# # create message queue +# set mq [list] +# } +# if {[llength $mq] > 0} { +# set next [lindex $mq 0] +# set mq [lrange $mq 1 end] +# lappend mq [sct target] +# sct target $next +# } + + return "" +} + +proc secop::writemsg {} { + sct send [sct target] + return secop::update_ +} + +proc secop::readmsg_ {} { # ending with _: invisible on debug + if {[sct connection_lost]} { + sct connection_lost 0 + return [secop::start] + } + sct send "" + return secop::update_ +} + +proc secop::test {} { + clientput test + return idle +} + +proc secop::check {} { + if {[silent "" sct secopar] eq ""} return + set validator [silent {} sct validator] + eval $validator + lassign [split [hinfo [sct]] ","] type + if {$type eq "text"} { + set msg "change [sct secopar] \"[sct target]\"" + } else { + set msg "change [sct secopar] [sct target]" + } + [sct controller] que [sct secopPath] write [list secop::queuedwrite $msg] +} + +proc secop::queuedwrite {msg} { + sct changed [DoubleTime] + # send message on /secop node + sct sent_message $msg + sct send $msg + return secop::update_ +} + +proc secop::write {} { + # dummy write + # clientput "secop::write [sct] [hvali [sct]]" + return idle +} + +proc secop::get {} { + error "secop::get is obsolete" + sct send "" + return secop::update_ +} + +proc secop::check_range {min max {absolute_resolution 0} {relative_resolution 0}} { + set prec [expr max($absolute_resolution, $relative_resolution * abs([sct target]))] +clientput "*** $prec [sct target] $max" + if {[sct target] < $min} { + if {[sct target] >= $min - $prec} { + sct target $min + return + } + } elseif {[sct target] > $max} { + if {[sct target] <= $max + $prec} { + sct target $max + return + } + } else { + return + } + error "[sct] value must be within \[$min, $max\]" +} + +proc secop::check_length {min max} { + set len [string length [sct target]] + if {$len < $min || $len > $max} { + error "[sct] string length must be within \[$min, $max\]" + } +} + +proc secop::check_bool {} { + switch -- [string tolower [sct target]] { + off - false - no - 0 - on - true - yes - 1 { + return + } + } + error "illegal value for boolean: [sct target]" +} + +proc secop::check_length {{low None} {high None}} { + if {$low ne "None" && [string length [sct target]] < $low} { + error "value [sct target] must not be shorter than $low" + } + if {$high ne "None" && [string length [sct target]] > $high} { + error "value [sct target] must not be longer than $high" + } +} + +proc secop::make_par {secopar desc {kind ""}} { + set path [topath $secopar [silent "" dict get $desc group]] + array set props $desc + lassign [silent "" set props(datatype)] secoptype0 datadesc + if {$secoptype0 eq "tuple" && [string match *:status $secopar]} { + set members [dict get $datadesc members] + # lassign $validator_args members + set text_path [regsub {status_code$} $path status_text] + make_par0 text $text_path $secopar $desc + hsetprop $text_path width 24 + lassign [lindex $members 0] secoptype datadesc + set status_node 1 + } else { + set secoptype $secoptype0 + set status_node 0 + } + switch -- $secoptype { + double {set type float} + int - enum {set type int} + string { + set type text + # can not use SICS drivable for string + set kind "" + } + bool {set type text} + none {set type none} + default { + clientput "unknown type for $secopar (use text): $secoptype ($props(datatype))" + set type text + } + } + make_par0 $type $path $secopar $desc $kind + hsetprop $path secoptype $secoptype0 + if {$status_node} { + hsetprop $path nonewline 1 + } + lassign [split $path /] nul obj par + set fmtunit "" + if {[lsearch [list enum int double] $secoptype0] >= 0} { + set fmtunit "" + if {[catch {set unit [dict get $datadesc unit]}]} { + set unit 1 + } else { + set fmtunit [format { [%s]} $unit] + } + if {$par eq "" || $par eq "target"} { + if {[sct shownUnits] eq "ALL" || [lsearch [sct shownUnits] $unit] >= 0} { + GraphAdd $path $unit + } + } + } + if {[info exists props(description)]} { + hsetprop $path help "$props(description)$fmtunit" + unset props(description) + } + switch -- $secoptype { + enum { + set enumprop [list] + set wid 8 + set sorted [list] + set members [dict get $datadesc members] + + foreach {name value} $members { + lappend sorted [list $value $name] + } + foreach value_name [lsort -integer -index 0 $sorted] { + lassign $value_name value name + lappend enumprop "$name=$value" + set wid [expr max($wid,[string length $name])] + } + hsetprop $path enum [join $enumprop ,] + if {[silent "" hgetpropval $path type] eq "drivable"} { + hsetprop $path visible false + } + if {$wid > 8} { + hsetprop $path width $wid + } + } + bool { + hsetprop $path enum 1 + hsetprop $path validator secop::check_bool + } + double { + set min [silent -inf dict get $datadesc min] + set max [silent inf dict get $datadesc max] + set absolute_resolution [silent 0 dict get $datadesc absolute_resolution] + set relative_resolution [silent 1.2e-7 dict get $datadesc relative_resolution] + hsetprop $path validator [concat secop::check_range $min $max $absolute_resolution $relative_resolution] + } + int { + set min [silent -inf dict get $datadesc min] + set max [silent inf dict get $datadesc max] + hsetprop $path validator [concat secop::check_range $min $max] + } + string { + set min [silent -inf dict get $datadesc min] + set max [silent inf dict get $datadesc max] + hsetprop $path width 16 + hsetprop $path validator [concat secop::check_length $min $max] + } + } + return $path +} + +proc secop::make_par0 {type path secopar desc {kind std}} { + array set props $desc + # clientput "$path $desc" + set readonly [silent 0 set props(readonly)] + if {$readonly} { + set priv internal + } else { + set priv user + } + if {[silent "" hinfo $path] ne ""} { + error "$path exists already!" + } + lassign [split $path /] nul obj par + if {$par eq ""} { + if {$kind eq "driv"} { + dynsctdriveobj $obj float user SECoP [sct controller] + hfactory $path link $obj + hsetprop $obj checklimits secop::checklimits + # hsetprop $obj checkstatus secop::checkstatus + hsetprop $obj halt secop::halt + # allow start without run: + hsetprop $obj check secop::checklimits + hsetprop $obj write secop::complete_run + set readonly 0 + hsetprop $obj sicscommand "run $obj" + } else { + # clientput "OBJ $obj $type" + dynsicsobj $obj SECoP $priv $type + hfactory $path link $obj + } + hsetprop $path group $obj + hsetprop $path s_group $obj + hsetprop $path objectPath $path + hsetprop /sics/[sct controller] p_$secopar:value $path + } else { + if {$par eq "status"} { + set path /$obj/status_code + } + # clientput "PAR $path $type [array get props]" + hfactory $path plain $priv $type + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } + hsetprop $path secopar $secopar + hsetprop /sics/[sct controller] p_$secopar $path + if {!$readonly} { + [sct controller] write $path + } else { + [sct controller] connect $path + } + logsetup $path 1 + if {[info exists props(value)]} { + clientput "VALUE in descr $path" + if {[catch {hupdate /$path $props(value)} msg]} { + clientput $msg + } + unset props(value) + } + foreach {prop item} [array get props] { + hsetprop $path s_$prop $item + } +} + +proc secop::make_cmd {secopar desc {first 0}} { + array set props $desc + set path [topath $secopar [silent "" dict get $desc group]] + set cmd [join [lassign [split $path /] _ obj] /] + set datadesc [lindex $props(datatype) 1] + set argument None + catch { + set argument [dict get $datadesc argument] + } + if {$argument eq "None"} { + $obj makescriptfunc $cmd "secop::check_cmd [sct secopPath] $secopar" user + hsetprop $path newline $first + hsetprop $path secopar $secopar + hsetprop $path sicscommand "$obj $cmd" + if {[info exists props(visibility)]} { + if {$props(visibility) >= 3} { + hsetprop $path visible false + } + } + } else { + dict set desc datatype $argument + make_par $secopar $desc + lassign $argument maintype datadesc + if {$maintype eq "double" || $maintype eq "int" || $maintype eq "bool"} { + hsetprop $path check "secop::check_cmd_num [sct secopPath] $secopar" + } else { + hsetprop $path check "secop::check_cmd_text [sct secopPath] $secopar" + } + } +} + +proc secop::check_cmd {secopPath secopar} { + hset $secopPath "do $secopar" +} + +proc secop::check_cmd_num {secopPath secopar} { + hset $secopPath [format {do %s %.15g} $secopar [sct target]] + sct update [sct target] +} + +proc secop::check_cmd_text {secopPath secopar} { + hset $secopPath [format {do %s "%s"} $secopar [sct target]] + sct update [sct target] +} + +proc secop::make_module {obj desc} { + clientput "MAKE_MODULE $obj" + if {[obj_list exists $obj]} { + clientput "$obj exists already" + return + } + obj_list makeitem $obj /$obj + + array unset modprop + set parlist [list] + set pardict [dict create] + foreach {key item} $desc { + switch $key { + accessibles { +# foreach acsitm $item { +# lassign $acsitm parname pardesc +# dict set pardict $parname $pardesc +# } + foreach {parname pardesc} $item { + dict set pardict $parname $pardesc + } + } + default { + set modprop($key) $item + } + } + } + if {[dict exists $pardict value]} { + set value [dict get $pardict value] + dict unset pardict value + } else { + set value [dict create datatype none] + } + set classes [silent "" set modprop(interface_class)] + if {[string match "* Drivable *" " $classes "]} { + set path [make_par $obj $value driv] + } else { + set path [make_par $obj $value] + } + if {[info exists modprop(visibility)] && $modprop(visibility) >= 3} { + hdelprop $path group + } + foreach {prop val} [array get modprop] { + hsetprop $obj sm_$prop $val + } + device_layout makeitem /$obj [silent 0 set modprop(layoutpos)] + + set groups [dict create] + foreach {parname pardesc} $pardict { + if {[dict exists $pardesc group]} { + dict set groups [dict get $pardesc group] 1 + } + } + foreach g [dict keys $groups] { + clientput "GROUP $g" + hfactory $obj/$g plain user none + hsetprop $obj/$g group "group $g" + } + set shortcmds [list] + foreach {parname pardesc} $pardict { + set datatype [dict get $pardesc datatype] + lassign $datatype secoptype datadesc + if {$secoptype eq "command"} { + if {[catch {set argument [dict get $datadesc argument]}]} { + set argument None + } + if {$argument ne "None"} { + # only commands with arguments + make_cmd $obj:$parname $pardesc 1 + } else { + lappend shortcmds $parname $pardesc + } + } else { + make_par $obj:$parname $pardesc + } + } + # then commands without arguments, on one line + set first 1 + foreach {parname pardesc} $shortcmds { + make_cmd $obj:$parname $pardesc $first + set first 0 + } +} + +proc secop::make_node {desc} { + array unset nodeprop + set modlist [list] + foreach {key item} $desc { + switch $key { + modules { + set modlist $item + } + default { + set nodeprop($key) $item + } + } + } + foreach {modname moddesc} $modlist { + make_module $modname $moddesc + } + foreach {prop val} [array get nodeprop] { + sct sn_$prop $val + } + sort_layout +} + +proc secop::topath {secopar {pargroup ""}} { + lassign [split [string tolower $secopar] :] module parameter + if {$parameter eq "value" || $parameter eq ""} { + return "/$module" + } + if {$parameter eq "status"} { + set parameter status_code + } + if {[string match {_*} $parameter]} { + set parameter [string range $parameter 1 end] + } + if {$pargroup ne ""} { + return "/$module/$pargroup/$parameter" + } + return "/$module/$parameter" +} + +proc secop::update_ {{wait_for {}}} { + if {$wait_for eq ""} { + set return_script idle + } else { + set return_script "secop::update_ $wait_for" + } + if {[silent "" sct result] eq ""} { + return idle + } + set sent_message [silent "" sct sent_message] + set message_to_client "" + + lassign "[sct result]" messagetype par val + set path [silent "" hgetpropval /sics/[sct controller] p_$par] + lassign [split $par :] obj + switch $messagetype { + update - changed { + # clientput "*** [DoubleTime]: [sct result]" + #if {[sct] ne "/secop"} { + # clientput "[sct] is not /secop, why?" + #} + #if {![sct active]} { + # clientput [sct result] + #} + if {$messagetype eq "changed"} { + if {[string match *:target $par]} { + hsetprop /$obj writestatus done + } + hsetprop $path changed 0 + if {[lrange $sent_message 0 1] eq [list change $par]} { + set message_to_client [sct result] + } + # clientput "CH $path [sct result]" + } else { + if {[DoubleTime] < [silent 0 hgetpropval $path changed] + 10} { + # ignore updates of variables during change + clientput "ignore [sct result]" + return idle + } + if {[lrange $sent_message 0 1] eq [list read $par]} { + set message_to_client [sct result] + } + } + lassign $val value qual + if {[silent 0 hgetpropval $path secoptype] eq "tuple" && + [string match *:status $par]} { + if {[llength $value] > 2} { + set text_value [lrange $value 1 end] + } else { + set text_value [lindex $value 1] + } + set objpath [sct parent $path] + lassign $value value + if {$value != 0} { + hsetprop $objpath group [hgetpropval $objpath s_group] + set shown 1 + } else { + catch {hdelprop $objpath group} + set shown 0 + } + if {$value < 100 || $value >= 400} { # error + updateerror $objpath $text_value + catch { + logsetup $objpath/target clear + } + if {[silent 0 hgetpropval $objpath status] eq "run"} { + hsetprop $objpath status posfault + } + } else { + if {$value >= 300} { # busy + hsetprop $objpath status run + } else { + hsetprop $objpath status idle + } + logsetup $objpath 1 + } + GraphItem shown $objpath $shown + if {[silent "" hgetpropval $objpath/target logger_name] ne ""} { + GraphItem shown $objpath/target $shown + } + set text_path [regsub {status_code$} $path status_text] + if {[catch {updateval $text_path $text_value}]} { + clientput "cannot update $text_path to $text_value" + clientput "MSG([sct result])" + } + } + if {[catch {updateval $path $value} msg]} { + if {$value eq "None"} { + hsetprop $path geterror None + } else { + clientput "cannot update $path to $value" + clientput $msg + } + } elseif {[string match *:target $par]} { + if {[string match 1* [silent 0 hval /$obj/status_code]]} { + hsetprop /$obj target $value + } + } + catch { + hsetprop $path timestamp [dict get $qual t] + } + } + pong { + if {[lindex $sent_message 0] eq "ping"} { + set message_to_client [sct result] + } + } + done { + if {[lrange $sent_message 0 2] eq [list do $par]} { + set message_to_client [sct result] + } else { + clientput "done $par $val" + } + } + active { + if {[lindex $sent_message 0] eq "activate"} { + set message_to_client [sct result] + } else { + clientput ACTIVE + } + sct active 1 + sct end_fast 0 + } + error { + lassign $val origin errortext + lassign $origin requesttype requestpar requestval + set path [silent "" hgetpropval /sics/[sct controller] p_$requestpar] + if {$requesttype eq "change" && $path ne ""} { + hsetprop $path changed 0 + } + if {$origin eq $sent_message} { + set message_to_client [sct result] + } else { + clientput "ERROR: $path $errortext" + } + } + describing { + do_as_manager { + make_node $val + } + sct send activate + [sct controller] poll [sct] 0.001 + return secop::update_ + } + default { + if {[string match "*,*" $messagetype]} { + clientput IDN=[sct result] + sct send describe + sct active 0 + return secop::update_ + } + if {$sent_message ne ""} { + set message_to_client [sct result] + } else { + # show untreated message + clientput [sct result] + } + } + } + if {$message_to_client ne ""} { + clientput "[sct]:\n> $sent_message\n< $message_to_client" + sct sent_message "" + sct sent_time 1e20 + } elseif {[DoubleTime] > [silent 1e20 sct sent_time] + 10} { + clientput "timeout waiting for response to $sent_message" + sct sent_message "" + sct sent_time 1e20 + } + #if {[DoubleTime] < [sct end_fast]} { + # return secop::get + #} + # [sct controller] queue [sct] read secop::get + return idle +} + +proc secop::checklimits {} { + # for whatever strange reason checklimits is called twice + # in addition again as write script of the obj node + # do this only once + set ws [silent 0 sct writestatus] + if {$ws ne "checked" && $ws ne "start" || + [sct target] != [silent "x" hgetpropval [sct]/target target]} { + hset [sct]/target [sct target] + sct writestatus checked + sct status run + } +} + +proc secop::checkstatus {} { + # obsolete + set ws [silent 0 sct writestatus] + set status [hvali [sct]/status_code] + if {[string match 3* $status]} { + set result run + } elseif {[string match 4* $status]} { + set result posfault + } else { + if {$ws ne "done"} { + set result run + } else { + set result idle + } + } + sct status $result + return $result +} + +proc secop::complete_run {} { + sct print "run [sct objectName] to [sct target]" + return idle +} + +proc secop::halt {} { + [sct objectName] stop + sct writestatus done + sct status idle + # clientput HALT:[sct] + return idle +} + +proc secop::start {} { + sct send *IDN? + return secop::update_ +} + +proc secop::describe {} { + sct send describe + return secop::describing +} + +proc secop::describing {} { + #obsolete? + lassign [sct result] messagetype par val + switch $messagetype { + describing { + do_as_manager { + make_node $val + } + } + default { + clientput "ignore $messagetype $par ..." + } + } + sct send activate + sct end_fast [expr [DoubleTime] + 5] + return secop::update_ +} + +proc secop_send {args} { + hset /secop $args + hsetprop /secop sent_message $args + hsetprop /secop sent_time [DoubleTime] +} + +publishLazy secop_send diff --git a/tcl/drivers/sg382.tcl b/tcl/drivers/sg382.tcl new file mode 100644 index 0000000..e9df6d0 --- /dev/null +++ b/tcl/drivers/sg382.tcl @@ -0,0 +1,60 @@ +namespace eval sg382 {} { +} + +proc stdConfig::sg382 {} { + controller std "\r" 5 + prop startcmd "*IDN?" + + pollperiod 5 5 + + obj "SG382" wr + prop read sg382::read + prop write sg382::write + + kids "frequency generator" { + node base par 0 + prop width 12 + prop fmt %.8g + + node target -text out + prop write sg382::writetext + prop width 16 + } + + return "SG382 frequency generator" +} + +proc sg382::read {} { + sct send "FREQ?" + return sg382::update +} + +proc sg382::update {} { + set value [sct result] + hupdate [sct]/target $value + set base [hval [sct]/base] + if {abs($base - $value) > 1e6} { + set base [expr 1e5 * int($value / 1e5)] + hupdate [sct]/base $base + } + sct update [expr $value - $base] + return idle +} + +proc sg382::write {} { + set base [hval [sct]/base] + set value [expr [sct target] + $base] + if {abs($base - $value) > 1e6} { + set base [expr 1e5 * int($value / 1e5)] + hupdate [sct]/base $base + } + sct send "FREQ $value;FREQ?" + sct update [expr $value - $base] + return sg382::update +} + +proc sg382::writetext {} { + sct send "FREQ [sct target];FREQ?" + [sct controller] queue [sct parent] read read + return stdSct::completeUpdate +} diff --git a/tcl/drivers/smc.tcl b/tcl/drivers/smc.tcl new file mode 100644 index 0000000..58f6f26 --- /dev/null +++ b/tcl/drivers/smc.tcl @@ -0,0 +1,410 @@ +namespace eval smc { +} + +source drivers/magfield.tcl + +proc stdConfig::smc {} { + +# GPIB through Prologix controller + controller lsc timeout=5 writedelay=0.2 + prop write smc::write + prop read smc::read + + variable node + set node $node/tasks + prop start smc::start + + pollperiod 2 2 + + variable name + magfield_obj SMC_MAGFIELD "smc::cmd /$name/smc" + + kids "SMC magnet power supply" { + + magfield_kids + + node smc rd + prop read smc::read_gn + prop label persistent field + + kids "SMC settings" { + + node ramp_slow out + prop write smc::set_ramp_rate ramp_slow + default 0.04 + prop help "ramp rate for coils Tesla/min." + + node ramp_fast out + prop write smc::set_ramp_rate ramp_fast + default 100 + prop help "ramp rate for leads Tesla/min." + +# use MID as set_field + node set_field out + prop cmd L + prop get S + prop check smc::check_mid + + node at_target upd -int + prop enum 1 + + node heater wr -int + prop write smc::set_ramp_rate heater + prop enum 1 + prop cmd H + prop get J + prop "persistent switch heater" + + node ramp_state out -int + prop check smc::chk_ramp_state + prop write stdSct::complete + prop enum hold,goto_zero,goto_set + + node leads_set upd + prop help "calculated current in the leads, converted to Tesla" + + node leads_meas upd + prop help {measured current in the leads, converted to Tesla} + + node show_internals -int par 1 + prop enum 1 + prop newline 1 + prop show_more 1 + + node ramp_amp_sec wr + prop cmd A + prop get O + + node pause out -int + prop enum 1 + prop cmd P + prop get K + + node ramp_target wr -int + prop enum go2zero,go2mid,go2max + prop cmd R + prop get K + +# MAX is always kept as least as high as set_field + node max wr + prop cmd U + prop get S + + node units wr -int + prop enum amps,tesla + prop cmd T + prop get S + default 1 + + node calib out + prop cmd C + prop get O + + node heater_voltage out + prop cmd W + prop get O + + node volt_limit out + prop cmd Y + prop get S + + node xtrip out -int + prop cmd X + prop get K + + node volt upd + + node error_code upd -int + + node quench_field upd + + node v_at_lim upd -int + } + } +} + +proc smc::cmd {node args} { + set cmd [linsert $args 0 node_cmd $node] + if {[llength $args] < 2} { + return [eval $cmd] + } + lassign $args var val + set old [eval [list node_cmd $node $var]] + set scache [silent $old hgetpropval $node/$var cached_set] + if {[silent 0 hgetpropval $node/$var cache_state] == 2} { + set rcache [hgetpropval $node/$var cached_readback] + if {$rcache != $old || abs($scache - $rcache) > 0.1 * $scache} { + clientput "$node/$var: $old != $rcache || $scache far $rcache" + set scache $old + } + } else { + set scache $old + } + if {$val != $scache} { +# clientput "$node: set $var to $val" + hsetprop $node/$var cached_set $val + return [eval [list node_cmd $node $var $val]] + } + return $old +} + +proc smc::start {} { + sct send "++addr" + return smc::start1 +} + +proc smc::start1 {} { + sct send "O\n++read" + sct cnt 0 + return smc::start2 +} + +proc smc::start2 {} { + set id 0 + regexp {A.{19}(C.*)} [sct result] -> id + if {$id eq "0"} { + sct cnt [expr [sct cnt] + 1] + if {[sct cnt] < 5} { + sct send "O\n++read" + return smc::start2 + } + error "[sct] bad response from SMC: [sct result]" + } + sct send "T1\n++ver" + return "smc::start3 $id" +} + +proc smc::start3 {id} { + clientput [sct result] + sct result $id + return [stdSct::completeStart] +} + +proc smc::write {} { + update_field + sct send "[sct cmd][sct target]\n++auto" + sct update [sct target] + update_field + sct cache_state 1 + return "smc::read 1" +} + +proc smc::complete {} { + sct cache_state 1 +clientput "complete [sct]" + return idle +} + +proc smc::check_mid {} { + if {[sct target] > [hvali [sct parent]/max]} { + hset [sct parent]/max [sct target] + } +} + +proc smc::read {{from_write 0}} { + sct send "[sct get]\n++auto" + sct from_write $from_write + return smc::update0 +} + +proc smc::update0 {} { + sct send "++read eoi" + return smc::update +} + +proc smc::read_gn {} { + if {[hvali [sct]/units] == 0} { + sct get G + } else { + sct get N + } + return [smc::read] +} + +proc smc::eat_rubbish {} { + sct send "++read" + return stdSct::complete +} + +proc smc::update_field {} { + set op [sct objectPath] + magfield::simleads [hgetpropval $op script] pf ls + hupdate $op/smc/leads_set $ls + if {[hval $op/smc/heater]} { + hupdate $op/smc $ls + } +} + +proc smc::updateit {node val} { + updateval $node $val + switch [silent 0 hgetpropval $node cache_state] { + 1 { + set t [hgetpropval $node target] + if {$t != $val} { + clientput "$node set to $val (target [hgetpropval $node target])" + } else { + clientput "$node set to $val" + } + hsetprop $node cached_readback $val + hsetprop $node cache_state 2 + return + } + 2 { + if {[hgetpropval $node cached_readback] != $val} { + hsetprop $node cache_state 0 + } + } + } +} + +proc smc::update {} { + set r [sct result] + set op [sct objectPath]/smc + if {[regexp {T(.)U(.{7})L(.{7})Y(.{4})} $r -> t u l y]} { + set tst S + updateit $op/units $t + updateit $op/max $u + updateit $op/set_field $l + updateit $op/volt_limit $y + } elseif {[regexp {(F|I)(.{8})H(.)} $r -> fi f h]} { + set tst J + set pf [hvali $op] + if {$h == 0} { + if {$pf != $f} { + clientput "persistent $f" + } + updateit $op $f + } elseif {[catch {hval $op}]} { + updateit $op $pf + } + updateit $op/heater $h + } elseif {[regexp {(F|I)(.{8})V(.{4})R(.)(A|V)} $r -> fi f v r av]} { + set tst (G|N) + updateit $op/leads_meas $f + updateit $op/volt $v + if {$av eq "A"} { + updateit $op/v_at_lim 0 + } else { + updateit $op/v_at_lim 1 + } + } elseif {[regexp {R(.)M(.)P(.)X(.)H(.)Z0.00E(..)Q(.{8})} $r -> r m p x h e q]} { + set tst K + updateit $op/ramp_target $r + updateit $op/pause $p + if {$p} { + updateit $op/ramp_state 0 + } else { + updateit $op/at_target $m + incr r + if {$r > 2} { + set r 2 + } + updateit $op/ramp_state $r + } + updateit $op/xtrip $x + updateit $op/error_code $e + updateit $op/quench_field $q + } elseif {[regexp {A(.{8})D.T(.)B0W(.{4})C(.{8})} $r -> a t w c]} { + set tst O + updateit $op/ramp_amp_sec $a + set af [format %.3g [expr $a * $c * 60]] + set rf [hvali $op/ramp_fast] + set rs [hvali $op/ramp_slow] + set h [hvali $op/heater] + set am [expr sqrt($rf * $rs)] + if {$af > $am && $rf > $rs && $h == 0} { + updateit $op/ramp_fast $af + } + if {$af < $am && $rf > $rs && $h == 1} { + updateit $op/ramp_slow $af + } + updateit $op/units $t + updateit $op/heater_voltage $w + updateit $op/calib $c + } else { + set tst [sct get] + clientlog "unknown response: [sct get] $r" + } + catch {update_field} + if {![regexp $tst [sct get]]} { + [sct controller] queue [sct] write smc::eat_rubbish + } + return idle +} + +proc smc::ramp_lim {field} { + set oldf 0 + set oldr 99999 + set result 0 + foreach {r f} [hval [sct objectPath]/profile] { + if {$r > $oldr} { + error "ERROR: in ramp profile, ramps must be decreasing" + } + if {$r == 0} { + error "ERROR: in ramp profile, ramps must be > 0" + } + set oldr $r + if {$f < $oldf} { + error "ERROR: in ramp profile, fields must be increasing" + } + set oldf $f + if {$result == 0 && $f >= $field} { + set result $r + } + } + if {$result == 0} { + error "ERROR: field too high" + } + return $result +} + +proc smc::set_ramp_rate {target_name} { + foreach var {heater ramp_slow ramp_fast} { + if {$target_name eq $var} { + set $var [sct target] + sct update [sct target] + } else { + set $var [hval [sct parent]/$var] + } + } + if {$heater} { + set r $ramp_slow + } else { + set r $ramp_fast + } + set calib [hval [sct parent]/calib] + if {$calib == 0} { + set calib 1 + } + set rr [expr $r / 60.0 / $calib] + set rr [format %.3g $rr] + hset [sct parent]/ramp_amp_sec $rr + if {$target_name eq "heater"} { + return smc::write + } + sct cache_state 1 + return idle +} + +proc smc::chk_ramp_state {} { + set pr [sct parent] + switch -- [sct target] { + 0 { + clientput "set pause to 1" + clientput "hset $pr/pause 1" + clientput "pause set to 1" + hset $pr/pause 1 + } + 1 { + hset $pr/pause 0 + hset $pr/ramp_target 0 + } + 2 { + hset $pr/pause 0 + hset $pr/ramp_target 1 + } + default { + error "illegal ramp_target: [sct target]" + } + } +} diff --git a/tcl/drivers/text.tcl b/tcl/drivers/text.tcl new file mode 100644 index 0000000..14edaf0 --- /dev/null +++ b/tcl/drivers/text.tcl @@ -0,0 +1,10 @@ +namespace eval text { +} + +proc stdConfig::text {} { + variable node + + controller syncedprot + + obj text par -text "" +}