Série de révision n°1

Voila ma proposition
Sujet 1

uses wincrt ;
var
n, m : Byte ;
R : Integer ;

{'+---------- Procédure Lecture -----------+'}

Procedure Lecture( var n : Byte );
Begin
Repeat
Write('Entrer un entier de deux chiffres : ') ;
Readln(n) ;
Until (n >= 10) AND (n <=99) ;
End ;


{'+---------- fonction construire -----------+'}
function Construire (n, m : byte) : Integer ;
begin
Construire := (m div 10)*1000 + (n div 10)*100 + (n mod 10)*10+ m mod 10 ;
end ;


{'+---------- programme principal -----------+'}
begin
Lecture(m) ;
Lecture(n) ;
R:= Construire(n,m) ;
writeln('L''entier résultat est : ', R);
End.

voila un exemple d'exécution


Sujet 2

Voila un exemple d'exécution

Sujet 3
uses wincrt;
Var
ch1,ch2:string;
{+---procedure qui fait le controle de saisie de chaine---+}
procedure saisie(var x:string);
begin
repeat
Write('entre une chaine non vide:');
Readln(x);
until (x<>'');
end;
{+---proceure qui cherche si le deux chaine snt anagramme---+}
procedure anagramme (x,y : string);
Var
i,j:integer;
stop:boolean;
begin
i:=1;
repeat
stop:= false; j:=1;
repeat
writeln(stop);if ch1[i]= ch2[j] then
begin
stop:= true; writeln(stop);
end
else j:=j+1; writeln(stop);
until (j>=length(ch2)) or (stop=true);
if stop= true then
i:=i+1
else
Write(ch2,' n''est pas un anagramme de ',ch1);
until(stop= false) or(i>=length(ch1));
if stop=true then
Write(ch2,' est un anagramme de ',ch1);
end;
{+---debut du programme principal---+}
begin
saisie(ch1);
saisie(ch2);
anagramme(ch1,ch2);
end.

Très bien Takwa

J'ai dis que le fait que chaque caractère de CH1 figure dans CH2 est insuffisant pour qu'ils soient anagramme l'une de l'autre. En effet chaque caractère de CH1 doit figurer en un même nombre de fois dans CH1 que dans CH2. Pour corriger ton idée j'ai supprimé de CH2 chaque caractère de de CH1 qu'on vérifier son existence dans CH2.

Voila ma solution

uses wincrt;
Var
ch1,ch2:string;
{+---procedure qui fait le controle de saisie de chaine---+}
procedure saisie(var x:string);
begin
repeat
Write('entre une chaine non vide:');
Readln(x);
until (x<>'');
end;
{+---proceure qui cherche si le deux chaine snt anagramme---+}
procedure anagramme (ch1,ch2 : string);
Var
i,j:integer;
stop:boolean;
ch : string ;
begin
i:=1;
ch:= ch2 ;
repeat
stop:= false; j:=1;
repeat
if ch1[i]= ch2[j] then
begin
stop:= true; delete(Ch2,j,1);
end
else j:=j+1;
until (j>length(ch2)) or (stop=true);
if stop= true then
i:=i+1
else
Write(ch,' n''est pas une anagramme de ',ch1);
until(stop= false) or(i>=length(ch1));
if stop=true then
Write(ch,' est une anagramme de ',ch1);
end;
{+---debut du programme principal---+}
begin
saisie(ch1);
saisie(ch2);
writeln('+---------------------------------+');
anagramme(ch1,ch2);
end.

Voila aussi deux exemples d'exécution de ton programme

Sujet 2
uses wincrt;
Var
a,b:integer;
procedure saisie (var x,y: integer);
begin
repeat
write('entre un entier>=2 et < à50:');
readln(x);
until (x>=2) and (x<50);
repeat
write('entre un entier<=50:');
readln(y);
until(y<=50) and (y>x);
end;
procedure rest1(x,y:integer);
Var
r,i,p:integer;
begin
for i:=x to y do
begin
r:=i;
p:=0;
repeat
if r mod 2=0 then
begin
r:=r div 2 ;
p:=p+1;
end
else
begin
r:=r*3+1;
p:=p+1;
end;
until (r=1) or (p>=i);
if r=1 then
writeln(i);
end;
end;
begin
saisie(a,b);
rest1(a,b);
end.

Bien Takwa la solution est claire et l'application est fonctionnelle.
Bon courage

Sujet 4

Uses Wincrt;
Type
tab=array[0..20]of real;
Var
n:integer;
t:tab;
{+---procedure qui controle le nombre des eleves----+}
procedure saisie (Var x:integer);
begin
repeat
Write('entre le nombre des eleves:');
readln(x);
until (10<=x) and (x<=30);
end;
{+---procedure qui remlit le tableau---+}
procedure tableau_moyenne( Var t:tab;x:integer);
Var
i:integer;
begin
for i:=1 to x do
repeat
Write('entrer le moyenne de l''eleve ',i,':');
Readln(t[i]);
Until (0<=t[i]) and (t[i]>=20);
end;
{Procedure qui determine le moyenne de la classe ainsi que le nombre des eleves ayant un moyenne supereur ou egal à lui meme}
Procedure moyenne_classe_sup (t:tab;n:integer);
Var
mc:real;
i,p:integer;
begin
mc:=0;
for i:=1 to n do
begin
mc:=mc+t[i];
end;
p:=0;
for i:=1 to n do
begin
if t[i]>=mc then
p:=p+1;
end;
Writeln('le nombre des eleves qui ont un moyenne superieur ou egale a la moyenne de classe ',mc,' est:',p);
end;
{+---debut de programme principale---+}
begin
saisie(n);
tableau_moyenne(t,n);
moyenne_classe_sup(t,n);
end.

Bon la solution comporte quelques erreurs qui sont corrigés et signalés en rouge.

Uses Wincrt;
Type
tab = array[1..30] of real; {premier T[1] et dernier on choisit la valeur max de n }
Var
n, P : integer;
t : tab;
mc : Real ;

{+---procedure qui saisit le nombre d' élèves----+}
procedure saisie (Var x : integer);
begin
repeat
Write('Entrer le nombre d''élèves : ');
readln(x);
until (10<=x) and (x<=30);
end;

{+---procedure qui remlit le tableau---+}
procedure tableau_moyenne( Var t : tab ; x : integer);
Var
i : integer;
begin
for i:=1 to x do
repeat
Write('Entrer la moyenne de l''eleve ',i,' : ');
Readln(t[i]);
Until (0<=t[i]) and (t[i]<=20) ; {moyenne entre 0 et 20}
End ;
{Procedure qui determine la moyenne de la classe ainsi que le nombre d'élèves ayant un moyenne superieure à la moyenne de la classe}
Procedure moyenne_classe_sup (t : tab ; n : integer ; Var mc : real ; Var P: integer);
Var
{mc et P doivent être rétourner au programme}
i : integer;
begin
mc:= 0 ;
for i:=1 to n do
begin
mc:= mc+t[i]/n ;
end ;
p:= 0 ;
for i:=1 to n do
begin
if t[i]>=mc then p:= p+1 ;
end ;
Writeln('+------------------------------------------------+');
writeln('La moyenne de la classe est : ', mc:5:2);
Writeln('Le nombre d''élèves qui ont un moyenne >= la moyenne de classe est : ',p);
end;
{+---début de programme principale---+}
Begin
saisie(n);
tableau_moyenne(t,n);
moyenne_classe_sup(t,n,mc,p);
End.

Sujet 5

Uses Wincrt;
Var
n:integer;
{+---Procedure qui controle le nombre donne---+}
Procedure saisie (x:integer);
Begin
Repeat
Write ('entre un nombre parmi 0,1 et 2:');
Readln(x);
Until (0<=x)and(x<=2);
end;
{+---Procedure qui affiche le joueur gagneant---+}
Procedure points(x:integer);
Var
o,po,pu,d:integer;
begin
Repeat
o:=random(3);
d:=abs(o-x);
if d=2 then
if o>x then
po:=po+1
else pu:=pu+1
else if d=1 then
if o>x then
pu:=pu+1;
Until(pu=10)
or (po=10);
if pu=10 then
Writeln('Vous avez gagne le jeu')
else Writeln('l''ordinzteur a gagnee le jeu');
end;
{+---Debut programme principal---+}
Begin
saisie(n);
points(n);
end.

Cette solution comporte aussi quelques petits erreurs qui sont corrigé et signalés en rouge

Uses Wincrt;
Var
n:integer;

{+---Procedure qui saisit le choix de l'utilisateur ---+}
Procedure saisie (VAR x: integer);
Begin
Repeat
Write ('Entrer un nombre parmi 0,1 et 2:');
Readln(x);
Until (0<=x)and(x<=2);
end;
{+---Procedure qui simule le jeu et affiche le joueur gagneant---+}
Procedure points ; {la procédure va faire tout donc elle n'a besoin d'aucune donnée}
Var
o,po,pu,d, x:integer;
begin
po:=0 ; pu := 0 ;
Repeat
randomize ;
o:=random(3);
saisie(x) ;
d:=abs(o-x);
if d=2 then if o>x then po:=po+1
else pu:=pu+1
else if d=1 then
if o>x then pu:=pu+1
Else po:= po + 1 ;
writeln('po=',po,' pu =',pu);
Until(pu=10) or (po=10);

if pu=10 then
Writeln('Vous avez gagné ')
else Writeln('l''ordinateur a gagné ');
end;
{+---Debut programme principal---+}
Begin
points ;
end.
voici un exemple d'exécution du programme

Sujet 6 : Lundi 22 mai 9 h

Uses Wincrt;
Var
n,max:integer;
{+---Procedure qui controle le nombre donne---+}
Procedure entiers (Var x,y:integer);
Begin
Repeat
Write ('entre un entier:');
Readln(x);
Until (2<=x)and(x<=9);
Repeat
Write ('entre un entier:');
Readln(y);
Until (10<=y)and(y<=99);
end;
{+---Procedure qui chercher et affiche les multiple---+}
Procedure multiple(x,y:integer);
Var
i,u,d:integer;
begin
for i:=1 to y do
Begin
if i mod x=0 then
Write('*')
else if i mod 10=x then
Write(i)
else u:=i mod 10;
if u=x then
Write('*')
else d:=i div 10;
if d=x then
Write ('*')
else Write(i);
end;
end;
{+---Debut programme principal---+}
Begin
entiers(n,max);
multiple(n,max);
end.

Bon la solution comporte certains erreurs
voila la version corrigée

Uses Wincrt;
Var
n,max:integer;

{+---Procedure qui fait la saise controlée de deux entiers ---+}
Procedure entiers (Var x,y:integer);
Begin
Repeat
Write ('Entrer un entier entre 2 et 9 :');
Readln(x);
Until (2<=x)and(x<=9);
Repeat
Write ('Entrer un entier entre 10 et 99 :');
Readln(y);
Until (10<=y)and(y<=99);
end;

{+---Procedure qui fait l'affichage demandé ---+}
Procedure multiple(x, y : integer);
Var
i : integer;
begin
for i:=1 to y do
Begin
if i mod x=0 then Write('* ')
else if (i mod 10=x)OR(i div 10 = x) then Write('* ')
else Write(i,' ');
end;
end;

{+---Debut programme principal---+}
Begin
entiers(n,max);
writeln('+------------------------------------+');
multiple(n,max);
End.
Bon Travail

Bonjour TLM
Voila une autre solution de Sujet 3 : Samedi 18 mai

Uses Wincrt ;
Var
mot1, mot2 : String ;

{'+---------- Procédure lecture -----------+'}
Procedure SAISIE (Var CH : String) ;
Begin
repeat
write('Entrer une chaîne non vide : ');
readln(CH) ;
Until CH <> '' ;
End;

{'+---------- Function Occurrence d'un caractère dans une chaîne -----------+'}
Function OCC (C : Char ; CH : String) : Integer ;
VAR
R, i : Integer ;

Begin
R:= 0 ;
For i:= 1 to Length(CH) do
If c=ch[i] then r:= r+1;
OCC:= R ;
End;

{'+---------- Function Anagramme -----------+'}
Function Anagramme (CH1 , CH2 : String) : boolean;
VAR
i : Integer ;
R : boolean ;
Begin
IF length(CH1) <> Length(CH2) Then R:= False
Else
Begin
i:= 1 ;
{Tant que l'occurence de CH1[i] est la même dans CH1 que dans CH2 on passe au caractère suivant}
While (OCC(Ch1[i], CH1) = OCC(CH1[i], CH2)) AND (i <= Length(CH1)) DO i:= i+1 ;
IF i > Length(CH1) Then R :=True;
{Si i > long(CH1) alors tous les caractères de CH1 on la même occurrence dans CH1 que dans CH2}
End;
Anagramme:= R ;
End ;
{'+---------- Programme principal -----------+'}
Begin
SAISIE(MOT1);
SAISIE(MOT2) ;
IF Anagramme(Mot1, Mot2) Then writeln(mot1, ' est une anagramme de ', mot2)
Else writeln(mot1,' n''est pas une anagramme de ',mot2) ;
End.

Voila une autre solution au sujet 5 : 18 mai 14 h

Uses wincrt ;
Var
SCORORD, SCORUTUL : Byte ;

{+--- Procédure qui saisit le choix de l'utilisateur ---+}
Procedure CHOIUT (VAR n: Byte ) ;
Begin
Repeat
Write ('Entrer votre choix : 0, 1 ou 2 : ');
Readln(n);
Until n IN [0..2] ;
end;

{+---Procédure qui simule le jeu ---+}
Procedure JEU (Var Scorut, scorord : Byte );
Var
O, U : Byte ;
begin

Scorut:=0 ; Scorord := 0 ;
Repeat
randomize ;
O:=random(3);
CHOIUT(U) ;

if ABS(O-U) = 2 then
Begin
if O > U Then Scorord := scorord + 1 ;
IF U > O Then Scorut := scorut+1 ;
End
Else if ABS(O-U) = 1 then
Begin
if O < U Then Scorord := Scorord + 1 ;
if U < O Then Scorut := scorut + 1 ;
End;
writeln('+=================================================+') ;
writeln('Score ordinateur =',scorord,' Score utilisateur = ', scorut);

Until(scorut = 10) or (scorord = 10);

End;

{+--- programme principal---+}
Begin
Jeu(Scorutul, Scorord);
If Scorutul = 10 Then Writeln(' Bien joué tu as gagné')
Else writeln('C''est moi le gagnant');
End.
Voila aussi un exemple d'exécution

Sujet 9 : 20 mai 15h 30

uses wincrt;
type
tableau=array[1..20] of integer;
var
t:tableau;n,i,j:byte;

{+------------ procédure Saisie -----------+}

procedure saisie (var t :tableau ; var n : byte) ;
var
i : byte ;
begin
repeat
write('entrer un entier n strictement positif : ') ;
readln(n);
until n in [2..20] ;

for i:=1 to n do
repeat
write('entrer t[',i,']: ');readln(t[i]);
until t[i]>0;
end;

{+-------------- procédure affiche -----------+}

procedure affiche(var t:tableau; n:byte);
var
i, j : byte;
begin
for i :=1 to n-1 do
if t[i]<>0 then
for j:=i+1 to n do
if t[i] = t[j] then t[j] := 0;

i:=1;
while (t[i]<>0) and (i<=n) do
i:=i+1 ;

for j := i+1 to n do
if t[j] <>0 then
begin
t[i]:=t[j];
i:=i+1;
t[j]:=0;
end;
writeln('le nombre d''élèments différent est ', i-1);
end;

{+-------------- programme principal -----------+}

begin
saisie(t,n);
affiche(t,n);
end.

Sujet 10 : 21 mai 9h

uses wincrt;
VAR
Phrase, InvPhrase : String ;

{+-------------- procédure lecture -----------+}

procedure saisie (var CH : string) ;
begin
repeat
write('Entrer une phrase : ') ;
readln(CH);
until (Upcase(CH[1])in ['A'..'Z']) AND( Pos(' ', CH) = 0) ;
End;

{+-------------- Fonction Inverse -----------+}

Function Inverse(CH : String) : String ;
var
R , Mot : String ;
P : Byte ;
begin
P:= Pos(' ', CH) ; R:= '' ;

While p <> 0 do
Begin
Mot:= Copy(Ch,1,p-1) ;
R := ' ' + Mot + R;
Delete(CH,1, p) ;
P:= Pos(' ' , CH) ;
End ;
Inverse := CH + R ;
end;

{+-------------- programme principal -----------+}

begin
saisie(Phrase);
InvPhrase:= Inverse(Phrase);
Writeln('L''inverse de la phrase est : ' , InvPhrase);
end.

Sujet 11 : 21 mai 10 h 30

uses wincrt;
var i,max, n,m:integer;

{############# procédure lecture #####################}
procedure lecture (var n,m:integer);
begin
repeat
write ('entrer un entier :');
readln(m);
until (m>=5)and (m<100);
repeat
write ('entrer un entier :');
readln(n);
until (n>m)and (n<=100);

end;
{############# fonctoin nbr diviseur ####################}
function nbdiv (x:integer):integer;
var nbd,i:integer;
begin
nbd:=2;
for i:=2 to x div 2 do
if x mod i =0 then nbd:=nbd +1;
nbdiv:=nbd;
end;

{############## programme principal##################}
begin
lecture(n,m);
max:=2;
for i:=m to n do
if nbdiv(i)>max then max:= nbdiv(i);

for i:=m to n do
if nbdiv(i)=max then writeln(i);
end.

Pour ajouter une solution ou une question Cliquer sur répondre puis taper votre votre texte dans la zone de saisie et enfin cliquer sur envoyer.

est ce que le type d'une fonction peut etre booléen ?

program sujet1;
uses wincrt ;
var m,n: byte; r: string;
procedure lecture(var k : byte);
begin
repeat write('entrer un entier a 2 chiffres: ');
read(k);
until (k>=10) and (k<=99);
end;
function intercaler (n , m: byte ):string;
var ch1,ch2:string ;
begin

str(m,ch1);
str(n,ch2);
insert (ch2,ch1,2);
write('l''entier est: ',ch1) ;
end;
begin
lecture(n);
lecture(m);
r:= intercaler(m,n);

end.

Pour Hanine Bien sur que oui la fonction peut retourner une valeur booléenne
Pour Asma la solution est correcte mais de préférence la fonction n'affiche pas le résultat ou vous aurais dû la déclarer comme procédure en tout elle donne la bonne solution.