GENÈSE D'UN DICTIONNAIRE

procedure regLiens;
var i, j, k : integer;
    fLiens : file of integer;
 
begin
  AssignFile(fLiens, 'fichLiens.bin');
  ReWrite(fLiens);
  for i := 0 to Length(Liens)-1 do
  begin
    j := Length(Liens[i]);
    Write(fLiens, j);
    for k:=0 to j-1 do
      Write(fLiens, Liens[i, k]);
  end;
  CloseFile(fLiens);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 regLiens;
 listeMots.Free;
 Application.Terminate;
end;

procedure lireLiens;
var
  j, m : integer;
  fLiens : file of integer;
begin
  nLiens := 0;   //nombre de mots liés
  AssignFile(fLiens, 'fichLiens.bin');
  {$I-}
  Reset(fLiens);
  {$I+}
  if IOResult<>0 then
    ShowMessage('Fichier liens inexistant')
  else
  while not EOF(fLiens) do
  begin
    SetLength(Liens, nLiens+1);      //taille du tableau principal
    Read(fLiens, m);
    SetLength(Liens[nLiens], m);     //taille du tableau secondaire
    for j := 0 to m-1 do
      Read(fLiens, Liens[nLiens, j]); //remplissage de tableau secondaire
    inc(nLiens);                      //nombre de mots liés
  end;
  CloseFile(fLiens);
end;

procedure TForm1.UpDown2Click(Sender: TObject; Button: TUDBtnType);
begin
   if CheckBox1.Checked then
      repeat
        inc(iMot);
      until (iMot=nMots) or (chercheTab(iMot)>=0)
   else
      if Button=btNext then Inc(iMot, UpDown2.Increment)
                         else Dec(iMot, UpDown2.Increment);
   iMot := (iMot + nMots) mod  nMots;
   MAJBalayage;
end;

unit uLex6;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls,
  Graphics, Dialogs, StdCtrls, ComCtrls, uDisque;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    CheckBox1: TCheckBox;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    ListBox1: TListBox;
    Memo2: TMemo;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    RadioButton3: TRadioButton;
    RadioButton4: TRadioButton;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    Zoom: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    AffListe: TListBox;
    Memo1: TMemo;
    PageControl1: TPageControl;
    Page1: TTabSheet;
    TabSheet1: TTabSheet;
    TrackBar1: TTrackBar;
    UpDown1: TUpDown;
    UpDown2: TUpDown;
    procedure AffListeClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure CheckBox1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Recherche(rechMot: string);
    procedure TrackBar1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
    procedure MAJAffichage;
    procedure MAJBalayage;
    procedure UpDown2Click(Sender: TObject; Button: TUDBtnType);
    procedure ZoomMouseLeave(Sender: TObject);
    function chercheTab(iMot : integer) : integer;
    procedure Lier(iMot, iLien: integer);
    procedure AffLiens;
 
  private
    { private declarations }
  public
    { public declarations }
  end;
 
const delta=5;
 
var
  Form1: TForm1;
  listeMots, listeInfo, listeObj : TstringList;
  iMot, nMots, nLiens : integer;
  Liens : Array of Array of integer;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender: TObject);
begin
   regLiens;
   listeMots.Free;
   Application.Terminate;
end;
 
procedure TForm1.AffListeClick(Sender: TObject);
begin
   iMot := (iMot -delta + AffListe.ItemIndex + nMots) mod nMots;
   MAJBalayage;
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  Recherche(Edit2.Caption);
end;
 
procedure TForm1.Button3Click(Sender: TObject);
var iLien, k : integer;
begin
   iLien := listeMots.IndexOf(UTF8ToAnsi(Edit3.Caption));
   if iLien<0 then
      ShowMessage('Ce mot n''existe pas, recommencez')
   else
   begin
     Lier(iMot, iLien);
     Lier(iLien, iMot);
     AffLiens;
   end;
   Edit3.Clear;
end;
 
 
procedure TForm1.CheckBox1Change(Sender: TObject);
begin
   if CheckBox1.Checked then CheckBox1.Caption := 'Avec filtre'
   else CheckBox1.Caption := 'Sans filtre';
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  listeMots := TStringList.Create;
  LireFichier(listeMots);
  nMots:= listeMots.Count;
  lireLiens;
  Memo1.Append('Premier mot : '+listeMots[0]);
  Memo1.Append('Dernier mot : '+listeMots[nMots-1]);
  iMot := 0;
  MAJAffichage;
  MAJBalayage;
end;
 
procedure TForm1.ListBox1Click(Sender: TObject);
begin
   if ListBox1.ItemIndex >= 0 then
   begin
     iMot := Liens[chercheTab(iMot), ListBox1.ItemIndex+1];
     Label4.Caption := AnsiToUTF8(listeMots[iMot]);
     AffLiens;
   end;
end;
 
procedure TForm1.MAJBalayage;
var i : integer;
begin
   Label2.Caption:=AnsiToUTF8(listeMots[iMot]);
   Label3.Caption:= Label2.Caption;
   Label4.Caption:= Label2.Caption;
   Edit3.Clear;
   TrackBar1.Position:= Round(iMot*1000/nMots);
   AffListe.Clear;
   for i := 0 to 10 do
       AffListe.Items.Add(AnsiToUTF8(listeMots[(iMot-delta + i
                         + nMots) mod nMots]));
   AffListe.Selected[delta] := True;
   AffLiens;
   Caption := IntToStr(nMots)+ ' mots dont '+IntToStr(nLiens)+' liés';
end;
 
procedure TForm1.UpDown2Click(Sender: TObject; Button: TUDBtnType);
begin
   if CheckBox1.Checked then
      repeat
        inc(iMot);
      until (iMot=nMots) or (chercheTab(iMot)>=0)
   else
      if Button=btNext then Inc(iMot, UpDown2.Increment)
                         else Dec(iMot, UpDown2.Increment);
   iMot := (iMot + nMots) mod  nMots;
   MAJBalayage;
end;
 
procedure TForm1.ZoomMouseLeave(Sender: TObject);
begin
   if RadioButton1.Checked then UpDown2.Increment := 1
   else if RadioButton2.Checked then UpDown2.Increment := 10
   else if RadioButton3.Checked then UpDown2.Increment := 100
   else if RadioButton4.Checked then UpDown2.Increment := 1000;
end;
 
function TForm1.chercheTab(iMot: integer): integer;
var i : integer;
begin
 chercheTab := -1;
 i := 0;
 while (i<Length(Liens)) and (Liens[i, 0]<>iMot) do inc(i);
 if i<Length(Liens) then chercheTab := i;
end;
 
procedure TForm1.Lier(iMot, iLien: integer);
var k : integer;
begin
  k := chercheTab(iMot);
  if k < 0 then
  begin
     SetLength(Liens, Length(Liens)+1); //extension du tableau principal
     k := Length(Liens)-1;  //indice du nouveau tableau
     SetLength(Liens[k], 1);
     Liens[k, 0] := iMot; //identifiant
  end;
  SetLength(Liens[k], Length(Liens[k])+1);  //extension du tableau secondaire
  Liens[k, Length(Liens[k])-1] := iLien;  // lien
end;
 
procedure TForm1.AffLiens;
var i, k : integer;
begin
   ListBox1.Clear;
   k := chercheTab(iMot);
   if k>=0 then
     for i :=1 to Length(Liens[k]) -1 do
       ListBox1.Items.Add(AnsiToUTF8(listeMots[Liens[k, i]]));
end;
 
 
procedure TForm1.TrackBar1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
   iMot := Round(TrackBar1.Position*nMots/1000);
   iMot := (iMot + nMots) mod  nMots;
   MAJBalayage;
end;
 
 
procedure TForm1.Recherche(rechMot: string);
var iMot : integer;
begin
   iMot := listeMots.IndexOf(rechMot);
   if iMot >= 0 then Label1.Caption:= listeMots[iMot]
                else Label1.Caption:= 'échec';
   Memo1.Append('Index '+IntToStr(iMot));
end;
 
 
 
procedure TForm1.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
   if Button=btNext then Inc(iMot)
                       else Dec(iMot);
   iMot := iMot + nMots   mod  nMots;
   MAJAffichage;
end;
 
procedure TForm1.MAJAffichage;
begin
   Label1.Caption:=listeMots[iMot];
   Edit2.Caption:= '';
   Memo1.Append('Index '+IntToStr(iMot));
end;
 
end.

unit uDisque;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, Dialogs;
 
procedure LireFichier(listeMots : TStringList);
procedure regLiens;
procedure lireLiens;
 
implementation
 
uses uLex6;
 
procedure LireFichier(listeMots: TStringList);
begin
  listeMots.LoadFromFile('liste.de.mots.francais.frgut.txt');
end;
 
procedure regLiens;
var i, j, k : integer;
    fLiens : file of integer;
 
begin
  AssignFile(fLiens, 'fichLiens.bin');
  ReWrite(fLiens);
  for i := 0 to Length(Liens)-1 do
  begin
    j := Length(Liens[i]);
    Write(fLiens, j);
    for k:=0 to j-1 do
      Write(fLiens, Liens[i, k]);
  end;
  CloseFile(fLiens);
end;
 
procedure lireLiens;
var
  j, m : integer;
  fLiens : file of integer;
begin
  nLiens := 0;   //nombre de mots liés
  AssignFile(fLiens, 'fichLiens.bin');
  {$I-}
  Reset(fLiens);
  {$I+}
  if IOResult<>0 then
    ShowMessage('Fichier liens inexistant')
  else
  while not EOF(fLiens) do
  begin
    SetLength(Liens, nLiens+1);      //taille du tableau principal
    Read(fLiens, m);
    SetLength(Liens[nLiens], m);     //taille du tableau secondaire
    for j := 0 to m-1 do
      Read(fLiens, Liens[nLiens, j]); //remplissage de tableau secondaire
    inc(nLiens);                      //nombre de mots liés
  end;
  CloseFile(fLiens);
end;
 
end.