1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
| program unique;
uses wincrt;
type
x=array [1..50] of string;
y=array [1..50] of integer;
var
t1;
t2:y;
i,n:integer;
procedure saisir(var n:integer;var t1);
var
i:integer;
begin
repeat
writeln('donner n ');
readln(n);
until n in [3..50];
for i := 1 to n do
begin
repeat
writeln('donner t1[',i, ']');
readln(t1[i]);
until length(t1[i]) in [1..30];
end;
{for i:=1 to n do
writeln(t1[i]); }
end;
function nb_occ (c:char;b:string):integer;
var
i,nbc:integer;
begin
nbc:=0;
for i:= 1 to length(b) do
begin
if b[i] =c then
nbc:=nbc+1;
end;
nb_occ:=nbc;
end;
procedure remplir(n:integer;t1;var t2:y);
var
occ,i,j,nb:integer;
ch:string;
begin
writeln('***************************');
nb:=0;
for i := 1 to n do
begin
ch:= t1[i];
for j := 1 to n do
begin
if nb_occ(ch[j],ch) =1 then
nb:= nb +1;
end;
t2[i]:= nb;
end;
end;
begin{pp}
saisir(n,t1);
remplir(n,t1,t2);
for i:= 1 to n do
writeln (t2[i]);
end. |
Partager