#f colors.tcl - gestion des couleurs (initialisation, colorisation du
# texte


package provide stead 2.0

## testColorStruct -- 
# 
# 
# 
#  bind Stead <Meta-agrave> testNewColor
# 
proc testColorStruct {  } {

    # PB : seule le premier mytag est pris en compte
    set colorSpecs [list \
        {simple myTag1 {\w*mm\w*}   {-foreground gold} } \
        {simple myTag2 {[tT]ext}  {-foreground red} } \
        {simple myTag3 {\w*[tT]ext\w*}  {-foreground blue} } \
    ]
    # cancel_colors :
    foreach colorSpec  $colorSpecs {
       te:colours:clear_foregroundStruct .main.t all [lindex $colorSpec 1]
    }
    te:cmd:coloriseStruct .main.t $colorSpecs all
        
}


## te:cmd:coloriseStruct -- colore le pattern de la couleur indiquée
# 
#  te:cmd:coloriseStruct  ?-nocase?  text  colorStructure  what
# 
# what peut être égal à all (tout le fichier), currentLine (la ligne en cours)
# le parametre colorStructure contient la liste de liste associant chaque 
# pattern au script TCL permettant de colorier ce pattern. Par exemple :
# 
# " { simple commentaire $commentaireRegExp {Script TCL}} \
#   { complexe commentaireComplexe A SPECIFIER...} "
# 
# Le champs "simple" permet de specifier des expressions regulieres qui 
# permettent une coloration sur une ligne
# Si le champs vaut "complexe", cela correspond a une expression reguliere
# qui nessecite une analyse sur plusieurs ligne...
# 
# A FAIRE : 
#    - option sel qui colorise la selection en cours
#    - redéfinir la gestion des options plus générale (changent API)
#    - completer les "type" de colorisation (simple, balance, exact, ..)
#    - en faire un "module" de pist
# 
# MODIF :#
#  xx/09/96 (David CARQUEIJAL)  : création
#  06/12/96 (diam) : ajout option -nocase
#  07/12/96 (diam) : simplification, et réorganisation
#  05/02/97 (diam) : rajout de la possibilité previousLine
#  22/08/00 (diam) utilisation de text search
# 
# REMARQUE : 
# sur le "update" de la boucle while
# On rend la main apres chaque coloration de ligne pour
# un pattern. L'utilisateur croit voir une coloration en
# tache de fond
# 
# Exemple :
#   te:cmd:coloriseStruc .main.t
# 
proc te:cmd:coloriseStruct {args} {

    set NOCASE_FLAG 0
    set i 0
    while "\$i < [string length $args]" {
        set arg [lindex $args $i]
        switch -glob -- $arg {
           --       {incr i ; break}
           -nocase  {set NOCASE_FLAG 1; incr i; continue}
           -*       {error "unknow option $arg"}
           default  {break  ;# no more options}
        }
    }
    # i point on the next unread argument
    set text           [lindex $args $i]
    set colorStructure [lindex $args [incr i]]
    set what           [lindex $args [incr i]]
    
        
    switch -exact -- $what {
        all { 
            set startId 1.0
            set endId [$text index end]
        }
        screen { 
            
            # endIdx : nbre de ligne total dans le text (182.0)
            set endIdx    [$text index end]
            # [$text yview] == {0.0331492 0.254827}
            set startLine [expr {int([lindex [$text yview] 0]*$endIdx)} ]
            set endLine   [expr {int([lindex [$text yview] 1]*$endIdx) + 1} ]
            set startId   $startLine.0
            set endId     $endLine.0
            
        }
        sel {
            # A FAIRE...
        }
        currentLine {
            set startId [$text index "insert linestart"]
            # set endId   [$text index "insert lineend + 1c"]
            set endId   [$text index "insert lineend"]
            # On efface les couleurs de la ligne
            foreach pat $colorStructure {
               te:colours:clear_foregroundStruct .main.t \
                    currentLine [lindex $pat 1]
            }   
        }
        previousLine {
            set startId [$text index "insert -1l linestart"]
            # set endId   [$text index "insert lineend + 1c"]
            set endId   [$text index "insert -1l lineend"]
            # On efface les couleurs de la ligne
            foreach pat $colorStructure {
               te:colours:clear_foregroundStruct .main.t \
                    currentLine [lindex $pat 1]
            }   
        }
    } ;#endswitch
    
    set firstLine [lindex [split $startId .] 0]
    set lastLine  [lindex [split $endId .] 0]

    # On colore pattern par pattern 
    foreach colStruct $colorStructure {
        # A ce stade, on ne traite que les elements de type "simple"
        if {[ string compare [lindex $colStruct 0] "simple"] } {
            continue
        }
        set type     [lindex $colStruct 1]
        set pattern  [lindex $colStruct 2]
        set options  [lindex $colStruct 3]
       
        ################################################################
        # DEBUT DE MODIF
        eval {$text tag configure foreground:$type} $options
        
        set endOfThisPattern 0
        set count 0 ;# nombre de caracteres "matched"
        set newStartId $startId
        while {!$endOfThisPattern} {
            
            if {$NOCASE_FLAG} {
                set idx [$text search -regexp  -count count  -nocase\
                                  $pattern $newStartId $endId]
            } else {
                set idx [$text search -regexp  -count count  \
                                  $pattern $newStartId $endId]
            }
           # ATTENTION si colorSpec mal faite, idx retse à  1.0 et ca boucle !!
          if {[string length $idx]} {
                $text tag add foreground:$type $idx [$text index "$idx + $count c"]
                set newStartId [$text index "$idx + $count c"]
            } else {
                set endOfThisPattern 1
            }
       # un update pour chaque couleur
       update
       } ;# endwhile
       

        # update idletasks
        update
    }

}

## te:colours:clear_foregroundStruct - 
# efface les tags du nom de background:$which
# - dans la selection si what = select
# - dans la ligne courante what = currentLine
# - dans tout le fichier si what = all
# 
proc te:colours:clear_foregroundStruct { text {what select} {which *} } {
  switch $what {
    select {
        # A FAIRE...
        set startId 1.0
        set endId 1.0
    }
    currentLine {
        set startId [$text index "insert linestart"]
        set endId [$text index "insert lineend"]
    }
    all {
        set startId 1.0
        set endId end
    }  
  }  
  foreach tag [$text tag names] {
      if {[string match "foreground:$which" $tag]} {
        catch {
            $text tag remove $tag $startId $endId
        }
        
      } 
  }
}


## stead:coloursResetBackground_BOF - efface les tags du nom de background:*
# 
proc stead:coloursResetBackground_BOF {} {
  set t .main.t
  foreach tag [.main.t tag names] {
    if {[string match "background:*" $tag]} {
      catch {
        .main.t tag remove $tag sel.first sel.last
      }
    }
  }
}


## stead:coloursResetForeground_BOF - efface les tags du nom de background:$which
# - dans la selection si what = select
# - dans tout le fichier si what = all
# 
proc stead:coloursResetForeground_BOF { {what select} {which *} } {
  set t .main.t
  
  switch $what {
    select {
  
      foreach tag [.main.t tag names] {
        if {[string match "foreground:$which" $tag]} {
          catch {
            .main.t tag remove $tag sel.first sel.last
          }
        }
      }
    }
    
    all {
      foreach tag [.main.t tag names] {
        if {[string match "foreground:$which" $tag]} {
          catch {
            .main.t tag remove $tag 1.0 end
          }
        }
      }
    }  
  }  
}
## stead:clearFont --
# 
proc stead:clearFont {} {
  set t .main.t
  foreach tag [.main.t tag names] {
    if {[string match "font:*" $tag]} {
      catch {
        .main.t tag remove $tag sel.first sel.last
      }
    }
  }
}

## te:cmd:colorise - colore le pattern de la couleur indiquée
# what est par défaut égal à la sélection
# peut être égal à all (tout le fichier, previous (ligne précédente),
# next (ligne suivante)
# A FAIRE : option -nocase
# 
proc te:cmd:colorise {pattern {what select} {color magenta}} {

  global stead
  upvar #0 stead(text) w
  
  $w tag configure foreground:$color -foreground $color

  switch $what {
    select {
      set sel [xtext_getSel $w]
      if { "x$sel" != "x" && "x[selection own]" == "x.main.t" } {
      
        # tant qu'on trouve le pattern, on ajoute les indices correspondants
        # à la liste
        
        set ip 0
        set liste_marques {}
        while {[regexp -indices -- $pattern $sel a]} {
          set sel [string range $sel [expr [lindex $a 1]+1] end]
          set a [list [expr [lindex $a 0]+$ip] [expr [lindex $a 1]+$ip]]
          lappend liste_marques $a
          set ip [expr [lindex $a 1] +1]
        }
        
        #  pour tous les intervalles trouvés, on colore
        
        foreach m $liste_marques {
          .main.t tag add foreground:$color "sel.first + [lindex $m 0] chars" \
          "sel.first + [expr [lindex $m 1] +1] chars"
        }
      }
    }
  
    all {
      set sel [.main.t get 1.0 end]
      # tant qu'on trouve le pattern, on ajoute les indices correspondants
      # à la liste
      
      set ip 0
      set liste_marques {}
      while {[regexp -indices -- $pattern $sel a]} {
        # lorsqu'on colore tous le fichier, on rend la main
        update
        set sel [string range $sel [expr [lindex $a 1]+1] end]
        set a [list [expr [lindex $a 0]+$ip] [expr [lindex $a 1]+$ip]]
        lappend liste_marques $a
        set ip [expr [lindex $a 1] +1]
      }
      
      #  pour tous les intervalles trouvés, on colore
      
      foreach m $liste_marques {
        .main.t tag add foreground:$color "1.0 + [lindex $m 0] chars" \
        "1.0 + [expr [lindex $m 1] +1] chars"
      }
      
    }      
    
  }
}
# ./
