Changeset 1211

Timestamp:

Aug 16, 2012 3:39:00 PM (8 years ago)

Author:

toby

Message:

manage abs constraints; changes to support MakeHistBox? in dialog

Location:

branches/sandbox

Files:

• expgui (modified) (5 diffs)
• readexp.tcl (modified) (5 diffs)

branches/sandbox/expgui

@@ -68 +68 @@
 catch {if $env(DEBUG) {set expgui(debug) 1}}
 #set expgui(debug) 1
-
+set expgui(HistSelectList) {}
 # location for web pages, if not found locally
 set expgui(website) 11bm.xor.aps.anl.gov/expguidoc/
@@ -1637 +1637 @@
             -yscrollcommand "$frm.y set" \
             ] -row 2 -column 0 -sticky news
-    lappend expgui(HistSelectList) $frm
+    if {[lsearch $expgui(HistSelectList) $frm] < 0} {
+        lappend expgui(HistSelectList) $frm
+    }
     grid [scrollbar $frm.x -orient horizontal \
             -command "move2boxesX \" $frm.title $frm.lbox \" " 
@@ -1661 +1663 @@
     }
     foreach lbox $expgui(HistSelectList) {
+        if {! [winfo exists $lbox]} continue
         $lbox.title delete 0 end
         $lbox.lbox delete 0 end
@@ -1723 +1726 @@
     # title field needs to match longest title
     foreach lbox $expgui(HistSelectList) {
+        if {! [winfo exists $lbox]} continue
         $lbox.title insert end [format "%2s %s %4s %8s  %-67s" \
                 "h#" \
@@ -1758 +1762 @@
         }
         foreach lbox $expgui(HistSelectList) {
+            if {! [winfo exists $lbox]} continue
             $lbox.lbox insert end [format "%2d  %s %4d %8s  %-67s" \
                     $h \

branches/sandbox/readexp.tcl

@@ -2353 +2353 @@
 #  -----------
 #  absorbX get number         returns a list of constraints for term X=1 or 2
-#                             use number=0 to get # of defined
-#                             constraints for term X
-#   "        set number value   replaces a list of constraints 
-#                               (value is a list of constraints)
-#   "        add number value   inserts a new list of constraints 
+#   returns a the number of constraints for number = 0
+#   returns a list of lists {{hist mult} {hist mult} ...}
+
+#  absorbX set number value   replaces a list of constraints 
+#      number corresponds to a specific constraint see "absorbX get 0"
+#      value is a list of lists {{hist mult} {hist mult} ...}
+#  absorbX add number value   inserts a new list of constraints 
 #                               (number is ignored)
-#   "        delete number      deletes a set of constraint entries
-# Each item in the list of constraints is composed of 3 items: 
-#              phase-list, histogram-list, multiplier
-# Note that phase-list and/or histogram-list can be ALL
-
+#  absorbX  delete number      deletes a set of constraint entries and renumbers
+# note that hist can be:
+#      a histogram number (such as 2) or
+#      range of histograms (such as 1:10 or 11:99, etc.) or
+#      the string "ALL"
 
 proc constrinfo {type action number "value {}"} {
@@ -2629 +2631 @@
                     # this line is not needed
                     if {$j % 3 == 1} {
-                        delexp %key
+                        delexp $key
                     }
                     continue
@@ -2749 +2751 @@
         absorb*-delete {
             regsub absorb $type {} term
+            set key "LEQV ABS$term   "
+            if {! [existsexp $key]} {return 0}
+            # current number of constraints
+            set nterm [string trim [string range [readexp $key] 0 5]]
+            if {$nterm == ""} {return 0}
+            # does the entry exist?
+            if {$nterm < $number} {
+                puts "deleted!"
+                return $nterm
+            }
+            for {set target $number} {$target < $nterm} {incr target} {
+                set source [expr {$target + 1}]
+                set recs [GetAbsCount $term $source]
+                SetAbsCount $term $target [expr {3*$recs}]
+                validint source 2
+                validint target 2
+                for {set i 1} {$i <= $recs} {incr i} {
+                    set keyin "LEQV ABS${term}${source}$i"
+                    set keyout "LEQV ABS${term}${target}$i"
+                    set ::exparray($keyout) $::exparray($keyin)
+                }
+            }
+            SetAbsCount $term $nterm 0
+            # delete the last entry
+            validint nterm 2
+            foreach i {1 2 3 4 5 6 7 8 9} {
+                set key "LEQV ABS${term}${nterm}$i"
+                delexp $key
+            }
+            # decrease the count by one
+            set nterm [expr {[string trim $nterm] - 1}]
+            if {$nterm == 0} {
+                delexp "LEQV ABS$term   "
+            } else {
+                validint nterm 5
+                setexp "LEQV ABS$term   " $nterm 1 5                    
+            }
+            return [string trim $nterm]
+
             if {$term < 10} {
                 set term " $term"
@@ -2823 +2864 @@
         absorb*-set {
             regsub absorb $type {} term
-            if {$term < 10} {
-                set term " $term"
-            }
-            set key "LEQV PF$term   "
-            # get number of constraint terms
-            set nterms [string trim [string range [readexp ${key}] 0 4] ]
-            # don't change a non-existing entry
-            if {$number > $nterms} {return 0}
-            if {$number > 9} {
-                set k1 [expr {($number+1)/10}]
-                set l1 $number
-            } else {
-                set k1 " "
-                set l1 " $number"
-            }
-            set key1 "LEQV PF$term  $k1"
-            # old number of constraint lines
-            set n1 [string trim [string range [readexp ${key1}] \
-                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
-            # number of new constraints
-            set j2 [llength $value]
-            # number of new constraint lines
-            set val [set n2 [expr {($j2 + 2)/3}]]
-            # store the new # of lines
-            validint val 5
-            setexp $key1 $val [expr {1+(($number%10)*5)}] 5
-
-            # loop over the # of lines in the old or new, whichever is greater
-            set v0 0
-            for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
-                set key "LEQV PF${term}${l1}$j"
-                # were there more lines in the old?
-                if {$j > $n2} {
-                    # this line is not needed
-                    if {$j % 3 == 1} {
-                        delexp %key
-                    }
-                    continue
-                }
-                # are we adding new lines?
-                if {$j > $n1} {
-                    makeexprec $key
-                }
-                # add the three constraints to the line
-                foreach s {3 23 43} \
-                        item [lrange $value $v0 [expr {2+$v0}]] {
-                    if {$item != ""} {
-                        set val [format %-10s%9.3f \
-                                [lindex $item 0],[lindex $item 1] \
-                                [lindex $item 2]]
-                        setexp $key $val $s 19
-                    } else {
-                        setexp $key " " $s 19
-                    }
-                }
-                incr v0 3
-            }
+            if {$number < 1} return   
+            # delete old records
+            set l [GetAbsCount $term $number]
+            set num $number
+            validint num 2
+            for {set i 1} {$i <= $l} {incr i} {
+                delexp "LEQV ABS${term}${num}$i"
+            }
+            # record the new number of records
+            SetAbsCount $term $number [llength $value]
+            # save the new records
+            set i 1
+            set offh 2
+            set offm 14
+            foreach set $value {
+                set hist [string trim [lindex $set 0]]
+                set mult [string trim [lindex $set 1]]
+                validreal mult 8 4
+                set key "LEQV ABS${term}${num}$i"
+                if {$offh == 2} {
+                    makeexprec $key
+                }
+                setexp $key $hist [expr {$offh+1}] 11
+                setexp $key $mult [expr {$offm+1}] 8
+                incr offh 21
+                incr offm 21
+                if {$offm > 67} {
+                    incr i
+                    set offh 2
+                    set offm 14
+                }
+            }
+            return
         }
         absorb*-add {
             regsub absorb $type {} term
-            if {$term < 10} {
-                set term " $term"
-            }
-            set key "LEQV PF$term   "
-            if {![existsexp $key]} {makeexprec $key}
-            set nterms [string trim [string range [readexp ${key}] 0 4] ]
-            if {$nterms == ""} {
-                set nterms 1
-            } elseif {$nterms >= 99} {
-                return 0
-            } else {
-                incr nterms
-            }
-            # store the new # of constraints
-            set val $nterms
-            validint val 5
-            setexp $key $val 1 5
-
-            if {$nterms > 9} {
-                set k1 [expr {($nterms+1)/10}]
-                set l1 $nterms
-            } else {
-                set k1 " "
-                set l1 " $nterms"
-            }
-            set key1 "LEQV PF$term  $k1"
-
-            # number of new constraints
-            set j2 [llength $value]
-            # number of new constraint lines
-            set val [set n2 [expr {($j2 + 2)/3}]]
-            # store the new # of lines
-            validint val 5
-            setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
-
-            # loop over the # of lines to be added
-            set v0 0
-            for {set j 1} {$j <= $n2} {incr j 1} {
-                set key "LEQV PF${term}${l1}$j"
-                makeexprec $key
-                # add the three constraints to the line
-                foreach s {3 23 43} \
-                        item [lrange $value $v0 [expr {2+$v0}]] {
-                    if {$item != ""} {
-                        set val [format %-10s%9.3f \
-                                [lindex $item 0],[lindex $item 1] \
-                                [lindex $item 2]]
-                        setexp $key $val $s 19
-                    } else {
-                        setexp $key " " $s 19
-                    }
-                }
-                incr v0 3
-            }
+            set key "LEQV ABS$term   "
+            if {! [existsexp $key]} {makeexprec $key}
+            # current number of constraints
+            set nterm [string trim [string range [readexp $key] 0 5]]
+            if {$nterm == ""} {set nterm 0}
+            if {$nterm >= 99} {
+                return $nterm
+            }
+            incr nterm
+            validint nterm 5
+            setexp $key $nterm 1 5
+            constrinfo $type set [string trim $nterm] $value
+            return [string trim $nterm]
         }
         absorb*-get {
             regsub absorb $type {} term
+            # no constraints, return blank
             set key "LEQV ABS$term   "
+            if {! [existsexp $key]} {return ""}
+            # requesting number of constraints
             if {$number == 0} {
-                puts [readexp ${key}]
-                puts [string range [readexp ${key}] 0 5]
-                puts [string trim [string range [readexp ${key}] 0 5]]
+                set l [string trim [string range [readexp ${key}] 0 5]]
+                if {$l == ""} {return 0}
+                return $l
             }
-            puts "**${term}**"
-            return
-            set key "LEQV ABS$term  $i"
-            # return nothing if no term exists
-            if {![existsexp $key]} {return 0}
-            # number of constraint lines
-            
-            set numline [string trim [string range [readexp ${key}] \
-                    [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
-            if {$number == 0} {return $numline}
-            set clist {}
-            if {$number < 10} {
-                set number " $number"
-            }
-            for {set i 1} {$i <= $numline} {incr i} {
-                set key "LEQV PF${term}${number}$i"
-                set line [readexp ${key}]
-                foreach s {1 21 41} e {20 40 60} {
-                    set seg [string range $line $s $e]
-                    if {[string trim $seg] == ""} continue
-                    # parse the string segment
-                    set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
-                            $seg junk phase hist mult]
-                    # was parse successful
-                    if {!$parse} {continue}
-                    lappend clist [list $phase $hist $mult]
-                }
-            }
-            return $clist
+            # 
+            if {$number > 9} {
+                set num $number
+                set i [expr {($number+1)/10}]
+                set off [expr {5*($number % 10)}]
+                set key "LEQV ABS$term  $i"
+            } else {
+                set num " $number"
+                set i " "
+                set off [expr {5*($number % 10)}]
+            }
+            set off1 [expr {$off + 5}]
+            set l [string trim [string range [readexp ${key}] $off $off1]]
+            if {$l == ""} {return {}}
+            # now look up those records
+            set res {}
+            for {set i 1} {$i <= $l} {incr i} {
+                set key "LEQV ABS${term}${num}$i"
+                for {set j 0} {$j < 3} {incr j} {
+                    set off [expr {2 + 21*$j}]
+                    set off1 [expr {$off + 11}]
+                    set hist [string trim [string range [readexp ${key}] $off $off1]]
+                    set off [expr {14 + 21*$j}]
+                    set off1 [expr {$off + 7}]
+                    set mult [string trim [string range [readexp ${key}] $off $off1]]
+                    if {$mult == ""} break
+                    lappend res [list $hist $mult]
+                }
+            }
+            return $res
         }
         default {
@@ -2982 +2962 @@
 
     }
+}
+proc GetAbsCount {term number} {
+    if {$number > 9} {
+        set num $number
+        set off [expr {5*($number % 10)}]
+        set i [expr {($number+1)/10}]
+        set key "LEQV ABS$term  $i"
+    } else {
+        set num " $number"
+        set off [expr {5*($number % 10)}]
+        set key "LEQV ABS$term   "
+    }
+    set off1 [expr {$off + 5}]
+    set l [string trim [string range [readexp ${key}] $off $off1]]
+    if {$l == ""} {set l 0}
+    return $l
+}
+proc SetAbsCount {term number len} {
+    if {$number > 9} {
+        set num $number
+        set off [expr {1 + 5*($number % 10)}]
+        set i [expr {($number+1)/10}]
+        set key "LEQV ABS$term  $i"
+    } else {
+        set num " $number"
+        set off [expr {1 + 5*($number % 10)}]
+        set key "LEQV ABS$term   "
+    }
+    set l [expr {($len + 2)/3}]
+    set val $l
+    validint val 5
+    setexp $key $val $off 5
 }