#######################################################################
##    /*                                                             */
##    /*  str2af.tcl --- (gH) 1998  :                                */
##    /*                                                             */
##    /*     +================================================+      */
##    /*     +                                                +      */
##    /*     +   pour Arbres et Langages :                    +      */
##    /*     +        d'une chaine avec "stacks"              +      */
##    /*     +        é une liste d'adresses AF               +      */
##    /*     +                                                +      */
##    /*     +================================================+      */
##    /*                                                             */
##    /*                                                             */
##    /* testà avec - tcl/tk 8.0 pour Windows                        */
##    /*            - tcl/tk 8.0 pour Linux                          */
##    /*            - tcl 2.0 plug-in Netscape Linux                 */
##    /*            - tcl 2.0 plug-in Netscape Windows               */
##    /*                                                             */
##    /*                                                             */
#######################################################################
##    /*                                                             */
##    /*  Auteur                                                     */
##    /*                                                             */
##    /*     gilles.hunault@univ-angers.fr                           */
##    /*     email : gilles.hunault@univ-angers.fr                   */
##    /*                                                             */
##    /*     http://www.info.univ-angers.fr/~gh/                     */
##    /*                                                             */
#######################################################################

proc bdb { ndb } {

## boutons du bas et ailleurs, disposition et numéro #
##                                           aide 1  #
## vidage envoi                              exit    #
## 2      3                                  4       #
## encore                                            #
## 5                                                 #

   global .th enx eny mplg
   catch { destroy .th.ci.aid .th.ci.agn .th.ci.env .th.ci.fin th.ci.hlp }

   # bouton d'aide

   if {[lsearch -exact $ndb 1] >= 0 } {
      catch { destroy .th.ci.aid }
      button .th.ci.aid  -text " Aide " -command { aide 1 } \
                         -font { Times 17 bold } -bg blue -fg yellow -relief ridge
      .th.ci create window [expr $enx - 45  ]  25              -window .th.ci.aid
   } ; # fin de si on demande le bouton 1

   # bouton de vidage des données

   if {[lsearch -exact $ndb 2] >= 0 } {
      catch { destroy .th.ci.aign }
      button .th.ci.agn  -text " vidage " -command { raz } \
                         -background yellow -foreground blue -font { Times 17 bold } \
                         -relief solid -width 13
      .th.ci create  window 95 [expr $eny - 85] -window .th.ci.agn
   } ; # fin de si on demande le bouton 2

   # bouton d'envoi des données

   if {[lsearch -exact $ndb 3] >= 0 } {
      catch { destroy .th.ci.env }
      button .th.ci.env  -text "     conversion     " -command { gereData  } \
                         -font { Times 17 bold } -bg yellow -fg blue -relief solid
      bind   .th.ci.env  <Return>   { gereData  }
      focus  .th.ci.env
      .th.ci create window [expr -8 + $enx/2] [expr $eny - 85] -window .th.ci.env
   } ; # fin de si on demande le bouton 3

   # bouton de fin de programme

   if {[lsearch -exact $ndb 4] >= 0 } {
      catch { destroy .th.ci.fin }
      button .th.ci.fin -text " exit " -command { fin } \
                        -background blue -foreground yellow -font { Times 17 bold }  -relief ridge
      .th.ci create  window [expr $enx - 40] [expr $eny - 85] -window .th.ci.fin
   } ; # fin de si on demande le bouton 4

   # bouton de relance du programme (pour le mode aide)

   if {[lsearch -exact $ndb 5] >= 0 } {
      catch { destroy .th.ci.aign }
      button .th.ci.agn  -text " encore " -command { affiche } \
                         -background yellow -foreground blue -font { Times 17 bold } \
                         -relief solid
      .th.ci create  window 60 [expr $eny - 85] -window .th.ci.agn
      bind  .th.ci.agn  <Return>   { affiche }
      focus .th.ci.agn
   } ; # fin de si on demande le bouton 5

   pack .th.ci -expand true -fill both

} ; # fin proc bdb


proc raz { } {

  global lstAdr chEnt

  set lstAdr(0) 0
  set chEnt ""
  affiche

} ; # fin proc raz

proc matchpos { frompos phrase } {

  set mdbg  1 ; # /* avec affichage de debug */
  set mdbg  0 ; # /* sans affichage de debug */
  set ipos  0
  if { $mdbg ==1 } {
  }
  set lrp     [string length $phrase]
  set inpos   $frompos
  set nbouv   0
  set nbferm  0
  while { $inpos <= $lrp } {
     set carc  [string range $phrase $inpos $inpos]
     if { $carc == "<" } { set nbouv  [expr $nbouv  + 1] }
     if { $carc == ">" } { set nbouv  [expr $nbouv  - 1] }
     # /* say " caractère " carc " nbouv " nbouv */
     if { $nbouv == 0 } {
        # /* say " vu ! on est en pos " inpos */
        set ipos $inpos
        set inpos [expr $lrp + 1]
     } ; # fin de si nbouv = 0
     set inpos [expr $inpos + 1 ]
  } ; # fin de tant que
return $ipos
} ; # fin proc matchpos

proc af { naorg lal } {

 global taf na

 set ijprec $taf($naorg)
 set adbg  0 ; # /* sans affichage de debug */
 set adbg  1 ; # /* avec affichage de debug */
 set nml  [llength $lal]
 if {  $nml < 1 } { return $lal } else {

   set pic [lsearch -exact $lal "<"]
   if { $pic == -1 } {
      set crochet  0
      set pic $nml
   } else { set crochet 1 }

   set taf($naorg)  [string trim $taf($naorg)]
   set nmo [llength $taf($naorg)]
   set tmp ""

   for { set i 0 } { $i < $nmo-1 } { set i [incr i 1] } {
       set tmp  "$tmp [lindex $taf($naorg) $i]"
   } ; # fin pour i
   set fe [lindex $taf($naorg) [expr $nmo-1]]
   for { set i 0 } { $i < $pic } { set i [incr i 1] } {
       set na     [expr $na + 1]
       set fe     [expr $fe + 1]
       set taf($na) "$tmp $fe"

       set naorg  $na
   } ; # fin pour i

   # /* on gère la suite é partir des crochets */

   if { $crochet == 1 } {
      set reste ""
      for { set i $pic } { $i <= $nml } { set i [incr i 1] } {
         set reste  "$reste [lindex $lal $i]"
      } ; # fin pour i
      # /* il y a deux appels récursifs possibles : */
      # /* un pour la partie crochet et un pour la partie après le crochet */
      set ic1  [string first "<" $reste]
      set ic2  [matchpos $ic1 $reste ]
      # m1  = substr(reste,ic1+1,ic2-ic1-1)
      set m1   [string range $reste  [expr $ic1+1] [expr $ic2 - 1]]
      set m2   [string range $reste  [expr $ic2+1] end ]
      if { $adbg == 1} {
      } ; # fin de si

      # /* la partie suite de l'axe est la plus simple */

      if { [llength $m2] > 0 } { af $naorg $m2 }

      # /* la partie ramification redemande une préparation */

         set nm1 [llength $m1]
         if { $nm1 > 0 } {
            set na  [expr $na + 1]
            set nmo [llength $taf($naorg)]
            set ax  [expr [lindex $taf($naorg) [expr $nmo-2]] + 1]
            set fe  1
            set tm1 ""
            set nmp [llength $m1]
            for { set i 1 } { $i < $nmp } { set i [incr i 1] } {
               set tm1 "$tm1 [lindex $m1 $i]"
            } ; # fin pour i
            set p1  "$na $tm1  "
            set taf($na)  "$taf($naorg) $ax $fe"

            if { $adbg == 1 } {
            } ; # fin de si
            if { [llength $tm1] > 0 } { af $na $tm1 }
         } ; # fin si nm1 > 0

   } ; # finsi crochet = 1
 } ; # finsi nml >= 1
} ; # fin proc af

proc convertit { } {

 global chEnt lstAdr taf na

 set cg "\["
 set cd "\]"
 set lon [string length $chEnt]
 set nphr ""
 for { set i 0 } { $i < $lon } { set i [incr i 1] } {
     set kar [string range $chEnt $i $i]
     if { $kar == $cg } { set kar " < " }
     if { $kar == $cd } { set kar " > " }
     append nphr $kar
 } ; # fin pour i

 set ligne $nphr
 set nbl 0
 set nbm [llength $chEnt]
 if { $nbm == 0 } { set lstAdr(0) 0 } else {

    if { [string compare [lindex $ligne 0] "<"] == 0 } {
    } else {
       set ax    1
       set fe    1
       set na    1
       set taf($na) "$ax $fe"
       set phrase  " "
       for { set i 1 } { $i < $nbm } { set i [incr i 1 ] } {
          set phrase  "$phrase [lindex $ligne $i]"
       } ; # fin pour i
       af $na $phrase

       for { set i 1 } { $i <= $na } { set i [incr i 1] } {
           set lg ""
           set wt [expr [llength $taf($i)] / 2 ]
           for { set j 0 } { $j < $wt } { set j [incr j 1] } {
               set k   [expr 2*$j]
               set ik  [lindex $taf($i) $k]
               set ikp [lindex $taf($i) [expr 1+$k]]
               set lg "$lg $ik"
               append lg " $ikp"
           } ; # fin pour j
           set lstAdr($i) $lg
       } ; # fin pour i
       set lstAdr(0) $na
    } ; # fin si premier mot = "]"
 } ; # fin si lon = 0
} ; # fin proc convertit

# partie 1 : demande

proc dessine { } {

 global enx eny adr lstAdr mplg chEnt .th .th.ci
 set xcsg 190
 set ycsg  48
 set xcid 630
 set ycid 368
 .th.ci create rectangle $xcsg $ycsg $xcid $ycid -outline black
 set hauteur [expr ($ycid-$ycsg)]
 set xracine [expr ($xcsg+$xcid)/2]
 set yracine [expr $ycid -20]

 # tracé de l'axe principal

 set na $lstAdr(0)
 set nbeax 0 ; # nombre d'entre-neoeuds sur l'axe principal
 for { set i 1 } { $i <= $na } { set i [incr i 1] } {
     if { [llength $lstAdr($i)] == 2 } { set nbeax [incr nbeax ] }
 } ; # fin pour i
 set hauEn 20
 if { $nbeax > 0 } { set hauEn [expr ($hauteur-3)/($nbeax+1)] }

 set ytdeb $yracine
 set ytfin [expr $ytdeb-$hauEn]
 for { set i 1 } { $i <= $nbeax } { set i [incr i 1] } {
     .th.ci create line $xracine $ytdeb $xracine $ytfin -arrow last
     set ytdeb $ytfin
     set ytfin [expr $ytdeb-$hauEn]
 } ; # fin pour i

 # tracé des ramifications d'ordre 2 seulement

 set nbram 0  ; # nombre d'entre-neoeuds sur l'axe principal
 set ramif "" ; # ramification
 set maxen 0  ; # plus grand entre-noeud de ramification
 for { set i 1 } { $i <= $na } { set i [incr i 1] } {
     set adr $lstAdr($i)
     if { [llength $adr] == 4 } {
          set nbram [incr nbram 1]
          set en [lindex $adr 1]
          if { $en > $maxen } { set maxen $en }
        }
 } ; # fin pour i

 for { set i 1 } { $i <= $maxen } { set i [incr i 1] } {
     set ten($i) 0
 } ; # fin pour i

 for { set i 1 } { $i <= $na } { set i [incr i 1] } {
     set adr $lstAdr($i)
     if { [llength $adr] == 4 } {
          set nbram [incr nbram 1]
          set en [lindex $adr 1]
          set ten($en) [incr ten($en)]
        }
 } ; # fin pour i

 set pomme "$nbeax hauteur $hauEn"
 set pomme "$nbram plus haute $maxen"
 set pomme ""
 set sens  -1
 for { set i 1 } { $i <= $maxen } { set i [incr i 1] } {
     append pomme " $ten($i) "
     set sen($i) 0
     if { $ten($i) > 0 } { set sens [expr -$sens] ; set sen($i) $sens }
     append pomme " $sen($i) ; "
 } ; # fin pour i

 set xdeb $xracine
 for { set i 1 } { $i <= $maxen } { set i [incr i 1] } {
     if { $ten($i) > 0 } {
        set sens $sen($i)
        set ydeb [expr $yracine -$i*$hauEn]
        set yfin $ydeb
        for { set j 1 } { $j <= $ten($i) } { set j [incr j 1 ] } {
            set xfin [expr $xdeb+$j*$sens*30]
            set yfin [expr $yfin-$hauEn/2]
            .th.ci create line $xdeb $ydeb $xfin $yfin -arrow last
        } ; # fin pour j
     } ; # fin si
     append pomme " $sen($i) ; "
 } ; # fin pour i

# label .th.ci.pomme -text "$pomme"
# .th.ci create window [expr $xcsg+10] [expr $ycsg+10] -window .th.ci.pomme -height 35  -width 170 -anchor nw

 pack .th.ci


} ; # fin proc dessine

proc affiche { } {

 global enx eny adr lstAdr mplg chEnt

 catch { destroy .th.ci.aid  .th.ci.bou  .th.ci.ent1 .th.ci.tit1  }
 catch { destroy .th.ci.agn  .th.ci.b1   .th.ci.b2   .th.ci.fin }
 catch { destroy .th.ci.ent2 .th.ci.tit2 }
 catch { destroy .th.ci.ent3 .th.ci.tit3 .th.ci.hlp  .th.ci }

 canvas .th.ci -width $enx -height  $eny -background white
 pack   .th.ci -expand true -fill both

 set titEff2 " Chaine   "

 set cg "\["
 set cd "\]"
 set lon [string length $chEnt]
 set nphr ""
 for { set i 0 } { $i < $lon } { set i [incr i 1] } {
     set kar [string range $chEnt $i $i]
     if { $kar == "<" } { set kar " $cg "}
     if { $kar == ">" } { set kar " $cd "}
     append nphr $kar
 } ; # fin pour i
 set chEnt $nphr

 label  .th.ci.tit2 -text $titEff2 \
                    -font { Times 17 bold } -bg green -fg black -relief ridge
 entry  .th.ci.ent2 -textvariable chEnt -font { Courier 13 bold } -relief solid
 .th.ci create window 010 005 -window .th.ci.tit2 -height 35 -width 170 -anchor nw
 .th.ci create window 190 005 -window .th.ci.ent2 -height 35 -width 320 -anchor nw
 bind .th.ci.ent2 <Return> { gereData }
 focus .th.ci.ent2

 set titEff1 " Adresses "
 label  .th.ci.tit1 -text $titEff1 \
                    -font { Times 17 bold } -bg green -fg black -relief ridge
 text  .th.ci.ent1 -font { Courier 12 bold } -relief solid
 .th.ci create window 010 48 -window .th.ci.tit1 -height 35  -width 170 -anchor nw
 .th.ci create window 010 90 -window .th.ci.ent1 -height 280 -width 170 -anchor nw
 set na $lstAdr(0)
 for { set i 1 } { $i <= $na } { set i [incr i 1] } {
     set ladr [string trim $lstAdr($i)]
     set wt [expr [llength $ladr] / 2 ]
     set lg ""
     for { set j 0 } { $j < $wt } { set j [incr j 1] } {
         set k   [expr 2*$j]
         set ik  [lindex $ladr $k]
         set ikp [lindex $ladr [expr 1+$k]]
         append lg "A$ik"
         append lg "F$ikp "
     } ; # fin pour j
     .th.ci.ent1 insert $i.0 "$lg\n"
 } ; # fin pour i

 dessine

 bdb { 1 2 3 4 } ; # boutons aide, vidage envoi et exit
 pack   .th.ci -expand true -fill both

} ; # fin proc affiche

# partie 2 : vérification

proc gereData { } {

  global enx eny mplg lstAdr chEnt errTxt

  catch { destroy  .th.ci.aid .th.ci.bou .th.ci.ent1 .th.ci.tit1 }
  catch { destroy  .th.ci.ent2 .th.ci.tit2 .th.ci.ent3 .th.ci.tit3 }

  pack   .th.ci -expand true -fill both

  set okData  1
  set errTxt  " Mais..."

  # on aére le texte et on remplace les < > par [ et ]

  if { [string trim $chEnt] == "" } { set okData 0
        append errTxt " \n      vous n'avez rien donné comme chaine !" } else {
        append errTxt " avant $chEnt \n"
        set cg "\["
        set cd "\]"
        set lon [string length $chEnt]
        set nphr ""
        for { set i 0 } { $i < $lon } { set i [incr i 1] } {
            set kar [string range $chEnt $i $i]
            if { $kar == "<" } { set kar "$cg"}
            if { $kar == ">" } { set kar "$cd"}
            append nphr $kar
        } ; # fin pour i
        set chEnt ""
        set lon [string length $nphr]
        for { set i 0 } { $i < $lon } { set i [incr i 1] } {
            set kar [string range $nphr $i $i]
            if { $kar == "$cg" } { set kar " $cg "}
            if { $kar == "$cd" } { set kar " $cd "}
            append chEnt $kar
        } ; # fin pour i
        append errTxt " apres $chEnt \n"
        ## check chaine bien formee
        set cro 0
        set lon [string length $chEnt]
        for { set i 0 } { $i < $lon } { set i [incr i 1] } {
            set kar [string range $chEnt $i $i]
            if { $kar == $cd } { set cro [expr $cro-1] }
            if { $kar == $cg } { set cro [expr $cro+1] }
            if { $cro < 0 } {
               append errTxt " votre chaine est mal formée \n"
               append errTxt " Partie de chaine lue jusqu'é l'erreur : "
               append errtxt [string range $chEnt 1 $i]
               set i [expr $lon+1]
            }
        } ; # fin pour i
        if { $cro < 0 } { set okData 0 }
        if { $cro > 0 } {
               append errTxt " votre chaine est mal formée \n"
               append errTxt " Il y a un $cg de trop (mais lequel ?) \n"
               set okData 0 }
  }

  # éliminons les espaces en double

  set nbr 1
  while { $nbr > 0 } {
    set nbr [regsub -all "  " $chEnt " " nch]
    set chEnt [string trim $nch]
  }

  bdb { 5 4 } ; # boutons encore et exit seulement
  if { $okData ==0 } { aide 2 } else {  convertit ; affiche }
} ; # finproc gereData

# partie 4 : aide éventuelle

proc aide { opt } {

 global enx eny mplg myGeom errTxt

 catch { destroy .th.ci.aid .th.ci.bou .th.ci.ent .th.ci.tit }
 catch { destroy .th.ci.agn .th.ci.b1  .th.ci.b2  .th.ci.fin }
 catch { destroy .th.ci }

 canvas .th.ci -width $enx -height  $eny -background white
 pack   .th.ci -expand true -fill both
 set cg "\[" ; # crochet gauche
 set cd "\]" ; # crochet droit
 if { $opt == 1 } {
 set    aidtxt ""
 append aidTxt "Une chaine avec 'stack' est une chaine de caractères dont les mots sont\n"
 append aidTxt "séparés par des espaces seulement avec comme mots soit des lettres soit\n"
 append aidTxt "les symboles $cg et $cd.\n\n"
 append aidTxt "Cette chaine doit etre bien formée c'est é dire que $cg et $cd\n"
 append aidTxt "doivent apparaitre dans cet ordre et par paire.\n\n"
 append aidTxt "Ainsi A $cg B $cg A $cd C $cd est une chaine valide \n"
 append aidTxt "mais  A $cd B ne l'est pas.\n\n"
 append aidTxt "Pour utiliser l'applet, écrivez des lettres et des crochets dans le panneau.\n"
 append aidTxt "à droite du mot \"Chaine\" puis validez par Entrée ou le bouton \"conversion\".\n"
 } else {
   set aidTxt $errTxt
 }


 append aidTxt "\n"
 append aidTxt "\n Appuyer sur le bouton ENCORE pour retourner à la saisie."

 label  .th.ci.hlp -text $aidTxt -relief solid -font { Times 13 bold } \
                   -width 80 -justify left -height 17
 .th.ci create  window 15 15 -window .th.ci.hlp -anchor nw

 bdb { 5 4 } ; # boutons aide, envoi et exit seulement
 pack   .th.ci


} ; # fin de proc aide

proc fin { } {

 global enx eny mplg myGeom val1 val2

 catch { destroy .th.ci.aid .th.ci.bou  .th.ci.ent1 .th.ci.env }
 catch { destroy .th.ci.agn .th.ci.b1   .th.ci.b2  .th.ci.fin }
 catch { destroy .th.ci.hlp .th.ci.tit1 .th.ci.ent3 .th.ci.tit3 }
 catch { destroy .th.ci.ent .th.ci.tit .th.ci }

 canvas .th.ci -width $enx -height  $eny -background white
 pack   .th.ci -expand true -fill both

## seulement en mode non plug-in

  if { $mplg == 0 } { exit } else {

     set finTxt "  "
     append finTxt "\n Au revoir !\n\n "
     .th.ci create text 270 70 \
            -text "$finTxt"  -font { Arial 17 bold }
     pack   .th.ci

  }

} ; # fin de proc fin


#######################################################################

set    enx 640                  ; # largeur
set    eny 480                  ; # hauteur
set    myGeom $enx              ; # assure un "bon"
append myGeom "x$eny+50+50"   ; # positionnement

## pour détecter si on est en mode tcl/normal ou en mode plug-in
## on utilise $plugin(release) ; mode non plug-in : variable mplg = 0

 set mplg 0
 catch { set mplg $plugin(release) }

## seulement en mode non plug-in

 if { $mplg == 0 } { wm geometry . $myGeom }

# le cadre

frame  .th  -width $enx -height  $eny -background white
pack   .th  -expand true -fill both

# le titre

label  .th.titre  -text " Conversion d'une chaine en une liste d'adresses AF" \
                  -font { Arial 15 bold } -bg red -fg yellow -relief sunken \
                  -width 60 -height 2
pack   .th.titre  -expand true -fill x
pack   .th

# le canevas

canvas .th.ci -width $enx -height  $eny -background white
pack   .th.ci -expand true -fill both

# les données (valeurs par défaut) et l'appel de la procédure d'affichage

set   lstAdr(0) 0
set   chEnt " A < B < C > D > E F < G > H"

gereData

## fin du fichier str2af.tcl