; $Id: dave_beast_ops.pro,v 1.5 2005/02/03 18:04:12 azuah Exp $
;###############################################################################
;
; LICENSE:
;  The software in this file is written by an employee of 
;  National Institute of Standards and Technology 
;  as part of the DAVE software project.
;
;  The DAVE software package is not subject to copyright protection
;  and is in the public domain. It should be considered as an
;  experimental neutron scattering data reduction, visualization, and
;  analysis system. As such, the authors assume no responsibility
;  whatsoever for its use, and make no guarantees, expressed or
;  implied, about its quality, reliability, or any other
;  characteristic. The use of certain trade names or commercial
;  products does not imply any endorsement of a particular product,
;  nor does it imply that the named product is necessarily the best
;  product for the stated purpose. We would appreciate acknowledgment
;  if the DAVE software is used of if the code in this file is
;  included in another product.
;
;###############################################################################
;
; Written by J.R.D. Copley.
;************************************************************************************************
pro dave_analyze_beast,beast,title,lines,flags,bptrs,analysis=analysis
;************************************************************************************************
; This procedure analyzes a "beast" recursively.
; It returns, inter alia, a flag which is:
; 0 if the "beast" is not a pointer and not a structure, e.g. a scalar, array, or string.
; 1 if the "beast" is a structure.
; 2 if the "beast" is a pointer.
;
compile_opt strictarr
;
;
flag=0
;
help,beast,output=helpmsg
;
isstructure = float(strpos(helpmsg,"STRUCT")) ge 0
ispointer = float(strpos(helpmsg,"POINTER")) ge 0
;
if (isstructure[0]) then begin
	flag=1
	tags=tag_names(beast)
	for i=0,n_tags(beast)-1 do begin
		dave_analyze_beast,beast.(i),title+"."+tags[i],lines,flags,bptrs,analysis=analysis
	endfor
endif
;
if (ispointer[0]) then begin
	valid=ptr_valid(beast)
	if (not valid[0]) then begin
		flag=99
	endif else begin
		flag=2
		bptrs=[bptrs,beast]
		dave_analyze_beast,*beast,"(*"+title+")",lines,flags,bptrs,analysis=analysis
	endelse
endif
;
if (analysis) then print,flag," ",title

lines=[lines,title]
flags=[flags,flag]
;
return
end


;************************************************************************************************
pro dave_beast_ops,operation,beast1,beast2,bpointers=bptrs,show_commands=kcommands,$
	show_analysis=kanalysis
;************************************************************************************************
; This is a procedure to operate on a top level beast that is either a structure or a pointer.
; The "bpointers" keyword returns the heap variables in the beast.
; Permitted operations are "dup*licate","cle*ar","rem*ove","get_ptrs".
; "dup" copies beast1 to beast2, "cle" initializes beast1, "rem" deletes beast1,
;	"get_ptrs" simply returns the pointer variables in the "bpointers" keyword.
; If the "show_commands" keyword is set, commands are also echoed to the screen.
; If the "show_analysis" keyword is set, the analysis of the beast is echoed to the screen.
; DO NOT TRY TO USE THIS WITH PROCEDURE WITH TOP LEVEL BEASTS THAT ARE
;	ELEMENTS OF POINTER ARRAYS.
;
compile_opt strictarr
;
;
commands=keyword_set(kcommands)
analysis=keyword_set(kanalysis)
origin_name="beast1"
destination_name="beast2"
;
lines=""
flags=0
bptrs=ptr_new()
;
dave_analyze_beast,beast1,origin_name,lines,flags,bptrs,analysis=analysis
;
nlines=n_elements(lines)-1
lines=lines[1:nlines]
flags=flags[1:nlines]
;
nptrs=n_elements(bptrs)-1
if (nptrs ge 1) then bptrs=bptrs[1:nptrs]
;
if (operation eq "get_ptrs") then return
;
fields=strarr(nlines)+"blank"
lhs=strarr(nlines)+"blank"
;
ops=strmid(operation,0,3)
;
if (commands) then print," "+string(10B)+strupcase(operation)+" operation."
;
tlstructure=(flags[nlines-1] eq 1); top level is a structure
tlpointer=(flags[nlines-1] eq 2); top level is a pointer
if (not tlstructure and not tlpointer) then begin
	print,"The beast must be a pointer or a structure."
	return
endif
;
case ops of
	"dup": begin
		temp_ptr=ptrarr(nlines)
		for i=0,nlines-1 do begin
			case flags[i] of
				0:	begin
					lhs[i]="temp_ptr["+strcompress(i,/remove_all)+"]"
					rhs="ptr_new("+lines[i]+")"
				end
				1: begin
					lhs[i]="temp_ptr["+strcompress(i,/remove_all)+"]"
					rhs="ptr_new({"
					for j=0,i-1 do begin
						if (strpos(lines[j],lines[i]) eq 0 and $
							strpos(lines[j],".",/reverse_search) le strlen(lines[i])) then begin
							if (strmid(lhs[j],0,4) eq "temp") then sep=":*" else sep=":"
								rhs=rhs+fields[j]+sep+lhs[j]+","
						endif
					endfor
					rhs=strmid(rhs,0,strlen(rhs)-1)+"})"
				end
				2:	begin
					lhs[i]=strmid(lines[i],strpos(lines[i],".",/reverse_search)+1)
					if (tlpointer and i eq nlines-1) then lhs[i]=destination_name
					rhs="ptr_new(*"+lhs[i-1]+")"
				end

				99: begin
					lhs[i]="blank"
					rhs="ptr_new()"
				end


				else:
			endcase
			fields[i]=strmid(lines[i],strpos(lines[i],".",/reverse_search)+1)
			command=lhs[i]+" = "+rhs
			if (commands) then print,strupcase(command)
			if (not execute(command)) then begin
				r=dialog_message("The command "+command+" is NO GOOD.",/error)
				return
			endif
		endfor
		if (tlstructure) then begin
			command=destination_name+"=*temp_ptr["+strcompress(nlines-1,/remove_all)+"]"
			if (commands) then print,strupcase(command)
			if (not execute(command)) then begin
				r=dialog_message("The command "+command+" is NO GOOD.",/error)
				return
			endif
		endif
		ptr_free,temp_ptr
	end
;
	"cle": begin
		for i=0,nlines-1 do begin
			if (flags[i] eq 0) then begin
				command="type=size("+lines[i]+",/type)"
				if (not execute(command)) then begin
					r=dialog_message("The command "+command+" is NO GOOD.",/error)
					return
				endif
				command="nels=size("+lines[i]+",/n_elements)"
				if (not execute(command)) then begin
					r=dialog_message("The command "+command+" is NO GOOD.",/error)
					return
				endif
				case type of
					0:	begin
						print,"Clear operation: type 0 (undefined) cannot be processed."
						return
					end
					1: rhs="byt"
					2: rhs="int"
					3: rhs="lon"
					4: rhs="flt"
					5: rhs="dbl"
					6: rhs="complex"
					7: rhs="str"
					9: rhs="dcomplex"
					10:	begin
						print,"Clear operation: type 10 (pointer) cannot be processed."
						return
					end
					11:	begin
						print,"Clear operation: type 11 (object reference) cannot be processed."
						return
					end
					12: rhs="uint"
					13: rhs="ulon"
					14: rhs="lon64"
					15: rhs="ulon64"
					else: begin
						print,"Clear operation: unknown type cannot be processed."
						return
					end
				endcase
				rhs=rhs+"arr("+strcompress(nels,/remove_all)+")"
				command=lines[i]+"="+rhs
				if (commands) then print,strupcase(command)
				if (not execute(command)) then begin
					r=dialog_message("The command "+command+" is NO GOOD.",/error)
					return
				endif
			endif
		endfor
	end
;
	"rem": begin
		for i=0,nlines-1 do begin
			if (flags[i] eq 2) then begin
				command="ptr_free,"+lines[i]
				if (commands) then print,strupcase(command)
				if (not execute(command)) then begin
					r=dialog_message("The command "+command+" is NO GOOD.",/error)
					return
				endif
			endif
		endfor
	end
	else: begin
		print,strupcase(operation)," is an invalid operation."
		print,"Permitted operations are DUP, CLE, REM."
	end
endcase
;
end
