initial commit

tcl/drivers/table.tcl

@@ -0,0 +1,120 @@
+# 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
+}