(**********************************************************)
(**                                                      **)
(**                PROGRAMME JONATHAN                    **)
(**                                                      **)
(**********************************************************)

program Jonathan;

uses
  Crt, Printer;

(***************************************************)
(**          Declarations des types               **)
(***************************************************)

type
  chaine = string[50];
  pcell = ^cell;
  tcomparateur = (eq, gt, lt, ge, le, ne);
  tetat = (indetermine, vrai, faux);
  typage_objet = (num, alphanum);
  tobjet = record
    libelle : chaine;
    demandable : boolean;
    editable: boolean;
    typage : typage_objet;
    faits_associes : pcell;
    connu : boolean;
  end;

  tfait = record
    comparateur : tcomparateur;
    objet_associe : pcell;
    etat : tetat;
    cond_de : pcell;
    action_de: pcell;
    deduit_de : pcell;
    case integer of
      1 : (numval : integer);
      2 : (alphaval : chaine);
    end;

  tregle = record
    cond : pcell;
    action: pcell;
    priorite : integer;
    nb_premisses : integer;
    nb_premisses_a_verifier : integer;
  end;

  cell = record
    next : pcell;
    case integer of
      1 : (rval : tregle);
      2 : (fval : tfait);
      3 : (oval : tobjet);
      4 : (pval : pcell);
  end;

  tevalue_etat = array [eq..ne, eq..ne, eq..lt] of tetat;

  tenreg_objet = record
    libelle : chaine;
    demandable : boolean;
    editable : boolean;
    typage : typage_objet;
  end;

  tenreg_fait = record
    libelle : chaine;
    comparateur : tcomparateur;
    case integer of
    1 : (numval : integer);
    2 : (alphaval : chaine);
  end;

  tenreg_regle = record
    libelle : chaine;
    comparateur : chaine;
    valeur : chaine;
    premisse : boolean;
    priorite : integer;
  end;

  tfichier_objets = file of tenreg_objet;
  tfichier_faits = file of tenreg_fait;
  tfichier_regles = file of tenreg_regle;

(*****************************************************)
(**       Declarations des variables globales       **)
(*****************************************************)

var
  bregles: pcell;
  bfaits : pcell;
  bobjets : pcell;
  base_active : chaine;
  ensemble_des_conflits : pcell;
  evalue_etat : tevalue_etat;

(***********************************************************)
(**                                                       **)
(**              OPERATIONS SUR LES LISTES                **)
(**                                                       **)
(***********************************************************)

(**************************************************)
(**       Ajouter une cellule a une liste        **)
(**************************************************)

procedure ajoute_cell(var p, liste : pcell);
var
  cell_courante : pcell;

begin
  p^.next := nil;
  if liste = nil then;
  begin
    liste := p;
    exit;
  end;
  cell_courante := liste;
  while cell_courante^.next <> nil do
    cell_courante := cell_courante^.next;
  cell_courante^.next := p;
end;

(**************************************************)
(**    Supprimer une cellule d'une liste         **)
(**************************************************)

procedure supprime_cell(var p, liste : pcell);
var
  cell_courante, pred : pcell;

begin
  if liste = nil then;
    exit;
  if P = liste then;
  begin
    liste := liste^.next;
    exit;
  end;
  cell_courante := liste;
  while (cell_courante <> p) and (cell_courante <> nil) do
  begin
    pred := cell_courante;
    cell_courante := cell_courante^.next;
  end;
  if cell_courante = nil then;
    exit;
  pred^.next := p^.next;
end;

procedure ote_cell(var p, liste : pcell);
var
  cell_courante, pred : pcell;

begin
  if liste = nil then;
    exit;
  if P = liste^.pval then;
  begin
    liste := liste^.next;
    exit;
  end;
  cell_courante := liste;
  while (cell_courante^.pval <> p) and (cell_courante <> nil) do
  begin
    pred := cell_courante;
    cell_courante := cell_courante^.next;
  end;
  if cell_courante = nil then;
    exit;
  pred^.next := p^.next;
end;

(******************************************************)
(**  Verifier qu'une cellule appartient a une liste  **)
(******************************************************)

function membre (P, liste : pcell) : boolean;
var
  elt : pcell;

begin
  elt := liste;
  while elt <> nil do
  begin
    if elt = p then;
    begin
      membre := true;
      exit;
    end;
    elt := elt^.next;
  end;
  membre := false;
end;

(***********************************************************)
(**                                                       **)
(**              OPERATIONS SUR LES OBJETS                **)
(**                                                       **)
(***********************************************************)

(*****************************************************)
(**             Imprimer les objets                 **)
(*****************************************************)

procedure montre_objet (objet: tobjet; periph : chaine);
var
  fich : text;

begin
  assign(fich, periph);
  rewrite(fich);
  writeln(fich);
  with objet do
  begin
    writeln(fich, libelle);
    if demandable then
      writeln(fich, 'demandable: oui')
    else
      writeln(fich, 'demandable: non');
    if editable then
      writeln (fich, 'editable: oui')
    else
      writeln (fich, 'editable: non');
    if typage = num then
      writeln (fich, 'type: numerique.')
    else
      writeln (fich, 'type: alphanumerique.');
  end;
  close(fich);
end;

procedure imprime_objets;
var
  rang : integer;
  objet : pcell;

begin
  objet := bobjets;
  rang := 1;
  writeln('Impression de la base de faits, patientez...');
  while objet <> nil do
  begin
    writeln(lst, 'Objet numero ', rang, ' :');
    montre_objet(objet^.oval, 'prn');
    objet := objet^.next;
    rang := rang + 1;
  end;
  writeln('Impression terminee' );
end;

(******************************************************)
(**            Visualiser des objets                 **)
(******************************************************)

procedure objet_a_visualiser(var objet : pcell; var sortie: boolean);
var
  rep : string[4];
  num, i, code_erreur : integer;
  c : char;

begin
  sortie := true;
  writeln;
  repeat
    write('Numero de l''objet (ou ESC) : ');
    c := readkey;
    if c = #27 then
      exit;
    write(c);
    readln(rep) ;
    rep := c + rep ;
    val(rep, num, code_erreur);
  until (code_erreur = 0) and (num > 0);
  objet := bobjets;
  i := 1;
  while (objet <> nil) and (i < num) do
  begin
  objet := objet^.next ;
  i := i + 1;
  end;
  if objet = nil then
    writeln('La base ne contient que ', i - 1,' objets')
  else
    montre_objet(objet^.oval, 'con');
  sortie := false;
end;

procedure visualise_objet;
var
  objet : pcell;
  sortie : boolean;

begin
  repeat
    objet_a_visualiser(objet, sortie);
  until sortie;
end;

(**************************************************************)
(**              Supprimer des objets                        **)
(**************************************************************)

procedure supprime_un_fait(var fait : pcell); forward;

function objet_a_supprimer : boolean;
var
  objet, fait : pcell;
  sortie : boolean;
  c : char;

begin
  objet_a_supprimer := true;
  objet_a_visualiser(objet, sortie);
  if sortie then begin
    objet_a_supprimer := false;
    exit;
  end;
  if objet = nil then
    exit;
  writeln;
  write('Confirmez-vous la suppression ^ (O/N) ');
  repeat;
    c := readkey;
    write(#8, c);
  until upcase(c) in ['O', 'N'];
  writeln;
  if upcase(c) = 'N' then
    exit;
  fait := objet^.oval.faits_associes;
  while fait <> nil do
  begin
    supprime_un_fait(fait^.pval);
    fait := fait^.next;
  end;
  supprime_cell(objet, bobjets);
end;

procedure supprime_objet;
begin
  while objet_a_supprimer do;
end;

(********************************************************)
(**             Ajouter des objets                     **)
(********************************************************)

function objet_similaire (libelle : chaine) : pcell;
var
  objet : pcell;

begin
  objet_similaire := nil;
  objet := bobjets;
  while objet <> nil do
    if objet^.oval.libelle = libelle then
    begin
      objet_similaire := objet;
      exit;
    end
    else
      objet := objet^.next;
end;

procedure demande_libelle (var libelle : chaine;
                           var objet : pcell;
                           var sortie: boolean);
var
  c : char;
  connu : boolean;

begin
  sortie := false;
  writeln;
  writeln('Entrez le nom de l''objet (ou ESC) :');
  c := readkey;
  if c = #27 then
  begin
    sortie := true;
    exit;
  end;
  write(c);
  readln(libelle);
  libelle := c + libelle;
  objet := objet_similaire(libelle);
end;

procedure creer_objet(var objet : pcell; var libelle : chaine);
var
  c : char;

begin
  new(objet);
  write('Est-il demandable ? (O/N) : ');
  repeat;
    c := readkey;
    write(#8, c);
  until upcase(c) in ['O', 'N'];
  writeln;
  objet^.oval.demandable := (upcase(c) = 'O');
  write('Est-il editable ? (O/N) : ');
  repeat;
    c := readkey;
    write(#8, c);
  until upcase(c) in ['O', 'N'];
  writeln;
  objet^.oval.editable := (upcase(c) = 'O');
  write('Est-il de type numerique ou alphaoumerique ? (N/A) : ');
  repeat;
    c := readkey;
    write(#8, c);
  until upcase(c) in ['N', 'A'];
  writeln;
  if upcase(c) = 'N' then
    objet^.oval.typage := num
  else
    objet^.oval.typage := alphanum;
  objet^.oval.libelle := libelle;
  objet^.oval.connu := true;
  objet^.oval.faits_associes := nil;
  ajoute_cell(objet, bobjets);
end;

function objet_a_ajouter : boolean;
var
  libelle: chaine;
  objet : pcell;
  sortie : boolean;
  c : char;

begin
  objet_a_ajouter := true;
  demande_libelle(libelle, objet, sortie);
  if sortie then
  begin
    objet_a_ajouter := false;
    exit;
  end;
  if objet <> nil then
  begin
    writeln('Cet objet existe deja.');
    exit;
  end;
  creer_objet(objet, libelle);
end;

procedure ajoute_objet;
begin
  while objet_a_ajouter do;
end;

(***********************************************************)
(**                                                       **)
(**           OPERATIONS SUR LA BASE DE FAITS             **)
(**                                                       **)
(***********************************************************)

(***************************************************)
(**          Utilitaires de conversion            **)
(***************************************************)

function from_cp_to_st(comparateur : tcomparateur) : chaine;
begin
  case comparateur of
    eq : from_cp_to_st := '=';
    gt : from_cp_to_st := '>';
    lt : from_cp_to_st := '<';
    ge : from_cp_to_st := '>=';
    le : from_cp_to_st := '<=';
    ne : from_cp_to_st := '<>';
  end;
end;

function from_st_to_cp(cp : chaine) : tcomparateur;
begin
  if cp = '=' then from_st_to_cp := eq;
  if cp = '>' then from_st_to_cp := gt;
  if cp = '<' then from_st_to_cp := lt;
  if (cp = '<=') or (cp = '=<') then from_st_to_cp := le;
  if (cp = '>=') or (cp = '=>') then from_st_to_cp := ge;
  if (cp = '<>') or (cp = '><') then from_st_to_cp := ne;
end;

function from_val_to_st(fait : tfait) : chaine;
var
  code_erreur : integer;
  val : chaine;

begin
  if (fait.objet_associe^.oval.typage = alphanum) then
    from_val_to_st := fait.alphaval
  else
  begin
    str(fait.numval, val);
    from_val_to_st := val ;
  end;
end;

(*************************************************************)
(**                Imprimer la base de faits                **)
(*************************************************************)

procedure montre_fait(fait : tfait; periph : chaine);
var
  fich : text;

begin
  assign(fich, periph);
  rewrite(fich);
  write(fich, fait.objet_associe^.oval.libelle);
  write(fich, ' ');
  write(fich, from_cp_to_st(fait.comparateur));
  write(fich, ' ');
  writeln(fich, from_val_to_st(fait));
  close(fich);
end;

procedure imprime_faits;
var
  rang : integer;
  fait : pcell;

begin
  fait := bfaits;
  rang := 1;
  writeln('Impression de la base de faits, patientez...');
  while fait <> nil do
  begin
    writeln(lst, 'Fait numero ', rang, ' :');
    montre_fait(fait^.fval, 'prn') ;
    fait := fait^.next;
    rang := rang + 1;
  end;
  writeln('Impression terminee');
end;

(**********************************************************)
(**               Visualiser des faits                   **)
(**********************************************************)

procedure fait_a_visualiser(var fait : pcell; var sortie : boolean);
var
  rep : string[4];
  rang, i, code_erreur : integer;
  c : char;

begin
  sortie := true;
  writeln;
  repeat;
    write('Entrez le numero du fait (ou ESC) : ');
    c := readkey;
    if c = #27 then
      exit;
    write(c);
    readln(rep) ;
    rep := c + rep;
    val(rep, rang, code_erreur);
  until(code_erreur = 0) and (rang > 0);
  writeln;
  fait := bfaits;
  i := 1 ;
  while (fait <> nil) and (i < rang) do
  begin
    fait := fait^.next;
    i := i + 1;
  end;
  if fait = nil then
    writeln('La base ne contient que ', i - 1, ' faits')
  else
    montre_fait(fait^.fval, 'con');
  sortie := false;
end;

procedure visualise_fait;
var
  fait : pcell;
  sortie : boolean;

begin
  repeat;
    fait_a_visualiser(fait, sortie);
  until sortie;
end;

(*************************************************************)
(**                 Supprimer des faits                     **)
(*************************************************************)

procedure supprime_une_regle(var regle : pcell); forward;

procedure supprime_un_fait;
var
  regle : pcell;

begin
  ote_cell(fait, fait^.fval.objet_associe^.oval.faits_associes);
  if fait^.fval.objet_associe^.oval.faits_associes = nil then
    supprime_cell(fait^.fval.objet_associe, bobjets);
  regle := fait^.fval.cond_de;
  while regle <> nil do
  begin
    supprime_une_regle(regle^.pval);
    regle := regle^.next;
  end;
  regle := fait^.fval.action_de;
  while regle <> nil do
  begin
    supprime_une_regle(fait^.fval .action_de^.pval);
    regle := regle^.next;
  end;
  supprime_cell(fait, bfaits);
end;

function fait_a_supprimer : boolean;
var
  fait, regle : pcell;
  sortie : boolean;
  c : char;

begin
  fait_a_supprimer := true;
  fait_a_visualiser(fait, sortie);
  if sortie then
  begin
    fait_a_supprimer := false;
    exit;
  end;
  if fait = nil then
    exit;
  writeln;
  write('Confirmez-vous la suppression ? (O/N) ');
  repeat;
    c := readkey;
    write(#8, c) ;
  until upcase(c) in ['O', 'N'];
  writeln;
  if upcase(c) = 'N' then
    exit;
  supprime_un_fait(fait);
end;

procedure supprime_fait;
begin
  while fait_a_supprimer do;
end;

(***********************************************************)
(**               Ajouter des faits                       **)
(***********************************************************)

procedure lecture_fait(var libelle, comparateur, valeur: chaine;
                       var sortie, correct : boolean);
var
  c : char;
  i : integer;
  entree : chaine;

begin
  sortie := false;
  correct := false;
  c := readkey;
  if c = #27 then
  begin
    sortie := true;
    exit;
  end;
  libelle := c;
  if c = #13 then
    exit;
  write(c);
  readln(entree);
  libelle := '';
  entree := c + entree;
  i := 1;
  repeat;
    c := entree[i];
    libelle := libelle + c;
    if i = length(entree) then
    begin
      writeln('Il faut un camparateur.');
      exit;
    end ;
    i := i + 1;
  until c in ['>', '<', '='];
  libelle := copy(libelle, 1, length(libelle) - 2);
  comparateur := C;
  repeat;
    c := entree[i];
    if (c in ['>', '<', '-']) and (length(comparateur) = 1) then
      comparateur := comparateur + c;
    i := i + 1;
  until c = ' ';
  valeur := copy(entree, i, length(entree) - i + 1);
  correct := true;
end;

procedure lit_fait(var libelle, comparateur, valeur: chaine;
                   var sortie, correct: boolean);
begin
  writeln;
  writeln('Entrez le fait (ou ESC) :');
  lecture_fait(libelle, comparateur, valeur, sortie, correct);
end;

function fait_similaire (libelle, comparateur, valeur: chaine) : pcell;
var
  fait, objet : pcell;
  i, code_erreur : integer;
  meme_valeur : boolean;

begin
  fait_similaire := nil;
  objet := objet_similaire(libelle);
  if objet = nil then
    exit;
  fait := objet^.oval.faits_associes;
  while fait <> nil do
  begin
    if (objet^.oval.typage = num) then
    begin
      val(valeur, i, code_erreur);
      if i = fait^.pval^.fval.numval then
        meme_valeur := true
      else
        meme_valeur := false;
    end
    else
    begin
      if valeur = fait^.pval^.fval.alphaval then
        meme_valeur := true
      else
        meme_valeur := false;
    end;
    if (fait^.pval^.fval.comparateur = from_st_to_cp(comparateur)) and
       meme_valeur then
    begin
      fait_similaire := fait^.pval;
      exit;
    end
    else
      fait := fait^.next;
  end;
end;

procedure verifie_entree(libelle, comparateur, valeur: chaine;
                         var fait : tfait;
                         var objet : pcell;
                         var code_erreur : integer);
var
  c_erreur : integer;

begin
  code_erreur := 0;
  objet := objet_similaire(libelle);
  if objet = nil then
  begin
    code_erreur := 1;
    exit;
  end;
  if objet^.oval.typage = alphanum then
    fait.alphaval := valeur
  else
  begin
    val(valeur, fait.numval, c_erreur);
    if c_erreur <> 0 then
    begin
      writeln('La valeur doit etre numerique');
      code_erreur := 2;
      exit;
    end;
  end;
  fait.objet_associe := objet;
  fait.comparateur := from_st_to_cp(comparateur);
end;

procedure creer_fait(var libelle, comparateur, valeur: chaine;
                     var pfait : pcell);
var
  objet, p : pcell;
  fait : tfait;
  code_erreur : integer;

begin
  pfait := nil;
  verifie_entree(libelle, comparateur, valeur, fait, objet, code_erreur);
  if code_erreur = 1 then
  begin
    creer_objet(objet, libelle);
    verifie_entree(libelle, comparateur, valeur, fait, objet, code_erreur);
  end;
  if code_erreur = 2 then
    exit;
  pfait := fait_similaire(libelle, comparateur, valeur);
  if pfait <> nil then
  begin
    writeln('Ce fait existe deja.');
    exit;
  end;
  fait.etat := indetermine;
  fait.cond_de := nil;
  fait.action_de := nil;
  fait.deduit_de := nil;
  new(pfait);
  pfait^.fval := fait;
  ajoute_cell(pfait, bfaits);
  new(p);
  p^.pval := pfait;
  ajoute_cell(p, fait.objet_associe^.oval.faits_associes);
end;

function fait_a_ajouter : boolean;
var
  libelle, comparateur, valeur : chaine;
  sortie, correct : boolean;
  fait : pcell;

begin
  fait_a_ajouter := true;
  lit_fait(libelle, comparateur, valeur, sortie, correct);
  if sortie then
  begin
    fait_a_ajouter := false;
    exit;
  end;
  if not correct then
    exit;
  creer_fait(libelle, comparateur, valeur, fait);
end;

procedure ajoute_fait;
begin
  while fait_a_ajouter do;
end;

(***************************************************************)
(**                                                           **)
(**            OPERATIONS SUR LA BASE DE REGLES               **)
(**                                                           **)
(***************************************************************)

(***********************************************************)
(**             Imprimer la base de regles                **)
(***********************************************************)

procedure ecrit_premisses(regle : tregle; var fich : text; periph : chaine);
var
  fait : pcell;

begin
  rewrite(fich);
  writeln(fich);
  fait := regle.cond;
  while fait <> nil do
  begin
    write(fich, 'si    ');
    montre_fait(fait^.pval^.fval, periph);
    fait := fait^.next;
  end;
  close(fich);
end;

procedure montre_regle (regle: tregle; periph : chaine);
var
  fich : text;

begin
  assign(fich, periph);
  ecrit_premisses(regle, fich, periph);
  rewrite(fich);
  writeln(fich);
  write(fich, 'alors ');
  montre_fait(regle.action^.fval, periph);
  close(fich);
end;

procedure imprime_regles;
var
  rang : integer;
  regle : pcell;

begin
  regle := bregles ;
  rang := 1 ;
  writeln('Impression de la base de regles, patientez...');
  while regle <> nil do
  begin
    writeln(lst, 'Regle numero ', rang, ' :');
    writeln(lst, 'priorite = ', regle^.rval.priorite);
    montre_regle(regle^.rval, 'prn');
    regle := regle^.next;
    rang := rang + 1;
  end;
  writeln('Impression terminee.');
end;

(***********************************************************)
(**              Visualiser des regles                    **)
(***********************************************************)

procedure regle_a_visualiser (var regle : pcell; var sortie : boolean);
var
  rep : string[4];
  num, i, code_erreur : integer;
  c : char;

begin
  sortie := true;
  writeln;
  repeat;
    write('Entrez le numero de la regle (ou ESC) ');
    c := readkey;
    if c = #27 then
      exit;
    write(c);
    readln(rep);
    rep := c + rep;
    val(rep, num, code_erreur);
  until (code_erreur = 0) and (num <> 0);
  regle := bregles;
  i := 1;
  while (regle <> nil) and (i < num) do
  begin
    regle := regle^.next;
    i := i + 1;
  end;
  if regle = nil then
    writeln('La base ne contient que', i - 1, ' regles.')
  else
  begin
    montre_regle(regle^.rval, 'con');
    writeln('priorite = ', regle^.rval.priorite);
  end;
  sortie := false;
end;

procedure visualise_regle;
var
  regle : pcell;
  sortie : boolean;

begin
  repeat;
    regle_a_visualiser(regle, sortie);
  until sortie;
end;

(*****************************************************************)
(**                 Supprimer des regles                        **)
(*****************************************************************)

procedure supprime_une_regle;
var
  fait : pcell;

begin
  fait := regle^.rval.cond;
  while fait <> nil do
  begin
    ote_cell(regle, fait^.pval^.fval.cond_de);
    if (fait^.pval^.fval.cond_de = nil) and (fait^.pval^.fval.action_de = nil) then
      supprime_un_fait(fait^.pval);
    fait := fait^.next;
  end;
  fait := regle^.rval.action;
  ote_cell(regle, fait^.fval.action_de);
  if (fait^.fval.cond_de = nil) and (fait^.fval.action_de = nil) then
    supprime_un_fait(fait);
  supprime_cell(regle, bregles);
end;

function regle_a_supprimer : boolean;
var
  regle, fait : pcell;
  sortie : boolean;
  c : char;

begin
  regle_a_supprimer := true;
  regle_a_visualiser(regle, sortie);
  if sortie then
  begin
    regle_a_supprimer := false;
    exit;
  end;
  if regle = nil then
    exit;
  writeln;
  write('Confirmez-vous la suppression ? (O/N) : ');
  repeat;
    c := readkey;
    write(#8, c);
  until upcase(c) in ['O', 'N'];
  writeln;
  if upcase(c) = 'N' then
    exit;
  supprime_une_regle(regle);
end;

procedure supprime_regle;
begin
  while regle_a_supprimer do;
end;

(************************************************************)
(**               Ajouter des regles                       **)
(************************************************************)

procedure demande_premisses(var regle : tregle; var fich : text;
                            var premisse : pcell;
                            var nb_premisses : integer;
                            var sortie : boolean);
var
  libelle, comparateur, valeur : chaine;
  correct : boolean;
  pfait : pcell;
  fait : tfait;

begin
  regle.cond := nil;
  nb_premisses := -1;
  writeln;
  writeln('Entrez la regle (ou ESC) ');
  writeln;
  writeln;
  repeat;
    ecrit_premisses(regle, fich, 'con');
    write('Si    ');
    lecture_fait(libelle, comparateur, valeur, sortie, correct);
    if sortie then
      exit;
    if (libelle <> #13) and (correct) then
    begin
      pfait := fait_similaire(libelle, comparateur, valeur);
      if pfait = nil then
        creer_fait(libelle, comparateur, valeur, pfait);
      if pfait = nil then
        exit;
      new(premisse);
      premisse^.pval := pfait;
      ajoute_cell(premisse, regle. cond);
      nb_premisses := nb_premisses + 1;
    end;
  until libelle = #13;
end;

function regle_a_ajouter : boolean;
var
  pregle, p, premisse : pcell;
  regle : tregle;
  libelle, comparateur, valeur, priorite : chaine;
  correct, sortie : boolean;
  c : char;
  nb_premisses : integer;
  fich : text;
  code_erreur : integer;

begin
  assign(fich, 'con');
  regle_a_ajouter := true;
  demande_premisses(regle, fich, premisse, nb_premisses, sortie);
  if sortie then
  begin
    regle_a_ajouter := false;
    exit;
  end;
  if regle.cond = nil then
    exit;
  p := regle.cond;
  while p^.next <> premisse do
    p := p^.next;
  p^.next := nil;
  regle.action := premisse^.pval;
  regle.nb_premisses := nb_premisses;
  regle.nb_premisses_a_verifier := nb_premisses;
  montre_regle(regle, 'con');
  writeln;
  repeat;
    write('Priorite de cette regle [0 .. 100] : ');
    readln(priorite);
    val(priorite, regle.priorite, code_erreur);
  until ((code_erreur = 0) and (regle.priorite >= 0) and (regle.priorite <= 100));
  write('Validez-vous cette regle ? (O/N) : ');
  repeat;
    c := readkey;
    write(#8, c);
  until upcase(c) in ['O', 'N'];
  writeln;
  if upcase(c) = 'O' then
  begin
    new(pregle);
    pregle^.rval := regle ;
    ajoute_cell(pregle, bregles);
    premisse := regle.cond;
    while premisse <> nil do
    begin
      new(p);
      p^.pval := pregle;
      ajoute_cell(p, premisse^.pval^.fval.cond_de);
      premisse := premisse^.next;
    end;
    new(p);
    p^. pval := pregle;
    ajoute_cell(p, regle.action^.fval.action_de);
  end;
end;

procedure ajoute_regle;
begin
  while regle_a_ajouter do;
end;

(************************************************************)
(**                                                        **)
(**                 CHAINAGE AVANT                         **)
(**                                                        **)
(************************************************************)

function priorite_max (liste : pcell) : pcell;
var
  regle : pcell;
  regle_max : pcell;

begin
  regle := liste;
  regle_max := regle;
  while regle <> nil do
  begin
    if regle^.pval^.rval.priorite > regle_max^.pval^.rval.priorite then
      regle_max := regle;
    regle := regle^.next;
  end ;
  priorite_max := regle_max;
end;

function cp_num(x, y : real) : tcomparateur;
begin
  if x > y then
    cp_num := gt
  else
    if X < Y then
      cp_num := lt
    else
      cp_num := eq;
end;

function cp_alpha(st1, st2 : chaine) : tcomparateur;
begin
  if st1 > st2 then
    cp_alpha := gt
  else
    if st1 < st2 then
      cp_alpha := lt
    else
      cp_alpha := eq;
end;

procedure consequences_sur_regles(fait : tfait);
var
  regle, p : pcell;

begin
  regle := fait.cond_de;
  while regle <> nil do
  begin
    regle^.pval^.rval.nb_premisses_a_verifier := regle^.pval^.rval.nb_premisses_a_verifier - 1;
    if regle^.pval^.rval.nb_premisses_a_verifier = 0 then
    begin
      new(p);
      p^.pval := regle^.pval;
      ajoute_cell(p, ensemble_des_conflits);
    end;
    regle := regle^.next;
  end;
end;

procedure interprete_fait(var fait : tfait; regle : pcell);
var
  fait_depend : pcell;
  cp1, cp2, cp3 : tcomparateur;

begin
  if fait.etat <> indetermine then
    exit;
  fait_depend := fait.objet_associe^.oval.faits_associes;
  while fait_depend <> nil do
  begin
    if fait_depend^.pval^.fval.etat = indetermine then;
    begin
      if fait.objet_associe^.oval.typage = num then
        cp3 := cp_num(fait.numval, fait_depend^.pval^.fval.numval)
      else
        cp3 := cp_alpha(fait.alphaval, fait_depend^.pval^.fval.alphaval);
      cp1 := fait.comparateur;
      cp2 := fait_depend^.pval^.fval.comparateur;
      fait_depend^.pval^.fval.etat := evalue_etat[cp1, cp2, cp3];
      if fait_depend^.pval^.fval.etat <> indetermine then
        fait_depend^.pval^.fval.deduit_de := regle;
      if fait_depend^.pval^.fval.etat = vrai then
        consequences_sur_regles(fait_depend^.pval^.fval);
    end;
    fait_depend := fait_depend^.next;
  end;
end;

function chainage_avant : boolean;
var
  regle : pcell;
  fait : tfait;

begin
  regle := priorite_max(ensemble_des_conflits);
  if regle = nil then
  begin
    chainage_avant := false;
    exit;
  end;
  fait := regle^.pval^.rval.action^.fval;
  if fait.objet_associe^.oval.editable then
  begin
    writeln('Je deduis:');
    montre_fait(fait, 'con');
  end;
  supprime_cell(regle, ensemble_des_conflits);
  interprete_fait(fait, regle^.pval);
  chainage_avant := true;
end;

function fait_en_entree : boolean;
var
  libelle, comparateur, valeur : chaine;
  sortie, correct : boolean;
  objet, pfait : pcell;
  code_erreur : integer;
  fait : tfait;

begin
  while chainage_avant do;
  fait_en_entree := true;
  lit_fait(libelle, comparateur, valeur, sortie, correct);
  if sortie then
  begin
    fait_en_entree := false;
    exit;
  end;
  if not correct then
    exit;
  verifie_entree(libelle, comparateur, valeur, fait, objet, code_erreur);
  pfait := fait_similaire(libelle, comparateur, valeur);
  if pfait = nil then
    writeln('Je ne connais pas ce fait.')
  else
  interprete_fait(pfait^.fval, nil);
end;

procedure deduit;
begin
  while fait_en_entree do;
end;

(************************************************************)
(**                                                        **)
(**                 CHAINAGE ARRIERE                       **)
(**                                                        **)
(************************************************************)

procedure lit_valeur(var fait : tfait; var code_retour : char);
var
  type_objet : typage_objet;
  fait2 : tfait;
  valeur : chaine;
  num : integer;
  code_erreur : integer;

begin
  code_retour := 'E';
  fait2 := fait;
  fait2.comparateur := eq;
  readln(valeur);
  if valeur = '?' then
  begin
    code_retour := '?';
    exit;
  end;
  type_objet := fait.objet_associe^.oval.typage;
  if type_objet = alphanum then
  begin
    fait2.alphaval := valeur;
    code_retour := 'C';
  end
  else
  begin
    val(valeur, num, code_erreur);
    if code_erreur <> 0 then
      writeln('La valeur doit etre numerique.')
    else
    begin
      fait2.numval := num;
      code_retour := 'C';
    end;
  end;
  interprete_fait(fait2, nil);
  while chainage_avant do;
end;

function prouver(regle : pcell) : boolean; forward;

function verifier (var fait : tfait; etat : tetat) : boolean;
var
  regle : pcell;
  c, code_retour : char;

begin
  verifier := true;
  if fait.etat = etat then
    exit;
  if (fait.etat <> etat) and (fait.etat <> indetermine) then
  begin
    verifier := false;
    exit;
  end;
  regle := fait.action_de;
  while regle <> nil do
  begin
    if prouver(regle^.pval) then
      exit;
    regle := regle^.next;
  end;
  if ((fait.objet_associe^.oval.demandable = false) or
      (fait.objet_associe^.oval.connu = false)) then
  begin
    verifier := false;
    exit;
  end;
  writeln;
  repeat
    write('Quelle est la valeur de ', fait.objet_associe^.oval.libelle, ' ? ');
    lit_valeur(fait, code_retour);
  until code_retour in ['C', '?'];
  fait.objet_associe^.oval.connu := false;
  if code_retour = '?' then
  begin
    verifier := false;
    exit;
  end;
  if fait.etat <> etat then
    verifier := false;
end;

function prouver;
var
  premisse : pcell;

begin
  prouver := false;
  premisse := regle^.rval.cond;
  while premisse <> nil do
  begin
    if not verifier(premisse^.pval^.fval, vrai) then
      exit;
    premisse := premisse^.next ;
  end;
  prouver := true;
  interprete_fait(regle^.rval.action^.fval, regle);
end;

function chainage_arriere : boolean;
var
  sortie, correct : boolean;
  libelle, comparateur, valeur : chaine;
  fait : pcell;

begin
  chainage_arriere := true;
  lit_fait(libelle, comparateur, valeur, sortie, correct);
  if sortie then
  begin
    chainage_arriere := false;
    exit;
  end;
  if not correct then exit;
  fait := fait_similaire(libelle, comparateur, valeur);
  if fait = nil then
  begin
    writeln('Je ne connais pas ce fait.');
    exit;
  end;
  fait^.fval.objet_associe^.oval.connu := false;
  if verifier(fait^.fval, vrai) then
  begin
    write('Le fait ');
    montre_fait(fait^.fval, 'con');
    writeln('est vrai');
    exit;
  end;
  if verifier(fait^.fval, faux) then
  begin
    writeln('Le fait ');
    montre_fait(fait^.fval, 'con');
    writeln('est faux');
  end
  else
    writeln('Desole, je ne peux rien dire sur ce fait.');
end;

procedure induit;
begin
  while chainage_arriere do;
end;

(************************************************************)
(**                                                        **)
(**                   JUSTIFICATION                        **)
(**                                                        **)
(************************************************************)

procedure justifie_fait(fait : tfait);
begin
  if (fait.etat = indetermine) then
  begin
    writeln('Ce fait est indetermine.');
    exit;
  end;
  write('ce fait est ');
  if fait.etat = vrai then
    writeln('vrai.')
  else
    writeln('faux.');
  if fait.deduit_de = nil then
  begin
    writeln('On me l''a affirme.');
    exit;
  end;
  writeln('deduit de la regle : ');
  montre_regle(fait.deduit_de^.rval, 'con');
end;

function fait_a_justifier : boolean;
var
  libelle, comparateur, valeur : chaine;
  fait : pcell;
  sortie, correct : boolean;

begin
  fait_a_justifier := true;
  lit_fait(libelle, comparateur, valeur, sortie, correct);
  if sortie then
  begin
    fait_a_justifier := false;
    exit;
  end;
  if not correct then
    exit;
  fait := fait_similaire(libelle, comparateur, valeur);
  if fait = nil then
    writeln('Je ne connais pas ce fait.')
  else
    justifie_fait(fait^.fval);
end;

procedure justifie;
begin
  while fait_a_justifier do;
end;

(************************************************************)
(**                                                        **)
(**                    UTILITAIRES                         **)
(**                                                        **)
(************************************************************)

(**********************************************************)
(**        Operations sur la table evalue_etat           **)
(**********************************************************)

procedure entre_table;
var
  i, j, k : tcomparateur;
  c : char;
  evalue_etat : tevalue_etat;
  fichier : file of tevalue_etat;

begin
  for k := eq to lt do
    for j := eq to ne do
      for i := eq to ne do
      begin
        write('Op1 = ', from_cp_to_st(i));
        write('  Op2 = ', from_cp_to_st(j));
        write('  Op3 = ', from_cp_to_st(k));
        write('.  Donc etat = (V/F/I) ? : ');
        repeat
          c := readkey;
          write(#8, c);
        until upcase(c) in ['V', 'F', 'I'];
        writeln;
        case upcase(c) of
          'V' : evalue_etat[i, j, k] := vrai;
          'F' : evalue_etat[i, j, k] := faux;
          'I' : evalue_etat[i, j, k] := indetermine;
        end;
      end;

  assign(fichier, 'eval.tab');
  rewrite(fichier);
  write(fichier, evalue_etat);
  close(fichier);
end;

procedure lit_table(var evalue_etat : tevalue_etat);
var
  fichier : file of tevalue_etat;

begin
  assign(fichier, 'eval.tab');
  reset(fichier);
  read(fichier, evalue_etat);
  close(fichier);
end;

(**********************************************************)
(**                 Reset des bases                      **)
(**********************************************************)

procedure reset_objets;
var
  objet : pcell;

begin
  objet := bobjets;
  while objet <> nil do
  begin
    objet^.oval.connu := true;
    objet := objet^.next;
  end;
end;

procedure reset_faits;
var
  fait : pcell;

begin
  fait := bfaits;
  while fait <> nil do
  begin
    fait^.fval.deduit_de := nil;
    fait^.fval.etat := indetermine;
    fait := fait^.next;
  end;
end;

procedure reset_regles;
var
  regle : pcell;

begin
  regle := bregles;
  while regle <> nil do
  begin
    regle^.rval.nb_premisses_a_verifier := regle^.rval.nb_premisses;
    regle := regle^.next;
  end;
end;

procedure reset_bases;
begin
  reset_objets;
  reset_faits;
  reset_regles;
  ensemble_des_conflits := nil;
end;

(***************************************************************)
(**                Sauvegarder les bases                      **)
(***************************************************************)

procedure sauve_objets(var fich : tfichier_objets);
var
  objet : pcell;
  enreg : tenreg_objet;

begin
  rewrite(fich);
  objet := bobjets;
  while objet <> nil do
  begin
    enreg.libelle := objet^.oval.libelle;
    enreg.typage := objet^.oval.typage;
    enreg.demandable := objet^.oval.demandable;
    enreg.editable := objet^.oval.editable;
    write(fich, enreg);
    objet := objet^.next;
  end;
  close(fich);
end;

procedure sauve_faits(var fich : tfichier_faits);
var
  fait : pcell;
  enreg : tenreg_fait;

begin
  rewrite(fich);
  fait := bfaits;
  while fait <> nil do
  begin
    enreg.libelle := fait^.fval.objet_associe^.oval.libelle;
    enreg.comparateur := fait^.fval.comparateur;
    if fait^.fval.objet_associe^.oval.typage = num then
      enreg.numval := fait^.fval.numval
    else
      enreg.alphaval := fait^.fval.alphaval;
    write(fich, enreg);
    fait := fait^.next;
  end;
  close(fich);
end;

procedure ecrit_regle(var fich : tfichier_regles; regle : tregle);
var
  enreg : tenreg_regle;
  premisse : pcell;

begin
  premisse := regle.cond;
  while premisse <> nil do
  begin
    enreg.libelle := premisse^.pval^.fval.objet_associe^.oval.libelle;
    enreg.comparateur := from_cp_to_st(premisse^.pval^.fval.comparateur);
    enreg.valeur := from_val_to_st(premisse^.pval^.fval);
    enreg.priorite := regle.priorite;
    enreg.premisse := true;
    write(fich, enreg);
    premisse := premisse^.next;
  end;
  enreg.libelle := regle.action^.fval.objet_associe^.oval.libelle;
  enreg.comparateur := from_cp_to_st(regle.action^.fval.comparateur);
  enreg.valeur := from_val_to_st(regle.action^.fval);
  enreg.premisse := false;
  enreg.priorite := regle.priorite;
  write(fich, enreg);
end;

procedure sauve_regles(var fich : tfichier_regles);
var
  regle : pcell;

begin
  rewrite(fich);
  regle := bregles;
  while regle <> nil do
  begin
    ecrit_regle(fich, regle^.rval);
    regle := regle^.next;
  end;
  close(fich);
end;

procedure sauve;
var
  fobjets : tfichier_objets;
  ffaits : tfichier_faits;
  fregles : tfichier_regles;

begin
  writeln;
  writeln('Sauvegarde en cours...');
  assign(fobjets, base_active + '.BO');
  assign(ffaits, base_active + '.BF');
  assign(fregles, base_active + '.BR');
  sauve_regles(fregles);
  sauve_faits(ffaits);
  sauve_objets(fobjets);
  writeln('Sauvegarde terminee.');
end;

(**************************************************************)
(**                Charger les bases                         **)
(**************************************************************)

function existe(nomfich : chaine) : boolean;
var
  fichier : file;

begin
  assign(fichier, nomfich);
  (*$I-*)
  reset(fichier);
  (*$I+*)
  if IOresult = 0 then
  begin
    existe := true;
    close(fichier);
  end
  else
    existe := false;
end;

procedure charge_objets(var fich : tfichier_objets);
var
  objet : tobjet;
  enreg : tenreg_objet;
  p : pcell;

begin
  reset(fich);
  bobjets := nil;
  while not eof(fich) do
  begin
    read(fich, enreg);
    objet.libelle := enreg.libelle;
    objet.typage := enreg.typage;
    objet.connu := true;
    objet.demandable := enreg.demandable;
    objet.editable := enreg.editable;
    objet.faits_associes := nil;
    new(p);
    p^.oval := objet;
    ajoute_cell(p, bobjets);
  end;
  close(fich);
end;

procedure charge_faits(var fich : tfichier_faits);
var
  fait : tfait;
  pfait, P, objet : pcell;
  enreg : tenreg_fait;

begin
  reset(fich);
  bfaits := nil;
  while not eof(fich) do
  begin
    read(fich, enreg);
    fait.objet_associe := objet_similaire(enreg.libelle);
    fait.comparateur := enreg.comparateur;
    if fait.objet_associe^.oval.typage = alphanum then
      fait.alphaval := enreg.alphaval
    else
      fait.numval := enreg.numval;
    fait.etat := indetermine;
    fait.cond_de:= nil;
    fait.action_de := nil;
    fait.deduit_de := nil;
    new(pfait);
    pfait^.fval := fait;
    ajoute_cell(pfait, bfaits);
    new(p);
    p^.pval := pfait;
    ajoute_cell(p, fait.objet_associe^.oval.faits_associes);
  end;
  close(fich);
end;

procedure lecture_regle(var fich : tfichier_regles; var regle : tregle);
var
  premisse : pcell;
  enreg : tenreg_regle;
  fait : tfait;

begin
  with regle do
  begin
    nb_premisses := 0;
    cond := nil;
    read(fich, enreg);
    while enreg.premisse do
    begin
      new(premisse);
      nb_premisses := nb_premisses + 1;
      premisse^.pval := fait_similaire (enreg.libelle, enreg.comparateur, enreg.valeur);
      ajoute_cell(premisse, cond);
      read(fich, enreg);
    end;
    nb_premisses_a_verifier := nb_premisses;
    action := fait_similaire(enreg.libelle, enreg.comparateur, enreg.valeur);
    priorite := enreg.priorite;
  end;
end;

procedure charge_regles(var fich : tfichier_regles);
var
  regle : tregle;
  pregle, P, pfait : pcell;

begin
  reset(fich);
  bregles := nil;
  while not eof(fich) do
  begin
    lecture_regle(fich, regle);
    new(pregle);
    pregle^.rval := regle;
    ajoute_cell(pregle, bregles);
    pfait := regle.cond;
    while pfait <> nil do
    begin
      new(p);
      p^.pval := pregle;
      ajoute_cell(p, pfait^.pval^.fval.cond_de);
      pfait := pfait^.next;
    end;
    new(p);
    p^.pval := pregle;
    ajoute_cell(p, pregle^.rval.action^.fval.action_de);
  end;
  close(fich);
end;

procedure charge;
var
  nom_base: chaine;
  fobjets : tfichier_objets;
  ffaits : tfichier_faits;
  fregles : tfichier_regles;
  c : char;

begin
  writeln;
  write('Nom de la base : ');
  readln(nom_base);
  assign(fobjets, nom_base + '.BO');
  assign(ffaits, nom_base + '.BF');
  assign(fregles, nom_base + '.BR');
  if (not (existe(nom_base + '.BF'))) or (not (existe(nom_base + '.BR')) or
     (not existe(nom_base + '.BO'))) then
  begin
    write('Cette base n''existe pas.');
    write(' Voulez-vous la creer ? (O/N) :  ');
    repeat;
      c := readkey;
      write(#8, c);
    until upcase(c) in ['O', 'N'];
    writeln;
    if upcase(c) = 'N' then
      exit;
    rewrite(fobjets);
    close(fobjets);
    rewrite(ffaits);
    close(ffaits);
    rewrite(fregles);
    close(fregles);
  end;
  charge_objets(fobjets);
  charge_faits(ffaits);
  charge_regles(fregles);
  base_active := nom_base;
  reset_bases;
end;

(************************************************************)
(**                                                        **)
(**                      MENUS                             **)
(**                                                        **)
(************************************************************)

procedure menu_consulte;
var
  c : char;
  fin : boolean;

begin
  reset_bases;
  fin := false;
  repeat;
    writeln;
    writeln('***** Consultation de la base *****');
    writeln;
    writeln('      D --> Deduit ');
    writeln('      I --> Induit ');
    writeln('      J --> Justifie ');
    writeln('      R --> Reset ');
    writeln('    ESC --> Menu principal ');
    writeln;
    write('Votre choix :  ');
    repeat
      c := readkey;
      write(#8, c);
    until upcase(c) in [#27, 'D', 'I', 'J', 'R'];
    writeln;
    case upcase(c) of
      'D' : deduit;
      'I' : induit;
      'J' : justifie;
      'R' : reset_bases;
      #27 : fin := true;
    end;
  until fin;
end;

procedure menu_modifie;
var
  c : char;
  fin : boolean;

begin
  fin := false;
  repeat;
    writeln;
    writeln('****** Operations sur les bases ******');
    writeln;
    writeln('Sur les objets :   A  -->  Ajoute');
    writeln('                   B  -->  Supprime');
    writeln('                   C  -->  Visualise');
    writeln('                   D  -->  Imprime');
    writeln;
    writeln('Base de faits :    E  -->  Ajoute');
    writeln('                   F  -->  Supprime');
    writeln('                   G  -->  Visualise');
    writeln('                   H  -->  Imprime');
    writeln;
    writeln('Base de regles :   I  -->  Ajoute');
    writeln('                   J  -->  Supprime');
    writeln('                   K  -->  Visualise');
    writeln('                   L  -->  Imprime');
    writeln;
    writeln('                 ESC  --> Menu principal');
    writeLn;
    write('Votre choix : ');
    repeat
      c := readkey;
      write(#8, c);
    until upcase(c) in [#27, 'A'..'L'];
    writeln;
    case upcase(c) of
      'A' : ajoute_objet;
      'B' : supprime_objet;
      'C' : visualise_objet;
      'O' : imprime_objets;
      'E' : ajoute_fait;
      'F' : supprime_fait;
      'G' : visualise_fait;
      'H' : imprime_faits;
      'I' : ajoute_regle;
      'J' : supprime_regle;
      'K' : visualise_regle;
      'L' : imprime_regles;
      #27 : fin := true;
    end;
  until fin;
end;

procedure menu_principal;
var
  c : char;
  i : integer;
  fin : boolean;

begin
  fin := false;
  repeat
    writeln;
    writeln('***** MENU PRINCIPAL *****  ');
    writeln;
    writeln('      A  -->  Modifie');
    writeln('      B  -->  Consulte');
    writeln('      C  -->  Charge');
    writeln('      D  -->  Sauve');
    writeln('      E  -->  Cr‚e la table des ‚valuations');
    writeln('    ESC  -->  Quitte');
    writeln;
    write('Votre choix : ');
    repeat
      c := readkey;
      write(#8, c);
    until upcase(c) in ['A'..'E', #27];
    writeln;
    case upcase(c) of
      'A' : menu_modifie;
      'B' : menu_consulte;
      'C' : charge;
      'D' : sauve;
      'E' : entre_table;
      #27 : fin := true;
    end;
  until fin;
end;

(*********************************************************)
(**                                                     **)
(**                PROGRAMME PRINCIPAL                  **)
(**                                                     **)
(*********************************************************)

begin
  base_active := '';
  bobjets := nil;
  bfaits := nil;
  bregles := nil;
  if not existe('eval.tab') then
    entre_table;
  clrscr;
  charge;
  lit_table(evalue_etat);
  menu_principal;
end.