######################################################################
# Le début : Paul Raines (raines@slac.stanford.edu)
# Fake TclX procedures if you don't have them. 
# Should work good enough for their use in these bindings
# 
# # Copyright 1992-1994 Karl Lehenbauer and Mark Diekhans.
# et beaucoup d'autre encore
# 
######################################################################

package provide xtcl 0.1

# on peut ne définir ces proc que si elle ne sont pas déja prédéfinies
# dans tclx (tcl étendu)
# MAIS ATTENTION : VERIFIER L"AUTOCHARGEMENT 
# utiliser plutot   ![string length [info command infox]]
# if {[catch "infox version"]} {
#   ....
# }


if {"[info proc infox]" == "infox"} {return}


## lassign -- affect several variable from a tcl list
# 
# example :
# 
#    lassign $bbox x1 y1 x2 y2
#    => affect bbox coordonates into separate variables
# 
#    lassign {1 2 3 4}   t(v1) t(v2)
#    => set t(v1) 1; set t(v2) 2; return {3 4}
# 
#    lassign {1 2}   v1 v2 v3
#    => set v1 1; set v2 2; set v3 {}; return {}
# 
#    pset {x1 y1 x2 y2} $bbox
#    lassign $bbox x1 y1 x2 y2
# 
# A REFAIRE 
# en utilisant le nouveau foreach (quand stead tournera sous tk8)
# Voir exemple B. Welch pour version solide :
# 
#    foreach {a b c} {popo pipi pupu} break
# 
if {"[info proc infox]" == ""} {
proc lassign {list args} {
  set i 0
  foreach varName $args {
    upvar $varName var
    set var [lindex $list $i]
    incr i
  }
  return [lrange $list $i end]
}
}

## lvarpop <list> ?indexExpr? ?substituteValue?
# 
# <indexExpr> may contain "end" (index of the last elem) and len (length 
# of the list)
# (but tclx allow only end and len to be in first pos of <indexExpr>)
# 
# Examples:
# set List {A B C D E}
# lvarpop List  => return "A" and List is set to {B C D E}
# lvarpop List 2 "deux" => return "D" and List is set to {B C deux E}
# set List {e0 e1 e2 e3 e4 e5 e6 e7 e8 e9}
# lvarpop List "end - (len/3)"  => return "e6" 
# and List is set to {e0 e1 e2 e3 e4 e5 e7 e8 e9}
# 
# won't insert an empty string
if {"[info proc infox]" == ""} {
proc lvarpop {listName args} {
  upvar $listName list
  if {[llength $args] == 0} {
    set idx 0
  } else {
    set idx [lindex $args 0]
    set len [llength $list]
    set end [expr $len-1]
    regsub -all -- "len" $idx $len idx
    regsub -all -- "end" $idx $end idx
    set idx [eval expr $idx]
  }
  set res [lindex $list $idx]
  if {[llength $args] == 2} {
    set list [lreplace $list $idx $idx [lindex $args 1]]
  } else {
    set list [lreplace $list $idx $idx]
  }
  return $res
}
}

## lvarpush <list> <string> ?indexExpr?
# <string> is pushed (inserted) as an element of <list> BEFORE position 
# specified by <indexExpr>
# if the var <list> doesn't exist, it is created.
# <indexExpr> may contain "end" (index of the last elem) and len (length 
# of the list)
# lvarpush <list> <string> end : in tclx insert BEFORE the last elem
# lvarpush <list> <string> len : in tclx insert AFTER the last elem
# (but tclx allow only end and len to be in first pos of <indexExpr>)
# 
# Examples:
# set List {A B C D E}
# lvarpush List "NEW"  => set List to {NEW A B C D E}
# lvarpush List "NEW2" len => set List to {NEW A B C D E NEW2}
# set List {e0 e1 e2 e3 e4 e5 e6 e7 e8}
# lvarpush List NEW3 len/2   ;# 9/2 -> 4
# => set List to {e0 e1 e2 e3 NEW3 e4 e5 e7 e8 e9}
# 
if {"[info proc infox]" == ""} {
proc lvarpush {listName str args} {
  upvar $listName list
  if {![info exists list]} {set list {}}
  if {[llength $args] == 0} {
    set idx 0
  } else {
    set idx [lindex $args 0]
    set idx [lindex $args 0]
    set len [llength $list]
    set end [expr $len-1]
    regsub -all -- "len" $idx $len idx
    regsub -all -- "end" $idx $end idx
    set idx [eval expr $idx]
  }
  set list [linsert $list $idx $str]
  return
}
}

if {"[info proc infox]" == ""} {
# lempty <list>  => return 1 if <list> is empty, 0 otherwise
# one can use insteed : if ![llength $my_list]   {...}
# insteed of :          if [lempty $my_list]     {...}
proc lempty {  l  } {
    return [string match 0 [llength $l]]
}
# tclx : 
# lvarcat <listName> <list1> <list2> <list3> ...
# modify the list <listName> by concataining all <listi> after listName.
# if <listName> doesn't exist, it is created.
# return the modified list value.
proc lvarcat {listName args} {
    upvar $listName list
    if {![info exist list]} {set list {}}
    foreach lst $args {
        append list " $lst"
    }
    return $list
}
# min  -10 2 5 4   => -10
# set List {-10 2 5 4}
# eval min $List    => -10
proc min {x args} {
    foreach i $args {if {$i<$x} {set x $i}}
    return $x
}
proc max {x args} {
    foreach i $args {if {$i>$x} {set x $i}}
    return $x
}
proc avg {args} {
    set sum 0.0
    foreach x $args {set sum [expr $sum+$x]}
    return [expr ($sum+0.0)/[llength $args]]
}
# abs " 1.0 / 10 - 2"      => 1.9
# abs 1.0 / 10 - 2         => 1.9 also
proc abs {args} {
    set res [eval expr $args]
    if {$res<0} {return [expr -$res]} {return $res}
}
} ;# end if ... infox


########################################################################
# keylget et keylset dans xtcl_keygetset.tcl
# # de Paul RAINES (tkmail4.0-beta-x)

if {"[info proc infox]" == ""} {
proc keylget { lvar key {rvar 0} } {
  upvar $lvar klist
  set check 0
  if {$rvar != 0} {
    set check 1
    if {[string length $rvar]} {upvar $rvar ret}
  }
  foreach pair $klist {
    if {[lindex $pair 0] == $key} {
      if [catch {lindex $pair 1} ret] {
        set ret [string trim [string range $pair [string length $key] end]]
        if {[string index $ret 0] == "\{"} {
          set ret [string trim $ret "{}"]
        }
      }
      if {$check} { return 1 } else {return $ret}
    }
  }
  if {$check} { 
    return 0 
  } else { error "No key named $key in $lvar" }
}
proc keylset { lvar key val } {
  upvar $lvar klist
  set ndx 0
  if {[info exists klist]} {
    foreach pair $klist {
      if {[lindex $pair 0] == $key} {
        set klist [lreplace $klist $ndx $ndx "$key {$val}"]
        return {}
      }
      incr ndx
    }
  }
  lappend klist "$key {$val}"
  return {}
}
} ;# end if ... infox


########################################################################
# pushd popd et dirs 

proc pushd {args} {
    global TCLXENV

    if {![info exist TCLXENV(dirPushList) ]} {
        set TCLXENV(dirPushList) ""
    }
    

    if {[llength $args] > 1} {
        error "bad # args: pushd [dir_to_cd_to]"
    }
    set TCLXENV(dirPushList) [linsert $TCLXENV(dirPushList) 0 [pwd]]

    if {[llength $args] != 0} {
        cd [glob $args]
    }
}

proc popd {} {
    global TCLXENV

    if {[info exist TCLXENV(dirPushList)] \
               && [llength $TCLXENV(dirPushList)]} {
        cd [lvarpop TCLXENV(dirPushList)]
        pwd
    } else {
        error "directory stack empty"
    }
}

proc dirs {} { 
    global TCLXENV
    if {![info exist TCLXENV(dirPushList) ]} {
        set TCLXENV(dirPushList) ""
    }
    echo [pwd] $TCLXENV(dirPushList)
}

########################################################################
# le glob récursif 

## recursive_glob -- retourne une liste récursive de fichiers ou répertoires
# 
# sous la forme <dir>/<relativeFilePath>
# Attention la liste optenue peut contenir des répertoires ou des 
# doublons (de la meme fa¡on que la commande UNIX "ls * *)"
# exemple : recursive_glob . * 
#    retourne {./rep1 ./fich1 ./fich2 ./rep1/fic11 ./rep1/fic12 ....)
#   
# REMARQUE : Attention si globlist contient ".*" alors les répertoires
# de la forme ".../." et .../.." font partie du résultat !!
# exemple d'utilisation :
#  set ABS [recursive_glob [pwd] $listOfPatterns]
#      liste de noms absolus
#  set REL [lcutleft $ABS [expr [string length [pwd]] + 1]]
#      liste de noms relatifs
# Modif 10/06/96 : compatibiltitÈ Mac et Windows (utilisation de la commande
#                  file join...) : Problemes potenciel avec fichier invisibles 
#                  pour unix (* et .*)
# 
proc recursive_glob {dirlist globlist} {
    # # global tcl_platteform
    # # switch $tcl_platform(platform) {
    # #     macintosh {recursive_globMac $dirlist $globlist}
    # #     windows   {}
    # #     unix      {}
    # # }

    set result {}
    set recurse {}
    foreach dir $dirlist {
        if ![file isdirectory $dir] {
            error "\"$dir\" is not a directory"
        }
        foreach pattern $globlist {
            set result [concat $result \
                [glob -nocomplain -- [file join $dir $pattern]]]
        }
        foreach file [glob -nocomplain -- [file join $dir *]  \
                                          [file join $dir .*] ] {
            if [file isdirectory $file] {
                # should not process special cases of "." and ".." on Mac ?
                set fileTail [file tail $file]
                if {!(($fileTail == ".") || ($fileTail == ".."))} {
                    lappend recurse $file
                }
            }
        }
    }
    if ![lempty $recurse] {
        set result [concat $result [recursive_glob $recurse $globlist]]
    }
    return $result
}

## for_recursive_glob --
# 
# Exemple (sous tclsh)
# proc frg  args {uplevel  for_recursive_glob $args}
# frg file . {*[~%]} {ls -al $file}
proc for_recursive_glob {var dirlist globlist code {depth 1}} {
    # # global tcl_platteform
    # # switch $tcl_platform(platform) {
    # #     macintosh {recursive_globMac $dirlist $globlist}
    # #     windows   {}
    # #     unix      {}
    # # }
    upvar $depth $var myVar
    set recurse {}
    foreach dir $dirlist {
        if ![file isdirectory $dir] {
            error "\"$dir\" is not a directory"
        }
        foreach pattern $globlist {
            foreach file [glob -nocomplain -- [file join $dir $pattern]] {
                set myVar $file
                uplevel $depth $code
            }
        }
        foreach file [glob -nocomplain -- [file join $dir *]  \
                                          [file join $dir .*] ] {
            if [file isdirectory $file] {
                # should not process special cases of "." and ".." on Mac ?
                set fileTail [file tail $file]
                if {!(($fileTail == ".") || ($fileTail == ".."))} {
                    lappend recurse $file
                }
            }
        }
    }
    if ![lempty $recurse] {
        for_recursive_glob $var $recurse $globlist $code [expr {$depth + 1}]
    }
    return {}
}

########################################################################
# about files

## for_file -- process each line of of file
# 
# exemple :
#   for_file line toto.tcl {
#       # process the line regex, regsub...
#   }
# 
# 
proc for_file {var filename code} {
    upvar $var line
    set fp [open $filename r]
    while {[gets $fp line] >= 0} {
        uplevel $code
    }
    close $fp
}


## read_file --  Voir de préférence  xtcl::file_read  et  ::fileutil::cat
# 
# retourne le contenu du fichier "filename"
# exemple : set txt [read_file ?-nonewline? toto.vhd]
#           set txt [read_file toto.vhd ?<nbr_chars>?]
#           
proc read_file {fileName args} {
    if {$fileName == "-nonewline"} {
        set flag $fileName
        # set fileName [lvarpop args]
        set fileName [lindex $args 0]
        set args [lreplace $args 0 0]
    } else {
        set flag {}
    }
    set fp [open $fileName]
    set stat [catch {
        eval read $flag $fp $args
    } result]
    close $fp
    if {$stat != 0} {
        global errorInfo errorCode
        error $result $errorInfo $errorCode
    }
    return $result
} 
## write_file --  Voir de préférence  xtcl::file_write 
# 
# crée (ou écrase) le fichier "filename" avec les chaines passer en parametre
# write_file <fileName> <string> ?<string> ...?
proc write_file {fileName args} {
    set fp [open $fileName w]
    
    set stat [catch {
        foreach string $args {
            puts $fp $string
        }
    } result]
    close $fp
    if {$stat != 0} {
        global errorInfo errorCode
        error $result $errorInfo $errorCode
    }
}
## append_file --
# 
# Ajoute au fichier "filename" avec les chaines passer en parametre
# append_file <fileName> <string> ?<string> ...?
proc append_file {fileName args} {
    set fp [open $fileName a]
    
    set stat [catch {
        foreach string $args {
            puts $fp $string
        }
    } result]
    close $fp
    if {$stat != 0} {
        global errorInfo errorCode
        error $result $errorInfo $errorCode
    }
}

########################################################################
# les ensembles

#
# return the logical union of two lists, removing any duplicates
#
proc union {lista listb} {
    return [lrmdups [concat $lista $listb]]
}

#
# sort a list, returning the sorted version minus any duplicates
# A REFAIRE EN OPTIMISANT...
# proc lrmdups list {
#     if [lempty $list] {
#         return {}
#     }
#     set list [lsort $list]
#     set last [lvarpop list]
#     lappend result $last
#     foreach element $list {
# 	if {$last != $element} {
# 	    lappend result $element
# 	    set last $element
# 	}
#     }
#     return $result
# }
proc lrmdups list {
    set result {}
    foreach e $list {
        if [info exists ($e)] continue
        set ($e) ""
        lappend result $e
    }
    return [lsort $result]
}


## intersect3 -- perform the intersecting of two lists, returning a list
# containing three lists.  The first list is everything in the first
# list that wasn't in the second, the second list contains the intersection
# of the two lists, the third list contains everything in the second list
# that wasn't in the first.
#
proc intersect3 {list1 list2} {
    set list1Result ""
    set list2Result ""
    set intersectList ""

    set list1 [lrmdups $list1]
    set list2 [lrmdups $list2]

    while {1} {
        if ![llength $list1] {
            if [llength $list2] {
                set list2Result [concat $list2Result $list2]
            }
            break
        }
        if ![llength $list2] {
	    set list1Result [concat $list1Result $list1]
            break
        }
        set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]

        if {$compareResult < 0} {
            # # lappend list1Result [lvarpop list1] ;# VIRER lvarpop
            lappend list1Result [lindex $list1 0]
            set list1 [lrange $list1 1 end]
            continue
        }
        if {$compareResult > 0} {
            # # lappend list2Result [lvarpop list2] ;# VIRER lvarpop
            lappend list2Result [lindex $list2 0]
            set list2 [lrange $list2 1 end]
            continue
        }
        # # lappend intersectList [lvarpop list1]
        lappend intersectList [lindex $list1 0]
        set list1 [lrange $list1 1 end]
        # # lvarpop list2
        set list2 [lrange $list2 1 end]
    }
    return [list $list1Result $intersectList $list2Result]
}

## intersect -- perform an intersection of two lists, returning a list
# containing every element that was present in both lists
#
proc intersect {list1 list2} {
    set intersectList ""

    set list1 [lsort $list1]
    set list2 [lsort $list2]

    while {1} {
        if {![llength $list1] || ![llength $list2]} break

        set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]

        if {$compareResult < 0} {
            # # lvarpop list1
            set list1 [lrange $list1 1 end]
            continue
        }

        if {$compareResult > 0} {
            # # lvarpop list2
            set list2 [lrange $list2 1 end]
            continue
        }

        # # lappend intersectList [lvarpop list1]
        lappend intersectList [lindex $list1 0]
        set list1 [lrange $list1 1 end]
        # # lvarpop list2
        set list2 [lrange $list2 1 end]
    }
    return $intersectList
}


########################################################################
## geom2posn -- 
# X-ish
# diam : elle utilise les nouvelles regexp, mais je ne sais plus 
# d'ou elle vient !
#
proc geom2posn {g} {
   regexp {(=?[0-9]+x[0-9]+)([-+]+[0-9]+[-+]+[0-9]+)} $g both d p
   return $p
}


# VOIR AUSSI lmatch... dans list.tcl