Tri de chaînes de caractères

' Tribul.bas tri par bulle (selon l'ordre ascii des caractères)
LABEL Tribul
DIM a$(1000), b$, na%, rg%, i, t1, t2
HEIGHT 0, 1100
LIST 1: WIDTH 1, 300: HEIGHT 1, 1000: TOP 1,25
LIST 2: WIDTH 2, 300: HEIGHT 2, 1000: LEFT 2,310: TOP 2,25
FONT_NAME 1,"Lucida Console": FONT_SIZE 1,10: FONT_NAME 2,"Lucida Console": FONT_SIZE 2,10
DATA "MemoChoixStyle","MemoValideEdit","Memo_applique_Style","MemoStyleEdit","MemoClicEditStyle"
DATA "Memo_Cde_Style","MemoListeStyle","Memo_Zoom","Memo_Scroll_color","Memo_Show","Memo_Hide"
DATA "Memo_Size","Memo_Fonte","Memo_Color","Memo_Alpha","Memo_Fond","Memo_Attribut","Memo_Copie","Memo_Fichier"
DATA "MemoCalcul","MemoData","MemoChange","Memo_Lecture_Style","quite_Memo_Include","LIRE_MemoRich"
DATA "$$$"
READ b$: na% = 0
WHILE b$ <> "$$$"
    na% = na% + 1: a$(na%) = b$
    READ b$
END_WHILE
rg% = 1: ' rang de début de tri dans l'article

' file_open_read 1,"C:\Textes\pgville.txt": na% = 0: ' 250 villes les plus peuplées
' while file_eof(1) = 0: na%=na%+1: file_readln 1,a$(na%): end_while
' file_close 1
' rg% = 5

FOR i = 1 TO na%: ITEM_ADD 1, a$(i): NEXT i: display
t1 = VAL(RIGHT$(TIME$,2))+60*VAL(MID$(TIME$,4,2))+3600*VAL(LEFT$(TIME$,2))
GOSUB Tribul
t2 = VAL(RIGHT$(TIME$,2))+60*VAL(MID$(TIME$,4,2))+3600*VAL(LEFT$(TIME$,2))
FOR i = 1 TO na%: ITEM_ADD 2, a$(i): NEXT i: ' affichage du tableau trié
PRINT "Terminé, durée= " + STR$(t2-t1) + " s."
END

Tribul:
' Tri croissant du tableau a$() de na% articles,
' à partir du caractère de rang rg%
DIM iv$, jv$, bt$, vi, vj, it, jt, kt
FOR it = 1 TO na%-1
    iv$ = MID$(a$(it), rg%, 1000)
    FOR jt = it+1 TO na%
        jv$ = MID$(a$(jt), rg%, 1000)
        IF LEN(jv$) > LEN(iv$)
            iv$ = iv$ + STRING$(LEN(jv$)-LEN(iv$)," ")
        ELSE
            IF LEN(iv$) > LEN(jv$)
                jv$ = jv$ + STRING$(LEN(iv$)-LEN(jv$)," ")
            END_IF
        END_IF
        FOR kt = 1 TO LEN(iv$)
            vi = ASC(MID$(iv$,kt,1))
            vj = ASC(MID$(jv$,kt,1))
            IF vj < vi: ' plus petit, on permute
                bt$ = a$(it): a$(it) = a$(jt): a$(jt) = bt$: ' swap
                iv$ = MID$(a$(it), rg%, 1000)
                EXIT_FOR
            END_IF
            IF vj > vi THEN EXIT_FOR: ' plus grand, on sort
        NEXT kt
    NEXT jt
    ' display
NEXT it
FREE iv$: FREE jv$: FREE bt$: FREE vi: FREE vj: FREE it: FREE jt: FREE kt
RETURN

' Tribul.bas tri par bulle (selon l'ordre ascii des caractères)
dim iv$, jv$, vi, vj, i, j, k, per
label sort3
height 0, 800:width 0,630
list 1: width 1, 200: height 1, 700: top 1,25
list 2: width 2, 200: height 2, 700: left 2,210: top 2,25
list 3: width 3, 200: height 3, 700: left 3,420: top 3,25
button 4:top 4,730:left 4,450:width 4,150:caption 4,"Tri de LIST 3 avec SORT":on_click 4,sort3
font_name 1,"Lucida Console": font_size 1,10: font_name 2,"Lucida Console": font_size 2,10
data "MemoChoixStyle","MemoValideEdit","Memo_applique_Style","MemoStyleEdit","MemoClicEditStyle"
data "Memo_Cde_Style","MemoListeStyle","Memo_Zoom","Memo_Scroll_color","Memo_Show","Memo_Hide"
data "Memo_Size","Memo_Fonte","Memo_Color","Memo_Alpha","Memo_Fond","Memo_Attribut","Memo_Copie","Memo_Fichier"
data "MemoCalcul","MemoData","MemoChange","Memo_Lecture_Style","quite_Memo_Include","LIRE_MemoRich"
data "$$$"
read iv$
while iv$ <> "$$$"
    item_add 1, iv$: item_add 2, iv$
    item_add 3,iv$:' pour le tri avec SORT
    read iv$
end_while
' file_load 1, "c:\textes\lorem.txt": ' pour trier un fichier ascii
' file_load 2, "c:\textes\lorem.txt"
for i = 1 to count(2)-1
    iv$ = item_read$(2,i)
    for j = i+1 to count(2)
        jv$ = item_read$(2,j)
        if len(jv$) > len(iv$)
            iv$ = iv$ + string$(len(jv$)-len(iv$)," ")
        else
            if len(iv$) > len(jv$)
                jv$ = jv$ + string$(len(iv$)-len(jv$)," ")
            end_if
        end_if
        per = 0
        for k = 1 to len(iv$)
            vi = asc(mid$(iv$,k,1))
            vj = asc(mid$(jv$,k,1))
            if vj < vi then per = 1: exit_for: ' plus petit, on permute
            if vj > vi then exit_for: ' plus grand, on sort
        next k
        if per = 1
            ' permutation
            item_delete 2,i: item_insert 2,i,rtrim$(jv$)
            item_delete 2,j: item_insert 2,j,rtrim$(iv$)
            iv$ = rtrim$(jv$)
        end_if
    next j
    ' display
next i
print "Terminé !"
end
sort3:
sort 3
return

'          Tri rapide de Shell-Metzner
'              par Papydall

dim n,i,j,ecart,permut,false,true ,temp
n = 50 : dim table(n)
false = 0 : true = 1 : n = 50
label permuter,ChargerTable,Tri_Shell_Metzner
height 0, 800
list 1: width 1, 200: height 1, 700: top 1,25
list 2: width 2, 200: height 2, 700: left 2,210: top 2,25

gosub ChargerTable
gosub Tri_Shell_Metzner
end

' Charger une table d'entiers aléatoires pour  la trier
ChargerTable:
item_add 1,"Liste non triée"
item_add 1,"              "
for i = 1 to n
  table(i) = int(rnd(2000))
'  Afficher la liste non triée

  item_add 1,table(i)
next i
return

' Algorithme de tri à adapter à ce qu'on veut trier
Tri_Shell_Metzner:
ecart = int(n/2)
while ecart <> 0
    for i = 1 to n - ecart
      j = i : permut = true
      while j > 0 and permut = true
          permut = false
          if table(j) > table(j + ecart)
            gosub permuter
            permut = true
            j = j - ecart
          end_if
      end_while
    next i
    ecart = int(ecart/2)
end_while
' Afficher la table triée
item_add 2,"Liste  triée"
item_add 2,"            "
for i = 1 to n
    item_add 2, table(i)
next i
return

' Pour permuter 2 valeurs
permuter:
temp = table(j)
table(j) = table(j+ecart) : table(j+ecart) = temp
return

' Tri.bas tri selon l'ordre ascii des caractères
LABEL Tribul, Trishell
DIM a$(1000), b$, na%, rg%, i, t1, t2
HEIGHT 0, 1100
LIST 1: WIDTH 1, 300: HEIGHT 1, 1000: TOP 1,25
LIST 2: WIDTH 2, 300: HEIGHT 2, 1000: LEFT 2,310: TOP 2,25
FONT_NAME 1,"Lucida Console": FONT_SIZE 1,10: FONT_NAME 2,"Lucida Console": FONT_SIZE 2,10
DATA "MemoChoixStyle","MemoValideEdit","Memo_applique_Style","MemoStyleEdit","MemoClicEditStyle"
DATA "Memo_Cde_Style","MemoListeStyle","Memo_Zoom","Memo_Scroll_color","Memo_Show","Memo_Hide"
DATA "Memo_Size","Memo_Fonte","Memo_Color","Memo_Alpha","Memo_Fond","Memo_Attribut","Memo_Copie","Memo_Fichier"
DATA "MemoCalcul","MemoData","MemoChange","Memo_Lecture_Style","quite_Memo_Include","LIRE_MemoRich"
DATA "$$$"
READ b$: na% = 0
WHILE b$ <> "$$$"
    na% = na% + 1: a$(na%) = b$
    READ b$
END_WHILE
rg% = 1: ' rang de début de tri dans l'article
' ==============================================================================
' ci-dessous, tri alphabétique du fichier des 255 communes les plus peuplées de
' france, à partir du 5ème caractère (le début d'article étant le rang 0 à 255)
' file_open_read 1,"C:\Textes\pgville.txt": na% = 0: ' 255 villes les plus peuplées
' while file_eof(1) = 0: na%=na%+1: file_readln 1,a$(na%): end_while
' file_close 1
' rg% = 5
' ==============================================================================
FOR i = 1 TO na%: ITEM_ADD 1, a$(i): NEXT i: display
t1 = VAL(RIGHT$(TIME$,2))+60*VAL(MID$(TIME$,4,2))+3600*VAL(LEFT$(TIME$,2))
' GOSUB Tribul
GOSUB Trishell
t2 = VAL(RIGHT$(TIME$,2))+60*VAL(MID$(TIME$,4,2))+3600*VAL(LEFT$(TIME$,2))
FOR i = 1 TO na%: ITEM_ADD 2, a$(i): NEXT i: ' affichage du tableau trié
PRINT "Terminé, durée= " + STR$(t2-t1) + " s."
END

Tribul:
' Tri croissant du tableau a$() de na% articles,
' à partir du caractère de rang rg% (méthode bubble sort)
DIM iv$, jv$, bt$, vi, vj, it, jt, kt
FOR it = 1 TO na%-1
    iv$ = MID$(a$(it), rg%, 1000)
    FOR jt = it+1 TO na%
        jv$ = MID$(a$(jt), rg%, 1000)
        IF LEN(jv$) > LEN(iv$)
            iv$ = iv$ + STRING$(LEN(jv$)-LEN(iv$)," ")
        ELSE
            IF LEN(iv$) > LEN(jv$)
                jv$ = jv$ + STRING$(LEN(iv$)-LEN(jv$)," ")
            END_IF
        END_IF
        FOR kt = 1 TO LEN(iv$)
            vi = ASC(MID$(iv$,kt,1))
            vj = ASC(MID$(jv$,kt,1))
            IF vj < vi: ' plus petit, on permute
                bt$ = a$(it): a$(it) = a$(jt): a$(jt) = bt$: ' swap
                iv$ = MID$(a$(it), rg%, 1000)
                EXIT_FOR
            END_IF
            IF vj > vi THEN EXIT_FOR: ' plus grand, on sort
        NEXT kt
    NEXT jt
    ' display
NEXT it
FREE iv$: FREE jv$: FREE bt$: FREE vi: FREE vj: FREE it: FREE jt: FREE kt
RETURN

Trishell:
' Tri croissant du tableau a$() de na% articles,
' à partir du caractère de rang rg%
' (méthode shell-metzner sort, dite aussi papydall sort)
DIM a1$, b1$, ecart, is, js, permut, temp$, va, vb, rc%, ktc
ecart = INT(na%/2)
WHILE ecart <> 0
    FOR is = 1 TO na% - ecart
      js = is : permut = 1
      WHILE js > 0 AND permut = 1
          permut = 0
          a1$ = MID$(a$(js), rg%, 1000)
          b1$ = MID$(a$(js+ecart), rg%, 1000)
          IF LEN(a1$) > LEN(b1$)
              b1$= b1$ + STRING$(LEN(a1$)-LEN(b1$)," ")
          ELSE
              IF LEN(b1$) > LEN(a1$)
                  a1$ = a1$ + STRING$(LEN(b1$)-LEN(a1$)," ")
              END_IF
          END_IF
          rc% = 0
          FOR ktc = 1 TO LEN(a1$)
              va = ASC(MID$(a1$, ktc, 1))
              vb = ASC(MID$(b1$, ktc, 1))
              IF vb < va THEN rc% = 1: EXIT_FOR
              IF vb > va THEN rc% = -1: EXIT_FOR
          NEXT ktc
          IF rc%= 1
              temp$ = a$(js)
              a$(js) = a$(js+ecart) : a$(js+ecart) = temp$
              permut = 1
              js = js - ecart
          END_IF
      END_WHILE
    NEXT is
    ecart = INT(ecart/2)
END_WHILE
FREE a1$: FREE b1$: FREE ecart: FREE is: FREE js: FREE temp$
FREE va: FREE vb: FREE rc%: FREE ktc
RETURN

'  Comparaison de deux chaînes de caractères C1$ et C2$
'  selon l'ordre ASCII des caractères
'
'  Le resultat est : -1 si C1$ < C2$
'                      0 si C1$ = C2$
'                    +1 si C1$ > C2$

dim c1$,c2$,result,L1,L2,L,i
label ComparerChaine
' Exemples pour le test
c1$ = "Aabc"    : c2$ = "a"          : gosub ComparerChaine
c1$ = "aBCabcd" : c2$ = "ABCabcdxxx" : gosub ComparerChaine
c1$ = "123"    : c2$ = "123456"    : gosub ComparerChaine
c1$ = "éèà"    : c2$ = "eeaazer"    : gosub ComparerChaine
c1$ = "azerty"  : c2$ = "azerty"    : gosub ComparerChaine
c1$ = "azerty"  : c2$ = "Azerty"    : gosub ComparerChaine
end

ComparerChaine:

L1 = len(c1$) : L2 = len(c2$) : L = min(L1,L2)
i = 1 : result = 0
while i <= L
  if asc(mid$(c1$,i,1)) > asc(mid$(c2$,i,1))
    result = 1 : exit_while : ' La chaîne c1$ est plus grande que c2$ : on sort de la boucle
  end_if
  if asc(mid$(c1$,i,1)) < asc(mid$(c2$,i,1))
    result = -1 : exit_while :' La chaîne c1$ est plus petite que c2$ : on sort de la boucle
  end_if
  i = i + 1
end_while
if result = 0  :' Pour traiter le cas où les 2 chaînes ont les mêmes premiers caractères
  if L1 <> L2
      if L1 = L
        result = -1
      else
        result = 1
      end_if
  end_if
end_if
select result
case -1 : print c1$ ; " < " ; c2$
case  0 : print c1$ ; " = " ; c2$
case +1 : print c1$ ; " > " ; c2$
end_select
return

' Tri de chaînes suivant la valeur Ascii des caractères
DIM f1$, f2$, rng%, t1, t2
DIM scr$, script$: scr$ = "Tri.vbs"
LABEL Trivbs

DATA "Tri.vbs"
DATA "Option Explicit"
DATA "' Tri de chaînes dans l'ordre des valeurs Ascii"
DATA "' Paramètres: fichieràtrier fichierrésultat [index de tri]"
DATA "' (peuvent être identiques)"
DATA "Dim objFso, objTextFile"
DATA "Dim arrLines"
DATA "Dim bpermute, cprovisoire, i, j, Rang, args"
DATA "Dim MyFile, MySortedFile"
DATA "args = wscript.Arguments.Count"
DATA "MyFile = wscript.Arguments(0)"
DATA "MySortedFile = wscript.Arguments(1)"
DATA "Rang = 1"
DATA "If args > 2 Then Rang = wscript.Arguments(2)"
DATA ""
DATA "Set objFso = CreateObject("+CHR$(34)+"Scripting.FileSystemObject"+CHR$(34)+")"
DATA "Set objTextFile = objFso.OpenTextFile(MyFile, 1)"
DATA "arrLines = Split(objTextFile.ReadAll,vbCrLf)"
DATA "objTextFile.Close "
DATA ""
DATA "bpermute = True"
DATA "Do While bpermute = True"
DATA "  bpermute = False"
DATA "  For i = UBound(arrLines) To 1 Step -1"
DATA "      If Len(arrLines(i)) > 1 Then"
DATA "          For j = 0 To i - 1"
DATA "              If Len(arrLines(j)) > 1 Then"
DATA "                If Mid(Split(arrLines(j), Chr(44))(0), Rang) >_"
DATA "                        Mid(Split(arrLines(j + 1), Chr(44))(0), Rang) Then"
DATA "                    cprovisoire = arrLines(j)"
DATA "                    arrLines(j) = arrLines(j + 1)"
DATA "                    arrLines(j + 1) = cprovisoire"
DATA "                    bpermute = True"
DATA "                End If"
DATA "              End If"
DATA "          Next"
DATA "      End If"
DATA "  Next"
DATA "Loop"
DATA "'Write File"
DATA "Set objTextFile = objFso.CreateTextFile(MySortedFile, 2)"
DATA "For i = 0 To UBound(arrLines)"
DATA "    objTextFile.WriteLine arrLines(i)"
DATA "Next"
DATA "objTextFile.Close"
DATA "Set objTextFile = Nothing"
DATA "Set objFso = Nothing"
DATA "f"
READ script$
WHILE script$ <> scr$: READ script$: END_WHILE: ' rephasage sur les datas
FILE_OPEN_WRITE 9, "C:\Temp" + scr$
    READ script$
    WHILE script$ <> "f": FILE_WRITELN 9, script$: READ script$: END_WHILE
FILE_CLOSE 9
script$ = "C:\Temp" + scr$: ' script à exécuter

HEIGHT 0, 900: WIDTH 0, 840
LIST 1: HEIGHT 1, 800: WIDTH 1, 400
LIST 2: HEIGHT 2, 800: LEFT 2, 410: WIDTH 2, 400
' =================================================== A VOIR ! ================
f1$ = "C:\Temp\Test.txt": ' ***** Fichier à trier
rng% = 5: ' index de début de tri par chaîne
f2$ = "C:\Temp\FTrie.txt": ' ***** Fichier résultat
' =============================================================================
FILE_LOAD 1, f1$
t1 = VAL(RIGHT$(TIME$,2))+60*VAL(MID$(TIME$,4,2))+3600*VAL(LEFT$(TIME$,2))
GOSUB Trivbs: ' tri par la méthode script vbs
t2 = VAL(RIGHT$(TIME$,2))+60*VAL(MID$(TIME$,4,2))+3600*VAL(LEFT$(TIME$,2))
FILE_LOAD 2, f2$
MESSAGE "Durée= " + STR$(t2-t1) + " s."
END

Trivbs:
' arguments: fichier à trier, fichier résultat, index début de tri (optionnel, =1 implicite)
EXECUTE_WAIT "Wscript.exe " + script$ + " " + f1$ + " " + f2$ + " " + STR$(rng%)
RETURN