Cours MASS première année 2003--2004 deuxième semestre

Mercredi 11 février 2004 : records

I nombres complexes :

Version 1 : tableau de deux nombres réels

type complexe=array[1..2] of real;

var a,b,c:complexe;
begin
  a[1]:=4; a[2]:=1;
  b[1]:=5; b[2]:=-1;
  c[1]:=a[1]+b[1];
  c[2]:=a[2]+b[2];
...

Version 2 : record, sans procédure

type complexe=record re,im:real end;

var a,b,c:complexe;
begin
  a.re:=4; a.im:=1;
  b.re:=5; b.im:=-1;
  c.re:=a.re+b.re;
  c.im:=a.im+b.im;
...

Version 3 : procédure d'addition (pascal standard)

type complexe=record re,im:real end;

procedure addc(x,y:complexe;var z:complexe);
begin
  z.re:=x.re+y.re;
  z.im:=x.im+y.im
end;

var a,b,c:complexe;
begin
  a.re:=4; a.im:=1;
  b.re:=5; b.im:=-1;
  addc(a,b,c);
...

Version 4 : fonction d'addition (extension de free pascal)

type complexe=record re,im:real end;

function addc(x,y:complexe):complexe;
begin
  addc.re:=x.re+y.re;
  addc.im:=x.im+y.im
end;

var a,b,c:complexe;
begin
  a.re:=4; a.im:=1;
  b.re:=5; b.im:=-1;
  c:=addc(a,b);
...

Version 5 : opérateur d'addition

type complexe=record re,im:real end;

operator + (x,y:complexe)z:complexe;
begin
  z.re:=x.re+y.re;
  z.im:=x.im+y.im
end;

var a,b,c:complexe;
begin
  a.re:=4; a.im:=1;
  b.re:=5; b.im:=-1;
  c:=a+b;
...

Version 5 complétée : soustraction, multiplication, lecture et écriture

type complexe=record re,im:real end;

operator + (x,y:complexe)z:complexe;
begin
  z.re:=x.re+y.re;
  z.im:=x.im+y.im
end;

operator - (x,y:complexe)z:complexe;
begin
  z.re:=x.re-y.re;
  z.im:=x.im-y.im
end;

operator * (x,y:complexe)z:complexe;
begin
  z.re:=x.re*y.re-x.im*y.im;
  z.im:=x.im+y.re+x.re*y.im
end;

procedure writec(a:complexe);
begin
  write('(');
  write(a.re:0:5);
  if a.im>0  then write('+');
  if a.im<>0 then write(a.im:0:5,'i');
  write(')')
end;

function readc:complexe;
begin
  read(readc.re,readc.im)
end;

var a,b,c:complexe;
begin
  a.re:=4; a.im:=1;
  b.re:=5; b.im:=-1;
  c:=a+b;
  writec(a);write('+');writec(b);write('=');writec(c);writeln;
  writeln('Tapez 2 nombres complexes et vous verrez leur somme.'); 
  writec(readc+readc);
  readln;
  readln
end.

II record comtenant des champs de différents types.

type personne=record
                nom,prenom:string[30];
                age:integer;
                sexe:(masculin,feminin)
              end;
procedure writepersonne(a:personne);
begin
  writeln(a.prenom,' ',a.nom,' ',a.age,' ');
  case a.sexe of
    masculin:write('M');
    feminin :write('F')
  end;
  writeln
end;

procedure readpersonne(var a:personne);
var c:char;
begin
  write('Nom ? ');readln(a.nom);
  write('Prénom ? ');readln(a.prenom);
  write('Age ? ');readln(a.age);
  repeat
    write('sexe ? '); readln(c); c:=upcase(c)
  until (c='M') or (c='F') or (c='H');
  if c='F' then a.sexe:=feminin
           else a.sexe:=masculin
end;

function nomlong(a:personne):boolean;
begin nomlong:=length(a.nom)>length(a.prenom) end;

Mercredi 18 février 2004 : type énuméré et records(suite) : with, case, records imbriqués

type énuméré :

type boolean=(false,true);
     char=(#0,#1,#2, .... ,'*', '+', ',', '-', '.', '/', '0', '1', ... #255);

type figure=(carre,cercle,triangle);
var f:figure;
begin
  f:=carre;
  write(ord(f));  // ord(carre)=0
  f:=succ(f);     // succ(carre)=cercle
  f:=succ(f);     // succ(cercle)=triangle
  f:=pred(f);     // pred(triangle)=cercle
  f:=pred(f);     // pred(cercle)=carre
  f:=figure(1);   // figure(1)=cercle
  for f:=carre to triangle do
  begin
    case f of
      carre:write('carré');
      cercle:write('cercle');
      triangle:write('triangle');
    end;
    writeln(ord(f):2)
  end;
  readln
end.

0carré 0
cercle 1
triangle 2

points et figures :

type real=extended;
     figure=(carre,cercle,triangle);
     point=record x,y:real end;
     fig=record
           surface,perimetre:real;
         case typfig:figure of
           carre   :(centre:point;
                     cote:real);
           cercle  :(centrec:point;
                     rayon:real);
           triangle:(s:array[1..3] of point)
         end;
const nomfig:array[figure] of string[8]=('carré','cercle','triangle');

procedure affpoint(a:point);
begin
  with a do write('(', x:0:5, ',', y:0:5, ')')
end;

function dist(a,b:point):real;
begin
  dist:=sqrt(sqr(a.x-b.x)+sqr(a.y-b.y))
end;

procedure calculsurfaceperimetre(var f:fig);
begin
  with f do
  case typfig of
    carre:
    begin
      surface:=sqr(cote);
      perimetre:=4*cote
    end;
    cercle:
    begin
      surface:=sqr(rayon)*pi;
      perimetre:=2*pi*rayon
    end;
    triangle:
    begin
      surface:=abs((s[1].x-s[2].x)*(s[1].y-s[3].y)
                  -(s[1].y-s[2].y)*(s[1].x-s[3].x))/2;
      perimetre:=dist(s[1],s[2])+dist(s[2],s[3])+dist(s[3],s[1])
    end
  end
end;

procedure afffig(f:fig);
var i:integer;
begin
  with f do
  begin
    writeln(nomfig[typfig]);
    case typfig of
      carre:
      begin
        write('centre : '); affpoint(centre); writeln;
        writeln('longueur des cotés : ',cote:0:5)
      end;
      cercle:
      begin
        write('centre : '); affpoint(centre); writeln;
        writeln('rayon : ',cote:0:5)
      end;
      triangle:
      begin
        write('sommets : ');
        for i:=1 to 3 do affpoint(s[i]);
        writeln
      end
    end;
    writeln('surface '  ,surface  :0:5);
    writeln('perimètre ',perimetre:0:5)
  end
end;

var ca,ce,tr:fig;
begin
  ca.typfig:=carre;
  ca.centre.x:=1;
  ca.centre.y:=2;
  ca.cote:=5;
  ce.typfig:=cercle;
  ce.centrec.x:=-1;
  ce.centrec.y:=2.4;
  ce.rayon:=5;
  tr.typfig:=triangle;
  tr.s[1].x:=0;
  tr.s[1].y:=4;
  tr.s[2].x:=3;
  tr.s[2].y:=0;
  tr.s[3].x:=-3;
  tr.s[3].y:=0;
  calculsurfaceperimetre(ca);
  calculsurfaceperimetre(ce);
  calculsurfaceperimetre(tr);
  afffig(ca); writeln;
  afffig(ce); writeln;
  afffig(tr);
  readln
end.

carré
centre : (1.00000,2.00000)
longueur des cotés : 5.00000
surface 25.00000
perimètre 20.00000

cercle
centre : (-1.00000,2.40000)
rayon : 5.00000
surface 78.53982
perimètre 31.41593

triangle
sommets : (0.00000,4.00000)(3.00000,0.00000)(-3.00000,0.00000)
surface 12.00000
perimètre 16.00000

Mercredi 3 mars 2004 : fichiers text

écriture sur l'écran

write(3+4);
write('bonjour');
write(3.0);
write('x');
write(4<5);
write(succ('A'));
write(11+23:4);
write('bonjour':10);
write('bonjour':4);
write(3.0:7);
write(3.0:7:2);
write(7/3:0:4);
writeln

7bonjour 3.0000000000000000E+0000xTRUEB  34   bonjourbonjour 3.0E+0000   3.002.3333

writeln(3+4,'bonjour',3.0,'x',4<5,succ('A'),11+23:4,
        'bonjour':10,'bonjour':4,3.0:7,3.0:7:2,7/3:0:4)

écriture dans un fichier

const n=7;
type vec=array[1..n] of integer;
procedure affvec(a:vec);
var i:integer;
begin
  for i:=1 to n do write(a[i]:10);
  writeln
end;

const n=7;
type vec=array[1..n] of integer;
procedure affvec(var f:text;a:vec);
var i:integer;
begin
  for i:=1 to n do write(f,a[i]:10);
  writeln(f)
end;

var f:text;
    a:vec;
    i:integer;
begin
  for i:=1 to n do a[i]:=23 mod i;
  assign(f,'a:\truc.txt');
  rewrite(f);
  affvec(f,a); // écrit a dans le fichier
  affvec(f,a); // écrit a une deuxième fois dans le fichier
  affvec(output,a); // écrit a sur l'écran
  for i:=2 to n do a[i]:=a[i]+a[a[i]];
  affvec(f,a);
  affvec(output,a);
  close(f)
end.

         0         1         2         3         3         5         2
         0         1         3         6         6        11         3

         0         1         2         3         3         5         2
         0         1         2         3         3         5         2
         0         1         3         6         6        11         3

lecture de fichier text

exemple 1

2 3
5 6
1 7
34 12

2+3=5
5+6=11
1+7=8
34+12=46

var f:text;
    x,y:integer;
begin
  assign(f,'a:\2n.txt');
  reset(f);
  while not eof(f) do
  begin
    readln(f,x,y);
    writeln(x,'+',y,'=',x+y)
  end;
  close(f)
end.

exemple 2

var f,g:text;
    c:char;
begin
  assign(f,'truc.txt');
  reset(f);
  assign(g,'troc.txt');
  rewrite(g);
  while not eof(f) do
  if eoln(f) then
  begin
    readln(f);
    writeln(g)
  end        else
  begin
    read(f,c);
    if (c>='A') and (c<='Z') then c:=chr(ord(c)-ord('A')+ord('a')) else
    if (c>='a') and (c<='z') then c:=chr(ord(c)-ord('a')+ord('A'));
    write(g,c)
  end;
  close(f);
  close(g)
end.

exemple 3

var f:text;
    c:char;
    n:integer;
begin
  n:=0;
  assign(f,'truc.txt');
  reset(f);
  while not eof(f) do
  if eoln(f) then readln(f) else
  begin
    read(f,c);
    if c=' ' then n:=n+1
  end;
  close(f);
  write('Il y a ',n,' blancs dans le fichier.');
  readln
end.

exemple 4

var f,g:text;
    c,d:char;
begin
  assign(f,'truc.txt');
  reset(f);
  assign(g,'trac.txt');
  rewrite(g);
  d:='a';
  while not eof(f) do
  if eoln(f) then
  begin
    readln(f);
    writeln(g);
    d:='a'
  end        else
  begin
    read(f,c);
    if(c<>' ') or (d<>' ') then write(g,c);
    d:=c
  end;
  close(f);
  close(g)
end.

Mercredi 10 mars 2004 : écriture et lecture de tableaux de record dans un fichier text

résultat d'une journée de championnat

type resultat=(gagne,nul,perdu);
     match=record equipe1,equipe2:string[20];
                  res:resultat
           end;
     journee=array[1..10] of match;
function opp(r:resultat):resultat;
begin
  opp:=resultat(2-ord(r))
end;
procedure litjournee(var f:text;var jour:journee);
var i:integer;
    c,d:char;
begin
  for i:=1 to 10 do
  with jour[i] do
  begin
    readln(f,c,equipe1);
    readln(f,d,equipe2);
    if (c='+') and (d='-') then res:=gagne else
    if (c='=') and (d='=') then res:=nul   else
    if (c='-') and (d='+') then res:=perdu else
    begin
      writeln('Données incorrectes :');
      writeln('i=',i);
      writeln(c,equipe1);
      writeln(d,equipe2);
      halt
    end;
    readln(f)
  end
end;
procedure ecritjournee(var f:text;jour:journee);
var i:integer;
const t:array[resultat] of char=('+','=','-');
begin
  for i:=1 to 10 do
  with jour[i] do
  begin
    writeln(f,t[    res ],equipe1);
    writeln(f,t[opp(res)],equipe2);
    writeln(f)
  end
end;
var f:text;
    nom:string[80];
    j:journee;
begin
  write('Quel fichier voulez-vous lire ? ');
  readln(nom);
  assign(f,nom);
  reset(f);
  litjournee(f,j);
  ecritjournee(output,j);
  close(f);
  write('Dans quel fichier voulez-vous écrire ? ');
  readln(nom);
  assign(f,nom);
  (*$i-*)
  append(f);
  (*$i+*)
  if ioresult<>0 then rewrite(f);
  ecritjournee(f,j);
  close(f)
end.

+Guingamp
-Lens

=Bastia
=Lyon

+Ajaccio
-Marseille

-Toulouse
+Metz

=Sochaux
=Lille

+Monaco
-Montpellier

+Bordeaux
-Nantes

+Auxerre
-Nice

=PSG
=Rennes

-Le Mans
+Strasbourg

Mercredi 17 mars 2004 : lecture, écriture et produits de vecteurs et matrices

type real=extended;
const n=3;
type vec=array[1..n] of real;
     mat=array[1..n] of vec;

procedure ecrvec(var f:text;a:vec);
var i:integer;
begin
  for i:=1 to n do write(f,a[i]:30);
  writeln(f)
end;

procedure ecrmat(var f:text;a:mat);
var i:integer;
begin
  writeln(f);
  for i:=1 to n do ecrvec(f,a[i])
end;

procedure lirvec(var f:text;var a:vec);
var i:integer;
begin
  for i:=1 to n do read(f,a[i]);
  readln(f)
end;

procedure lirmat(var f:text;var a:mat);
var i:integer;
begin
  for i:=1 to n do lirvec(f,a[i])
end;

operator +(a,b:vec)c:vec;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]+b[i]
end;

operator +(a,b:mat)c:mat;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]+b[i]
end;

operator -(a,b:vec)c:vec;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]-b[i]
end;

operator -(a,b:mat)c:mat;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]-b[i]
end;

operator *(a:mat;b:vec)c:vec;
var i,j:integer;
    s:real;
begin
  for i:=1 to n do
  begin
    s:=0;
    for j:=1 to n do s:=s+a[i,j]*b[j];
    c[i]:=s
  end
end;

operator *(a,b:mat)c:mat;
var i,j,k:integer;
    s:real;
begin
  for i:=1 to n do
  for k:=1 to n do
  begin
    s:=0;
    for j:=1 to n do s:=s+a[i,j]*b[j,k];
    c[i,k]:=s
  end
end;

function trace(a:mat):real;
var i:integer;
    s:real;
begin
  s:=0;
  for i:=1 to n do s:=s+a[i,i];
  trace:=s
end;

function norme1(a:vec):real;
var i:integer;
    s:real;
begin
  s:=0;
  for i:=1 to n do s:=s+abs(a[i]);
  norme1:=s
end;

function normem1(a:mat):real;
var i:integer;
    s:real;
begin
  s:=0;
  for i:=1 to n do s:=s+norme1(a[i]);
  normem1:=s
end;

var a,b,c,ab,bc,ca:mat;
    v:vec;
    i,j:integer;
    f:text;
begin
  for i:=1 to n do
  for j:=1 to n do
  begin
    a[i,j]:=i*i+j+i xor j;
    b[i,j]:=i*i-j-i and j;
    c[i,j]:=i div j-j mod i
  end;
  write('a:');ecrmat(output,a);
  write('b:');ecrmat(output,b);
  write('c:');ecrmat(output,c);
  ab:=a*b;
  bc:=b*c;
  ca:=c*a;
  write('ab:');ecrmat(output,ab);
  write('bc:');ecrmat(output,bc);
  write('ca:');ecrmat(output,ca);
  writeln('|a*bc-ab*c|=',normem1(a*bc-ab*c));
  writeln('Tr(abc)=',trace(ab*c));
  writeln('Tr(bca)=',trace(bc*a));
  writeln('Tr(cab)=',trace(ca*b));
  for i:=1 to n do v[i]:=i*7 div 4;
  writeln('|a*(b*v)-ab*v|=',norme1(a*(b*v)-ab*v));
  writeln('|b*(c*v)-bc*v|=',norme1(b*(c*v)-bc*v));
  assign(f,'truc');
  rewrite(f);
  ecrmat(f,a);
  ecrmat(f,b);
  close(f);
  reset(f);
  lirmat(f,ab);
  lirmat(f,bc);
  close(f);
  write('|ab-a|=',normem1(ab-a),' ab=');ecrmat(output,ab);
  write('|bc-b|=',normem1(bc-b),' bc=');ecrmat(output,bc);
  readln
end.

Mercredi 24 mars 2004 : système d'équations linéaires

type real=extended;
const n=3;
type vec=array[1..n] of real;
     mat=array[1..n] of vec;
     veci=array[1..n] of integer;

procedure ecrvec(var f:text;a:vec);
var i:integer;
begin
  for i:=1 to n do write(f,a[i]:12:6);
  writeln(f)
end;

procedure ecrmat(var f:text;a:mat);
var i:integer;
begin
  writeln(f);
  for i:=1 to n do ecrvec(f,a[i])
end;

procedure lirvec(var f:text;var a:vec);
var i:integer;
begin
  for i:=1 to n do read(f,a[i]);
  readln(f)
end;

procedure lirmat(var f:text;var a:mat);
var i:integer;
begin
  for i:=1 to n do lirvec(f,a[i])
end;

operator +(a,b:vec)c:vec;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]+b[i]
end;

operator +(a,b:mat)c:mat;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]+b[i]
end;

operator -(a,b:vec)c:vec;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]-b[i]
end;

operator -(a,b:mat)c:mat;
var i:integer;
begin
  for i:=1 to n do c[i]:=a[i]-b[i]
end;

operator *(a:mat;b:vec)c:vec;
var i,j:integer;
    s:real;
begin
  for i:=1 to n do
  begin
    s:=0;
    for j:=1 to n do s:=s+a[i,j]*b[j];
    c[i]:=s
  end
end;

operator *(a,b:mat)c:mat;
var i,j,k:integer;
    s:real;
begin
  for i:=1 to n do
  for k:=1 to n do
  begin
    s:=0;
    for j:=1 to n do s:=s+a[i,j]*b[j,k];
    c[i,k]:=s
  end
end;

function trace(a:mat):real;
var i:integer;
    s:real;
begin
  s:=0;
  for i:=1 to n do s:=s+a[i,i];
  trace:=s
end;

function norme1(a:vec):real;
var i:integer;
    s:real;
begin
  s:=0;
  for i:=1 to n do s:=s+abs(a[i]);
  norme1:=s
end;

function normem1(a:mat):real;
var i:integer;
    s:real;
begin
  s:=0;
  for i:=1 to n do s:=s+norme1(a[i]);
  normem1:=s
end;

function resoutgauss(a:mat;b:vec):vec;
var c:vec;
    i,j,m:integer;
    p:real;
begin
  for m:=1 to n do
  begin
    (* recherche du plus gros coefficient de la colonne m sur
       la diagonale et en dessous i.e. dans a[m..n,m] *)
    i:=m;
    for j:=m to n do if abs(a[j,m])>abs(a[i,m]) then i:=j;
    (* échange des équations m et i *)
    c:=a[i]; a[i]:=a[m]; a[m]:=c;
    p:=b[i]; b[i]:=b[m]; b[m]:=p;
    (* division de l'équation m par a[m,m] pour faire apparaître
       un 1 sur la diagonale *)
    p:=a[m,m];
    if p=0 then begin writeln('matrice non inversible');halt end;
    for j:=m to n do a[m,j]:=a[m,j]/p;
    b[m]:=b[m]/p;
    (* A chacune des lignes en dessous du pivot, on soustrait un multiple
       de la ligne du pivot pour faire apparaître un 0 sous le pivot *)
    for i:=m+1 to n do
    begin
      p:=a[i,m];
      for j:=m to n do a[i,j]:=a[i,j]-p*a[m,j];
      b[i]:=b[i]-p*b[m]
    end
  end;
  (* La matrice a est triangulaire supérieure *)
  (* Résolution de ce sytème triangulaire *)
  for i:=n downto 1 do
  begin
    p:=b[i];
    for j:=i+1 to n do p:=p-a[i,j]*c[j];
    c[i]:=p
  end;
  resoutgauss:=c
end;
(* On peut diviser la procédure précédente en deux :
  Dans la première on mettra tous les calculs qui ne dépendent que de
  la matrice A. Le temps de ces calculs est en O(n³).
  Dans la deuxième on mettra tous les calculs qui dépendent aussi du vecteur
  B. Le temps de ces calculs est en O(n²).
  De cette façon si on veut résoudre plusieurs systèmes d'équations linéaires
  ayant la même matrice mais des membres droits différents, on ne fera qu'une
  fois le calcul en O(n³) qui dépend de la matrice, et on ne répètera que le
  calcul en O(n²). Cela permet en particulier de calculer l'inverse d'une
  matrice avec O(n³) opérations élémentaires (comme pour le produit de deux
  matrices). *)
procedure decomplu(var a:mat;var b:veci);
var i,j,m:integer;
    c:vec;
    p:real;
begin
  for i:=1 to n do b[i]:=i; (* numérotation initiale des lignes *)
  for m:=1 to n do
  begin
    (* recherche du plus gros coefficient de la colonne m sur
       la diagonale et en dessous i.e. dans a[m..n,m] *)
    i:=m;
    for j:=m to n do if abs(a[j,m])>abs(a[i,m]) then i:=j;
    (* échange des équations m et i *)
    c:=a[i]; a[i]:=a[m]; a[m]:=c;
    j:=b[i]; b[i]:=b[m]; b[m]:=j;
    (* division de l'équation m par a[m,m] pour faire apparaître
       un 1 sur la diagonale *)
    p:=a[m,m];
    if p=0 then begin writeln('matrice non inversible');halt end;
    for j:=m+1 to n do a[m,j]:=a[m,j]/p;
    (* A chacune des lignes en dessous du pivot, on soustrait un multiple
       de la ligne du pivot pour faire apparaître un 0 sous le pivot *)
    for i:=m+1 to n do
    begin
      p:=a[i,m];
      for j:=m+1 to n do a[i,j]:=a[i,j]-p*a[m,j];
    end
  end
end;
function resoutlu(a:mat;bb:veci;b:vec):vec;
var i,j:integer;
    p:real;
    c:vec;
begin
  c:=c;
  for i:=1 to n do
  begin
    p:=b[bb[i]];
    for j:=1 to i-1 do p:=p-a[i,j]*c[j];
    c[i]:=p/a[i,i]
  end;
  for i:=n downto 1 do
  begin
    p:=c[i];
    for j:=i+1 to n do p:=p-a[i,j]*c[j];
    c[i]:=p
  end;
  resoutlu:=c
end;
function transpose(a:mat):mat;
var i,j:integer;
begin
  for i:=1 to n do
  for j:=1 to n do transpose[i,j]:=a[j,i]
end;
function invmat(a:mat):mat;
var i:integer;
    bb:veci;
    b:vec;
begin
  a:=transpose(a);
  decomplu(a,bb);
  for i:=1 to n do b[i]:=0;
  for i:=1 to n do
  begin
    b[i]:=1;
    invmat[i]:=resoutlu(a,bb,b);
    b[i]:=0
  end
end;

var a,b,c,ab,bc,ca:mat;
    v:vec;
    bb:veci;
    i,j:integer;
    f:text;
begin
  for i:=1 to n do
  for j:=1 to n do
  begin
    a[i,j]:=i*i-j*j+i xor j;
    b[i,j]:=i*i-j-i and j;
    c[i,j]:=i div j-j mod i
  end;
  write('a:');ecrmat(output,a);
  write('b:');ecrmat(output,b);
  write('c:');ecrmat(output,c);
  ab:=a*b;
  bc:=b*c;
  ca:=c*a;
  write('ab:');ecrmat(output,ab);
  write('bc:');ecrmat(output,bc);
  write('ca:');ecrmat(output,ca);
  writeln('|a*bc-ab*c|=',normem1(a*bc-ab*c));
  writeln('Tr(abc)=',trace(ab*c));
  writeln('Tr(bca)=',trace(bc*a));
  writeln('Tr(cab)=',trace(ca*b));
  for i:=1 to n do v[i]:=i*7 div 4;
  writeln('|a*(b*v)-ab*v|=',norme1(a*(b*v)-ab*v));
  writeln('|b*(c*v)-bc*v|=',norme1(b*(c*v)-bc*v));
  assign(f,'truc');
  rewrite(f);
  ecrmat(f,a);
  ecrmat(f,b);
  close(f);
  reset(f);
  lirmat(f,ab);
  lirmat(f,bc);
  close(f);
  write('|ab-a|=',normem1(ab-a),' ab=');ecrmat(output,ab);
  write('|bc-b|=',normem1(bc-b),' bc=');ecrmat(output,bc);
  write('  v= ');ecrvec(output,v);
  write('a*v= ');ecrvec(output,a*v);
  write('(1/a)*a*v= ');ecrvec(output,resoutgauss(a,a*v));
  ab:=a;
  decomplu(ab,bb);
  write('(1/a)*a*v= ');ecrvec(output,resoutlu(ab,bb,a*v));
  write('a*(1/a)='); ecrmat(output,a*invmat(a));
  readln
end.

Mercredi 31 mars 2004 : polynômes : addition, multiplication, degré

Mercredi 7 avril 2004 : polynômes : division, dérivée, méthode de Horner

const dmax=30;
type real=extended;
     poly=array[0..dmax] of real;
     poly2=record degre:integer;coeff:poly end;
procedure affpoly(a:poly);
var i:integer;
    x:real;
    nul:boolean;
begin
  nul:=true;
  for i:=dmax downto 0 do if a[i]<>0 then
  begin
    x:=a[i];
    if x<0     then write('-') else
    if not nul then write('+');
    x:=abs(x);
    if int(x)=x then if (x=1) and (i>0) then
                                        else write(x:0:0)
    else if x<1 then write(x:10)
                else write(x:0:6);
    case i of
      0:;
      1:write('X');
      2:write('X²');
      else write('X^',i)
    end;
    nul:=false
  end;
  if nul then write(0)
end;

function degre(a:poly):integer;
begin
  degre:=dmax;
  while (degre>=0) and (a[degre]=0) do degre:=degre-1
end;

procedure caldeg(var a:poly2);
begin
with a do while (degre>=0) and (coeff[degre]=0) do degre:=degre-1
end;

operator+(a,b:poly)c:poly;
var i:integer;
begin
  for i:=0 to dmax do c[i]:=a[i]+b[i]
end;

operator+(a,b:poly2)c:poly2;
var i:integer;
begin
  if a.degre<b.degre then c:=b+a else
  begin
    c:=a;
    for i:=0 to b.degre do c.coeff[i]:=a.coeff[i]-b.coeff[i];
    caldeg(c)
  end
end;

operator-(a,b:poly)c:poly;
var i:integer;
begin
  for i:=0 to dmax do c[i]:=a[i]-b[i]
end;

function min(a,b:integer):integer;
begin
  if a<b then min:=a
         else min:=b
end;

function max(a,b:integer):integer;
begin
  if a<b then max:=b
         else max:=a
end;

operator-(a,b:poly2)c:poly2;
var i:integer;
begin
  for i:=0 to min(a.degre,b.degre) do
  c.coeff[i]:=a.coeff[i]-b.coeff[i];
  c.degre:=max(a.degre,b.degre);
  for i:=a.degre+1 to c.degre do c.coeff[i]:=-b.coeff[i];
  for i:=b.degre+1 to c.degre do c.coeff[i]:= a.coeff[i];
  caldeg(c)
end;

operator*(a,b:poly)c:poly;
var i,j,da,db:integer;
begin
  da:=degre(a);
  db:=degre(b);
  if da+db>dmax then
  begin
    writeln('produit de degré trop élevé ',da,' + ',db);
    halt
  end;
  for i:=0 to dmax do c[i]:=0;
  for i:=0 to da do if a[i]<>0 then
  for j:=0 to db do c[i+j]:=c[i+j]+a[i]*b[j]
end;

operator*(a,b:poly2)c:poly2;
var i,j:integer;
begin
  if (a.degre=-1) or (b.degre=-1) then c.degre:=-1
                                  else c.degre:=a.degre+b.degre;
  if c.degre>dmax then
  begin
    writeln('produit de degré trop élevé ',a.degre,' + ',b.degre);
    halt
  end;
  for i:=0 to c.degre do c.coeff[i]:=0;
  for i:=0 to a.degre do if a.coeff[i]<>0 then
  for j:=0 to b.degre do
  c.coeff[i+j]:=c.coeff[i+j]+a.coeff[i]*b.coeff[j]
end;

procedure divpoly(a,b:poly;var q,r:poly);
var da,db,i:integer;
    p:real;
begin
  db:=degre(b);
  if db=-1 then
  begin
    writeln('division par 0');
    halt
  end;
  for i:=0 to dmax do q[i]:=0;
  for da:=degre(a) downto db do
  begin
    p:=a[da]/b[db];
    q[da-db]:=p;
    if p<>0 then
    for i:=da-db to da-1 do a[i]:=a[i]-p*b[i-da+db];
    a[da]:=0
  end;
  r:=a
end;

function pgcd(a,b:poly):poly;
var q,r:poly;
begin
  while degre(b)>=0 do
  begin
    divpoly(a,b,q,r);
    a:=b;
    b:=r
  end;
  pgcd:=a
end;

function val(a:poly;x:real):real;
var i:integer;
begin
  val:=0;
  for i:=dmax downto 0 do val:=val*x+a[i]
end;

function derivee(a:poly):poly;
var i:integer;
begin
  for i:=1 to dmax do derivee[i-1]:=i*a[i];
  derivee[dmax]:=0
end;

Mercredi 28 avril 2004 : méthode de Newton et décomposition LU

type fonc=function(x:real):real;

function newton(f,df:fonc;x:real):real;
var y:real;
begin
  repeat
    y:=x;
    x:=x-f(x)/df(x)
  until x=y;
  newton:=x
end;

function  f1(x:real):real; begin  f1:=sin(x)-0.7 end;
function df1(x:real):real; begin df1:=cos(x)     end;

function newtonpoly(p:poly;x:real):real;
var y,px,dpx:real;
    d,i:integer;
begin
  d:=degre(p);
  repeat
    y:=x;
    px:=0;
    dpx:=0;
    for i:=d downto 0 do
    begin
      dpx:=dpx*x+px;
       px:= px*x+p[i]
    end;
    x:=x-px/dpx
  until x=y;
  newtonpoly:=x
end;

var a,b,c:poly;
    i:integer;
    x:real;
begin
  for i:=0 to dmax do a[i]:=0;
  b:=a;
  c:=a;
  a[0]:=1; a[10]:=1; a[20]:=1;
  b[0]:=1; b[13]:=1; b[26]:=1;
  c[0]:=1; c[ 1]:=1; c[11]:=1;
  affpoly(pgcd(a,b)); writeln;
  x:=newton(@f1,@df1,0); writeln('sin(',x:0:18,')=',sin(  x):0:18);
  x:=newtonpoly(c   ,0); writeln('c  (',x:0:18,')=',val(c,x):0:18);
  readln
end.

Mercredi 5 mai 2004 : readkey

uses crt;
var c:char;
begin
  repeat
    c:=readkey;
    writeln(ord(c))
  until (c='q') or (c='Q') or (c=#3)
end.

uses crt;
begin
  while true do
  case upcase(readkey) of
    'A':writeln('alpha');
    'B':writeln('bravo');
    'C':writeln('charly');
    'D':writeln('delta');
    'E':writeln('echo');
    'F':writeln('fox-trot');
    'G':writeln('golf');
    'H':writeln('hotel');
    'I':writeln('india');
    'J':writeln('juliette');
    'K':writeln('kilo');
    'L':writeln('lima');
    'M':writeln('mike');
    'N':writeln('november');
    'O':writeln('oscar');
    'P':writeln('papa');
    'Q':begin writeln('quebec');halt end;
    'R':writeln('romeo');
    'S':writeln('sierra');
    'T':writeln('tango');
    'U':writeln('uniforme');
    'V':writeln('victor');
    'W':writeln('whisky');
    'X':writeln('x-ray');
    'Y':writeln('yankee');
    'Z':writeln('zoulou');
    '0':writeln('zero');
    '1':writeln('un');
    '2':writeln('deux');
    '3':writeln('trois');
    '4':writeln('quatre');
    '5':writeln('cinq');
    '6':writeln('six');
    '7':writeln('sept');
    '8':writeln('huit');
    '9':writeln('neuf');
    '+':writeln('plus');
    '-':writeln('moins');
    ',':writeln('virgule');
    ':':writeln('deux points');
    '''':writeln('apostrophe');
    '"':writeln('guillemet');
    '&':writeln('et commercial');
    #0:case readkey of
      #75:writeln('vers la gauche');
      #77:writeln('vers la droite');
      #72:writeln('vers le haut');
      #80:writeln('vers le bas');
      end;
    #3:begin writeln('ctrl C');halt end;
    #8:writeln('ctrl H ou backspace');
    #10:writeln('ctrl J ou <LF>(line feed)');
    #13:writeln('ctrl M ou <CR>(carriage return) ou entrée');
    #26:writeln('ctrl Z');
    #27:writeln('échappement');
    ' ':writeln('blanc');
    '=':writeln('égale');
  end  
end.

Mercredi 12 mai 2004 : fichiers binaires d'entiers

création d'un fichier

program creef1;
type fic=file of integer;
var f:fic;
    i,j:integer;
begin
  assign(f,'f1.int');
  rewrite(f);
  for i:=1 to 10 do
  begin
    j:=i*i+1;
    write(f,j)
  end;
  close(f)
end.

affichage sur l'écran d'un fichier existant

program afff1;
var f:file of integer;
    nom:string;
    j:integer;
begin
  write('Nom du fichier binaire d''entiers à afficher : ');
  readln(nom);
  assign(f,nom);
  reset(f);
  while not eof(f) do
  begin
    read(f,j);
    write(j,' ')
  end;
  close(f);
  readln
end.

modification de F1: mélange de read et write

program f1sur2;
var f:file of integer;
    j:integer;
begin
  assign(f,'f1.int');
  reset(f);
  while not eof(f) do
  begin
    read(f,j);
    j:=j+2;
    write(f,j)
  end;
  close(f);
  readln
end.

affichage à l'envers sur l'écran d'un fichier existant

program aff1f;
var f:file of integer;
    i,j:integer;
begin
  assign(f,'f1.int');
  reset(f);
  for i:=filesize(f)-1 downto 0 do
  begin
    seek(f,i);
    read(f,j);
    write(j,' ')
  end;
  close(f);
  readln
end.

concaténation de deux fichiers

program concat;
var f1,f2,f3:file of integer;
    nom:string;
    j:integer;
begin
  repeat
    write('Nom du premier fichier : ');
    readln(nom);
    assign(f1,nom);
    (*$i-*)
    reset(f1)
    (*$i+*)
  until ioresult=0;
  repeat
    write('Nom du deuxième fichier : ');
    readln(nom);
    assign(f2,nom);
    (*$i-*)
    reset(f2)
    (*$i+*)
  until ioresult=0;
  repeat
    write('Nom du fichier à créer : ');
    readln(nom);
    assign(f3,nom);
    (*$i-*)
    rewrite(f3)
    (*$i+*)
  until ioresult=0;
  while not eof(f1) do
  begin
    read(f1,j);
    write(f3,j)
  end;
  while not eof(f2) do
  begin
    read(f2,j);
    write(f3,j)
  end;
  close(f1);
  close(f2);
  close(f3);
  write('C''est fait.');
  readln
end.

C:\users\lpierre\freepascal>creef1

C:\users\lpierre\freepascal>afff1
Nom du fichier binaire d'entiers à afficher : f1.int
2 5 10 17 26 37 50 65 82 101

C:\users\lpierre\freepascal>copy f1.int f2.int
        1 fichier(s) copié(s).

C:\users\lpierre\freepascal>f1sur2


C:\users\lpierre\freepascal>afff1
Nom du fichier binaire d'entiers à afficher : f1.int
2 4 10 12 26 28 50 52 82 84

C:\users\lpierre\freepascal>aff1f
84 82 52 50 28 26 12 10 4 2

C:\users\lpierre\freepascal>concat
Nom du premier fichier : f1.int
Nom du deuxième fichier : f2.int
Nom du fichier à créer : f12.int
C'est fait.

C:\users\lpierre\freepascal>afff1
Nom du fichier binaire d'entiers à afficher : f12.int
2 4 10 12 26 28 50 52 82 84 2 5 10 17 26 37 50 65 82 101

Mercredi 19 mai 2004 : fichier binaire de records, carnet d'adresses

procedure assign(var f:file of ...;nom:string);

procedure reset(var f:file of ...);
procedure rewrite(var f:file of ...);
procedure append(var f:file of ...);

procedure read(var f:file of element;var x:element);
procedure write(var f:file of element;var x:element);

function eof(var f:file of ...):boolean;
function filepos(var f:file of ...):integer;
function filesize(var f:file of ...):integer;
procedure seek(var f:file of ...;p:integer);

procedure truncate(var f:file of ...);

procedure close(var f:file of ...);

uses crt;
type personne=record
                nom,prenom:string[30];
		age:integer;
		portable,maison,boulot:string[10];
		adresse:string[100];
		codepostal:longint
              end;
var f:file of personne;

procedure ouvrir;
var nom:string;
begin
  repeat
    write('nom du fichier : ');
    readln(nom);
    assign(f,nom);
    (*$i+*)
    reset(f);
    if ioresult<>0 then rewrite(f)
    (*$i-*)
  until ioresult=0
end;

procedure precedent;
begin
  if filepos(f)>0 then seek(f,filepos(f)-1)
end;

procedure suivant;
begin
  if not eof(f) then seek(f,filepos(f)+1)
end;

procedure aff;
var p:personne;
begin
  if eof(f) then exit;
  read(f,p); precedent;
  writeln('Nom    : ',p.nom);
  writeln('Prénom : ',p.prenom);
  writeln('Age    : ',p.age);
  writeln('Numéro de téléphone portable    : ',p.portable);
  writeln('Numéro de téléphone à la maison : ',p.maison);
  writeln('Numéro de téléphone au travail  : ',p.boulot);
  writeln('Adresse : ',p.adresse);
  writeln('Code postal : ',p.codepostal)
end;

procedure creer;
var p:personne;
begin
  write('Nom    : ');readln(p.nom);
  write('Prénom : ');readln(p.prenom);
  repeat
    (*$i+*)
    write('Age    : ');readln(p.age)
    (*$i-*)
  until ioresult=0;
  write('Numéro de téléphone portable    : ');readln(p.portable);
  write('Numéro de téléphone à la maison : ');readln(p.maison);
  write('Numéro de téléphone au travail  : ');readln(p.boulot);
  write('Adresse : ');readln(p.adresse);
  repeat
    (*$i+*)
    write('Code postal : ');readln(p.codepostal)
    (*$i-*)
  until ioresult=0;
  seek(f,filesize(f));
  write(f,p);
  precedent
end;

procedure supprimer;
var p:personne;
    i:integer;
    c:char;
begin
  if eof(f) then exit;
  aff;
  write('Voulez vous le supprimer ?');
  readln(c);
  if upcase(c)<>'O' then exit;
  i:=filepos(f);
  seek(f,filesize(f)-1);
  read(f,p);
  seek(f,i);
  write(f,p);
  seek(f,filesize(f)-1);
  truncate(f);
  seek(f,i)
end;

procedure cherchenom;
var p:personne;
    nom:string;
    c:char;
begin
  write('Quel nom cherche-t-on ? ');
  readln(nom);
  seek(f,0);
  while not eof(f) do
  begin
    read(f,p);
    if pos(nom,p.nom)<>0 then
    begin
      precedent; aff;
      write('Est-ce la bonne personne ? ');
      readln(c);
      if upcase(c)='O' then exit;
      suivant
    end
  end
end;

procedure modifier;
begin
  (* à compléter *)
end;

begin
  ouvrir;
  while true do
  case upcase(readkey) of
    'P':precedent;
    'S':suivant;
    'A':aff;
    'C':creer;
    'E':supprimer;
    'M':modifier;
    'N':cherchenom;
    'Q':begin close(f); exit end;
    else writeln('Précédent Suivant Afficher Creer Effacer Modifier chercheNom Quitter')
  end
end.

Mercredi 26 mai 2004 : reorésentation des entiers et variantes de case

type byte=0..255;
     shortint=-128..127;
     word=0..65535;
     integer=-32768..32767;
     longint=-2147483648..2147483647;

var a:packed record
      case integer of
        0:(l:longint);
        1:(w0:word; w1:integer);
        2:(b0,b1,b2:byte;
           case boolean of
             false:(b3:byte);
             true :(s3:shortint)
          );
        3:(c0,c1,c2,c3:char)
      end;
begin
  a.l:=-1;
  writeln(a.l);
  writeln(a.w0:10,a.w1:10);
  writeln(a.b0:5,a.b1:5,a.b2:5,a.b3:5,'/',a.s3);
  a.l:=530;
  writeln(a.l);
  writeln(a.w0:10,a.w1:10);
  writeln(a.b0:5,a.b1:5,a.b2:5,a.b3:5,'/',a.s3);
  a.c0:='A';
  writeln(a.l);
  writeln(a.w0:10,a.w1:10);
  writeln(a.b0:5,a.b1:5,a.b2:5,a.b3:5,'/',a.s3);
  a.w1:=1000;
  writeln(a.l);
  writeln(a.w0:10,a.w1:10);
  writeln(a.b0:5,a.b1:5,a.b2:5,a.b3:5,'/',a.s3);
  readln
end.

---------l---------
----wO--- ----w1---
               -s3-
-b0- -b1- -b2- -b3- 
-c0- -c1- -c2- -c3- 

-1
     65535        -1
  255  255  255  255/-1
530
       530         0
   18    2    0    0/0
577
       577         0
   65    2    0    0/0
65536577
       577      1000
   65    2  232    3/3