linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- Implemented Hipadaba

Browse Source
This commit is contained in:
koennecke
2008-05-08 09:32:05 +00:00
parent d5b792f385
commit 65b5b27a0e
1 changed files with 690 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

690
tcl/hdbutil.tcl Normal file
View File

@ -0,0 +1,690 @@
#-----------------------------------------------------------------------
# This is a collection of utility procedures to help with Hipadaba and
# Gumtree Swiss Edition. This file is supposed to be sourced by any
# instrument using Hipadaba.
#
# Copyright: see file COPYRIGHT
#
# Collected from various files: Mark Koennecke, March 2008
#
# Requirements:
# * the internal scan command xxxscan
# * scan data to live /graphics/scan_data
#----------------------------------------------------------------------
if { [info exists hdbinit] == 0 } {
set hdbinit 1
InstallHdb
MakeStateMon
Publish getgumtreexml Spy
if {[string first tmp $home] < 0} {
set tmppath $home/tmp
} else {
set tmppath $home
}
Publish mgbatch Spy
Publish loadmgbatch Spy
Publish hsearchprop Spy
Publish hdbscan User
Publish hdbprepare User
Publish hdbcollect User
Publish listbatchfiles Spy
Publish makemumopos User
Publish dropmumo User
Publish hdbbatchpath User
# Publish hmake Mugger
# Publish hmakescript Mugger
# Publish hlink Mugger
# Publish hcommand Mugger
}
#===================================================================
# Configuration commands provided:
# hdbReadOnly
# makesampleenv path
# makestdscan path
# makestdscangraphics path
# makestdbatch
# makeQuickPar name path
# makeslit path left right upper lower
# configures a slit. Missing motors can be indicated with NONE
# makestdadmin
# makecount path
# makerepeat path
# makekillfile path
# makesuccess path
# makestdgui
# makewait path
# makeevproxy rootpath hdbname devicename
# makemumo rootpath mumoname
# makeexe
#===================== hfactory adapters ==========================
proc hmake {path priv type {len 1}} {
hfactory $path plain $priv $type $len
}
#--------------------------------------------------------------------
proc hmakescript {path readscript writescript type {len 1}} {
hfactory $path script $readscript $writescript $type $len
}
#-------------------------------------------------------------------
proc hlink {path obj {treename NONE} } {
if {[string equal $treename NONE]} {
set treename $ob
}
append realpath $path / $treename
hfactory $realpath link $obj
}
#-------------------------------------------------------------------
proc hcommand {path script} {
hfactory $path command $script
}
#================ make XML tree =====================================
proc getdataType {path} {
return [lindex [split [hinfo $path] ,] 0]
}
#----------------------------------------------------------------------
proc make_nodes {path result indent} {
set nodename [file tail $path];
set type [getdataType $path]
set prefix [string repeat " " $indent]
set newIndent [expr $indent + 2]
#array set prop_list [ string trim [join [split [hlistprop $path] =]] ]
set prop_list(control) true
set we_have_control [info exists prop_list(control)]
if {$we_have_control == 0 || $we_have_control && $prop_list(control) == "true"} {
append result "$prefix<component id=\"$nodename\" dataType=\"$type\">\n"
foreach p [property_elements $path $newIndent] {
append result $p
}
foreach x [hlist $path] {
set result [make_nodes [string map {// /} "$path/$x"] $result $newIndent]
}
append result "$prefix</component>\n"
}
return $result
}
#-------------------------------------------------------------------
proc property_elements_old {path indent} {
set prefix [string repeat " " $indent]
foreach {key value} [string map {= " "} [hlistprop $path]] {
if {[string compare -nocase $key "control"] == 0} {continue}
lappend proplist "$prefix<property id=\"$key\">\n"
# foreach v [split $value ,] {
# lappend proplist "$prefix$prefix<value>$v</value>\n"
# }
lappend proplist "$prefix$prefix<value>$value</value>\n"
lappend proplist "$prefix</property>\n"
}
if [info exists proplist] {return $proplist}
}
#-----------------------------------------------------------------------
proc property_elements {path indent} {
set prefix [string repeat " " $indent]
set data [hlistprop $path]
set propList [split $data \n]
foreach prop $propList {
set pl [split $prop =]
set key [string trim [lindex $pl 0]]
set value [string trim [lindex $pl 1]]
if {[string length $key] < 1} {
continue
}
lappend proplist "$prefix<property id=\"$key\">\n"
lappend proplist "$prefix$prefix<value>$value</value>\n"
lappend proplist "$prefix</property>\n"
}
if [info exists proplist] {return $proplist}
}
#--------------------------------------------------------------------------
proc getgumtreexml {path} {
append result "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"
if {[string compare $path "/" ] == 0} {
foreach n [hlist $path] {
set result [make_nodes $n $result 2]
}
} else {
# set result [make_nodes $path $result 2]
foreach n [hlist $path] {
set result [make_nodes $path/$n $result 2]
}
}
append result "</hipadaba:SICS>\n"
}
#==================== Gumtree batch =========================================
proc searchPathForDrivable {name} {
set path [string trim [hmatchprop / sicsdev $name]]
if {[string compare $path NONE] != 0} {
return $path
}
set txt [findalias $name]
if {[string compare $txt NONE] == 0} {
return NONE
}
set l1 [split $txt =]
set l [split [lindex $l1 1] ,]
foreach alias $l {
set alias [string trim $alias]
set path [string trim [hmatchprop / sicsdev $alias]]
if {[string compare $path NONE] != 0} {
return $path
}
}
return NONE
}
#----------------------------------------------------------------
proc searchForCommand {name} {
return [string trim [hmatchprop / sicscommand $name]]
}
#----------------------------------------------------------------
proc treatsscan {scanpath command out} {
set l [split $command]
set len [llength $l]
set noVar [expr ($len-2)/3]
set np [lindex $l [expr $len -2]]
set preset [lindex $l [expr $len -1]]
for {set i 0} {$i < $noVar} {incr i} {
set start [expr $i * 3]
set scanVar [lindex $l [expr 1 + $start]]
set scanStart [lindex $l [expr 2 + $start]]
set scanEnd [lindex $l [expr 3 + $start]]
set scanStep [expr ($scanEnd*1. - $scanStart*1.)/$np*1.]
append hdbVar $scanVar ,
append hdbStart $scanStart ,
append hdbStep $scanStep ,
}
set hdbVar [string trim $hdbVar ,]
set hdbStart [string trim $hdbStart ,]
set hdbStep [string trim $hdbStep ,]
puts $out "\#NODE: $scanpath"
puts $out "clientput BatchPos = 1"
puts $out "hdbscan $hdbVar $hdbStart $hdbStep $np monitor $preset"
}
#----------------------------------------------------------------
proc treatcscan {scanpath command out} {
set l [split $command]
set scanVar [lindex $l 1]
set scanCenter [lindex $l 2]
set scanStep [lindex $l 3]
set np [lindex $l 4]
set preset [lindex $l 5]
set hdbStart [expr $scanCenter - ($np*1.0)/2. * $scanStep*1.0]
puts $out "\#NODE: $scanpath"
puts $out "clientput BatchPos = 1"
puts $out "hdbscan $scanVar $hdbStart $scanStep $np monitor $preset"
}
#----------------------------------------------------------------
proc translateCommand {command out} {
set drivelist [list drive dr run]
set textList [list for while source if]
# clientput "Translating: $command"
set command [string trim $command]
if {[string length $command] < 2} {
return
}
set l [split $command]
set obj [string trim [lindex $l 0]]
#------- check for drive commands
set idx [lsearch $drivelist $obj]
if {$idx >= 0} {
set dev [lindex $l 1]
set path [searchPathForDrivable $dev]
if {[string compare $path NONE] != 0} {
set realTxt [hgetprop $path sicsdev]
set realL [split $realTxt =]
set realDev [lindex $realL 1]
set mapList [list $dev $realDev]
set newCom [string map $mapList $command]
puts $out "\#NODE: $path"
puts $out "clientput BatchPos = 1"
puts $out $newCom
return
}
}
#------ check for well known broken commands
set idx [lsearch $textList $obj]
if {$idx >= 0} {
puts $out "\#NODE: /batch/commandtext"
puts $out "clientput BatchPos = 1"
set buffer [string map {\n @nl@} $command]
puts $out "hset /batch/commandtext $buffer"
return
}
#--------- check for simple commands
set path [searchForCommand $command]
if {[string compare $path NONE] != 0} {
puts $out "\#NODE: $path"
puts $out "clientput BatchPos = 1"
puts $out $command
return
}
set scancom [searchForCommand hdbscan]
#---------- deal with scans
if {[string first sscan $obj] >= 0} {
if {[catch {treatsscan $scancom $command $out}] == 0} {
return
}
}
if {[string first cscan $obj] >= 0} {
if {[catch {treatsscan $scancom $command $out}] == 0} {
return
}
}
#--------- give up: output as a text node
puts $out "\#NODE: /batch/commandtext"
puts $out "clientput BatchPos = 1"
set buffer [string map {\n @nl@} $command]
puts $out "hset /batch/commandtext $buffer"
}
#----------------------------------------------------------------
proc mgbatch {filename} {
global tmppath
set f [open $filename r]
gets $f line
close $f
if {[string first MOUNTAINBATCH $line] > 0} {
#--------- This is a mountaingum batch file which does not need
# to be massaged
return $filename
}
set f [open $filename r]
set realfilename [file tail $filename]
set out [open $tmppath/$realfilename w]
puts $out \#MOUNTAINBATCH
while {[gets $f line] >= 0} {
append buffer $line
if {[info complete $buffer] == 1} {
translateCommand $buffer $out
unset buffer
} else {
append buffer \n
}
}
close $out
return $tmppath/$realfilename
}
#----------------------------------------------------------------
proc loadmgbatch {filename} {
set txt [exe fullpath $filename]
set l [split $txt =]
set realf [lindex $l 1]
set realf [mgbatch $realf]
return [exe print $realf]
}
#============== hdbscan =========================================
proc hdbscan {scanvars scanstart scanincr np mode preset} {
global stdscangraph hdbscanactive
xxxscan clear
xxxscan configure script
xxxscan function prepare hdbprepare
xxxscan function collect hdbcollect
set varlist [split $scanvars ,]
set startlist [split $scanstart ,]
set incrlist [split $scanincr ,]
hset $stdscangraph/scan_variable/name [lindex $varlist 0]
set count 0
foreach var $varlist {
if {[string first / $var] >= 0} {
set var [string trim [SplitReply [hgetprop $var sicsdev]]]
}
xxxscan add $var [lindex $startlist $count] [lindex $incrlist $count]
incr count
}
set hdbscanactive 1
set status [catch {xxxscan run $np $mode $preset} msg]
set hdbscanactive 0
if {$status == 0} {
return $msg
} else {
error $msg
}
}
#------------------------------------------------------------------------------
proc hdbprepare {obj userdata } {
global stdscangraph
stdscan prepare $obj userdata
hupdate $stdscangraph/dim
}
#------------------------------------------------------------------------------
proc hdbcollect {obj userobj np} {
global stdscangraph
stdscan collect $obj $userobj $np
hupdate $stdscangraph/scan_variable
hupdate $stdscangraph/counts
}
#-----------------------------------------------------------------------------
proc gethdbscanvardata {no} {
set np [string trim [SplitReply [xxxscan np]]]
if {$np == 0} {
return ".0 .0 .0"
}
set status [catch {SplitReply [xxxscan getvardata $no]} txt]
if {$status == 0} {
return [join $txt]
} else {
return ".0 .0 .0"
}
}
#----------------------------------------------------------------------------
proc gethdbscancounts {} {
set np [string trim [SplitReply [xxxscan np]]]
if {$np == 0} {
return "0 0 0"
}
set status [catch {SplitReply [xxxscan getcounts]} txt]
if {$status == 0} {
return [join $txt]
} else {
return "0 0 0"
}
}
#================= helper to get the list of batch files =================
proc listbatchfiles {} {
set ext [list *.tcl *.job *.run]
set txt [SplitReply [exe batchpath]]
set dirlist [split $txt :]
set txt [SplitReply [exe syspath]]
set dirlist [concat $dirlist [split $txt :]]
# clientput $dirlist
set result [list ""]
foreach dir $dirlist {
foreach e $ext {
set status [catch {glob [string trim $dir]/$e} filetxt]
if {$status == 0} {
set filelist [split $filetxt]
foreach f $filelist {
# clientput "Working at $f"
set nam [file tail $f]
if { [lsearch $result $nam] < 0} {
# clientput "Adding $nam"
lappend result $nam
}
}
} else {
# clientput "ERROR: $filetxt"
}
}
}
foreach bf $result {
append resulttxt $bf ,
}
return [string trim $resulttxt ,]
}
#-------------------------------------------------------------------------
proc hsearchprop {root prop val} {
set children [hlist $root]
set childlist [split $children \n]
if {[llength $childlist] <= 0} {
error "No children"
}
foreach child $childlist {
if {[string length $child] < 1} {
continue
}
catch {hgetprop $root/$child $prop} msg
if { [string first ERROR $msg] < 0} {
set value [string trim [SplitReply $msg]]
if { [string equal -nocase $value $val] == 1} {
return $root/$child
}
}
set status [catch {hsearchprop $root/$child $prop $val} node]
if {$status == 0} {
return $node
}
}
error "Not found"
}
#============ various utility routines =====================================
proc hdbReadOnly {} {
error "Parameter is READ ONLY"
}
#---------------------------------------------------------------------------
proc makesampleenv {path} {
hfactory $path plain spy none
hsetprop $path type graphdata
hsetprop $path viewer mountaingumui.TimeSeries
hfactory $path/vars plain user text
hset $path/vars tomato
hfactory $path/rank plain user int
hset $path/rank 1
hfactory $path/dim plain user intar 1
hset $path/dim 300
hfactory $path/getdata plain user text
hsetprop $path/getdata type logcommand
hfactory $path/getdata/starttime plain spy text
hfactory $path/getdata/endtime plain spy text
}
#--------------------------------------------------
proc makestdscan {path} {
hfactory $path command hdbscan
hsetprop $path type command
hsetprop $path viewer mountaingumui.ScanEditor
hsetprop $path priv user
hfactory $path/scan_variables plain user text
hsetprop $path/scan_variables argtype drivable
hfactory $path/scan_start plain user text
hfactory $path/scan_increments plain user text
hfactory $path/NP plain user int
hfactory $path/mode plain user text
hsetprop $path/mode values "monitor,timer"
hfactory $path/preset plain user float
}
#---------------------------------------------------
proc makestdscangraphics {path} {
global stdscangraph
set stdscangraph $path
hfactory $path plain spy none
hsetprop $path type graphdata
hsetprop $path viewer default
hattach $path title title
hfactory $path/rank plain mugger int
hset $path/rank 1
hsetprop $path/rank priv internal
hfactory $path/dim script "xxxscan np" hdbReadOnly intar 1
hsetprop $path/dim priv internal
hfactory $path/scan_variable script "gethdbscanvardata 0" hdbReadOnly floatvarar 1
hsetprop $path/scan_variable type axis
hsetprop $path/scan_variable dim 0
hsetprop $path/scan_variable transfer zip
hsetprop $path/scan_variable priv internal
hfactory $path/scan_variable/name plain user text
hfactory $path/counts script "gethdbscancounts" hdbReadOnly intvarar 1
hsetprop $path/counts type data
hsetprop $path/counts transfer zip
hsetprop $path/counts priv internal
}
#----------------------------------------------------
proc makeQuickPar {name path} {
hfactory /quickview/$name plain mugger text
hset /quickview/$name $path
}
#---------------------------------------------------
proc makestdbatch {} {
hfactory /batch plain spy none
hfactory /batch/bufferlist script listbatchfiles hdbReadOnly text
sicspoll add /batch/bufferlist hdb 30
hfactory /batch/commandtext plain spy text
hsetprop /batch/commandtext viewer mountaingumui.TextEdit
hsetprop /batch/commandtext commandtext true
hfactory /batch/currentline plain user int
}
#-----------------------------------------------------
proc makeslit {path left right upper bottom} {
hfactory $path plain spy none
hsetprop $path type part
if {![string equal $left NONE]} {
hattach $path $left left
}
if {![string equal $right NONE]} {
hattach $path $right right
}
if {![string equal $upper NONE]} {
hattach $path $upper upper
}
if {![string equal $bottom NONE]} {
hattach $path $bottom bottom
}
}
#---------------------------------------------------------
proc makestdadmin {} {
hfactory /instrument/experiment plain spy none
hattach /instrument/experiment title title
hattach /instrument/experiment user user
hattach /instrument/experiment/user adress address
hattach /instrument/experiment/user phone phone
hattach /instrument/experiment/user email email
hfactory /instrument/experiment/datafilenumber script sicsdatanumber \
hdbReadOnly int
hsetprop /instrument/experiment/datafilenumber priv internal
hfactory /instrument/experiment/batchpath script "exe batchpath" \
"exe batchpath" text
hsetprop /instrument/experiment/batchpath priv user
}
#----------------------------------------------------------
proc makecount {path} {
hfactory $path command count
hsetprop $path type command
hsetprop $path priv user
hfactory $path/mode plain user text
hsetprop $path/mode values "monitor,timer"
hfactory $path/preset plain user float
hset $path/preset 60000
hset $path/mode monitor
}
#----------------------------------------------------------
proc makerepeat {path} {
hfactory $path command repeat
hsetprop $path type command
hsetprop $path priv user
hfactory $path/num plain user int
hfactory $path/mode plain user text
hsetprop $path/mode values "monitor,timer"
hfactory $path/preset plain user float
hset $path/preset 60000
hset $path/mode monitor
}
#----------------------------------------------------------
proc makekillfile {path} {
hcommand $path killfile
hsetprop $path type command
hsetprop $path priv manager
}
#----------------------------------------------------------
proc makesuccess {path} {
hcommand $path success
hsetprop $path type command
hsetprop $path priv user
}
#-----------------------------------------------------------
proc makestdgui {} {
hfactory /gui plain spy none
hfactory /gui/status plain internal text
status hdbinterest /gui/status
}
#------------------------------------------------------------
proc makewait {path} {
hfactory $path command wait
hsetprop $path type command
hsetprop $path priv user
hfactory $path/time plain user int
}
#------------------------------------------------------------
proc makeevproxy {rootpath hdbname devicename} {
MakeProxy p${devicename} $devicename float
p${devicename} map upperlimit upperlimit float user
p${devicename} map lowerlimit lowerlimit float user
hlink $rootpath p${devicename} $hdbname
hsetprop $rootpath/$hdbname sicsdev $devicename
hsetprop $rootpath/$hdbname type drivable
sicspoll add $rootpath/$hdbname hdb 30
}
#================== multi motor stuff =======================
proc getNamposList {mumo} {
set txt [$mumo list]
set l [split $txt "\n"]
set lala [llength $l]
for {set i 1} {$i < [llength $l]} {incr i} {
set pos [lindex $l $i]
if {[string length $pos] > 1} {
append result [lindex $l $i] ","
}
}
if { ![info exists result] } {
# clientput "nampos = $txt"
append result UNKNOWN
}
return [string trimright $result ","]
}
#------------------------------------------------------------
proc getNamPos {mumo} {
set txt [$mumo find]
set l [split $txt =]
return [string trim [lindex $l 1]]
}
#-----------------------------------------------------------
proc updateNamePosValues {rootpath} {
hupdate $rootpath/namedposition/values
hupdate $rootpath/dropnamedposition/name/values
}
#------------------------------------------------------------
proc makemumopos {mumo rootpath name} {
$mumo pos $name
updateNamePosValues $rootpath
}
#-----------------------------------------------------------
proc dropmumo {mumo rootpath name} {
$mumo drop $name
updateNamePosValues $rootpath
}
#------------------------------------------------------------
proc getDropList {mumo} {
set txt [getNamposList $mumo]
append txt ",all"
return $txt
}
#-------------------------------------------------------------
proc makemumo {rootpath mumoname} {
hfactory $rootpath/namedposition script "getNamPos $mumoname" \
$mumoname text
hsetprop $rootpath/namedposition priv user
hfactory $rootpath/namedposition/values script \
"getNamposList $mumoname" hdbReadOnly text
hsetprop $rootpath/namedposition/values visible false
hupdate $rootpath/namedposition/values
hfactory $rootpath/assignname2current command \
"makemumopos $mumoname $rootpath"
hsetprop $rootpath/assignname2current priv user
hsetprop $rootpath/assignname2current type command
hfactory $rootpath/assignname2current/name plain user text
hset $rootpath/assignname2current/name "Undefined"
hfactory $rootpath/dropnamedposition command \
"dropmumo $mumoname $rootpath"
hsetprop $rootpath/dropnamedposition priv user
hsetprop $rootpath/dropnamedposition type command
hfactory $rootpath/dropnamedposition/name plain user text
hfactory $rootpath/dropnamedposition/name/values script \
"getDropList $mumoname" hdbReadOnly text
hsetprop $rootpath/dropnamedposition/name/values visible false
hupdate $rootpath/dropnamedposition/name/values
}
#-----------------------------------------------------------------
proc hdbbatchpath {pathstring} {
exe batchpath $pathstring
hupdate /instrument/commands/batch/execute/file/values
}
#------------------------------------------------------------------
proc makeexe {} {
set path /instrument/commands/batch
hfactory $path plain spy none
hfactory $path/batchpath script "exe batchpath" hdbbatchpath text
hsetprop $path/batchpath priv user
hfactory $path/execute command exe
hsetprop $path/execute type command
hsetprop $path/execute priv user
hfactory $path/execute/file plain user text
hfactory $path/execute/file/values script listbatchfiles hdbReadOnly text
sicspoll add $path/execute/file/values hdb 60
}