sea/tcl/archive/startup/store.tcl

proc get_next_filename {} {
  set file [store file]
  set filepattern [file join [result exe batchpath] $file]
  set nameformat [string map "* [store numfmt]" $filepattern]
  if {$nameformat eq $filepattern} {
    # no * in filepattern
    if {![file exists $filepattern]} {
      # simple filename
      store path [file normalize $filepattern]
      return $filepattern
    }
    # insert * before . or at end
    set split [split $file .]
    if {[llength $split] == 1} {
      lappend split ""
    }
    set file [join [linsert $split end-1 *] .]
    store file $file
    set filepattern [file join [result exe batchpath] $file]
    set nameformat [string map "* [store numfmt]" $filepattern]
    set num 0
    store num 0
  } else {
    set num [store num]
  }
  set path [format $nameformat $num]
  if {$num == 0 || [file exists $path]} {
    # determine next num
    set n $num
    foreach p [glob -nocomplain $filepattern] {
      scan $p $nameformat n
      if {$n > $num} {
        set num $n
      }
    }
    incr num
    store num $num
    set path [format $nameformat $num]
  }
  store path [file normalize $path]
  return $path
}

proc store {{command ""} args} {
  if {[sicsdescriptor store_array] ne "array"} {
    makeobject store_array array
    store_array makeitem numfmt %04d
    store_array makeitem file data.txt
    store_array makeitem path
    store_array makeitem vars
    store_array makeitem num 0
  }
  switch -- $command {
    open {
      store_array vars $args
      set f [open [get_next_filename] w]
      set i 1
      foreach var $args {
        puts $f [format "# col %d: %s (%s)" $i $var [GraphItem label $var]]
        incr i
      }
      close $f
      return "open [store path]"
    }
    put {
      set row [list]
      foreach var [split [store vars]] {
        lappend row [get_var_value $var]
      }
      set f [open [store path] a]
      puts $f [join $row "\t"]
      close $f
    }
    "" - list {
      set result [join {
         "store open <var1> <var2> ...    # open file for storing named variables"
         "store put                       # write a row with values of variables"
      } "\n"]
      foreach key [store_array items] {
        append result "\nstore $key [result store_array $key]"
      }
      return $result
    }
    default {
      set l [llength $args]
      if {$l > 1} {
         error "Usage: store $command \[<$command>\]"
      }
      if {![store_array exists $command]} {
         error "what is 'store $command'?"
      }
      if {$l == 1} {
         if {$command eq "file" || $command eq "numfmt" } {
           store_array num 0
         }
         store_array $command $args
      }
      return "[result store_array $command]"
    }
  }
}

namespace eval varscan {} {
  variable waittime 10
  variable cmd ""
  variable reltol 0
  variable digits 6
  
  proc reltol {rel args} {
    variable reltol
    variable tolcmd
    
    set reltol [expr abs($rel)]
    set tolcmd $args
  }
  
  proc do {args} {
    variable waittime
    variable cmd
    variable last
    variable reltol
    variable tolcmd
    variable digits
    
    foreach value $args {
      if {$reltol != 0} {
        eval "$tolcmd [format %.${digits}g [expr $reltol * $value]]"
      }
      set starttime [DoubleTime]
      clientput "$cmd $value"
      eval "$cmd $value"
      wait [expr max(0, $starttime + $waittime - [DoubleTime])]
      store put
      set last $value
    }
  }

  proc linear {encode value} {
    return $value
  }
  
  proc log {encode value} {
    variable digits
    if {$encode} {
      return [expr log10($value)]
    }
    return [format %.${digits}g [expr 10 ** $value]]
  }
  
  proc dosteps {step endarg {func linear}} {
    variable last
    variable precision
    variable reltol
    variable digits
    
    set end [$func 1 $endarg]
    set val [$func 1 $last]
    if {$end < $val} {
      set step [expr -abs($step)]
    } else {
      set step [expr abs($step)]
    }
    set precision [expr max(abs($step) * 0.1, $reltol)]
    set prec 0.1
    for {set digits 2} {$prec > $precision} {incr digits} {
      set prec [expr $prec * 0.1]
    }
    while 1 {
      set val [expr $val + $step]
      if {($end - $val) / $step < 0.5} {
        break
      }
      do [$func 0 $val]
    }
    do $endarg
    set digits 6
  }

  proc waittime {wait} {
    variable waittime
    set waittime $wait
  }

  proc command {args} {
    variable cmd
    set cmd $args
  }
}

proc varscan {code} {
  namespace eval varscan $code
}

publishLazy store
publishLazy varscan