Changeset 1211
- Timestamp:
- Aug 16, 2012 3:39:00 PM (8 years ago)
- Location:
- branches/sandbox
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/sandbox/expgui
r1204 r1211 68 68 catch {if $env(DEBUG) {set expgui(debug) 1}} 69 69 #set expgui(debug) 1 70 70 set expgui(HistSelectList) {} 71 71 # location for web pages, if not found locally 72 72 set expgui(website) 11bm.xor.aps.anl.gov/expguidoc/ … … 1637 1637 -yscrollcommand "$frm.y set" \ 1638 1638 ] -row 2 -column 0 -sticky news 1639 lappend expgui(HistSelectList) $frm 1639 if {[lsearch $expgui(HistSelectList) $frm] < 0} { 1640 lappend expgui(HistSelectList) $frm 1641 } 1640 1642 grid [scrollbar $frm.x -orient horizontal \ 1641 1643 -command "move2boxesX \" $frm.title $frm.lbox \" " … … 1661 1663 } 1662 1664 foreach lbox $expgui(HistSelectList) { 1665 if {! [winfo exists $lbox]} continue 1663 1666 $lbox.title delete 0 end 1664 1667 $lbox.lbox delete 0 end … … 1723 1726 # title field needs to match longest title 1724 1727 foreach lbox $expgui(HistSelectList) { 1728 if {! [winfo exists $lbox]} continue 1725 1729 $lbox.title insert end [format "%2s %s %4s %8s %-67s" \ 1726 1730 "h#" \ … … 1758 1762 } 1759 1763 foreach lbox $expgui(HistSelectList) { 1764 if {! [winfo exists $lbox]} continue 1760 1765 $lbox.lbox insert end [format "%2d %s %4d %8s %-67s" \ 1761 1766 $h \ -
branches/sandbox/readexp.tcl
r1209 r1211 2353 2353 # ----------- 2354 2354 # 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 2360 2362 # (number is ignored) 2361 # " delete number deletes a set of constraint entries2362 # Each item in the list of constraints is composed of 3 items:2363 # phase-list, histogram-list, multiplier2364 # Note that phase-list and/or histogram-list can be ALL2365 2363 # absorbX 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" 2366 2368 2367 2369 proc constrinfo {type action number "value {}"} { … … 2629 2631 # this line is not needed 2630 2632 if {$j % 3 == 1} { 2631 delexp %key2633 delexp $key 2632 2634 } 2633 2635 continue … … 2749 2751 absorb*-delete { 2750 2752 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 2751 2792 if {$term < 10} { 2752 2793 set term " $term" … … 2823 2864 absorb*-set { 2824 2865 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 2882 2899 } 2883 2900 absorb*-add { 2884 2901 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] 2939 2915 } 2940 2916 absorb*-get { 2941 2917 regsub absorb $type {} term 2918 # no constraints, return blank 2942 2919 set key "LEQV ABS$term " 2920 if {! [existsexp $key]} {return ""} 2921 # requesting number of constraints 2943 2922 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 2947 2926 } 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 2977 2957 } 2978 2958 default { … … 2982 2962 2983 2963 } 2964 } 2965 proc 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 } 2981 proc 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 2984 2996 } 2985 2997
Note: See TracChangeset
for help on using the changeset viewer.