
# This code is shared by all the ICEM CFD GUI's.
#
# Copyright (c) 1993 - 1995 Pacific Marketing and Consulting, Inc,
#       and ICEM Systems, GmbH.  All rights reserved.
# Author:  Wayne A. Christopher, wayne@icemcfd.com

set i 0
foreach c {
    #ff4040
    #40ff40
    #4040ff
    #40ffff
    #ff40ff
    #ffff40
    #bb22ff
    #2244ff
    #22ffbb
    #44ff22
    #ffbb22
    #8844ff
    #4488ff
    #44ff88
    #88ff44
    #ff8844
    #4422ff
    #22bbff
    #22ff44
    #bbff22
    #ff4422
} {
    set default_misc_colors($i) $c
    incr i
}

proc putcenter {w} {
    global toplevel
    
    top_withdraw $w
    update idletask
    
    if !$toplevel(single) {
	wm sizefrom $w user
	wm positionfrom $w user
    }
    
    set sw [winfo screenwidth .]
    set sh [winfo screenheight .]
    set ww [winfo reqwidth $w]
    set wh [winfo reqheight $w]
    set x [expr {($sw - $ww) / 2}]
    set y [expr {($sh - $wh) / 2}]
    if {$x < 0} {
	set x 0
	puts stderr "Warning: window $w too wide for screen."
    }
    if {$y < 0} {
	set y 0
	puts stderr "Warning: window $w too tall for screen."
    }
    
    top_geometry $w +$x+$y
    
    update idletask
    top_deiconify $w
    update idletask
}

proc numsort {names} {
    set fnames {}
    foreach n $names {set fnames "$fnames \"[format "%10d" $n]\""}
    set list [lsort $fnames]
    set fnames {}
    foreach n $list {eval append fnames {" "} $n}
    return $fnames
}

proc beep {} {puts -nonewline stderr \007}

proc lfirst {list} {lindex $list 0}
proc llast {list} {lindex $list [expr {[llength $list] - 1}]}

proc old_lreplace {list index new} {
    set ind 0
    set newlist {}
    foreach elem $list {
	if {$ind == $index} {
	    lappend newlist $new
	} else {
	    lappend newlist $elem
	}
	incr ind
    }
    return $newlist
}

proc ldelete {list elem} {
    set res {}
    foreach l $list {
	if {$l != $elem} { lappend res $l }
    }
    return $res
}

proc ldelete_multiple {list del_list} {
    foreach d $del_list { set del($d) 1 }
    set res {}
    foreach l $list {
	if ![info exists del($l)] { lappend res $l }
    }
    return $res
}

proc lmember {list elem} {
    foreach l $list {
	if {$l == $elem} { return 1 }
    }
    return 0
}

proc lreverse {list} {
    set res ""
    foreach l $list { set res [concat [list $l] $res] }
    return $res
}

proc luniq {list} {
    foreach l $list { set got($l) 1 }
    return [array names got]
}

proc replace_string {full old new} {
    set p [string first $old $full]
    if {$p == -1} { return $full }
    return [string replace $full $p [expr $p + [string length $old] - 1] $new]
}

proc first_existing_font {fonts} {
    foreach f $fonts {
	catch {destroy .xxx}
	if {![catch "toplevel .xxx; button .xxx.yyy -font $f"]} {
	    destroy .xxx
	    return $f
	}
    }
    puts stderr "Fatal error: no fonts available from list: $fonts"
    exit 1
}

proc read_token {f} {
    global cur_read_line
    
    if {![info exists cur_read_line($f)]} {
	set cur_read_line($f) [gets $f]
    }
    while 1 {
	set tok [lfirst $cur_read_line($f)]
	set cur_read_line($f) [lrange $cur_read_line($f) 1 end]
	if {$tok == ""} {
	    set cur_read_line($f) [gets $f]
	    if [eof $f] {
		unset cur_read_line($f)
		return ""
	    }
	} else {
	    return $tok
	}
    }
}

proc swap {a b} {
    upvar 1 $a l1
    upvar 1 $b l2
    set temp $l1
    set l1 $l2
    set l2 $temp
}

proc locate_useful_programs {} {
    # These pathnames are never the same and we can't trust people to have
    # reasonable paths.
    
    set programs {
	uname
	whoami
	date
	vi
	xterm
	scrsave
	ps
    }
    
    set directories {
	/bin
	/usr/bin
	/usr/sbin
	/usr/ucb
	/usr/bsd
	/usr/X11/bin
	/usr/bin/X11
	/usr/openwin/bin
    }
    
    foreach p $programs {
	global ${p}_path
	foreach d $directories {
	    if [file exists $d/$p] {
		set ${p}_path $d/$p
		break
	    }
	}
	if {![info exists ${p}_path]} {
	    puts stdout "Warning: can't find the \"$p\" program on this system"
	    set ${p}_path $p
	}
    }    
}

proc get_path {what {check 0}} {
    global program_paths env bindir
    
    if [info exists program_paths($what)] { return $program_paths($what) }
    
    if {$what == "rsh"} {
	# This one gets special treatment.
	set rsh [get_path remsh 1]
	if {($rsh == "") && [file exists /usr/bsd/rsh]} {
	    set rsh /usr/bsd/rsh
	}
	if {$rsh != ""} {
	    set program_paths(rsh) $rsh
	    return $rsh
	}
    }
    
    set dirs ""
    if [info exists env(PATH)] {
	set dirs [split $env(PATH) :]
    }
    if [info exists bindir] {
	lappend dirs $bindir
    }
    foreach dir {
	/bin
	/usr/bin
	/usr/sbin
	/usr/ucb
	/usr/bsd
	/usr/openwin/bin
	/usr/X11/bin
	/usr/bin/X11
	/etc
	/usr/etc
	/usr/local/bin
    } {
	lappend dirs $dir
    }
    lappend dirs $env(ICEM_ACN)/bin $env(ICEM_ACN)/netscape
    
    foreach dir $dirs {
    	if [catch {file type $dir/$what} type] continue
	if {$type == "link" && $::tcl_platform(platform) == "unix"} {
	    set hd [open "| find $dir/$what" r]
	    fconfigure $hd -blocking 0
	    for {set i 1} {$i <= 5} {incr i} {
		set ret [gets $hd]
		if {$ret != ""} break
		after 100
	    }
	    close $hd
	    if {$ret == ""} continue
	}
	if {[file executable $dir/$what] && ![file isdirectory $dir/$what]} {
	    set program_paths($what) $dir/$what
	    return $dir/$what
	}
	if {[file executable $dir/$what.exe] && ![file isdirectory $dir/$what.exe]} {
	    set program_paths($what) $dir/$what.exe
	    return $dir/$what.exe
	}
    }
    
    if $check { return "" }
    
    mess "Warning: can't run the \"$what\" program on this system\n" red
    set program_paths($what) ""
    return ""
}

# This is from Karl Lehenbauer (karl@neosoft.com), modified somewhat.

proc static {args} {
    global staticvars
    
    set procName [lindex [info level -1] 0]
    set name [lindex $args 0]
    uplevel 1 "upvar #0 staticvars($procName:$name) $name"
    if {[llength $args] > 1} {
	if ![info exists staticvars($procName:$name)] {
	    set staticvars($procName:$name) [lindex $args 1]
	}
    }
}

# This is from Michael Salmon (etxmesa@eos.ericsson.se), modified somewhat.

proc random {limit} {
    static seed
    
    if {![info exists seed]} {
        set seed [expr [exec [get_path date] +1%S%M%H%j]%100000]
    }
    set seed [expr (($seed*21421)+1)%100000]
    
    return [expr {int(($seed / 100000.0) * $limit)}]
}

proc determine_memory {} {
    set hinv [get_path hinv 1]
    set lsdev [get_path lsdev 1]
    set grep [get_path grep]
    
    if {$hinv != ""} {
	if ![catch {exec $hinv | $grep "Main memory"} memline] {
	    if [regexp {: ([0-9]+)} $memline dummy mem] {
		return $mem
	    }
	}
    }
    
    if {$lsdev != ""} {
	if ![catch {exec $lsdev -C | $grep ^mem} memlines] {
	    set mem 0
	    foreach memline [split $memlines \n] {
		if [regexp { ([0-9]+) MB} $memline dummy mem1] {
		    incr mem $mem1
		}
	    }
	    if $mem { return $mem }
	}
    }
    
    set messfiles [lsort [glob -nocomplain /usr/adm/messages*]]
    
    foreach mess $messfiles {
	if ![catch {exec $grep ": mem" $mess} stuff] {
	    if [regexp {mem = ([0-9]+)} $stuff dummy mem] {
		return [expr {$mem / 1000}]
	    }
	}
    }
    foreach mess $messfiles {
	if ![catch {exec $grep "real mem" $mess} stuff] {
	    if [regexp {mem = ([0-9]+)} $stuff dummy mem] {
		return [expr {$mem / 1000}]
	    }
	}
    }
    return 0
}

proc confirm {message {doit 0}} {
    global job_confirm
    
    if {$job_confirm || $doit} {
	if [tk_dialog .confirm Confirm $message "" 0 Accept Cancel] {
	    mess "Warning: not performing operation.\n" red
	    return 0
	}
    }
    return 1
}

# Non-internal error.

proc user_error {mess} {
    global user_error_is_fatal ai_environment

    busy reset
    if {[info exists ai_environment] && $ai_environment} {
        aie_update_dez_onerror
    }
    puts $mess
    if [info exists user_error_is_fatal] {
        error $mess
    } else {
        set len [string length $mess]
        if {$len < 1000} {
            tk_dialog .user_error "Error" "Error: $mess" error 0 OK
        } else {
            tkerror_stacktrace "Error: $mess" "Error"
        }
    }
}

proc popup {title mess {quest 0}} {
    if $quest {
	return [expr ![tk_dialog .popup $title $mess "" 0 Yes No]]
    } else {
	tk_dialog .popup $title $mess "" 0 Ok
	return 0
    }
}

proc set_tabring {wins} {
    set nw [llength $wins]
    for {set i 0} {$i < $nw} {incr i} {
	set w [lindex $wins $i]
	set next [lindex $wins [expr ($i + 1) % $nw]]
	set prev [lindex $wins [expr ($i - 1 + $nw) % $nw]]
	bind $w <Tab> "focus $next; $next select range 0 end"
	bind $w <Shift-Tab> "focus $prev; $prev select range 0 end"
	bind $w <Down> "focus $next; $next select range 0 end"
	bind $w <Up> "focus $prev; $prev select range 0 end"
    }
}

proc handle_events {delay} {
    global handle_events_variable
    after $delay "uplevel \#0 set handle_events_variable 1"
    vwait handle_events_variable
}

proc newest_file_in_dir {dir pats} {
    set file ""; set mtime 0
    foreach p $pats {
	foreach f [glob -nocomplain $dir/$p] {
	    set t [file mtime $f]
	    if {$t > $mtime} {
		set file $f
		set mtime $t
	    }
	}
    }
    return $file
}

proc variable_space_used {} {
    set tot 0
    foreach __v [info globals] {
	global $__v
	if [array exists $__v] {
	    foreach n [array names $__v] {
		incr tot [string length [set ${__v}($n)]]
	    }
	} else {
	    incr tot [string length [set ${__v}]]
	}
    }
    return $tot
}

proc is_feature_available {feat def_lic} {
    global env is_win feature_available_lines
    
    if [info exists env(LM_LICENSE_FILE)] {
	if $is_win {
	    set lics [split $env(LM_LICENSE_FILE) \;]
	} else {
	    set lics [split $env(LM_LICENSE_FILE) :]
	}
    } else {
	set lics $def_lic
    }
    regsub -all \\\\ $lics / lics
    
    if ![info exists feature_available_lines] {
	foreach l $lics {
	    if [file readable $l] {
		set fp [open $l r]
		while {![eof $fp]} {
		    lappend feature_available_lines [gets $fp]
		}
		close $fp
	    }
	}
    }
    if ![info exists feature_available_lines] { return 0 }
    foreach line $feature_available_lines {
	if [string match "*FEATURE $feat*" $line] { return 1 }
    }
    return 0
}

proc license_unavailable_warning {} {
    global ai_environment
    if {[info exists ai_environment] && $ai_environment} {
        set mess "You cannot use this function because a valid license for\
		the mesh editor was not found.  Please make sure your license server\
		is running and that you have a valid and available FEATURE or INCREMENT line\
		for \"aienv\", \"aimed\", or \"med\".  If you are an academic user\
		with a valid academic key, please verify that the \"User's License Preferences\"\
		are set to \"Use Academic Licenses\"."   
    } else {
        set mess "You cannot use this function because a valid license for\
		the mesh editor was not found.  Please use the\
		\"Start license server\" option in the File/Utilities menu."
    }
    if {[info command lpopup] != ""} {
        lpopup $mess
    } else {
        mess "$mess\n" red
    }
}

proc view_file {{file ""} {indir ""} {mess ""}} {
    if {$file == ""} {
	if {$mess == ""} { set mess "Select a file to view." }
	set file [file_selection -message $mess -default $indir]
	if {$file == ""} return
    }
    set fp [open $file r]
    set text [read $fp]
    close $fp
    for {set i 0} {[winfo exists .view_file$i]} {incr i} {}
    set d [form_init .view_file$i $file "" close "" 1 1 1]
    form_text $d.text "" "" {0 0} "" 80x40
    $d.text.text configure -font fixed
    form_text_set $d.text $text
    form_finish top
}

proc tcl_memory {} {
    set tot_len 0
    foreach test_var [info global] {
	global $test_var
        if [array exists $test_var] {
	    set nn [array names $test_var]
	    foreach n $nn {
		catch {set tot_len [expr $tot_len + \
					[string length [subst $[subst ${test_var}($n)]]]]}
	    }
        } else {
            set tot_len [expr $tot_len + [string length [subst $$test_var]]]
        }
    }
    return $tot_len
}

proc sf {file} {
    global source_dirs
    
    foreach dir $source_dirs {
	if [file exists $dir/$file.tcl] {
	    mess "$dir/$file.tcl\n"
	    uplevel #0 source \"$dir/$file.tcl\"
	    return
	}
    }
    error "no such file"
}

proc with_view_inactive {cmd} {
    global tdv_default
    global batch_mode
    
    set pa [tdv_active 0]
    busy 1
    
    if [catch {uplevel 1 $cmd} res] {
	mess "Error: $res\n" red
    }
    
    busy 0
    tdv_active $pa

    return $res
}

proc tearoff_record {old new} {
    global tearoff_menus
    set tearoff_menus($new) $old
}

proc rm_tmp_file {file} {
    global options
    if {![info exists options(clean_up_tmp_files)] || \
	    $options(clean_up_tmp_files)} {
	cmd_rm $file
    } else {
	mess "Warning: leaving temporary file $file\n" red
    }
}

proc gui_license_check {feat} {
    global env
    
    set prog $env(ICEM_ACN)/bin/test_licensing
    set file $env(ICEM_ACN)/lic/license.dat
    if [info exists env(LM_LICENSE_FILE)] {
	set file $env(LM_LICENSE_FILE)
    }
    if [info exists env(ICEM_LICENSE_FILE)] {
	set file $env(ICEM_LICENSE_FILE)
    }
    set fp [open [list |$prog -keep PMAC $feat 0.0 $file 0] r]
    set line [gets $fp]
    if {$line == "OK"} {
	while 1 {
	    set line [gets $fp]
	    if {$line == "WAITING"} { return 1 }
	    puts $line
	    mess $line\n
	}
    } else {
	while 1 {
	    set line [gets $fp]
	    if {$line == "EXITING"} { exit 1 }
	    puts $line
	    mess $line\n red
	}
    }
}

proc list_drives {} {
    global env is_win

    set drives ""
    if {[info exists env(USERPROFILE)] && \
	    [file exists $env(USERPROFILE)/Desktop]} {
	regsub -all {\\} $env(USERPROFILE) / profile
	lappend drives [list Desktop $profile/Desktop]
    }
    if $is_win {
	foreach d [win_drives] {
	    set dn [win_drive_name $d/]
	    if {$dn == ""} {
		set dn $d/
	    } else {
		set dn "$dn ($d)"
	    }
	    lappend drives [list $dn $d/]
	}
    }
    return $drives
}

proc win_shortname {pathname} {
    global is_win
    if {$is_win && [string first " " $pathname] > 0 &&
        [file exists $pathname]} {
        return [file attributes $pathname -shortname]
    }
    return $pathname
}

# ---------------------------------------

proc vec_cross {v1 v2} {
    set r0 [expr [lindex $v1 1] * [lindex $v2 2] - \
		[lindex $v1 2] * [lindex $v2 1]]
    set r1 [expr [lindex $v1 2] * [lindex $v2 0] - \
		[lindex $v1 0] * [lindex $v2 2]]
    set r2 [expr [lindex $v1 0] * [lindex $v2 1] - \
		[lindex $v1 1] * [lindex $v2 0]]
    return [list $r0 $r1 $r2]
}

proc vec_dot {v1 v2} {
    return [expr [lindex $v1 0] * [lindex $v2 0] + \
		[lindex $v1 1] * [lindex $v2 1] + \
		[lindex $v1 2] * [lindex $v2 2]]
}

proc vec_unit {v1} {
    set dist [expr sqrt([vec_dot $v1 $v1])]
    if {abs($dist) < 1e-100} { return "0 0 0" }
    return [list [expr [lindex $v1 0] / $dist] \
		 [expr [lindex $v1 1] / $dist] \
		 [expr [lindex $v1 2] / $dist]]
}

proc vec_times {vec s} {
    set vec2 ""
    foreach v $vec { lappend vec2 [expr $v * $s] }
    return $vec2
}

proc vec_add {v1 v2} {
    set v3 ""
    foreach s1 $v1 s2 $v2 { lappend v3 [expr $s1 + $s2] }
    return $v3
}

proc vec_sub {v1 v2} {
    set v3 ""
    foreach s1 $v1 s2 $v2 { lappend v3 [expr $s1 - $s2] }
    return $v3
}

proc vec_minus {v} {
    set mv ""
    foreach i {0 1 2} {
	set r [lindex $v $i]
	if {$r} {set r [expr -$r]}
	lappend mv $r
    }
    return $mv
}

proc vec_mag {v1} {
    return [expr sqrt([vec_dot $v1 $v1])]
}

proc vec_angle {v1 v2} {
    return [expr asin([vec_sin_angle $v1 $v2])]
}

proc vec_sin_angle {v1 v2} {
    return [vec_mag [vec_cross [vec_unit $v1] [vec_unit $v2]]]
}

proc vec_normalize {v} {
    set d 0
    foreach i {0 1 2} {
	set d [expr $d + [lindex $v $i] * [lindex $v $i]]
    }
    if {!$d} {return $v}
    set d [expr sqrt($d) + 0.0]
    foreach i {0 1 2} {
	set v [lreplace $v $i $i [expr [lindex $v $i]/$d]]
    }
    return $v
}

# This is forced to be a right-handed coordinate system.  For that reason
# we ignore v3

proc vec_orthonormal_righthanded_basis {v1 v2} {
    set v3 [vec_cross $v1 $v2]
    set v1 [vec_unit $v1]
    set v2 [vec_unit [vec_cross $v3 $v1]]
    set v3 [vec_cross $v1 $v2]
    return [list $v1 $v2 $v3]
}

proc remove_control_ms {infile outfile} {
    set fp1 [open $infile r]
    set fp2 [open $outfile w]
    set nl 0
    while {![eof $fp1]} {
	puts $fp2 [gets $fp1]
	incr nl
    }
    close $fp1
    close $fp2
    return $nl
}

# -------- copy a menu or part of a menu, Jigen

proc copy_menu_options {m1 m2} {
   set rr ""
   foreach n {tearoff title tearoffcommand selectcolor postcommand \
              relief font foreground background cursor} {
      lappend rr -$n [$m1 cget -$n]
   }
   eval $m2 configure $rr 
}

proc copy_menu_entries {opt m1 m2 {i0 0} {i1 ""}} {
   if {$i1 == ""} {
       set i1 $i0
       while {[$m1 index $i1] == $i1} {incr i1}
   } 

   set flags {label command image bitmap state underline columnbreak \
              font foreground background columnbreak hidemargin \
              activebackground activeforeground accelerator}

   for {set i $i0} {($i < $i1) && ([$m1 index $i] == $i)} {incr i} {
      set type [$m1 type $i]
      set ff $flags; set rr ""
      switch -- $type {
         command {
            foreach n $ff { lappend rr -$n [$m1 entrycget $i -$n] }
         }
         checkbutton {
            lappend ff indicatoron selectcolor selectimage variable onvalue offvalue
            foreach n $ff { lappend rr -$n [$m1 entrycget $i -$n] }
         }
         radiobutton {
            lappend ff indicatoron selectcolor selectimage variable value
            foreach n $ff { lappend rr -$n [$m1 entrycget $i -$n] }
         }
         tearoff { lappend rr -background [$m1 entrycget $i -background] }
         separator { lappend rr -background [$m1 entrycget $i -background] }
         cascade {
            set sm1 [$m1 entrycget $i -menu]
            if {[string first r $opt] > -1} {
               set sm2 $m2[string range $sm1 [string last \. $sm1] end]
               lappend rr -menu $sm2
            } else {
               lappend rr -menu $sm1
            }
            foreach n $ff { lappend rr -$n [$m1 entrycget $i -$n] }
         }
      }
      if {$rr != ""} {
         eval $m2 add $type $rr
      }
      if {($type == "cascade") && ([string first r $opt] > -1)} {
         copy_menu_options $sm1 [menu $sm2]
         copy_menu_entries $opt $sm1 $sm2
      }
   }
}

