# $Id: import_cif.tcl 377 2009-12-04 23:05:09Z toby $

#-------------------------------------------------
# define info used in addcmds.tcl
set description "Crystallographic Information File (CIF)"
set extensions .cif
set procname ReadCIFFile
#-------------------------------------------------

proc ReadCIFFile {filename} {
    global expgui
    set fp [open $filename r]
    pleasewait "Reading CIF file"	   
    set blocks [ParseCIF $filename]
    if {$blocks == ""} {
	donewait
	MyMessageBox -parent . -type ok -icon warning \
		-message "Note: no valid CIF blocks were read from file $filename"
	return 
    }
    set allblocks {}
    set coordblocks {}
    # search each block for coordinate
    for {set i 1} {$i <= $blocks} {incr i} {
	lappend allblocks $i
	global block$i
	set flag 1
	foreach id {_atom_site_fract_x _atom_site_fract_y _atom_site_fract_z} {
	    if {[array name block$i $id] == ""} {set flag 0}
	}
	if $flag {lappend coordblocks $i}
    }
    donewait
    if {$coordblocks == ""} {
	MyMessageBox -parent . -type ok -icon warning \
		-message "Note: CIF $filename contains no coordinates"
	return
    }
    set expgui(choose) [lindex $coordblocks 0]
    # there is more than one appropriate block
    if {[llength $coordblocks] > 1} {
	catch {destroy .choose}
	toplevel .choose
	wm title .choose "Choose CIF Block"
	bind .choose <Key-F1> "MakeWWWHelp expguierr.html ChooseCIF"
	grid [label .choose.0 -text \
		"More than one block in CIF $filename\ncontains coordinates.\nSelect the block to use" \
		] -row 0 -column 0 -columnspan 2
	set row 0
	foreach i $coordblocks {
	    incr row
	    set name ""
	    catch {set name [set block${i}(data_)]}
	    grid [radiobutton .choose.$row -value $i \
		    -text "block $i ($name)" -variable expgui(choose)] \
		    -row $row -column 0 -sticky w
	}
	grid [button .choose.browse -text CIF\nBrowser -command \
		"BrowseCIF [list $allblocks] [list $coordblocks] .choose.cif" \
		] -row 1 -rowspan $row -column 1 
	grid [button .choose.ok -text OK -command "destroy .choose"] \
		-row [incr row] -column 0 -sticky w
	grid [button .choose.help -text Help -bg yellow \
	    -command "MakeWWWHelp expguierr.html ChooseCIF"] \
	    -column 1 -row $row -sticky e
	putontop .choose
	tkwait window .choose
	# fix grab...
	afterputontop
    }

    set i $expgui(choose)
    # get the space group
    set spg {}
    set msg {}
    catch {
	set spg [set block${i}(_symmetry_space_group_name_h-m)]
	regsub -all {'} $spg {} spg
	# see if this space group exists in the table
	set fp [open [file join $expgui(scriptdir) spacegrp.ref] r]
	while {[gets $fp line] >= 0} {
	    if {[string trim $spg] == [lindex $line 8]} {
		close $fp
		break
		set fp {}
	    }
	}	
	if {$fp != ""} {
	    close $fp
	    set msg "Warning: the Space Group ($spg) may not be correctly specified for GSAS"
	}
    }
    set cell {}
    foreach var {_cell_length_a _cell_length_b _cell_length_c \
	    _cell_angle_alpha _cell_angle_beta _cell_angle_gamma} {
	# leave blank any unspecified data items
	set val {}
	catch {set val [set block${i}($var)]}
	lappend cell [lindex [ParseSU $val] 0]
    }
    
    set atomlist {}
    set lbllist {}
    catch {
	set lbllist [set block${i}(_atom_site_label)]
    }
    set uisolist {}
    set Uconv 1
    catch {
	set uisolist [set block${i}(_atom_site_u_iso_or_equiv)]
    }
    if {$uisolist == ""} {
	catch {
	    set uisolist [set block${i}(_atom_site_b_iso_or_equiv)]
	    set Uconv [expr 1/(8*3.14159*3.14159)]
	}
    }
    set occlist {}
    catch {
	set occlist [set block${i}(_atom_site_occupancy)]
    }
    set typelist {}
    catch {
	set typelist [set block${i}(_atom_site_type_symbol)]
    }
    foreach x [set block${i}(_atom_site_fract_x)] \
	    y [set block${i}(_atom_site_fract_y)] \
	    z [set block${i}(_atom_site_fract_z)] \
	    lbl $lbllist uiso $uisolist occ $occlist type $typelist {
	if {$uiso == ""} {set uiso 0.025}
	# should not be any quotes, but remove them, if there are
	foreach var {lbl type} {
	    foreach char {' \"} {
		set q {\\}
		append q $char
		set hidden [regsub -all $q [set $var] \200 $var]
		if {[string index [set $var] 0] == $char} {
		    regsub -all $char [set $var] {} $var
		}
		if {$hidden} {regsub -all \200 [set $var] $char $var}
	    }
	}
	# CIF specifies types as Cu2+; GSAS uses Cu+2
	if {[regexp {([A-Za-z]+)([1-9])([+-])} $type junk elem sign val]} {
	    set type ${elem}${val}$sign
	}
	# if type is missing, attempt to parse an element in the label
	if {$type == "" && $lbl != ""} {
	    regexp {[A-Za-z][A-Za-z]?} $lbl type 
	}
	# get rid of standard uncertainies
	foreach var {x y z occ uiso} {
	    catch {
		set $var [lindex [ParseSU [set $var]] 0]
	    }
	}
	# convert Biso to Uiso (if needed)
	if {$Uconv != 1} {
	    catch {set $uiso [expr $Uconv*$uiso]}
	}
	lappend atomlist [list $lbl $x $y $z $type $occ $uiso]
    }

    # clean up -- get rid of the CIF arrays
    for {set i 1} {$i <= $blocks} {incr i} {
	unset block$i
    }
    return "[list $spg] [list $cell] [list $atomlist] [list $msg]"
}

# ParseCIF reads and parses a CIF file putting the contents of
# each block into arrays block1, block2,... in the caller's level
#    the name of the block is saved as blockN(data_)
# data names and items are saved as blockN(_data_name) = {data item}
#    data items are not reformatted, thus quotes, semicolons & newlines 
#    are included in the data item string
#    CIF names are converted to lower case
# for looped data names, the data items are included in a list:
#    blockN(_cif_name) = {item1 "item2 with spaces" item3 ...} 
# the contents of each loop are saved as blockN(loop_M)
#
# The proc returns the number of blocks that have been read or a
#    null string if the file cannot be opened
#
# This parser does some error checking [errors are reported in blockN(error)]
#    but the parser could get confused if the CIF has invalid syntax
#
proc ParseCIF {filename} {
    if [catch {
	set fp [open $filename r]
    }] {return ""}

    set blocks 0
    set EOF 1
    set line {}
    set dataname {}
    # line counter (for error messages)
    set linenum 0
    # this flags where we are w/r a loop_
    #    -1 not in a loop
    #     0 reading a loop header (data names)
    #     1 reading the data items in a loop
    set loopflag -1
    set loopnum -1
    # loop over tokens
    while {$EOF} {
	# read the next line, unless we have a holdover from the previous
	if {[string length [string trim $line]] <= 0} {
	    incr linenum
	    if {[gets $fp line] < 0} {set EOF 0}
	}
	# flag if the string \' has been replaced
	set hidden 0
	set trimline [string trim $line]
	set firstchar [string index $trimline 0]
	
	if {[string length $trimline] <= 0} {
	    # the line is blank
	    set line {}
	    continue
	} 
	
	if {$firstchar == "#"} {
	    # this is a comment
	    set line {}
	    continue
	} 
	
	if {[string tolower [string range $trimline 0 4]] == "data_"} {
	    # this is the beginning of a data block
	    incr blocks
	    # are there other tokens on this line?
	    if {[set pos [string first { } $trimline]] == -1} {
		set blockname [string range $trimline 5 end]
		set line {}
	    } else {
		set blockname [string range $trimline 5 [expr $pos-1]]
		set line [string range $trimline $pos end]
	    }
	    global block$blocks
	    catch {unset block$blocks}
	    set block${blocks}(data_) $blockname
	    set loopnum -1
	    
	    if {$line == ""} continue
	    if {$dataname != ""} {
		# this is an error -- data_ block where a data item is expected
		append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
		set dataname {}
	    }
	}
	
	if {$firstchar == "_"} {
	    # this is a cif data name
	    if {$dataname != ""} {
		# this is an error -- data name where a data item is expected
		append block${blocks}(errors) "No data item was found for $dataname near line $linenum\n"
	    }
	    # parse it out & convert it to lower case
	    if {[set pos [string first { } $trimline]] == -1} {
		# nothing else is on this line
		set dataname [string tolower $trimline]
		set line {}
	    } else {
		# There other tokens on this line
		set dataname [string tolower [string range $trimline 0 [expr $pos-1]]]
		set line [string tolower [string range $trimline $pos end]]
	    }
	    
	    if {$loopflag == 0} {
		# in a loop header, save the names in the loop list
		lappend looplist $dataname
		set block${blocks}(loop_${loopnum}) $looplist
		# clear the array element for the data item 
		# -- should not be needed for a valid CIF but if a name is used
		# -- twice in the same block, want to wipe out the 1st data
		catch {
		    if {[set block${blocks}($dataname)] != ""} {
			# this is an error -- repeated data name
			append block${blocks}(errors) \
				"Data item $dataname is repeated near line $linenum\n"
		    }   
		    set block${blocks}($dataname) {}
		}
		set dataname {}
	    } elseif {$loopflag > 0} {
		# in a loop body, so the loop is over
		set loopflag -1
	    }
	    continue
	}
	
	if {[string tolower [string range $trimline 0 4]] == "loop_"} {
	    set loopflag 0
	    incr loopnum
	    set looplist {}
	    set block${blocks}(loop_${loopnum}) {}
	    # save any other tokens on this line
	    set line [string range $trimline 5 end]
	    continue
	}

	# keywords not matched, must be some type of data item
	set item {}
	
	if {[string index $line 0] == ";"} {
	    # multiline entry with semicolon termination
	    set item $line
	    # read lines until we get a naked semicolon
	    while {$EOF} {
		incr linenum
		if {[gets $fp line] < 0} {set EOF 0}
		if {[string index $line 0] == ";"} {
		    append item "\n;"
		    # make sure the line has a blank in front, so 
		    # a semicolon in col 2 is not treated as a quote character
		    set line " [string range $line 1 end]"
		    break
		}
	    }
	    if {[string trim $line] == ""} {set line ""}
	} elseif {$firstchar == {"}} {
	    # a quoted string
	    # hide any \" sequences in a non-ASCII character (\201)
	    set hidden [regsub -all {\\"} $trimline \201 trimline]
	    # parse out the quoted string, save the remainder
	    if {![regexp {("[^"]*")(.*)} $trimline junk item line]} {
		# this is an error -- no end-quote was found
		set item $line
		set line {}
		append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
	    }
	} elseif {$firstchar == {'}} {
	    # a quoted string
	    # hide any \' sequences in a non-ASCII character (\200)
	    set hidden [regsub -all {\\'} $trimline \200 trimline]
	    # parse out the quoted string, save the remainder
	    if {![regexp {('[^']*')(.*)} $trimline junk item line]} {
		# this is an error -- no end-quote was found
		set item $line
		set line {}
		append block${blocks}(errors) "The quoted string on line $linenum does not have a close quote ([string trim $item])\n"
	    }
	} else {
	    # must be a single space-delimited value
	    set pos [string first { } $trimline]
	    if {$pos < 0} {
		# and the only thing left on the line
		set item $trimline
		set line {}
	    } else {
		# save the rest of the line
		set line [string range $trimline $pos end]
		incr pos -1
		set item [string range $trimline 0 $pos]
	    }
	}
	
	# a data item has been read
	# fix the hidden characters, if any
	if $hidden {
	    regsub -all \200 $item {\\'} item
	    regsub -all \201 $item {\\"} item
	}

	# store the data item
	if {$loopflag >= 0} {
	    # if in a loop, increment the loop element counter to select the
	    # appropriate array element
	    incr loopflag
	    set i [expr ($loopflag - 1) % [llength $looplist]]
	    lappend block${blocks}([lindex $looplist $i]) $item
	} elseif {$dataname == ""} {
	    # this is an error -- a data item where we do not expect one
	    append block${blocks}(errors) "The string \"$item\" on line $linenum was unexpected\n"
	} else {
	    catch {
		if {[set block${blocks}($dataname)] != ""} {
		    # this is an error -- repeated data name
		    append block${blocks}(errors) \
			    "Data item $dataname is repeated near line $linenum\n"
		}
	    }
	    set block${blocks}($dataname) $item
	    set dataname ""
	}
    }
    close $fp
    return $blocks
}

# this proc creates a hierarchical CIF browser 
# note that the BWidget package is required
proc BrowseCIF {blocklist "selected {}" "frame .cif"} {

    if [catch {package require BWidget}] {
	tk_dialog $frame {No BWidget} \
                "Sorry, the CIF Browser requires the BWidget package" \
                warning 0 Continue
	return
    }
    if {$selected == ""} {set selected $blocklist}
    catch {destroy $frame}
    toplevel $frame 
    wm title $frame "CIF Browser"

    set pw    [PanedWindow $frame.pw -side top]
    grid $pw -sticky news -column 0 -row 0 
    grid columnconfigure $frame 0 -weight 1
    grid rowconfigure $frame 0 -minsize 250 -weight 1

    # create a left hand side pane for the hierarchical tree
    set pane  [$pw add -weight 1]
    set sw    [ScrolledWindow $pane.lf \
	    -relief sunken -borderwidth 2]
    set tree  [Tree $sw.tree \
	    -relief flat -borderwidth 0 -width 15 -highlightthickness 0 \
	    -redraw 1]
    grid $sw
    grid $sw -sticky news -column 0 -row 0 
    grid columnconfigure $pane 0 -minsize 275 -weight 1
    grid rowconfigure $pane 0 -weight 1
    $sw setwidget $tree
    
    # create a right hand side pane to show the value
    set pane [$pw add -weight 1]
    set sw   [ScrolledWindow $pane.sw \
	    -relief sunken -borderwidth 2]
    pack $sw -fill both -expand yes -side bottom
    set lb [ScrollableFrame::create $sw.lb -width 250]
    $sw setwidget $lb

    set num 0
    foreach n $blocklist {
	global block$n
	# make a list of data names in loops
	set looplist {}
	foreach loop [array names block$n loop_*] {
	    eval lappend looplist [set block${n}($loop)]
	}
	# put the block name
	set blockname [set block${n}(data_)]
	set open 0
	if {[lsearch $selected $n] != -1} {set open 1}
	$tree insert end root block$n -text "_data_$blockname" \
		-open $open -image [Bitmap::get copy]
	# loop over the names in each block 
	foreach name [array names block$n _*] {
	    # don't include looped names
	    if {[lsearch $looplist $name] == -1} {
		$tree insert end block$n [incr num] -text $name \
			-image [Bitmap::get folder] -data block$n
	    }
	}
	foreach loop [array names block$n loop_*] {
	    $tree insert end block$n block${n}$loop -text $loop \
		    -image [Bitmap::get file] -data "block$n loop"
	    foreach name [set block${n}($loop)] {
		$tree insert end block${n}$loop [incr num] -text $name \
			-image [Bitmap::get folder] -data "block$n $loop"
	    }
	}
	foreach name [array names block$n errors] {
	    $tree insert end block$n [incr num] -text $name \
		    -image [Bitmap::get undo] -data block$n
	}
    }
    $tree bindImage <1> "showCIFvalue $tree $sw"
    $tree bindText <1> "showCIFvalue $tree $sw"
    grid [button $frame.c -text Close -command "destroy $frame"] -column 0 -row 1
}

# used in BrowseCIF in response to the spinbox
# show the contents of a loop
proc ShowLoopVar {array loop frame sb} {
    global $array
    set looplist [set ${array}($loop)]
    set index [$sb getvalue]
    set i 0
    foreach var $looplist {
	incr i
	[$frame.$i getframe].l config \
		-text [lindex [set ${array}($var)] $index]
    }
}

# used in BrowseCIF in response to the clicking on a CIF dataname
# shows the contents data name or a loop
proc showCIFvalue {tree sw name} {
    set data [$tree itemcget $name -data]
    set text [$tree itemcget $name -text]

    # delete old contents of frame
    set frame [$sw.lb getframe]
    eval destroy [grid slaves $frame]
    # reset the scrollbars
    $sw.lb xview moveto 0
    $sw.lb yview moveto 0
    # leave room for a scrollbar
    grid columnconfig $frame 0 -minsize [expr \
	    [winfo width [winfo parent $frame]] - 20]
    if {$data == ""} {
	return
    }
    
    #
    if {[llength $data] == 2} {
	global [lindex $data 0]
	if {[lindex $data 1] == "loop"} {
	    set looplist [set [lindex $data 0]($text)]
	    # get number of elements for first name
	    set names [llength [set [lindex $data 0]([lindex $looplist 0])]]
	    set sb $frame.spin
	    grid [SpinBox $sb -range "1 $names 1" \
		    -label "Loop\nelement #" -labelwidth 10 -width 10 \
		    -command    "ShowLoopVar [lindex $data 0] $text $frame $sb" \
		    -modifycmd  "ShowLoopVar [lindex $data 0] $text $frame $sb"] \
		    -column 0 -row 0 -sticky w
	    set i 0
	    foreach var $looplist {
		incr i
		grid [TitleFrame $frame.$i -text $var -side left] \
			-column 0 -row $i -sticky ew
		pack [label [$frame.$i getframe].l -anchor w -justify left] -side left
	    }
	    ShowLoopVar [lindex $data 0] $text $frame $sb
	} else {
	    grid [TitleFrame $frame.0 -text $text -side left] \
		    -column 0 -row 0 -sticky ew
	    set row 0
	    set frame0 [$frame.0 getframe]
	    grid columnconfig $frame0 2 -weight 1
	    foreach name [set [lindex $data 0]($text)] {
		incr row
		grid [label $frame0.a$row -justify left -text $row]\
			-sticky w -column 0 -row $row
		grid [label $frame0.b$row -bd 2 -relief groove \
			-justify left -anchor w -text $name]\
			-sticky new -column 1 -row $row 
	    }
	}
    } else {
	# unlooped data name
	global [lindex $data 0]
	grid [TitleFrame $frame.0 -text $text -side left] \
		-column 0 -row 0 -sticky ew
	pack [label [$frame.0 getframe].l -anchor w -justify left\
		-text [set ${data}($text)]] -side left
    }
}

# Parse a number in CIF, that may include a SU (ESD) value
# note that this routine will ignore spaces, quotes & semicolons
proc ParseSU {value} {
    # if there is no SU just return the value
    if {[string first "(" $value] == -1} {
	return $value
    }
    # is there a decimal point?
    if [regexp {([-+]?[0-9]*\.)([0-9]*)\(([0-9]+)\)} $value junk a b err] {
	set ex [string length $b]
	return [list ${a}${b} [expr {pow(10.,-$ex)*$err}]]
    }
    if [regexp {([-+]?[0-9]*)\(([0-9]+)\)} $value junk a err] {
	return [list ${a} $err]
    }
    tk_dialog .err {ParseSU Error} \
	    "ParseSU: Error processing value $value" \
	    warning 0 Continue
}

# a stand-alone routine for testing. Select, read and browse a CIF
proc Read_BrowseCIF {} {
    global tcl_platform
    if {$tcl_platform(platform) == "windows"} {
	set filetypelist {
	    {"CIF files" .CIF} {"All files" *}
	}
    } else {
	set filetypelist {
	    {"CIF files" .CIF} {"CIF files" .cif} {"All files" *}
	}
    }    
    set file [tk_getOpenFile -parent . -filetypes $filetypelist]
    if {$file == ""} return
    if {![file exists $file]} return
    # plasewait and donewait are defined in gsascmds.tcl and may not be present
    catch {pleasewait "Reading CIF file"}
    set blocks [ParseCIF $file]
    if {$blocks == ""} {
	donewait
	MessageBox -parent . -type ok -icon warning \
		-message "Note: no valid CIF blocks were read from file $filename"
	return
    }
    catch {donewait}
    set allblocks {}
    for {set i 1} {$i <= $blocks} {incr i} {
	lappend allblocks $i
    }
    if {$allblocks != ""} {
	BrowseCIF $allblocks "" .cif
	# wait for the window to close
	tkwait window .cif
    } else {
	puts "no blocks read"
    }
    # clean up -- get rid of the CIF arrays
    for {set i 1} {$i <= $blocks} {incr i} {
	global block$i
	unset block$i
    }
}