Viewing contents of file '../idllib/contrib/lamp/dons.pro'
pro don_init_prog_mac ,flg
;** *****************
;**
@dons.cbk
@lamp.cbk
common c_draw, w0,xx,yy,axy,uxy,wnumber,v,p,thresh,rx,rz,nlv,tcol,siz,flgsurf,$
wbeside,vfl,styles,w4d,smoo,vff
;Read in user command list
on_ioerror, end_fc
in=-1
openr,in,'lamp.cds',/get_lun
n=n_elements(prog_mac)
bstr=''
for k=0,n-1 do begin
readf,in,bstr
prog_mac(k)=bstr
if flg eq 1 then $
if prog_txt(k) gt 0 then widget_control,prog_txt(k),bad_id=i,set_value=bstr
endfor
if flg eq -1 then begin
readf,in,bstr & bstr=''
readf,in,bstr & if bstr ne '' then lamp_devps=bstr
readf,in,bstr & bstr=''
readf,in,rx,rz,nlv,bstr
readf,in,bstr & bstr='' & s1=0 & s2=0 & s3=0 & s4=0
readf,in,s1,s2,s3,s4,bstr
styles(0,0)=s1 & styles(1,0)=s2 & styles(2,0)=s3 & !P.psym=s4
readf,in,bstr & bstr=''
readf,in,bstr & if bstr ne '' then begin
inst_value=strtrim(bstr,2)
if b_labins(0) gt 0 then $
widget_control,bad_id=i,b_labins(0),set_value=inst_value
endif
readf,in,bstr & bstr='' & s1=-1
readf,in,s1,bstr & if (s1 ge 0) and (s1 le 40) then tcol=s1
readf,in,bstr & bstr='' & s1=-1
readf,in,s1,bstr & if (s1 ge 0) then smoo=s1
endif
end_fc: if in gt 0 then free_lun,in
for i=0,n_elements(lamp_ins)-1 do if inst_value eq lamp_ins(i) then $
inst_group = lamp_grp(i)
return
end
;
;
pro p_don_init_var ,prog_base ,mess_base
;** **************
;** Sets up variables
@lamp.cbk
@dons.cbk
n=6
if n_elements(prog_base) eq n then prog_txt =prog_base $
else prog_txt =lonarr(n)
if n_elements(mess_base) eq 1 then l_message=mess_base
last_w =1
nwk =1
ifixed =0
formtxt =0
his_info=0
rawmanip=0
mac_raw =0
prog_mac=strarr(n) & don_init_prog_mac ,1
return
end
;
pro p_don_create ,base
;** ************
;** Sets up Formula windows etc
@lamp.cbk
@dons.cbk
;
p_don_init_var
formu =['Enter formula below','']
umac='User'
if GEORGE then begin dou =" STATUS CONTROL" & formu(0)='' & umac='Dial'
baso =widget_base(base ,/row)
baso1=widget_base(baso ,/column)
baso2=widget_base(baso ,/column)
base =widget_base(map=0,group_leader=lamp_b1)
endif else dou =" MANIPULATIONS"
;
; Help and Macro buttons
;
; Text area for formula entry
;
bar0 =widget_base(base ,/row)
bar001 =widget_base(bar0 ,/column)
macro_area_a=widget_base(bar0)
; First Column
; ***** ******
bar01 =widget_base (bar001 ,/row)
bar1 =widget_base (bar01 ,/column)
bar1_1 =widget_base (bar1 ,/row)
btit1 =widget_label (bar1_1 ,font=ft_biggest,value=dou)
bar1_x =widget_base (bar1_1 ,/nonexclusive)
if sys_dep('MAP') ne -1 then $
mac_raw =widget_button(bar1_x ,value='raw',font=ft_smaller,resource_name='discret') else $
mac_raw =widget_button(bar1_x ,value='raw',font=ft_smaller)
bhelp =widget_button(bar1_1 ,font=ft_normal ,value='?')
if lamp_siz lt 900 then begin nbli1=2 & nbli2=2 & labx =350
formtxt =widget_text (bar1 ,font=ft_b_bigger,xsize=40,ysize=nbli1,/editable,value=formu)
endif else begin nbli1=3 & nbli2=2 & labx =562
formtxt =widget_text (bar1 ,font=ft_b_bigger,xsize=40,ysize=nbli1,/editable,value=formu,/scroll)
endelse
;
bar2 =widget_base (bar01 ,/column)
mac_but =widget_button(bar2 ,value=umac+' Macros?')
idlbut =widget_button(bar2 ,value='The Journal')
lamp_don =[lamp_don,idlbut]
up_button =widget_button(bar2 ,value='Data Params')
lamp_don =[lamp_don,up_button]
; *****
l_message =widget_label (bar001 ,font=ft_b_bigger ,xsize=labx,value=' ')
; *****
bar01 =widget_base (bar001 ,/row)
his_info =widget_text (bar01 ,font=ft_b_bigger ,xsize=40,ysize=nbli2,/scroll,$
value=lims(1:*))
bar2 =widget_base (bar01 ,/column)
bar2_1 =widget_base (bar2 ,/column,/exclusive)
info_but =widget_button(bar2_1 ,value='W Min,Max ' ,/no_release)
his_but =widget_button(bar2_1 ,value='W History ' ,/no_release)
; Second Column
; ****** ******
prog_buttons
; Third Column
; ****** *****
machin=sys_dep('MACHINE')
if ((lamp_siz ge 800) and (lamp_siz le 950) and (machin eq 'win')) or $
((lamp_siz ge 800) and (lamp_siz lt 900) and (machin eq 'mac')) then begin
w0=2 & LOGO,w0 & pax1=size(w0)
base =widget_base (bar0,/column)
base =widget_base (base,/frame,/row)
lamp_ben(6)=widget_draw (base,retain=2,xsize=pax1(1),ysize=pax1(2),/button_event)
endif
;
; Controls
widget_control,bhelp ,bad_id=i,set_uvalue=[-88,588,0,0]
widget_control,formtxt ,bad_id=i,set_uvalue=[-88,200,0,0]
widget_control,idlbut ,bad_id=i,set_uvalue=[-88,396,0]
widget_control,his_but ,bad_id=i,set_uvalue=[-88,202,0,0]
widget_control,mac_but ,bad_id=i,set_uvalue=[-88,203,0,0]
widget_control,up_button ,bad_id=i,set_uvalue=[-88,204,0,0]
widget_control,info_but ,bad_id=i,set_uvalue=[-88,207,0,0]
widget_control,mac_raw ,bad_id=i,set_uvalue=[-88,212,0]
widget_control,his_info ,bad_id=i,set_uvalue=[-88,215,0,0]
;;;; widget_control,save_but ,bad_id=i,set_uvalue=[-88,370,0,0]
lamp_focus =formtxt
if GEORGE then begin widget_control,base,/REALIZE
XMANAGER, 'Don beside' ,base, event_handler='LAMP_EVENT_PARSER',/just_reg
for k=0,1 do begin
baso11=widget_base (baso1,/row)
button=widget_button(baso11,value='Do')
text =widget_text (baso11,value=prog_mac(k),font=ft_propor,/editable,xsize=30,ysize=1)
widget_control,button,set_uvalue=[-88,214,0,text,0] & prog_txt(k)=text
widget_control,text ,set_uvalue=[-88,214,0,text,0] & endfor
baso21 =widget_base (baso2 ,/row)
mac_but=widget_button (baso21,value='Macros' ,uvalue=[-88,203,0,0],font=ft_normal)
idlbut =widget_button (baso21,value='Journal',uvalue=[-88,396,0,0],font=ft_normal)
bid =widget_label (baso21,value=' ')
text =widget_text (baso21,value='Ctrl:' ,font=ft_propor,/editable,xsize=30,ysize=1,resource_name="geo")
button =widget_button (baso21,value='Send' ,uvalue=[-88,614,0,text,0])
widget_control,text , set_uvalue=[-88,614,0,text,0]
baso22 =widget_base (baso2,/row)
bhelp =widget_button (baso22,value='?' ,uvalue=[-88,588,0,0],font=ft_normal)
bact =widget_base (baso22,/nonexclusive)
bact =widget_button (bact ,value='Activity ->',uvalue=[-88,660,0,0],font=ft_normal)
l_message=widget_label(baso22,font=ft_b_bigger ,xsize=labx<500,value=' ')
endif
return
end
;
pro prog_buttons
;** ************
;**
@lamp.cbk
@dons.cbk
macro_area_b =widget_base(macro_area_a,/column)
n=n_elements(prog_mac)
if lamp_siz lt 900 then n=5
dou="Do" & uv=214 & prpt=''
for k=0,n-1 do begin
if GEORGE then if k eq 3 then begin dou="Send" & uv=614 & prpt='Ctrl:' & endif
if prpt ne '' then if strpos(prog_mac(k),':') ne 4 then prog_mac(k)=prpt
base =widget_base ( macro_area_b,/row)
if prpt ne '' then $
text=widget_text( base,value=prog_mac(k),font=ft_propor,/editable,$
xsize=26,ysize=1,resource_name="geo") $
else text=widget_text( base,value=prog_mac(k),font=ft_propor,/editable,$
xsize=26,ysize=1)
button=widget_button( base,value=dou)
widget_control,button,bad_id=i,set_uvalue=[-88,uv,k,text,0]
widget_control,text ,bad_id=i,set_uvalue=[-88,uv,k,text,0]
prog_txt(k)=text
endfor
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro p_don_event ,event,uv
;** ***********
;**
;
; 299 Destroy alert windows
if uv(1) eq 299 then begin wait,.3 & widget_control,event.top,/destroy & endif
;
; 200 CR in formula entry
if uv(1) eq 200 then form_in,event
;
; 201 IDL help
if uv(1) eq 201 then MANUAL
; if uv(1) eq 201 then if sys_dep('MAP') le 0 then man_proc,''
; if uv(1) eq 201 then if sys_dep('MAP') le 0 then man_proc,'' $
; else spawn,'$IDL_DIR/bin/idlhelp&'
;
; 202 History
if uv(1) eq 202 then history,event
;
; 203 Update macros
if uv(1) eq 203 then macro_files,event
;
; 204 Display user parameters
if uv(1) eq 204 then par_disp,event
;
; 205 Update user parameters
if uv(1) eq 205 then par_mod,event,uv(2),uv(3)
;
; 206 Update NWK
if uv(1) eq 206 then nwk_mod,event,uv(2),uv(3),uv(4)
;
; 207 Update limits
if uv(1) eq 207 then limits,event
;
; 210 Fire instrument macro
; if uv(1) eq 210 then fire_inst_mac,event,uv(2)
;
; 211 Display *.pro file
if uv(1) eq 211 then pro_list,event
;
; 212
if uv(1) eq 212 then begin
if event.select then setmanip,/raw else setmanip
if event.select then txt="SETMANIP,/raw" else txt="SETMANIP,/noraw"
to_don_history,-1,0, txt
endif
;
; 213 Set up programable button window
if uv(1) eq 213 then prog_buttons
;
; 214 Fire instrument macro
if uv(1) eq 214 then fire_prog_mac,event,uv(2),uv(3)
;
; 215 Set up current workspace
if uv(1) eq 215 then set_cur_work,event
;
; 216 Create a .pro file
if uv(1) eq 216 then pro_create ,uv
;
; 217 Compile a .pro file
if uv(1) eq 217 then pro_compile
;
; 222 DO not use
;
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro setmanip,raw=raw,noraw=noraw
;** ********
;**
@dons.cbk
if keyword_set(raw) then rawmanip=1 else rawmanip=0
if mac_raw gt 0 then widget_control,mac_raw,bad_id=ii,set_button=rawmanip
end
pro form_in,event
;** *******
;**
;FORMULA WINDOW
;
@lamp.cbk
@dons.cbk
; Reads Formula Windows
;
widget_control,event.id,get_value=formu
n =n_elements (formu)-1
formu(n) =strtrim (formu(n),2)
index =where(formu ne '')
if n_elements(index) le n then formu=formu(index)
nelement =n_elements (formu)-1
if n gt nelement then begin
widget_control,event.id,set_value=formu(0:nelement)
widget_control,event.id,set_value='',/append,/no_newline,$
set_text_top_line=nelement-1
endif
if nelement gt 20 then begin
widget_control,event.id,set_value=formu(nelement-10:nelement)
widget_control,event.id,set_value='',/append,/no_newline,$
set_text_top_line=10-1
endif
if (last_form ne formu(nelement)) or (nelement eq n) then begin
ifixed=1 & xicute,formu(nelement) & endif
return
end
pro form_out,outxt
;** ********
;**
@dons.cbk
if formtxt gt 0 then begin
widget_control,formtxt,bad_id=i,get_value=formu
n=(n_elements(formu)-1) >0
formu=[formu((n-15)>0:n),outxt]
n=(n_elements(formu)-1) >0
widget_control,formtxt,bad_id=i,set_value=formu
widget_control,formtxt,bad_id=i,set_value='' ,/append,/no_newline,$
set_text_top_line=n
endif else print,outxt
end
pro commsi ,file, params, macro=extxt, exec=exec
;** ******
;**
common for_users, a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
@lamp.cbk
on_ioerror,miscom
line='' & extxt='' & u=-1
OPENR,u,file,/get_lun
while (not EOF(u)) do begin READF,u,line & extxt=[extxt,line] & endwhile
miscom:if u gt 0 then begin free_lun,u
nn= n_elements(params)<23
if nn gt 0 then for ii=1,nn do begin
jj=strtrim(string(ii),2)
kk=execute('par'+jj+'='+params(ii-1))
endfor
extxt= extxt(1:*)
if keyword_set(exec) then COMMCA,extxt
if nn gt 0 then for ii=1,nn do begin
jj=strtrim(string(ii),2)
kk=execute(params(ii-1)+'=par'+jj)
endfor
endif
end
pro commca ,extxt, prox
;** ******
;**
common for_users, a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
common c_lamp_par
i1=0L & i2=n_elements(extxt)-1
if n_elements(prox) eq 2 then if prox(0) ge 0 then begin i1=prox(0)
i2=prox(1) & endif
for kk=i1,i2 do jj=execute(extxt(kk))
end
pro xicuter,intxt
;** *******
;**
@lamp.cbk
@dons.cbk
if formtxt gt 0 then begin
widget_control,formtxt,bad_id=i,set_value=intxt,/append
widget_control,formtxt,bad_id=i,get_value=formu
n=(n_elements(formu)-1) >0
widget_control,formtxt,bad_id=i,set_value='' ,/append,/no_newline,$
set_text_top_line=n
endif
ifixed=1 & xicute,intxt
return
end
pro xicute,intxt
;** ******
;**
@lamp.cbk
@dons.cbk
common for_users, a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
on_ioerror, mis
GEORGEO, COMMAND=intxt
last_form=intxt & lwtxt=strlowcase(intxt)
if strpos(intxt,';') eq 0 then begin & endif else $
if strpos(intxt,'$') eq 0 then begin
len=strlen(intxt)
if b_labins(3) ne 2 then spawn,strmid(intxt,1,len)
endif else $
if strpos(intxt,'&') gt 0 then begin
com_split,last_form
endif else $
if strpos(intxt,'@') eq 0 then begin
sep=str_sep(intxt,',')
sep=strtrim(sep,2)
if strpos (sep(0),'.') lt 0 then file_name=sep(0)+'.prox' else file_name=sep(0)
len=strlen (file_name) & file_name=strmid(file_name,1,len)
if n_elements(sep) eq 1 then com_file,file_name $
else begin to_don_history, -1,0, intxt
commsi,file_name, sep(1:*), /EXEC & endelse
endif else $
if strpos(intxt,'?') eq 0 then begin
; if sys_dep('MAP') le 0 then man_proc,''
if sys_dep('VERSION') ge 5.0 then online_help else $
if sys_dep('MAP') gt 0 then spawn,'$IDL_DIR/bin/idlhelp&'
endif else $
if strpos(lwtxt,'retall') eq 0 then begin & endif else $
if strpos(lwtxt,'save,') eq 0 then begin SaveSession & endif else $
if (lwtxt eq 'save') then begin SaveSession & endif else $
if strpos(lwtxt,'stop') eq 0 then begin P_LAMP_STOP & endif else $
if strpos(lwtxt,'sho') eq 0 then begin show,intxt & endif else begin
if strpos(lwtxt,'exit') eq 0 then DON_WRITE_PROG_MAC ,0
;** Inspect line for "W" or "Dials"
;** -------------------------------
ii=strpos(intxt,';') & if ii gt 0 then intxt=strmid(intxt,0,ii)
find_w1_w2, intxt ,line_2,one,two,three ,alone ,splitxyz ,opp_r
if (one ge 0) and (one le 23) then begin
if (two lt 0) or (two gt 23) then two=0
if one gt 0 then begin
;** SAVE one parameters
;** ---- --- ----------
one_str =strtrim(string(one) ,2)
two_str =strtrim(string(two) ,2)
three_str=strtrim(string(three),2)
MOVEPAR, (one),one_str, 0,'0'
;** PUT two parameters in one
;** --- --- ---------- -- ---
if two ne 0 then begin
sz_two=[0]
iii =execute('sz_two=size(w' +two_str+')')
calc_e=0
rawraw=rawmanip
if strpos(last_form,';++') gt 0 then rawraw=0 else $
if strpos(last_form,';--') gt 0 then rawraw=1
if (not rawraw) then $
if sz_two(sz_two(0)+2) gt 1 then $
if (three gt 0) and ((opp_r eq '+') or (opp_r eq '-') or (opp_r eq '*') or (opp_r eq '/')) then begin
sz_three=[0] & iii=execute('sz_three=size(w' +three_str+')')
if sz_three(sz_three(0)+2) gt 1 then begin
;** First if third W is here then update n,e
;** ----- -- ----- - -- ---- ---- ------ ---
tix1='' & tix2='' & tix3='E'+one_str & tix4='' & kp_n='' & kp_e=''
nenn=1 & iii=execute('nenn=n_elements(n'+two_str +'(*,0))')
nenk=1 & iii=execute('nenk=n_elements(n'+three_str +'(*,0))')
jjn =0 & iii=execute('jjn =total(n'+two_str +'(*,0))/nenn')
jjk =jjn & iii=execute('jjk =total(n'+three_str+'(*,0))/nenk')
jje =1 & iii=execute('jje=2*sz_two(sz_two(0)+2)-n_elements(e'+two_str+')-n_elements(e'+three_str+')')
tstn=((jjn le 1) and (jjk le 1)) or ((nenn eq 1) and (nenk eq 1))
tstx=1 & iii=execute('tstx=(x'+two_str +'(0) eq x'+three_str+'(0)) and ' + $
'(x'+two_str +'(n_elements(x'+two_str +')-1) eq '+ $
'x'+three_str+'(n_elements(x'+three_str+')-1)) and'+ $
'(sz_two(0) eq sz_three(0))')
; Monitors > 1 or X different then W_ACCU is used
; *************************** **** **************
if (( opp_r eq '+') or (opp_r eq '-')) and (splitxyz(0) ne 'yes') $
and ((not tstx)) then begin
if opp_r eq '+' then ads= ',add=' else ads=',sub='
roaw=''
;if monimon lt 0 then roaw=',/raw'
tt =tolerance
tix4=last_form
plac=0
if (sz_two(0) ne sz_three(0)) then begin
plac=1
tix4='; Incompatible dimensions ...'
if (sz_two(1) eq sz_three(1)) then begin
if (sz_two(0) eq 2) and (sz_three(0) eq 1) then $
tix4='w=w'+two_str+' & for i=0,'+strtrim(string(sz_two(2)-1),2)+ $
' do w(*,i)=w' +two_str+'(*,i) '+opp_r+' w' +three_str+' & w'+one_str+'=w' $
else $
if (sz_two(0) eq 3) and (sz_three(0) eq 2) then $
tix4='w=w'+two_str+' & for i=0,'+strtrim(string(sz_two(3)-1),2)+ $
' do w(*,*,i)=w'+two_str+'(*,*,i) '+opp_r+' w'+three_str+' & w'+one_str+'=w'
endif
endif else begin
if one eq two then tix4='W_ACCU,accu='+ one_str+ ads +three_str +',tol=tt'+roaw else $
if one eq three then begin
tix4='W_ACCU,accu='+three_str+ ads +two_str +',tol=tt'+roaw
if opp_r eq '-' then tix4=tix4+'& w'+one_str+'=-w'+one_str
endif else tix4='W'+one_str+'=0'$
+' & W_ACCU,accu='+one_str+',add='+ two_str +',tol=tt' $
+' & W_ACCU,accu='+one_str+ ads +three_str +',tol=tt'+roaw
endelse
toler=tt
oon=one & if one ne two then too=two else too=three
laa=last_form & ifixed=0
XICUTE, tix4
if (not plac) then begin
if (jjk+jjn gt 1) then tix4='N'+one_str+' average ... ' else tix4=''
if (jje eq 0) then tix4=tix4+'E'+one_str+' evaluated ...'
if opp_r eq '-' then $
if (jjk ne jjn) and (not tstn) then tix4='n'+three_str+' and n'+two_str+' are different ...'
endif
if l_message gt 0 then widget_control,bad_id=iii,l_message,set_value=tix4 else print,tix4
last_w=oon & to_don_history, oon , too , laa+';W_ACCU'
RETURN
endif else begin
;** N..
if jjn gt 0 then begin
if one ne two then kp_n='n0' else kp_n='n'+one_str+'(*,0)'
tix0= kp_n +'=n'+two_str+'(*,0)'+opp_r+'n'+three_str+'(*,0)'
tix1='n'+one_str+'=n'+two_str +opp_r+'n'+three_str
iii=execute(tix0) & if iii ne 1 then tix1=''
endif
;** E..
if jje eq 0 then begin
if one ne two then kp_e='e0' else kp_e=tix3
if (opp_r eq '+') then tix2='=SQRT( e'+two_str+'^2+e'+three_str+'^2)'
if (opp_r eq '-') then tix2='=SQRT( e'+two_str+'^2+e'+three_str+'^2)'
if (opp_r eq '*') then tix2='=SQRT((e'+two_str+'*w'+three_str+')^2+(e'+three_str+'*w'+two_str+')^2)'
if (opp_r eq '/') then tix2='=SQRT((e'+two_str+'/w'+three_str+')^2+(e'+three_str+'*w'+two_str+'/w'+three_str+'^2)^2)'
iii=execute(kp_e+tix2) & if iii ne 1 then tix2='' else if tix1 ne '' then tix1=tix1+' & '
endif
endelse
if tix1+tix2 ne '' then calc_e=1
endif
endif
if one ne two then begin MOVEPAR ,(two),two_str , (one),one_str
if calc_e ne 0 then if tix1 ne '' then iii=execute('n'+one_str+'(*,0)='+kp_n)
if calc_e ne 0 then if tix2 ne '' then iii=execute('e'+one_str+ '='+kp_e)
endif
;** ELSE CLEAR one parameters
;** ---- ----- --- ----------
endif else CLEARPAR,(one),one_str
endif
if l_message gt 0 then widget_control,bad_id=iii,l_message,set_value=' '
datpon=strpos(strlowcase(strcompress(last_form,/remove_all)),',datp')
if datpon gt 0 then SETDATP,datp
stat=0 & jjj=1
catch,stat
if (stat eq 0) and (jjj eq 1) then jjj=EXECUTE(last_form)
if n_elements(one_str) eq 0 then one=0 ;Recursivity Problem ...
if (stat ne 0) or (jjj ne 1) then begin
catch,/cancel
P_MUS,'mus_cannon'
therror=strmid(!err_string,0,65)
if l_message gt 0 then $
widget_control,bad_id=iii,l_message,set_value=therror $
else print,!err_string
print,string(7b)
;** ERROR RESTORE one parameters
;** ----- ------- --- ----------
if one gt 0 then MOVEPAR, 0,'0' , (one),one_str
ifixed=0 & return
endif else begin
if datpon gt 0 then GETDATP,datp
; Place x,y title correctly when nb dimensions change.
; ----- --- ----- --------- ---- -- ---------- ------
if (one gt 0) and (two gt 0) then begin
sz_one=[0] & sz_err=[0] & sz_mon=[0] & sz_x=[0] & sz_y=[0]
iii =execute('w'+one_str+ '=reform(w' +one_str+ ',/overwrite)')
iii =execute('x'+one_str+ '=reform(x' +one_str+ ',/overwrite)')
iii =execute('y'+one_str+ '=reform(y' +one_str+ ',/overwrite)')
iii =execute('sz_one=size(w' +one_str+')')
iii =execute('sz_err=size(e' +one_str+')')
iii =execute('sz_mon=size(n' +one_str+')')
iii =execute('sz_x =size(x' +one_str+')')
iii =execute('sz_y =size(y' +one_str+')')
if (sz_one(sz_one(0)+2) eq sz_x (sz_x (0)+2)) or $
(sz_one(1) eq sz_x (1)) then xko=0 else xko=1
if (sz_one(sz_one(0)+2) eq sz_y (sz_y (0)+2)) or $
(sz_one(0) eq 1) or $
((sz_one(0) gt 1) and (sz_one(2) eq sz_y(1))) then yko=0 else yko=1
if sz_one(sz_one(0)+2) eq sz_err(sz_err(0)+2) then eer=0 else eer=1
if sz_one(sz_one(0)+2) eq sz_mon(sz_mon(0)+2) then mon=0 else mon=1
;** Then reform x,y,z,e,n with splitxyz
;** ---- ------ --------- ---- --------
if splitxyz(0) eq 'yes' then begin
;** X..
if splitxyz(1) ne '' then if xko eq 1 then begin
svtwo=[0] & iii=execute( 'svtwo=size(x' +two_str+')' )
if sz_two(0) ge 1 then begin
if (svtwo(0) eq 0) or (svtwo(1) ne sz_two(1)) then $
iii=execute( 'x'+two_str+'=indgen(sz_two(1))+1' )
if svtwo(0) gt 1 then $
iii=execute( 'x'+one_str+'=reform(x'+two_str+splitxyz(4)+')' ) else $
iii=execute( 'x'+one_str+'= x'+two_str+'('+splitxyz(1)+')' )
iii=execute( 'sz_x =size(x' +one_str+')')
if (sz_one(sz_one(0)+2) eq sz_x (sz_x (0)+2)) or $
(sz_one(1) eq sz_x (1)) then xko=0 else xko=1
endif
endif
;** Y..
if splitxyz(2) ne '' then if yko eq 1 then begin
svtwo=[0] & iii=execute( 'svtwo=size(y' +two_str+')' )
if sz_two(0) ge 2 then begin
if (svtwo(0) eq 0) or $
((svtwo(0) eq 1) and (svtwo(1) ne sz_two(2))) or $
((svtwo(0) eq 2) and (svtwo(2) ne sz_two(2))) then $
iii=execute( 'y'+two_str+'= indgen(sz_two(2))+1' )
if svtwo(0) gt 1 then $
iii=execute( 'y'+one_str+'=reform(y'+two_str+splitxyz(4)+')' ) else $
iii=execute( 'y'+one_str+'= y'+two_str+'('+splitxyz(2)+')' )
iii=execute( 'sz_y =size(y' +one_str+')')
if (sz_one(sz_one(0)+2) eq sz_y (sz_y (0)+2)) or $
((sz_one(0) gt 1) and (sz_one(2) eq sz_y(1))) then yko=0 else yko=1
endif
endif
;** Z..
if splitxyz(3) ne '' then begin
svtwo=[0] & iii=execute( 'svtwo=size(z' +two_str+')' )
if sz_two(0) ge 3 then begin
if (svtwo(0) eq 0) or (svtwo(1) ne sz_two(3)) then $
iii=execute( 'z'+two_str+'= indgen(sz_two(3))+1' )
iii=execute( 'z'+one_str+'= z'+two_str+'('+splitxyz(3)+')' )
endif
endif
;** E..
if (eer eq 1) and (sz_err(0) eq sz_two(0)) then begin
ei1=max(sz_err(0:sz_err(0)) - sz_two(0:sz_two(0)),min=ei2)
if (ei1 eq 0) and (ei2 eq 0) then begin
iii=execute( 'e'+one_str+'=reform(e'+one_str+splitxyz(4)+')' )
iii=execute( 'sz_err=size( e'+one_str+')')
if sz_one(sz_one(0)+2) eq sz_err(sz_err(0)+2) then eer=0 else eer=1
endif
endif
;** N..
if (mon eq 1) and (sz_mon(0) eq sz_two(0)) then begin
ei1=max(sz_mon(0:sz_mon(0)) - sz_two(0:sz_two(0)),min=ei2)
if (ei1 eq 0) and (ei2 eq 0) then begin
iii=execute( 'n'+one_str+'=reform(n'+one_str+splitxyz(4)+')' )
iii=execute( 'sz_mon=size( n'+one_str+')')
if sz_one(sz_one(0)+2) eq sz_mon(sz_mon(0)+2) then mon=0 else mon=1
endif
endif
endif
;** Now check if TOTAL was used
;** --- ----- -- ----- --- ----
; ---- X Y Z
if (sz_one(0) eq 2) and (sz_two(0) eq 3) then begin
if sz_one(1) eq sz_two(1) then begin
if sz_one(2) eq sz_two(2) then begin
endif else if (sz_one(2) eq sz_two(3)) and (yko eq 1) then begin
iii=execute('y' +one_str+'= z' +two_str)
y_tit(one) = z_tit(two)
endif
endif else if (sz_one(1) eq sz_two(2)) and (xko eq 1) then begin
iii=execute('x' +one_str+'= y' +two_str)
iii=execute('y' +one_str+'= z' +two_str)
x_tit(one) = y_tit(two)
y_tit(one) = z_tit(two)
endif
z_tit(one) ='Count'
iii=execute('z' +one_str+'= 0')
endif
; ---- X Y
if (sz_one(0) eq 1) and (sz_two(0) gt 1) and (xko+yko ge 1) then begin
y_tit(one) = 'Count'
if (sz_one(1) eq sz_two(2)) then begin
if (sz_one(1) ne sz_two(1)) then begin
iii=execute('x' +one_str+'= y' +two_str)
x_tit(one) = y_tit(two)
y_tit(one) = z_tit(two)
endif
endif else if sz_two(0) gt 2 then if (sz_one(1) eq sz_two(3)) then begin
iii=execute('x' +one_str+'= z' +two_str)
x_tit(one) = z_tit(two)
y_tit(one) = 'Count'
endif
z_tit(one) =''
iii=execute('y' +one_str+'= [0]')
endif
; ---- E
if (eer eq 1) and (sz_err(0) eq sz_one(0)+1) then begin
if sz_err(0) eq 1 then iii=execute('e'+one_str+'=sqrt(total(e'+one_str+'^2 ))') else $
if sz_err(0) ge 2 then if sz_one(1) ne sz_err(1) then $
iii=execute('e'+one_str+'=sqrt(total(e'+one_str+'^2,1))') else $
if sz_one(1) eq sz_err(2) then $
iii=execute('e'+one_str+'=sqrt(total(e'+one_str+'^2,2))') else $
if sz_err(0) eq 3 then if sz_one(2) ne sz_err(3) then $
iii=execute('e'+one_str+'=sqrt(total(e'+one_str+'^2,3))')
endif
; ---- N
if (mon eq 1) and (sz_mon(0) eq sz_one(0)+1) then begin
if sz_mon(0) eq 1 then iii=execute('n'+one_str+'=total(n'+one_str+' )') else $
if sz_mon(0) ge 2 then if sz_one(1) ne sz_mon(1) then $
; iii=execute('n'+one_str+'=total(n'+one_str+',1)') else $
iii=1 else $
if sz_one(1) eq sz_mon(2) then $
iii=execute('n'+one_str+'=total(n'+one_str+',2)') else $
if sz_mon(0) eq 3 then if sz_one(2) ne sz_mon(3) then $
iii=execute('n'+one_str+'=total(n'+one_str+',3)')
endif
if calc_e ne 0 then begin
if tix2 ne '' then begin tix2=tix3+' evaluated' & last_form=last_form+';E'+one_str & endif
if l_message gt 0 then widget_control,bad_id=iii,l_message,set_value=tix1+tix2 else print,tix1+tix2
endif
endif
; Keep last workspace altered in last_w in common block
; Update history if "wn=" found
if (one ge 1) and (one le 20) then begin last_w=one
his_mod,last_form,line_2
endif else if alone gt 0 then begin
one=alone & two=-1 & last_w=one
his_mod,last_form,''
one=0 & two= 0
endif else if (one ge 0) and (ifixed eq 1) then begin
jou_c=[jou_c,last_form]
jou_w=[jou_w,'']
endif
endelse
endif
endelse
ifixed=0
return
mis: therror=strmid(!err_string,0,65)
if l_message gt 0 then $
widget_control,bad_id=iii,l_message,set_value=therror $
else print,!err_string
print,string(7b)
ifixed=0
return
end
pro don_me_lastf, ici ,flg
;** ************
@dons.cbk
if flg then last_form=ici else ici=last_form
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
pro com_split,formi
;** *********
;**
@lamp.cbk
form =formi & pe=strpos(form,'&') & ifi=ifixed
xicute,strmid (form,0,pe) & ifixed=ifi
xicute,strtrim(strmid(form,pe+1,strlen(form)-pe),2)
return
end
pro com_file,file_name
;** ********
;**
; Executes command file
bstr=''
on_ioerror, end_f
in=-1
openr,in,file_name,/get_lun
while (1) do begin
readf,in,bstr
; assume xicuter is recursive.
xicuter ,bstr
endwhile
end_f: if in gt 0 then free_lun,in
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro history, event
;** *******
;**
@lamp.cbk
;HISTORY BUTTON
if event.select eq 1 then begin
widget_control,his_info,set_value=histxt
ihis=1
endif
return
end
pro set_history
;** ***********
;**
@lamp.cbk
;SHOW HISTORY
DON_LIM_SENS & nh=n_elements(histxt)
if his_info gt 0 then widget_control,his_info,set_value=histxt else $
if l_message le 0 then if nh gt 1 then for i=0,nh-2 do print,histxt(i)
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro limits, event
;** ******
;**
@lamp.cbk
;Info BUTTON
if event.select eq 1 then begin
widget_control,his_info,set_value=limtxt
ihis=0
endif
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
pro macro_files,event
;** ***********
;** Display macros
@lamp.cbk
@dons.cbk
curr_macr=''
n_emacs =0
mac_list ,n_emacs
i=xregistered('mac_page')
if i eq 0 then begin
script=strarr(1000)
mac_help = widget_base (title='Lamp Macro Information',/column,resource_name='lamptouch')
mc_bar1 = widget_base (mac_help ,/row)
;***
mc_bar11 = widget_base (mc_bar1 ,/column)
put_logo ,widget_base(mc_bar11,/row)
header = widget_label (mc_bar11 ,value='Select macro',font=ft_b_bigger)
header = widget_label (mc_bar11 ,value='to view ',font=ft_b_bigger)
mc_bidon = widget_label (mc_bar1 ,value=' ' ,font=ft_b_bigger)
mc_bar11 = widget_base (mc_bar1 ,/column,/frame)
mc_bar111= widget_base (mc_bar11 ,/row)
if GEORGE then can='New:' else can='Create a new:'
mc_bidon = widget_label (mc_bar111,value=can ,font=ft_b_bigger)
compp ='Write new file'
if (sys_dep('RUNTIME') or sys_dep('EMBEDDED')) then $
crea_but2= widget_button(mc_bar111,value='Batch file' ,font=ft_b_bigger,uvalue=[-88,216,2,0]) $
else begin
compp ='Compile new file'
crea_but1= widget_button(mc_bar111,value='Macro' ,font=ft_b_bigger,uvalue=[-88,216,1,0])
crea_but2= widget_button(mc_bar111,value='Batch' ,font=ft_b_bigger,uvalue=[-88,216,2,0])
if GEORGE then $
crea_but2= widget_button(mc_bar111,value='Dial' ,font=ft_b_bigger,uvalue=[-88,216,3,0])
endelse
mac_file = widget_text (mc_bar11 ,value=' ',xsize=18,ysize=1 ,font=ft_propor,/editable)
mc_bar11 = widget_base (mc_bar1 ,/column)
done_but = widget_button(mc_bar11 ,value='Exit' ,font=ft_b_bigger)
comp_but = widget_button(mc_bar11 ,value= compp ,font=ft_b_bigger)
mac_labl = widget_label (mc_bar11 ,value=' ',font=ft_b_normal,xsize=200)
;***
mc_bar2 = widget_base (mac_help ,/row)
if lamp_siz lt 900 then nl=30 else nl=35
mack = widget_list (mc_bar2 ,ysize=n_emacs <nl ,value=macros,font=ft_propor)
file_text= widget_text (mc_bar2 ,xsize=80,ysize=30 ,value=script,font=ft_propor,$
/scroll,/editable)
bid=sys_dep ('DYNLAB',mac_help,1)
widget_control,mac_help ,group_leader=lamp_b1,/realize & put_logo
widget_control,mack ,bad_id=i,set_uvalue=[-88,211,0,0,0,0,0,0,0]
widget_control,comp_but ,bad_id=i,set_uvalue=[-88,217,0,0,0,0,0,0,0]
widget_control,done_but ,bad_id=i,set_uvalue=[-88,299,0,0,0,0,0,0,0]
XMANAGER, 'mac_page' ,mac_help,event_handler='LAMP_EVENT_PARSER',/just_reg
widget_control,bad_id=i,file_text,set_value=''
endif else begin
widget_control,bad_id=i,mack ,set_value=macros
widget_control,bad_id=i,file_text,set_value=''
widget_control,bad_id=i,mac_help ,map=1
endelse
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
pro mac_list,n_emacs
;** ********
;**
@lamp.cbk
@dons.cbk
; Set up macros
mac_ful=[''] & macros=['']
cd,current=mee & home=mee & pmac=''
lmac=sys_dep ('NEWSUB',lamp_dir,'lamp_mac')
hhm=sys_dep ('HOME')
cd,hhm
cd,mee,current=home
if lamp_macro ne '' then begin
stat=0 & catch,stat
if stat ne 0 then begin lamp_macro='' & pmac='' & catch,/cancel
endif else begin
cd,lamp_macro & cd,mee,current=pmac
if (sys_dep('MACHINE') ne 'mac') then pmac=pmac+lamp_dvd
endelse
endif
stat=0 & catch,stat
if stat ne 0 then begin lmac='' & catch,/cancel
endif else begin
cd,lmac & cd,mee,current=lmac
if (sys_dep('MACHINE') ne 'mac') then lmac=lmac+lamp_dvd
endelse
if (sys_dep('MACHINE') ne 'mac') then begin
mee =mee +lamp_dvd
home=home+lamp_dvd & endif
if (sys_dep('RUNTIME') or sys_dep('EMBEDDED')) then xx='x' else xx='*'
;** Current macros
file_names=mee +'*.pro'+xx
mac_all=findfile(file_names,count=n_files)
if n_files gt 0 then begin
ln =strpos(strupcase(mac_all(0)),strupcase(mee))
if ln ge 0 then ln=ln+strlen(mee)
macros =['-- USER --',strmid(mac_all,ln,30)]
mac_ful=['', mac_all]
n_files=n_files+1
endif
n_emacs=n_files
;** Home macros
if home ne mee then begin
file_names=home+'*.pro'+xx
mac_all=findfile(file_names,count=n_files)
if n_files gt 0 then begin
ln =strpos(strupcase(mac_all(0)),strupcase(home))
if ln ge 0 then ln=ln+strlen(home)
if n_emacs gt 0 then begin macros =[macros ,'','-- HOME --',strmid(mac_all,ln,30)]
mac_ful=[mac_ful,'','', mac_all]
n_files=n_files+1
endif else begin macros =[ '-- HOME --',strmid(mac_all,ln,30)]
mac_ful=[ '', mac_all]
endelse
n_files=n_files+1
endif
n_emacs=n_emacs+n_files
endif
;** Lamp_macro macros
if pmac ne '' then if pmac ne home then if pmac ne mee then begin
file_names=pmac+'*.pro'+xx
mac_all=findfile(file_names,count=n_files)
if n_files gt 0 then begin
ln =strpos(strupcase(mac_all(0)),strupcase(pmac))
if ln ge 0 then ln=ln+strlen(pmac)
if n_emacs gt 0 then begin macros =[macros ,'','-- MACP --',strmid(mac_all,ln,30)]
mac_ful=[mac_ful,'','', mac_all]
n_files=n_files+1
endif else begin macros =[ '-- MACP --',strmid(mac_all,ln,30)]
mac_ful=[ '', mac_all]
endelse
n_files=n_files+1
endif
n_emacs=n_emacs+n_files
endif
if lmac ne pmac then if lmac ne home then if lmac ne mee then begin
file_names=lmac+'*.pro'+xx
mac_all=findfile(file_names,count=n_files)
if n_files gt 0 then begin
ln =strpos(strupcase(mac_all(0)),strupcase(lmac))
if ln ge 0 then ln=ln+strlen(lmac)
if n_emacs gt 0 then begin macros =[macros ,'','-- LAMP --',strmid(mac_all,ln,30)]
mac_ful=[mac_ful,'','', mac_all]
n_files=n_files+1
endif else begin macros =[ '-- LAMP --',strmid(mac_all,ln,30)]
mac_ful=[ '', mac_all]
endelse
n_files=n_files+1
endif
n_emacs=n_emacs+n_files
endif
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
pro pro_list,event
;** ********
;**
@dons.cbk
curr_macr=macros (event.index)
file_name=mac_ful(event.index)
ln=strpos(curr_macr,';')
if ln gt 0 then curr_macr=strmid(curr_macr,0,ln)
if file_name ne '' then begin
on_ioerror, no_f
in=-1 & k=0
openr,in,file_name,/get_lun
on_ioerror, end_f
script= strarr(1000)
bstr = ''
for k=long(0),999 do begin
readf,in,bstr
script(k)=bstr
endfor
on_ioerror, end_m
while (1) do begin
mors = strarr(1000)
readf , in,mors
script=[script,mors] & k=k+1000
endwhile
end_m: script=[script,mors] & k=k+1000
while script(k-1) eq '' do k=k-1
end_f:
no_f: if in gt 0 then free_lun,in
if in gt 0 then widget_control,bad_id=i,mac_file ,set_value=curr_macr
if k gt 0 then widget_control,bad_id=i,file_text,set_value=script(0:k-1)
if k gt 0 then widget_control,bad_id=i,mac_labl ,set_value=' ' $
else widget_control,bad_id=i,mac_labl ,set_value='Read error ...!'
endif
return
end
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro pro_create ,uv
;** **********
;**
@dons.cbk
if uv(2) eq 1 then curr_macr='macro.pro'
if uv(2) eq 2 then curr_macr='bat.prox'
if uv(2) eq 3 then curr_macr='dial_model.pro'
widget_control,bad_id=i,mac_file ,set_value= curr_macr
widget_control,bad_id=i,file_text,set_value='',/input_focus
widget_control,bad_id=i,mac_labl ,set_value=' '
if uv(2) eq 1 then widget_control,bad_id=i,file_text,set_value=$
[";Enter PRO or FUNCTION macro below. (the call is macro or a=macros() )" ,$
"" ,$
"PRO macro" ,$
" print,!stime+' by macro'" ,$
"return" ,$
"end"]
if uv(2) eq 2 then widget_control,bad_id=i,file_text,set_value=$
[";Enter lines of IDL commands below. (the call is @bat)",$
"" ,$
"print,!stime+' by bat.prox'",$
""]
if uv(2) eq 3 then widget_control,bad_id=i,file_text,set_value=$
["pro dial_model_macro, Dial" ,$
";** ****************" ,$
";**" ,$
"" ,$
" V=DialNewValue()" ,$
" Dial.value=V" ,$
" end" ,$
"" ,$
"function dial_model" ,$
";******* **********" ,$
";**" ,$
"" ,$
" return, {NAME:'model',VALUE:lonarr(64,64)}" ,$
" end" ,$
"" ,$
";Replace the 4 occurences of 'model' by your 'dial name'" ,$
";File dial_template1.pro contains a list of usual Tags ans Calls" ]
return
end
pro pro_compile
;** ***********
;**
@dons.cbk
widget_control,bad_id=i,mac_file ,get_value=curr_macr
curr_macr=strlowcase(strtrim(curr_macr(0),2))
if curr_macr ne '' then begin
widget_control,bad_id=i,file_text,get_value=new_macro
bat=strmid(curr_macr,strpos(curr_macr,'.'),5)
ok=0
ON_IOERROR,mis_open
OPENW ,out1,'new_'+curr_macr,/get_lun
OPENW ,out2, curr_macr,/get_lun
ON_IOERROR,mis_io
for i=0,n_elements(new_macro)-1 do PRINTF,out1,new_macro(i)
for i=0,n_elements(new_macro)-1 do PRINTF,out2,new_macro(i)
FREE_LUN,out1 & FREE_LUN,out2 & out1=-1 & out2=-1
iii=0
if bat eq '.pro' then iii=execute( strmid('new_'+curr_macr,0,strpos('new_'+curr_macr,'.')) )
if iii eq 0 then ok=1
P_MUS,'mus_shot'
OPENR ,out1,'new_'+curr_macr,/get_lun,/DELETE & FREE_LUN,out1 & out1=-1
mac_list ,n_emacs
widget_control,bad_id=i,mack ,set_value=macros
mis_io :if out1 gt 0 then free_lun,out1
if out2 gt 0 then free_lun,out2
mis_open:if ok eq 0 then widget_control,bad_id=i,mac_labl ,set_value=!err_string $
else widget_control,bad_id=i,mac_labl ,set_value=curr_macr+' Created'
endif
return
end
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro par_disp, event
;** ********
;**
@lamp.cbk
@dons.cbk
;USERPAR BUTTON
;
; Construct the text
if nwk le 0 then nwk=1
par_txt_all(*)=''
npa=0
bb=execute('npa=n_elements(p'+strtrim(string (nwk),2)+')' )
i =0
bb=execute('for i=0,npa-1 do par_txt_all(i)=strtrim(par_txt(nwk,i))+string(p' $
+strtrim(string (nwk),2) + '(i))')
up_t =widget_base (title='LAMP Instrument Parameters',/column,resource_name='lampdon')
bar1 =widget_base (up_t,/row)
put_logo ,widget_base(bar1,/column)
donebut =widget_button(bar1,value='Write')
abortbut=widget_button(bar1,value='Quit')
up_slid =widget_slider(bar1,value=nwk,title='Workspace #',maximum=20,$
minimum=1,xsize=200)
up_labl =widget_label (bar1,value='Numor #',xsize=8*10)
mc_bidon=widget_label (bar1,value=' ' ,xsize=4)
up_win =widget_text (up_t,xsize=51,ysize=31,/scroll,/editable,font=ft_propor)
bid=sys_dep ('DYNLAB',up_t,0)
widget_control,up_t,group_leader=lamp_b1,/realize & put_logo
widget_control,up_win ,bad_id=i,set_value = par_txt_all
widget_control,up_slid ,bad_id=i,set_uvalue=[-88,206,up_win,up_slid,up_labl,0,0,0,0]
widget_control,donebut ,bad_id=i,set_uvalue=[-88,205,up_win,up_slid,up_labl,0,0,0,0]
widget_control,abortbut ,bad_id=i,set_uvalue=[-88,299,0,0,0,0,0,0,0]
XMANAGER, 'ups' ,up_t,event_handler='LAMP_EVENT_PARSER',/just_reg
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro par_mod,event,up_win,up_slid
;** *******
;**
@lamp.cbk
@dons.cbk
; DONE button in USERPAR display
i=0
widget_control,bad_id=i,up_slid,get_value=nwk
if i eq 0 then begin
widget_control,bad_id=i,up_win, get_value=par_txt_all
n =n_elements(par_txt_all)
junk=fltarr(n)
for j=0,n-1 do begin
sht_txt=strtrim (par_txt_all(j))
lnth=strlen(sht_txt)
;
; Pick out number after '='
npos =strpos(sht_txt,'=')
par_len=lnth-npos
par_val=strmid(sht_txt,npos+1,par_len)
junk(j)=float(par_val)
endfor
bb=execute('p' + strtrim(string(nwk),2) + '=junk' )
; Destroy the evidence
wait,.3 & widget_control,event.top,/destroy
endif
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro nwk_mod,event,up_win,up_slid,up_labl
;** *******
;**
@lamp.cbk
@dons.cbk
;
;Changes current workspace
widget_control,bad_id=i,up_slid,get_value=nwk
widget_control,bad_id=i,up_labl,set_value=w_numor(nwk)
par_txt_all(*)=''
npa=0
bb=execute('npa=n_elements(p'+strtrim(string (nwk),2)+')' )
i =0
bb=execute('for i=0,npa-1 do par_txt_all(i)=strtrim(par_txt(nwk,i))+string(p' $
+strtrim(string (nwk),2) + '(i))')
;
; Update window text
widget_control,bad_id=i,up_win,set_value=par_txt_all
return
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro find_w1_w2, line,line_2,one,two,three ,alone ,splitxyz ,opp_r
;** **********
;**
;find first two workspaces on line
;must be an "="
;must be one "w" each side of "="
splitxyz=['no']
line_2 =''
opp_r =''
one =0
two =0
three =0
alone =0
;find first "w"
;--------------
pos_w=strpos(strlowcase(line),'w')
if pos_w lt 0 then RETURN
lnth =strlen(line)
;find ","
;--------
pos_v=strpos(line,',')
;find "="
;--------
pos_e=strpos(line,'=')
if pos_v ge 0 then if pos_v lt pos_w then pos_e=-1
if pos_e lt pos_w then pos_e=-1
;find a lone "w"
;---- ---------
if pos_e le 0 then begin
ch1=strmid(line,pos_w+1,1)
if (ch1 ge '0') and (ch1 le '9') then begin
ch2=strmid(line,pos_w+2,1)
if (ch2 lt '0') or (ch2 gt '9') then alone=fix(ch1) $
else alone=fix(ch1+ch2)
endif
RETURN
endif
; is there a second "w" before the "="?
;--------------------------------------
line_t=strmid(line,pos_w+1,pos_e-(pos_w))
pos_t =strpos(strlowcase(line_t),'w')
if pos_t gt 0 then RETURN
;what follows first "w";Is it a number?
;--------------------------------------
ch1=strmid(line,pos_w+1,1)
if (ch1 lt '0') or (ch1 gt '9') then RETURN
;next;Try a case (care wi(m,n)=x --> assume two=one to keep history)
;---------------
ch2=strmid(line,pos_w+2,1)
case 1 of
(ch2 eq ' '): one=fix(ch1)
(ch2 eq '='): one=fix(ch1)
(ch2 eq '('): begin one=fix(ch1) & two=one & end
(ch2 lt '0') or (ch2 gt '9'): RETURN
else: begin one=fix(ch1+ch2)
ch3=strmid(line,pos_w+3,1)
if ch3 eq '(' then two=one & end
endcase
; is there a "w" after the "="
;-----------------------------
;This is repeated until a "w" if followed by an number or eol
iquit=0 & pos_e1=0
while (iquit eq 0) do begin
line_2=strmid(line,pos_e,lnth-pos_e)
; find second or third "w"
pos_w =strpos(strlowcase(line_2),'w')
if pos_w lt 0 then begin
iquit=1
RETURN
endif
; what follows second or third "w"
ch1=strmid(line_2,pos_w+1,1)
; Is it a number?
if (ch1 ge '0') and (ch1 le '9') then begin
ch2=strmid(line_2,pos_w+2,1)
po3=pos_w+3
case 1 of
(ch2 eq ''): if two eq 0 then two=fix(ch1) else three=fix(ch1)
(ch2 eq ' '): if two eq 0 then two=fix(ch1) else three=fix(ch1)
(ch2 eq '('): begin po3=po3-1
if two eq 0 then two=fix(ch1) else three=fix(ch1) & end
else: if (ch2 ge '0') and (ch2 le '9') then $
if two eq 0 then two=fix(ch1+ch2) else three=fix(ch1+ch2) else $
if two eq 0 then two=fix(ch1) else three=fix(ch1)
endcase
; Check for splitxyz
pe=po3
lp=pos_w+1
if strmid(line_2,po3,1) eq '(' then $
if three gt 0 then pe=(strpos(line_2,')',po3)+1)>po3 else $
if three eq 0 then begin
f2p=strpos(line_2,':',po3)
lp =strpos(line_2,')',po3)
if (lp gt po3+1) then splitxyz=['yes','','','',strmid(line_2,po3,lp-po3+1)]
if (lp gt f2p) and (f2p gt 0) then begin
fv =strpos(line_2,',',po3)
;** SPLIT X
;** -------
if (fv gt f2p) or (fv lt 0) then begin
if (fv lt 0) or (fv gt lp) then ib=lp else ib=fv
splitxyz(1)=strmid(line_2,po3+1,ib-po3-1)
endif
if fv gt 0 then begin
s2p=strpos(line_2,':',fv)
if s2p gt 0 then begin
sv =strpos(line_2,',',fv+1)
;** SPLIT Y
;** -------
if (sv gt s2p) or (sv lt 0) then begin
if (sv lt 0) or (sv gt lp) then ib=lp else ib=sv
splitxyz(2)=strmid(line_2,fv+1,ib-fv-1)
endif
if sv gt 0 then begin
t2p=strpos(line_2,':',sv)
if t2p gt 0 then begin
tv =strpos(line_2,',',sv+1)
;** SPLIT Z
;** -------
if (tv gt t2p) or (tv lt 0) then begin
if (tv lt 0) or (tv gt lp) then ib=lp else ib=tv
splitxyz(3)=strmid(line_2,sv+1,ib-sv-1)
endif
endif
endif
endif
endif
endif
endif
; is there a third "w" ?
;-----------------------
if three ne 0 then begin if three gt 0 then begin
pe_l =strcompress(strmid(line_2,pe,10),/remove_all)
if pe_l eq '' then begin
line_2=strmid(line,pos_e1,pos_e+pos_w-pos_e1+1)
if strpos(line_2,'+') ge 0 then opp_r=opp_r+'+'
if strpos(line_2,'-') ge 0 then opp_r=opp_r+'-'
if strpos(line_2,'/') ge 0 then opp_r=opp_r+'/'
if strpos(line_2,'*') ge 0 then opp_r=opp_r+'*'
if strpos(line_2,'#') ge 0 then opp_r=opp_r+'#'
endif
endif
RETURN & endif
pos_e1=pos_e+lp
three=-1
endif
pos_e=pos_e+pos_w+1
if pos_e ge lnth then RETURN
endwhile
RETURN
end
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
pro to_don_history, did_one , did_two , line
;** **************
;**
@lamp.cbk
@dons.cbk
kp_one=one & kp_two=two
one=did_one
two=did_two
ifixed=1
his_mod, line , ''
ifixed=0
if did_one lt 0 then begin one=kp_one & two=kp_two & endif
return
end
pro his_mod,line,line_2
;** *******
;**
;Modify history of one
@lamp.cbk
@dons.cbk
IF one ge 0 THEN BEGIN
dim=[0,0]
wkspce='w'+strtrim(string(one),2)
wkspac='w'+ string(one,format='(i2)')
i=execute('dim=size('+wkspce+')')
tipe=dim(dim(0)+1)
case tipe of
1:lims(one)='Byte '
2:lims(one)='Integer'
3:lims(one)='Long '
4:lims(one)='Float '
5:lims(one)='Double '
6:lims(one)='Complex'
7:lims(one)='String '
8:lims(one)='Struct '
else:lims(one)='Undef '
endcase
lims(one)=wkspac+': '+lims(one)
if dim(0) ge 1 then lims(one)=lims(one)+' dim = ' + strtrim(string(dim(1)),2)
if dim(0) ge 2 then lims(one)=lims(one)+' * ' + strtrim(string(dim(2)),2)
if dim(0) ge 3 then lims(one)=lims(one)+' * ' + strtrim(string(dim(3)),2)
if dim(0) ge 4 then lims(one)=lims(one)+' * ' + strtrim(string(dim(4)),2)
miny=0
maxy=0
if (tipe gt 0) and (tipe lt 7) then begin
if dim(0) gt 0 then begin
i=execute('maxy=max('+wkspce+',min=miny)')
if tipe eq 1 then begin miny=fix(miny) & maxy=fix(maxy) & endif
lims(one)=lims(one)+' min='+strtrim(string(miny),2)+$
' max='+strtrim(string(maxy),2)
endif else begin
i=execute('miny='+wkspce)
if tipe eq 1 then miny=fix(miny)
if miny ne 0 then lims(one)=lims(one)+' Scalar='+ strtrim(string(miny),2) $
else lims(one)=' '
endelse
endif
w_min(one)=miny
w_max(one)=maxy
DON_LIM_SENS
if ihis eq 0 then begin
n=n_elements(limtxt)
i=0 & chk='w'+string(last_w,format='(i2)')
if n gt 1 then $
for j=1,n-1 do if strmid(limtxt(j),0,3) eq chk then i=j
if his_info gt 0 then $
widget_control,bad_id=i,his_info ,set_value=limtxt, $
set_text_top_line=i $
else if l_message gt 0 then $
widget_control,bad_id=i,l_message,set_value=lims(one) $
else print,lims(one)
endif
if two lt 0 then begin
; update info only
endif else begin
;
; search for another wkspce after th =
pos2=strpos(line_2,wkspce)
;
; when wkspce appears again append history
if pos2 ge 0 then begin
his(one)=line+' ... '+his(one)
; when wkspce appears again but not the same
endif else if two gt 0 then begin
his(one)=line+' ... '+his(two)
; when no second workspace just use line as history
endif else begin
if (dim(0) eq 0) and (miny eq 0) and (tipe lt 7) then his(one)=' ' $
else his(one)=line
endelse
endelse
wtb(one)=0
if (one gt 0) and (one le 20) then begin i=execute('Sna'+strtrim(string(one),2)+'=0')
if abs(sys_dep('MAP')) ne 1 then to_did_cur , wkspce
endif
histxt=his(where(his ne ' '))
if ihis eq 1 then if his_info gt 0 then $
widget_control,bad_id=i,his_info ,set_value=histxt $
else if l_message gt 0 then $
widget_control,bad_id=i,l_message,set_value=his(one) $
else print,his(one)
ENDIF
if ifixed eq 1 then begin
if one lt 0 then begin one=0 & j=n_elements(jou_c)-1
if j gt 200 then begin DID_WRITE_JOURNAL & j=n_elements(jou_c)-1 & endif
i=strpos(strlowcase(line(0)),'see')
if i ge 0 then i=strpos(strlowcase(jou_c(j)),'see') $
else i=strpos(strlowcase(line (0)),'passw')
if i lt 0 then begin jou_c=[jou_c,line]
j=n_elements(line) & lines=strarr(j)
jou_w=[jou_w,lines]
endif else lines=''
endif else begin
jou_c=[jou_c,line] & lines=';'+lims(one)
jou_w=[jou_w,lines] & endelse
i=xregistered('JOURNAL')
if i gt 0 then begin widget_control,bad_id=i,lamp_don(0),get_uvalue=basc
widget_control,bad_id=i,basc,set_value=line+' '+lines,$
/append,SET_TEXT_TOP_LINE=(n_elements(jou_c)-18)>0
endif
endif
end
pro DON_LIM_SENS
;** ************
;**
@lamp.cbk
limtxt=lims(where(lims ne ' '))
if n_elements(lamp_don) gt 2 then begin
nl=n_elements(limtxt) & j=-1
if (nl gt 1) and (lamp_don(1) eq 1) then begin lamp_don(1)=0 & j=1 & endif
if (nl le 1) and (lamp_don(1) eq 0) then begin lamp_don(1)=1 & j=0 & endif
if not GEORGE then $
if j ge 0 then begin for i=2,n_elements(lamp_don)-1 do $
widget_control,bad_id=ii,lamp_don(i),sensitive=j
endif
endif
end
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
pro fire_prog_mac,event,num1,num2
;** *************
;**
@dons.cbk
;
; Put programmed key macro command into formula window for last workspace
comy=[' ']
widget_control,num2,bad_id=i,get_value=comy
prog_mac(num1)=comy(0)
xicuter,strtrim(comy(0),2)
return
end
;
pro don_write_prog_mac ,flg
;** ******************
;**
;** Write user command list and begood options
@dons.cbk
@lamp.cbk
common c_draw, w0,xx,yy,axy,uxy,wnumber,v,p,thresh,rx,rz,nlv,tcol,siz,flgsurf,$
wbeside,vfl,styles,w4d,smoo,vff
n=n_elements(prog_mac)
if flg eq 0 then begin
for k=0,n-1 do begin
comy=[' ']
if prog_txt(k) gt 0 then widget_control,prog_txt(k),bad_id=i,get_value=comy
prog_mac(k)=comy(0)
endfor
endif
on_ioerror, end_fc
bid=findfile('lamp.cds',count=cnt)
if cnt gt 0 then bid=sys_dep('DELET','lamp.cds')
out=-1 & openw,out ,'lamp.cds',/get_lun
for k=0,n-1 do printf,out,prog_mac(k)
printf,out,' '
printf,out,lamp_devps
printf,out,' '
printf,out,rx,rz,nlv,' For rx ry nlv'
printf,out,' '
printf,out,styles(0,0),styles(1,0),styles(2,0),!P.psym,' For styles !P.psym'
printf,out,' '
printf,out,inst_value
printf,out,' '
printf,out,tcol,' For color table #'
printf,out,' '
printf,out,smoo,' For smooth image '
end_fc: if out gt 0 then free_lun,out
return
end
pro set_cur_work,event
;** ************
;**
@lamp.cbk
w =event.index
wk=strmid(limtxt(w),0,3)
to_did_cur , wk
return
end
pro show,string_in
;** ****
;**
;
;Handles sho command
;
@lamp.cbk
@dons.cbk
common for_users, a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z
rhs =' '
moan='Cant show '
stat=0 & jjj=1
catch,stat
if (stat ne 0) or (jjj ne 1) then begin
catch,/cancel
P_MUS,'mus_cannon'
if l_message le 0 then print,moan+rhs else $
widget_control,bad_id=iii,l_message,set_value=moan+rhs
print,string(7b)
return
endif else begin
string_in=strtrim(string_in,2)
coma=strpos(string_in,',')
if (coma le 0) then coma=strpos(string_in,' ')
fin =strlen(string_in)
lstr=fin-coma
if (coma le 0) or (coma eq fin-1) then return
rhs =strmid(string_in,coma+1,lstr)
abc=' '
jjj=execute('abc='+rhs)
icheck=n_elements(abc)
if icheck gt 1 then abc=reform(abc,icheck,/overwrite)
if icheck gt 10 then abc=abc(0:9)
ans=string(abc)
if GEORGE then begin
if icheck gt 10 then ans=['!first elements printed ...',ans]
to_don_history,-1,0, ans
endif
if formtxt le 0 then begin
if icheck eq 1 then if l_message le 0 then print,ans else $
widget_control,l_message,bad_id=iii,set_value=ans $
else begin print,ans & ans='!first elements printed ...'
if l_message le 0 then print,ans else $
widget_control,bad_id=iii,l_message,set_value=ans
endelse
endif else begin
if l_message le 0 then begin
print,ans
if icheck gt 10 then print,'Woops - Only first 10 elements given'
endif else begin
widget_control,formtxt,bad_id=iii,set_value=ans,/append
widget_control,formtxt,bad_id=iii,set_value='' ,/append
if icheck gt 10 then begin
i_bust='Woops - Only first 10 elements given'
widget_control,bad_id=iii,l_message,set_value=i_bust
endif else widget_control,bad_id=iii,l_message,set_value=' '
endelse
endelse
endelse
return
end
pro dons
;** ****
return
end