Changeset 1211 for branches/sandbox


Ignore:
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:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/sandbox/expgui

    r1204 r1211  
    6868catch {if $env(DEBUG) {set expgui(debug) 1}}
    6969#set expgui(debug) 1
    70 
     70set expgui(HistSelectList) {}
    7171# location for web pages, if not found locally
    7272set expgui(website) 11bm.xor.aps.anl.gov/expguidoc/
     
    16371637            -yscrollcommand "$frm.y set" \
    16381638            ] -row 2 -column 0 -sticky news
    1639     lappend expgui(HistSelectList) $frm
     1639    if {[lsearch $expgui(HistSelectList) $frm] < 0} {
     1640        lappend expgui(HistSelectList) $frm
     1641    }
    16401642    grid [scrollbar $frm.x -orient horizontal \
    16411643            -command "move2boxesX \" $frm.title $frm.lbox \" "
     
    16611663    }
    16621664    foreach lbox $expgui(HistSelectList) {
     1665        if {! [winfo exists $lbox]} continue
    16631666        $lbox.title delete 0 end
    16641667        $lbox.lbox delete 0 end
     
    17231726    # title field needs to match longest title
    17241727    foreach lbox $expgui(HistSelectList) {
     1728        if {! [winfo exists $lbox]} continue
    17251729        $lbox.title insert end [format "%2s %s %4s %8s  %-67s" \
    17261730                "h#" \
     
    17581762        }
    17591763        foreach lbox $expgui(HistSelectList) {
     1764            if {! [winfo exists $lbox]} continue
    17601765            $lbox.lbox insert end [format "%2d  %s %4d %8s  %-67s" \
    17611766                    $h \
  • branches/sandbox/readexp.tcl

    r1209 r1211  
    23532353#  -----------
    23542354#  absorbX get number         returns a list of constraints for term X=1 or 2
    2355 #                             use number=0 to get # of defined
    2356 #                             constraints for term X
    2357 #   "        set number value   replaces a list of constraints
    2358 #                               (value is a list of constraints)
    2359 #   "        add number value   inserts a new list of constraints
     2355#   returns a the number of constraints for number = 0
     2356#   returns a list of lists {{hist mult} {hist mult} ...}
     2357
     2358#  absorbX set number value   replaces a list of constraints
     2359#      number corresponds to a specific constraint see "absorbX get 0"
     2360#      value is a list of lists {{hist mult} {hist mult} ...}
     2361#  absorbX add number value   inserts a new list of constraints
    23602362#                               (number is ignored)
    2361  "        delete number      deletes a set of constraint entries
    2362 # Each item in the list of constraints is composed of 3 items:
    2363 #              phase-list, histogram-list, multiplier
    2364 # Note that phase-list and/or histogram-list can be ALL
    2365 
     2363absorbX  delete number      deletes a set of constraint entries and renumbers
     2364# note that hist can be:
     2365#      a histogram number (such as 2) or
     2366#      range of histograms (such as 1:10 or 11:99, etc.) or
     2367#      the string "ALL"
    23662368
    23672369proc constrinfo {type action number "value {}"} {
     
    26292631                    # this line is not needed
    26302632                    if {$j % 3 == 1} {
    2631                         delexp %key
     2633                        delexp $key
    26322634                    }
    26332635                    continue
     
    27492751        absorb*-delete {
    27502752            regsub absorb $type {} term
     2753            set key "LEQV ABS$term   "
     2754            if {! [existsexp $key]} {return 0}
     2755            # current number of constraints
     2756            set nterm [string trim [string range [readexp $key] 0 5]]
     2757            if {$nterm == ""} {return 0}
     2758            # does the entry exist?
     2759            if {$nterm < $number} {
     2760                puts "deleted!"
     2761                return $nterm
     2762            }
     2763            for {set target $number} {$target < $nterm} {incr target} {
     2764                set source [expr {$target + 1}]
     2765                set recs [GetAbsCount $term $source]
     2766                SetAbsCount $term $target [expr {3*$recs}]
     2767                validint source 2
     2768                validint target 2
     2769                for {set i 1} {$i <= $recs} {incr i} {
     2770                    set keyin "LEQV ABS${term}${source}$i"
     2771                    set keyout "LEQV ABS${term}${target}$i"
     2772                    set ::exparray($keyout) $::exparray($keyin)
     2773                }
     2774            }
     2775            SetAbsCount $term $nterm 0
     2776            # delete the last entry
     2777            validint nterm 2
     2778            foreach i {1 2 3 4 5 6 7 8 9} {
     2779                set key "LEQV ABS${term}${nterm}$i"
     2780                delexp $key
     2781            }
     2782            # decrease the count by one
     2783            set nterm [expr {[string trim $nterm] - 1}]
     2784            if {$nterm == 0} {
     2785                delexp "LEQV ABS$term   "
     2786            } else {
     2787                validint nterm 5
     2788                setexp "LEQV ABS$term   " $nterm 1 5                   
     2789            }
     2790            return [string trim $nterm]
     2791
    27512792            if {$term < 10} {
    27522793                set term " $term"
     
    28232864        absorb*-set {
    28242865            regsub absorb $type {} term
    2825             if {$term < 10} {
    2826                 set term " $term"
    2827             }
    2828             set key "LEQV PF$term   "
    2829             # get number of constraint terms
    2830             set nterms [string trim [string range [readexp ${key}] 0 4] ]
    2831             # don't change a non-existing entry
    2832             if {$number > $nterms} {return 0}
    2833             if {$number > 9} {
    2834                 set k1 [expr {($number+1)/10}]
    2835                 set l1 $number
    2836             } else {
    2837                 set k1 " "
    2838                 set l1 " $number"
    2839             }
    2840             set key1 "LEQV PF$term  $k1"
    2841             # old number of constraint lines
    2842             set n1 [string trim [string range [readexp ${key1}] \
    2843                     [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
    2844             # number of new constraints
    2845             set j2 [llength $value]
    2846             # number of new constraint lines
    2847             set val [set n2 [expr {($j2 + 2)/3}]]
    2848             # store the new # of lines
    2849             validint val 5
    2850             setexp $key1 $val [expr {1+(($number%10)*5)}] 5
    2851 
    2852             # loop over the # of lines in the old or new, whichever is greater
    2853             set v0 0
    2854             for {set j 1} {$j <= [expr {($n1 > $n2) ? $n1 : $n2}]} {incr j 1} {
    2855                 set key "LEQV PF${term}${l1}$j"
    2856                 # were there more lines in the old?
    2857                 if {$j > $n2} {
    2858                     # this line is not needed
    2859                     if {$j % 3 == 1} {
    2860                         delexp %key
    2861                     }
    2862                     continue
    2863                 }
    2864                 # are we adding new lines?
    2865                 if {$j > $n1} {
    2866                     makeexprec $key
    2867                 }
    2868                 # add the three constraints to the line
    2869                 foreach s {3 23 43} \
    2870                         item [lrange $value $v0 [expr {2+$v0}]] {
    2871                     if {$item != ""} {
    2872                         set val [format %-10s%9.3f \
    2873                                 [lindex $item 0],[lindex $item 1] \
    2874                                 [lindex $item 2]]
    2875                         setexp $key $val $s 19
    2876                     } else {
    2877                         setexp $key " " $s 19
    2878                     }
    2879                 }
    2880                 incr v0 3
    2881             }
     2866            if {$number < 1} return   
     2867            # delete old records
     2868            set l [GetAbsCount $term $number]
     2869            set num $number
     2870            validint num 2
     2871            for {set i 1} {$i <= $l} {incr i} {
     2872                delexp "LEQV ABS${term}${num}$i"
     2873            }
     2874            # record the new number of records
     2875            SetAbsCount $term $number [llength $value]
     2876            # save the new records
     2877            set i 1
     2878            set offh 2
     2879            set offm 14
     2880            foreach set $value {
     2881                set hist [string trim [lindex $set 0]]
     2882                set mult [string trim [lindex $set 1]]
     2883                validreal mult 8 4
     2884                set key "LEQV ABS${term}${num}$i"
     2885                if {$offh == 2} {
     2886                    makeexprec $key
     2887                }
     2888                setexp $key $hist [expr {$offh+1}] 11
     2889                setexp $key $mult [expr {$offm+1}] 8
     2890                incr offh 21
     2891                incr offm 21
     2892                if {$offm > 67} {
     2893                    incr i
     2894                    set offh 2
     2895                    set offm 14
     2896                }
     2897            }
     2898            return
    28822899        }
    28832900        absorb*-add {
    28842901            regsub absorb $type {} term
    2885             if {$term < 10} {
    2886                 set term " $term"
    2887             }
    2888             set key "LEQV PF$term   "
    2889             if {![existsexp $key]} {makeexprec $key}
    2890             set nterms [string trim [string range [readexp ${key}] 0 4] ]
    2891             if {$nterms == ""} {
    2892                 set nterms 1
    2893             } elseif {$nterms >= 99} {
    2894                 return 0
    2895             } else {
    2896                 incr nterms
    2897             }
    2898             # store the new # of constraints
    2899             set val $nterms
    2900             validint val 5
    2901             setexp $key $val 1 5
    2902 
    2903             if {$nterms > 9} {
    2904                 set k1 [expr {($nterms+1)/10}]
    2905                 set l1 $nterms
    2906             } else {
    2907                 set k1 " "
    2908                 set l1 " $nterms"
    2909             }
    2910             set key1 "LEQV PF$term  $k1"
    2911 
    2912             # number of new constraints
    2913             set j2 [llength $value]
    2914             # number of new constraint lines
    2915             set val [set n2 [expr {($j2 + 2)/3}]]
    2916             # store the new # of lines
    2917             validint val 5
    2918             setexp $key1 $val [expr {1+(($nterms%10)*5)}] 5
    2919 
    2920             # loop over the # of lines to be added
    2921             set v0 0
    2922             for {set j 1} {$j <= $n2} {incr j 1} {
    2923                 set key "LEQV PF${term}${l1}$j"
    2924                 makeexprec $key
    2925                 # add the three constraints to the line
    2926                 foreach s {3 23 43} \
    2927                         item [lrange $value $v0 [expr {2+$v0}]] {
    2928                     if {$item != ""} {
    2929                         set val [format %-10s%9.3f \
    2930                                 [lindex $item 0],[lindex $item 1] \
    2931                                 [lindex $item 2]]
    2932                         setexp $key $val $s 19
    2933                     } else {
    2934                         setexp $key " " $s 19
    2935                     }
    2936                 }
    2937                 incr v0 3
    2938             }
     2902            set key "LEQV ABS$term   "
     2903            if {! [existsexp $key]} {makeexprec $key}
     2904            # current number of constraints
     2905            set nterm [string trim [string range [readexp $key] 0 5]]
     2906            if {$nterm == ""} {set nterm 0}
     2907            if {$nterm >= 99} {
     2908                return $nterm
     2909            }
     2910            incr nterm
     2911            validint nterm 5
     2912            setexp $key $nterm 1 5
     2913            constrinfo $type set [string trim $nterm] $value
     2914            return [string trim $nterm]
    29392915        }
    29402916        absorb*-get {
    29412917            regsub absorb $type {} term
     2918            # no constraints, return blank
    29422919            set key "LEQV ABS$term   "
     2920            if {! [existsexp $key]} {return ""}
     2921            # requesting number of constraints
    29432922            if {$number == 0} {
    2944                 puts [readexp ${key}]
    2945                 puts [string range [readexp ${key}] 0 5]
    2946                 puts [string trim [string range [readexp ${key}] 0 5]]
     2923                set l [string trim [string range [readexp ${key}] 0 5]]
     2924                if {$l == ""} {return 0}
     2925                return $l
    29472926            }
    2948             puts "**${term}**"
    2949             return
    2950             set key "LEQV ABS$term  $i"
    2951             # return nothing if no term exists
    2952             if {![existsexp $key]} {return 0}
    2953             # number of constraint lines
    2954            
    2955             set numline [string trim [string range [readexp ${key}] \
    2956                     [expr {($number%10)*5}] [expr {4+(($number%10)*5)}]] ]
    2957             if {$number == 0} {return $numline}
    2958             set clist {}
    2959             if {$number < 10} {
    2960                 set number " $number"
    2961             }
    2962             for {set i 1} {$i <= $numline} {incr i} {
    2963                 set key "LEQV PF${term}${number}$i"
    2964                 set line [readexp ${key}]
    2965                 foreach s {1 21 41} e {20 40 60} {
    2966                     set seg [string range $line $s $e]
    2967                     if {[string trim $seg] == ""} continue
    2968                     # parse the string segment
    2969                     set parse [regexp { *([0-9AL]+),([0-9AL]+) +([0-9.]+)} \
    2970                             $seg junk phase hist mult]
    2971                     # was parse successful
    2972                     if {!$parse} {continue}
    2973                     lappend clist [list $phase $hist $mult]
    2974                 }
    2975             }
    2976             return $clist
     2927            #
     2928            if {$number > 9} {
     2929                set num $number
     2930                set i [expr {($number+1)/10}]
     2931                set off [expr {5*($number % 10)}]
     2932                set key "LEQV ABS$term  $i"
     2933            } else {
     2934                set num " $number"
     2935                set i " "
     2936                set off [expr {5*($number % 10)}]
     2937            }
     2938            set off1 [expr {$off + 5}]
     2939            set l [string trim [string range [readexp ${key}] $off $off1]]
     2940            if {$l == ""} {return {}}
     2941            # now look up those records
     2942            set res {}
     2943            for {set i 1} {$i <= $l} {incr i} {
     2944                set key "LEQV ABS${term}${num}$i"
     2945                for {set j 0} {$j < 3} {incr j} {
     2946                    set off [expr {2 + 21*$j}]
     2947                    set off1 [expr {$off + 11}]
     2948                    set hist [string trim [string range [readexp ${key}] $off $off1]]
     2949                    set off [expr {14 + 21*$j}]
     2950                    set off1 [expr {$off + 7}]
     2951                    set mult [string trim [string range [readexp ${key}] $off $off1]]
     2952                    if {$mult == ""} break
     2953                    lappend res [list $hist $mult]
     2954                }
     2955            }
     2956            return $res
    29772957        }
    29782958        default {
     
    29822962
    29832963    }
     2964}
     2965proc GetAbsCount {term number} {
     2966    if {$number > 9} {
     2967        set num $number
     2968        set off [expr {5*($number % 10)}]
     2969        set i [expr {($number+1)/10}]
     2970        set key "LEQV ABS$term  $i"
     2971    } else {
     2972        set num " $number"
     2973        set off [expr {5*($number % 10)}]
     2974        set key "LEQV ABS$term   "
     2975    }
     2976    set off1 [expr {$off + 5}]
     2977    set l [string trim [string range [readexp ${key}] $off $off1]]
     2978    if {$l == ""} {set l 0}
     2979    return $l
     2980}
     2981proc SetAbsCount {term number len} {
     2982    if {$number > 9} {
     2983        set num $number
     2984        set off [expr {1 + 5*($number % 10)}]
     2985        set i [expr {($number+1)/10}]
     2986        set key "LEQV ABS$term  $i"
     2987    } else {
     2988        set num " $number"
     2989        set off [expr {1 + 5*($number % 10)}]
     2990        set key "LEQV ABS$term   "
     2991    }
     2992    set l [expr {($len + 2)/3}]
     2993    set val $l
     2994    validint val 5
     2995    setexp $key $val $off 5
    29842996}
    29852997
Note: See TracChangeset for help on using the changeset viewer.