ЗАДАЧИ ПО ИНФОРМАТИКЕ
uses crt;
var n,i,a,q,w,s,e:integer; r,s1:string;
h1, pi, pa,pq,pw,ps,pe, h:real;
begin clrscr;
r:='aqwseaeswaqeawseqweasesaeseeewawwqwwesassea';
a:=0;q:=0;w:=0;s:=0;e:=0;n:=30;
for i:=1 to length(r) do begin
if r[i]='a' then a:=a+1;
if r[i]='q' then q:=q+1;
if r[i]='w' then w:=w+1;
if r[i]='s' then s:=s+1;
if r[i]='e' then e:=e+1;
end;
Writeln ('буква а встречается ',a,' раз');
Writeln ('буква q встречается ',q,' раз');
Writeln ('буква w встречается ',w,' раз');
Writeln ('буква s встречается ',s,' раз');
Writeln ('буква e встречается ',e,' раз');
pa:=a/N; pq:=q/N; pw:=w/n; ps:=s/n; pe:=e/n;
Writeln ('Pa=',pa);Writeln ('Pq=',pq);Writeln ('Pw=',pw);
Writeln ('Ps=',ps);Writeln ('Pe=',pe);
h1:=-30*(((pa*(ln(pa+0.001)/ln(2)))+(pq*(ln(pq+0.0000001)/ln(2)))));
h:=h1-30*((pw*(ln(pw+0.001)/ln(2)))+(ps*(ln(ps+0.001)/ln(2)))+
(pe*(ln(pe+0.001)/ln(2))));
writeln('H=',h); readkey;
end.
Кодирование и декодирование сообщения
uses crt;
var f,s,a,b:string; i,k:integer; x:real;
begin clrscr;
s:='aaabbcbddeeebbcadeaabbddeeffgh';
writeln(s); b:='';
for i:=1 to length(s) do begin
a:=s[i];
if a='a' then b:=b+'000';
if a='b' then b:=b+'001';
if a='c' then b:=b+'010';
if a='d' then b:=b+'011';
if a='e' then b:=b+'100';
if a='f' then b:=b+'101';
if a='g' then b:=b+'110';
if a='h' then b:=b+'111'; end;
write(b); writeln; randomize; s:='';
for i:=1 to length(b) do begin
f:=copy(b,3*i-2,3);
if f='000' then s:=s+'a';
if f='001' then s:=s+'b';
if f='010' then s:=s+'c';
if f='011' then s:=s+'d';
if f='100' then s:=s+'e';
if f='101' then s:=s+'f';
if f='110' then s:=s+'g';
if f='111' then s:=s+'h'; end;
write(s); readln;
end.
uses Crt;
var aa1,aa,y,z,zz,x1,x : string;
i : byte; s,k,p : real;
Begin clrscr;
writeln('Исходное сообщение: ');
aa1:='101010101010101010101010101010101010101010101010101010';
writeln(aa1); writeln('Задайте вероятность ошибки: ');
readln(p);
for i:=1 to length(aa1) do begin
x:=copy(aa1,i,1);
if x='0' then y:='000';
if x='1' then y:='111';
z:=z+y;
end;
writeln('Закодированное сообщение: '); writeln(z);
randomize; zz:='';
for i:=1 to length(z) do begin
s:=random(1000)/1000;
if (s=p then zz:=zz+z[i];
end;
writeln('Сообщение с ошибкой: '); writeln(zz);
aa:=''; i:=1;
while i < length(zz) do begin
x:=copy(zz,i,3);
if x='000' then y:='0';
if x='001' then y:='0';
if x='010' then y:='0';
if x='011' then y:='1';
if x='100' then y:='0';
if x='101' then y:='1';
if x='110' then y:='1';
if x='111' then y:='1';
aa:=aa+y; i:=i+3;
end;
writeln('Декодированное сообщение: '); writeln(aa);
for i:=1 to length(aa) do begin
x1:=copy(aa1,i,1);
x:=copy(aa,i,1);
if x1<>x then k:=k+1;
end; k:=k/length(aa);
writeln('Относительное количество ошибок: ',k); readln;
End.
uses crt; {Вставляет бит четности, вносит ошибки, и находит ошибку}
var s,s1,a,a1,b,b1,p,f:string;
i,i1,j,j1,k,k1,q,q1,n,x,x1:integer; w:real;
begin clrscr; n:=49; s1:='';
s:='001010010111011000101010101001010110010010';
writeln('Исходное сообщение');
writeln(s); k:=round(length(s)/7);
writeln('Сообщение с битом четности');
for i:=1 to k do
begin a:=copy(s,7*i-6,7); q:=round(length(a)/7);
for j:=1 to q do
begin x:=0; b:=copy(a,j-1,1);
If b='1' then x:=x+1; end;
if (x mod 2)=0 then a:=a+'0'
else a:=a+'1'; write(a); s1:=s1+a; f:=s1; end;
writeln; randomize;
for i:=1 to length(f) do
begin w:=random(100)/100;
if (w<0.1) and (s1[i]='1') then s1[i]:='0';
if (w<0.1) and (s1[i]='0') then s1[i]:='1'; end;
writeln('Сообщение с ошибкой'); writeln(s1); readln;
end.
Оцифровка сигнала и его восстановление
uses crt, Graph;
var i: integer; A, b, nev, nevyazka : real;
u:array[1..100]of integer;
begin clrscr;
For i:=1 to 100 do u[i]:=round(512*exp(-0.05*i));
For i:=1 to 100 do write(u[i],' ');
A:=100; b:=0.001; {начальные значения A и b}
Repeat
nevyazka:=0; {найдем начальную невязку}
for i:=1 to 100 do nevyazka:=nevyazka+abs(u[i]-A*exp(-b*i));
A:=A+0.5; {приращение A}
nev:=0; {снова найдем невязку}
for i:=1 to 100 do nev:=nev+abs(u[i]-A*exp(-b*i));
if nev>nevyazka then A:=A-0.5; {сравним и изменим A}
{---- то же самое для b ---}
nevyazka:=0;
for i:=1 to 100 do nevyazka:=nevyazka+abs(u[i]-A*exp(-b*i));
b:=b+0.00001;
nev:=0;
for i:=1 to 100 do nev:=nev+abs(u[i]-A*exp(-b*i));
if nev>nevyazka then b:=b-0.00001;
{----------------------------}
writeln(A,' ', b,' ',nevyazka); {вывод на экран}
until nevyazka<0.1;
Repeat until KeyPressed;
end. {программа работает 1-2 минуты}
Модель нейрона. Нейросеть
Логические задачи
А: монета греческая, 5 век;
Б: монета испанская, 3 век;
В: монета не греческая, 4 век;
Каждый из археологов прав только в одном из двух предположений. Где и когда была выпущена монета?
Решение:
Обозначим простые высказывания:
G - монета греческая, I - монета испанская, P - 5 век, C - четвертый век,
T - третий век.
Высказывания:
G not(P) + not(G) P = 1,
I not(T) + not(I) T = 1,
not(G) not(C) + G C = 1,
Монета не может быть изготовлена в двух государствах и
двух веках:
GI=0, PC=0, PT=0, CT=0.
Необходимо написать программу, в которой перебираются все варианты
и автоматически находится приемлемый.
uses crt; var G,P,I,T,C:boolean; gg,pp,tt,cc,ii,k,l,m,n,o:integer; begin clrscr; k:=0; for gg:=0 to 1 do begin if gg=0 then g:=false else g:=true; for pp:=0 to 1 do begin if pp=0 then p:=false else p:=true; for tt:=0 to 1 do begin if tt=0 then t:=false else t:=true; for cc:=0 to 1 do begin if cc=0 then c:=false else c:=true; for ii:=0 to 1 do begin if ii=0 then i:=false else i:=true; if ((g)and(not(p))or(not(g)and(p))=true) then k:=k+1; if ((i)and(not(t)))or(not(i)and(t))=true then k:=k+1; if (not(g)and(not(c)))or((g)and(c))=true then k:=k+1; if(g)and(i)=false then k:=k+1; if(p)and(c)=false then k:=k+1; if(p)and(t)=false then k:=k+1; if(c)and(t)=false then k:=k+1; writeln(g,' ',p,' ',t,' ',c,' ',i,' ',k,' '); k:=0; end;end;end;end;end; writeln(k);readkey; end.
uses crt; {ЖИЗНЬ --- 2007}
const N=26;
type z1=record x,y,xy,x1,y1:real end;
massiv = array[-1..N+1,-1..N+1] of integer;
var z,y,x,x1: massiv; s,i,j,k,l,m:integer;
procedure Print; {++++++++++++++++++++++++++++++++++++}
var i,j:integer;
begin clrscr;
For i:=1 to N do Begin
For j:=1 to N do Begin
If x[i,j]=1 then Write(' * ');
If x[i,j]=0 then Write(' ');
end; Writeln; end;
end; {+++++++++++++++++++++++++++++++++++++++++++++++}
procedure Oboznach; {++++++++++++++++++++++++++++++++}
var i,j:integer;
begin
For i:=1 to N do Begin
For j:=1 to N do x1[i,j]:=x[i,j]; end;
end;{++++++++++++++++++++++++++++++++++++++++++++++++}
procedure Raschet; {++++++++++++++++++++++++++++++++++}
var i,j:integer;
begin
For i:=1 to N do For j:=1 to N do
Begin
S:=x1[i-1,j-1]+x1[i-1,j]+x1[i-1,j+1]+x1[i,j-1]+
x1[i,j+1]+x1[i+1,j-1]+x1[i+1,j]+x1[i+1,j+1];
if s=3 then x[i,j]:=1;
If (s<2)or(s>3) then x[i,j]:=0;
end;end;
{---------ПРОГРАММА----------}
Begin {Начальные условия ------------------------------}
For i:=-1 to N+1 do For j:=-1 to N+1 do x[i,j]:=0;
{x[14,18]:=1; x[14,17]:=1; x[14,16]:=1; x[14,15]:=1;}
{x[14,17]:=1; x[14,16]:=1; x[14,15]:=1;}
{x[14,17]:=1; x[14,16]:=1; x[14,15]:=1; x[13,15]:=1; x[12,16]:=1;}
{x[15,13]:=1; x[15,14]:=1; x[15,15]:=1; x[16,14]:=1;}
{x[14,17]:=1; x[14,16]:=1; x[14,15]:=1;
x[15,16]:=1; x[15,15]:=1; x[15,14]:=1;}
x[14,17]:=1; x[14,16]:=1; x[14,15]:=1;
x[15,16]:=1; x[15,15]:=1; x[15,14]:=1;
x[14,10]:=1; x[14,11]:=1; x[14,12]:=1;
x[15,11]:=1; x[15,15]:=1; x[15,13]:=1;
{-------------------------------------------------------}
Print;
Repeat delay(6000); Oboznach; Raschet; Print;
until keypressed;
End.
uses crt;
var i:integer;x,S,a,b,c,y:string;
q:integer; label 1;
BEGIN clrscr;
S:='abacaaacccbbb';writeln('S=',S);q:=1;
for i:=1 to length(S) do begin
x:=copy(S,i,1);
if (x='a') and (q=1) then begin q:=1; y:='F';goto 1;end;
if (x='c') and (q=1) then begin q:=2; y:='G';goto 1;end;
if (x='b') and (q=1) then begin q:=4; y:='E';goto 1;end;
if (x='b') and (q=2) then begin q:=2; y:='G';goto 1;end;
if (x='a') and (q=2) then begin q:=3; y:='F';goto 1;end;
if (x='c') and (q=2) then begin q:=4; y:='F';goto 1;end;
if (x='a') and (q=3) then begin q:=4; y:='F';goto 1;end;
if (x='c') and (q=3) then begin q:=3; y:='E';goto 1;end;
if (x='b') and (q=3) then begin q:=2; y:='F';goto 1;end;
if (x='a') and (q=4) then begin q:=4; y:='E';goto 1;end;
if (x='b') and (q=4) then begin q:=3; y:='F';goto 1;end;
if (x='c') and (q=4) then begin q:=2; y:='G';goto 1;end;
1: writeln(q,' ',y);
end;readkey;
END.
uses crt;
var a,b,c,d:integer; label 10;
BEGIN
clrscr; write('введите число в 10 система счисления ');
read(a); c:=20;
repeat
c:=c-1; b:=a; a:=a div 16; d:=b-16*a; gotoxy(c,5);
if d=10 then begin write('a'); goto 10; end;
if d=11 then begin write('b'); goto 10; end;
if d=12 then begin write('c'); goto 10; end;
if d=13 then begin write('d'); goto 10; end;
if d=14 then begin write('e'); goto 10; end;
if d=15 then begin write('f'); goto 10; end;
write(d); 10:until a=0; readkey;
END.
Uses Graph,crt; Var k4,k1,k,k2,k3,i,Gd, Gm,p: Integer; a,x: string; Begin Gd:=Detect; InitGraph(Gd, Gm, 'c:\BP\BGI'); moveto(320,240); a:='drdrdruuululululululdddddd'; k:=0; for i:=1 to length(a) do begin x:=copy(a,i,1); if x='r' then begin k1:=k+30;linerel(k1,0) end else if x='u' then begin k2:=k+30;linerel(0,k2) end else if x='l' then begin k3:=k-30; linerel(k3,0) end else if x='d' then begin k4:=k-30; linerel(0,k4) end; delay(5000);sound(400); delay(1500);nosound; end; Readkey; CloseGraph; End.
uses crt;
var s,i,j,a,b,c,n:integer;
begin clrscr; randomize; s:=0;
for j:=1 to 5 do begin
a:=random(9); b:=random(9); c:=a*b; writeln;
writeln('Сколько будет ',a,'*',b );
writeln('ответ'); readln(n);
if n=c then begin write('ВЕРНО') ;s:=s+1;
if n<>c then begin write('НЕТ');
end; end;
write('Число правильных ответов=',s);
end;
if s=5 then begin write ('ваша оценка 5'); end;
if s=4 then begin write ('ваша оценка 4'); end;
if s=3 then begin write ('ваша оценка 3');end;
if s=2 then begin write ('ваша оценка 2');end;
if (s=1) or (s=0) then begin write('попробуйте заново'); end;
readkey;
end.