121 lines
2.8 KiB
Tcl
121 lines
2.8 KiB
Tcl
# general temperature driver
|
|
namespace eval table {
|
|
}
|
|
|
|
proc stdConfig::table {varpath table} {
|
|
variable path
|
|
|
|
controller syncedprot 10
|
|
|
|
pollperiod 1 1
|
|
|
|
obj table -none rd
|
|
prop read table::update
|
|
prop varpath $varpath
|
|
|
|
set names [list]
|
|
|
|
kids "parameter table $varpath" {
|
|
foreach {par table} $table {
|
|
set name [join [join [split $par /] _] _]
|
|
lappend names $name
|
|
|
|
node fix_$name par 0
|
|
prop enum 1
|
|
prop label "fix $par"
|
|
prop newline 1
|
|
|
|
node val_$name upd
|
|
prop par $par
|
|
prop label "actual:"
|
|
prop nonewline 1
|
|
|
|
node tbl_$name -text par $table
|
|
prop width 32
|
|
prop newline 1
|
|
prop label table
|
|
prop help "enter value pair separated with colon T1:par1 T2:par2 ..."
|
|
}
|
|
}
|
|
|
|
hsetprop $path names $names
|
|
}
|
|
|
|
proc table::update {} {
|
|
foreach name [sct names] {
|
|
# individual varpath, if available
|
|
set varpath [silent [sct varpath] hgetpropval [sct]/tbl_$name varpath]
|
|
set x [silent none hvali $varpath]
|
|
set par [hgetpropval [sct]/val_$name par]
|
|
set path "/[join $par /]"
|
|
set old [silent none result $par]
|
|
if {[hvali [sct]/fix_$name] || $x eq "none"} {
|
|
catch {
|
|
hupdate [sct]/val_$name $old
|
|
hsetprop $path priv [string tolower [hgetpropval $path priv]]
|
|
}
|
|
} else {
|
|
set tbl [split [hvali [sct]/tbl_$name] :]
|
|
if {[llength $tbl] == 1} {
|
|
eval "$par [lindex [split $tbl] 0]"
|
|
return
|
|
}
|
|
set x0 0
|
|
set x1 1e30
|
|
set y0 0
|
|
set y1 0
|
|
set xi [lindex [split [lindex $tbl 0]] end]
|
|
set tbl [lrange $tbl 1 end]
|
|
foreach item $tbl {
|
|
set it [split $item]
|
|
set yi [lindex $it 0]
|
|
if {$xi <= $x} {
|
|
if {$xi > $x0} {
|
|
set x0 $xi
|
|
set y0 $yi
|
|
}
|
|
} else {
|
|
if {$xi < $x1} {
|
|
set x1 $xi
|
|
set y1 $yi
|
|
}
|
|
}
|
|
set xi [lindex $it end]
|
|
}
|
|
|
|
if {$x0 == 0} {
|
|
# first point
|
|
set y $y1
|
|
} elseif {$x1 == 1e30} {
|
|
# last point
|
|
set y $y0
|
|
} elseif {$y0 <= 0 || $y1 <= 0} {
|
|
# linear in x and y
|
|
set q [expr $x1 - $x0]
|
|
if {$q > 0} {
|
|
set y [expr $y0 + ($x - $x0) / $q * ($y1 - $y0)]
|
|
} else {
|
|
set y $y0
|
|
}
|
|
} else {
|
|
# logarithmic in x and y
|
|
set q [expr log($x1*1.0/$x0)]
|
|
if {$q > 0} {
|
|
set y [expr $y0*exp(log($x*1.0/$x0)/$q*log($y1*1.0/$y0))]
|
|
} else {
|
|
set y $y0
|
|
}
|
|
}
|
|
catch {
|
|
if {$y != $old} {
|
|
eval "$par $y"
|
|
hupdate [sct]/val_$name $y
|
|
}
|
|
# user priv in uppercase is showing parameter as readonly
|
|
hsetprop $path priv [string toupper [hgetpropval $path priv]]
|
|
}
|
|
}
|
|
}
|
|
return idle
|
|
}
|