package provide xtcl 0.1


# $Id: list.tcl,v 1.3 2001/07/25 07:36:01 diam Exp $
# 22/10/98 (diam) : rajout version de lunique2 utilisant caractere \0
# 12/05/97 (diam) : rajout des proc ladd, lsub et lmult


# lunique ?-options? <list>
# Return a list where all duplicated element are removed
# make use of an array with an empty name!
#
# option:
#    -sort (default): the returned list is sorted
#    -nosort: result is in arbitrared order
#    -keeporder: keep the same order than the original list
#
# For critical cases: you can use the shortest names without using
# procedure call:
#      set b [foreach x $a {set u($x) 1};array names u]

proc lunique {args} {
   set MODE  -sort
   set i 0
   while "\$i < [string length $args]" {
       set arg [lindex $args $i]
       switch -glob -- $arg {
          --       {incr i ; break}
          -nosort    -
          -sort      -
          -keeporder {set MODE $arg; incr i; continue}
          -*         {error "unknow option $arg"}
          default    {break  ;# no more options}
       }
   }
   # i point on the next unread argument
   set list    [lindex $args $i]

   switch -exact -- $MODE {
     -nosort {
        foreach e $list   {set ($e) 1}
        return [array names ""]
     }
     -sort {
        foreach e $list   {set ($e) 1}
        return [lsort [array names ""]]
     }
     -keeporder {
        set result {}
        foreach e $list {
            if [info exists ($e)] continue
            set ($e) ""
            lappend result $e
        }
        return $result
     }
   }
}


# Principe :
#
# (idée de John Ellson <ellson@lucent.com> le 22/10/98 sur comp.lang.tcl)
# Si on peut trouver un caractere jamais utilisé dans la liste (i.e \0)
# alors :
# 1 - on transforme cette liste en chaine par insertion de DEUX caracteres
#     séparateur (\0 ici) et on rajout un caractÿre séparateur final
# 2 - on crée une nouvelle liste de taille deux fois plus grande en
#     cassant la chaine sur chaque occurence du caractÿre séparateur.
#     Chaque élément impair de cette liste paire est vide (car deux
#     séparateur consécutifs à chaque élément)
# 3 - On crée un tableau dans les élément paire (0, 2, ..) sont les
#     indices, et les élément impaires sont les contenus.
#
#   # various test cases
#   puts [unique [list b b c a c c a]]
#   puts [unique [list b b c a c c a c]]
#   puts [unique [list b]]
#   puts [unique [list]]
proc lunique2 {lst} {
    array set tmp [split [join $lst\0 \0\0] \0]
    lsort [array names tmp]
}
# lunique --
#   order independent list unique proc.  most efficient, but requires
#   __LIST never be an element of the input list
# Arguments:
#   __LIST      list of items to make unique
# Returns:
#   list of only unique items, order not defined
#
;proc lunique3 __LIST {
    if {[llength $__LIST]} {
        foreach $__LIST $__LIST break
        unset __LIST
        return [info locals]
    }
}

# # procedure de gestion de liste (Tom Phelps (phelps@cs.Berkeley.EDU) )
# #
# proc lfirst   {l} {return [lindex $l 0]}
# proc lsecond  {l} {return [lindex $l 1]}
# proc lthird   {l} {return [lindex $l 2]}
# proc lfourth  {l} {return [lindex $l 3]}
# proc lfifth   {l} {return [lindex $l 4]}
# # five is enough to get all pieces of `configure' records
# proc lsixth   {l} {return [lindex $l 5]}
# proc lseventh {l} {return [lindex $l 6]}
# proc llast    {l} {return [lindex $l end]}

########################################################################
# lreverse <list> => return return a reversed ordered list
proc lreverse {l} {
   set l2 ""
   for {set i [expr [llength $l]-1]} {$i>=0} {incr i -1} {
      lappend l2 [lindex $l $i]
   }
   return $l2
}


## lfound ?-mode? list pattern
# 
# return 1 if there is one matched element 0 otherwise
# option could be one of -glob, -exact or -regexp (as for lsearch)
# A FAIRE : REMPLACER <pattern> par <patternList>
# en CONCATENANT les arguments residuels.
# exemple if {[lfound <biglist> <elemListToSearchFor>]} {...}
# 
proc lfound args {
    return [expr [eval lsearch $args] != -1]
}

## lmatch ?-first? ?-mode? list pattern
#
# Search the elements of list, returning a list of all elements
# matching pattern.  If none match, an empty list is returned.
# mode is one of: -exact, -glob, -regexp (-glob is default)
# option: -first for include only the first matched element
#
# Example :
#  set subList [lmatch -first -regexp -- $myList $myPattern]
# 
# historique :
#  - 24/05/96 (diam@ensta.fr) : création
#  - 25/07/01 (diam@ensta.fr) : correction bug
#
# A FAIRE :
# 1 - REMPLACER <pattern> par <patternList> <patternList> ...
#     en CONCATENANT les arguments residuels.
# 2 - rajouter options (exclusives) -and et -or permettant de choisir entre
#     l'intersection et la reunion des patterns a satisfaire
#     TOUT EN CONCERVANT L'ORDRE !
# 3 - modifier lecture options pour éviter les guillemets while "..."
# 
# ATTENTION : il existe une "lmach" dans tclx mais moins souple et pas 
#             forcément compatible !
# 
proc lmatch {args} {
   set FIRST 0
   set MODE  -glob
   set i 0
   while "\$i < [string length $args]" {
       set arg [lindex $args $i]
       switch -glob -- $arg {
          --       {incr i ; break}
          -first   {set FIRST 1; incr i; continue}
          -exact   -
          -glob    -
          -regexp  {set MODE $arg; incr i; continue}
          -*       {error "unknow option $arg"}
          default  {break  ;# no more options}
       }
   }
   # i point on the next unread argument
   set list    [lindex $args $i]
   set pattern [lindex $args [incr i]]

   set result {}
   foreach e $list {
     switch $MODE -- $e $pattern {
         lappend result $e
         if $FIRST "return $e"
     }
   }
   return $result
}

###########################################################################
# lexclude ?-first? ?-mode? list patterns patterns ...
# Search the elements of list, returning a list by removing all elements
# in the patterns lists (which are concatained).
#
# principe :
#
#  on peut eviter d'utiliser cette procedure :
#
#      while {[set ndx [lsearch -exact $list $element]] != -1} {
#         set list [lreplace $list $ndx $ndx]
#      }
#
# options:
#
# -mode:  -exact | -glob | -regexp : (default to glob: id lsearch)
# -first: then excluding only the first matched element.
#         The first pattern is match first against the wall list
#         before looking for other patterns.
#
# examples :
#
#    set L {popo popi {pi pi} pipi pkpk lolo lili popi}
#       popo popi {pi pi} pipi pkpk lolo lili popi
#    lexclude -exact $L {popo pipi} popi {pi pi}
#       {pi pi} pkpk lolo lili
#    lexclude -exact $L {popo pipi} popi {pi\ pi}
#       pkpk lolo lili
#    lexclude -first $L pi*
#       popo popi pipi pkpk lolo lili popi
#
# diam@ensta.fr 26/07/96 : list of patterns instead of only one pattern
# 
proc lexclude {args} {
   set FIRST 0
   set MODE  -glob
   set i 0
   while "\$i < [string length $args]" {
       set arg [lindex $args $i]
       switch -glob -- $arg {
          --       {incr i ; break}
          -first   {set FIRST 1; incr i; continue}
          -exact   -
          -glob    -
          -regexp  {set MODE $arg; incr i; continue}
          -*       {error "unknow option $arg"}
          default  {break  ;# no more options}
       }
   }
   # i point on the next unread argument
   set list    [lindex $args $i]
   set patterns [join [lreplace $args 0 $i]]
   foreach p $patterns {
      if {[set ndx [lsearch $MODE $list $p]] == -1} continue
      set list [lreplace $list $ndx $ndx]
      if !$FIRST {
         while {[set ndx [lsearch $MODE $list $p]] != -1} {
            set list [lreplace $list $ndx $ndx]
         }
      }
   }
   return $list

}



##  llongest <list> retourne la taille du plus long element de la liste
# 
proc llongest list {
    set max 0
    foreach e $list {
        if {[set len [string length $e]] > $max} {set max $len}
    }
    return $max
}

## llongestPrefix - plus long prefix commun dans une liste
# 
# @return plus long prefix commun aux élément de la liste
# @param l  liste à explorer
# 
# todo : 
#   A REFONDRE (impléménetation périmé !)
#    
# historique :
#   origine : extrait de Paul Raines (tkBind) 
#   25/07/2001 : intégré à pist
# 
proc llongestPrefix { l } {
    # case [llength $l] in {
    #     {0} { return {} }
    #     {1} { return [lindex $l 0] }
    # }
    switch  {[llength $l]} {
        0 { return {}            }
        1 { return [lindex $l 0] }
        default { error "llongestPrefix <list>"}
    }
    set first   [lindex $l 0]
    set matchto [expr {[string length $first] - 1}]
    for {set i 1} {$i < [llength $l]} {incr i} {
        set current [lindex $l $i]
        # if they don't match up to matchto, find new matchto
        if { [string compare \
               [string range $first 0 $matchto] \
               [string range $current 0 $matchto]] } {
          # loop, decreasing matchto until the strings match that far
          for {} \
              {[string compare \
                  [string range $first 0 $matchto] \
                  [string range $current 0 $matchto]] } \
              {incr matchto -1 } \
              {}			;# don't need to do anything in body
        } ;# end if they didn't already match up to matchto
    } ;# end for each element in list
    if {$matchto < 0} then {
        return {}
    } else {
        return [string range $first 0 $matchto]
    }
}

## lcutleft <liste> <N>
# 
# retourne la liste <liste>, mais dont les éléments sont tronqués ›
# gauche de N caractères.
# 
proc lcutleft {list N} {
    set result ""
    foreach e $list {
        lappend result [string range $e $N end]
    }
    return $result
} ;#endproc lcutleft


## laddleft <liste> <string>
# 
# retourne la liste <liste>, mais dont les éléments sont préfixés ›
# gauche par la chaine <string>.
# 
proc laddleft {list str} {
    set result ""
    foreach e $list {
        lappend result "$str$e"
    }
    return $result
} ;#endproc laddleft


# PREVOIR AUSSI lsub smult.

## lsum -- addition de listes : list = list1 + list2
#
# Retourne une liste formée de la somme de chaque éléments des
# deux listes <list1> et <list2>
# Les deux parametres <list[12]> doivent etre de meme longueur
#
proc lsum {list1 list2} {
   if {[llength $list1]!=[llength $list2] || ![llength $list1]} {
      error "lsum requests the two lists are not empty \
            and of the same length"
   }
   set list {}
   foreach e1 $list1 e2 $list2 {
      lappend list [expr {$e1 + $e2}]
   }
   return $list
}

## lsub --  soustraction de listes : list = list1 - list2
#
# Retourne une liste (ou un vecteur) formée de la différence
# de chaque éléments des deux listes <list1> et <list2>
# Les deux parametres <list[12]> doivent etre de meme longueur
#
proc lsub {list1 list2} {
   if {[llength $list1]!=[llength $list2] || ![llength $list1]} {
      error "lsub requests the two lists are not empty \
            and of the same length"
   }
   set list {}
   foreach e1 $list1 e2 $list2 {
      lappend list [expr {$e1 - $e2}]
   }
   return $list
}

## lmult --  multiplication de listes : list = list1 x list2
#
# Retourne une liste (ou un vecteur) formée de la différence
# de chaque éléments des deux listes <list1> et <list2>
# Les deux parametres <list[12]> doivent etre de meme longueur
#
proc lmult {list1 list2} {
   if {[llength $list1]!=[llength $list2] || ![llength $list1]} {
      error "lmult requests the two lists are not empty \
            and of the same length"
   }
   set list {}
   foreach e1 $list1 e2 $list2 {
      lappend list [expr {$e1 * $e2}]
   }
   return $list
}

## lmix -- retourne le mélange d'une liste
#
# (idée de Marc Thirion <thirion@mipnet.fr>)
#
# modif :
#   01/12/99 (diam) : correction et intégration dans pist
#
# a faire
#  - créer lmixvar prenant le NOM d'une liste en parametre
#
proc lmix {list} {

    if {[llength $list]} {
        foreach elt $list {
            set disorder([expr {rand()}]) $elt
        }
        foreach elt $list {
           set key [expr {rand()}]
           while {[info exists disorder($key)]} {
               set key [expr {rand()}]
           }
           set disorder($elt) $elt
        }
        foreach index [lsort -real [array names disorder]] {
            lappend result $disorder($index)
        }
        set result
    }
}

## lmerge fusionne deux listes par intercalage
#
# Utilisation
#
# Permet d'affecter un tableaux a partir d'une liste de clés, et
# d'une liste de valeur correspondante :
#
#   array set arrayName [pairlist $keys $value]
#
#
proc lmerge {list1 list2} {
        set res [list]
        foreach key $list1 value $list2 {
            lappend res $key $value
        }
        set res
}


## clist2list == Compact integer list to list 
# 
# from wikit
# 
#  {1-4 6-8} => {1 2 3 4 6 7 8} 
# 
proc clist2list {clist} {
   #-- clist: compact integer list w.ranges, e.g. {1-5 7 9-11}
   set res {}
   foreach i $clist {
       if [regexp {([^-]+)-([^-]+)} $i -> from to] {
           for {set j [expr $from]} {$j<=[expr $to]} {incr j} {
               lappend res $j
           }
       } else {lappend res [expr $i]}
   }
   return $res
} ;#RS

## ListApplyCmd applay a tcl cmd to each element
# 
# 
# 
# 
proc ListApplyCmd {list cmd} {
    set res [list]
    foreach item $list {
        lappend res [uplevel 1 [concat $cmd [list $item]]]
    }
    set res
}


## kvsort Take a key-value list and return list sorted by key
# 
# Take a key-value list and return list sorted by key, 
# but with corresponding values staying with their key
# 
# Stollen from uri.test from tcllib (03/07/00)
# 
proc kvsort args {
    array set arr $args
    set result {}
    foreach key [lsort [array names arr]] {
	lappend result $key $arr($key)
    }
    return $result
}

## list_gen -- génère une liste {1 2 3 ..} de longueur n
# 
proc list_gen {n} {
    for { set i 0 } { $i < $n } { incr i } {
        lappend retval $i
    }
    return $retval
}

## shuffle -- mélange une liste d'une manière arbitraire
# 
# meilleur solution par Steve Cohen 
# idem à shuffle4 testé en  http://mini.net/cgi-bin/wikit/941.html.
# 
# Test sur powermac G3-400Mhz :
#    # 5.15s pour générer une liste de 10e6 éléments {1 2 3 ...}  par :
#    time {set L1 [list_gen 1000000] }
#    # 18.5s pour mélange la liste par :
#    time {set L2 [shuffle $L1]}
#
proc shuffle { list } {
    set n [llength $list]
    while {$n>0} {
        set j [expr {int(rand()*$n)}]
        lappend slist [lindex $list $j]
        incr n -1
        set temp [lindex $list $n]
        set list [lreplace [shuffle-K $list [set list {}]] $j $j $temp]
    }
    return $slist
}
## shuffle-K -- Donal's K combinator renommé pour éviter pollution des noms
# 
#    Donal's K combinator is a clever hack for managing the 
#    lifetime of the Tcl_Obj that represents the
#    list so that it doesn't get copied needlessly.
#    allows us to destroy the excess reference to
#    $list. It's also important to structure the code so that the list
#    never gets resized, otherwise there's a lot of memory copying
#    involved. 
# 
proc shuffle-K { x y } { set x }



## xsplit -- pour casser une chaine en liste sur une expression regulier
# 
# A IMPLEMENTER DES QUE NECESSAIRE, IL SUFFIT DE FAIRE :
# 
#  1 - regsub de la chaine en un caractere UNICODE rare (ou tout
#      simplement en \u0000
#  2 - split sur ce caractere
# 
# proc xplit [subst {str  {regexp {\[\t \r\n]+\} }  {splitCar {\u0000} }  ] {
#    xxx
# }


