Eugeniusz Jakubas
programy źródłowe w Pascalu

Stąd można pobrać teksty źródłowe poniższych 57 programów w Pascalu pr-pascal.zip - 34 kB
1. Ciągi

Program Wykresy_ciagow;
uses Graph;
var karta,tryb,n,j:integer;
    y:real;
function a(n:integer):real;
begin
  a:=10/n;
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  j:=16;
  setColor(darkGray);
  for n:=10 to 640 div j do line(n*j+20,0,n*j+20,479);
  for n:=-240 div j to 240 div j do line(160,240+n*j,639,240+n*j);
  setcolor(white);
  line(160,240,639,240); line(630,235,639,240); line(630,245,639,240);
  outtextxy(630,250,'n');
  line(180,0,180,479); line(175,9,180,0); line(180,0,185,9);
  outtextxy(190,8,'an');
  n:=0;  setColor(lightBlue); setFillStyle(1,lightBlue);
  repeat
    n:=n+1;
    y:=a(n);
    writeLn(y:1:11);
    if abs(y)<480 then fillEllipse(round(n*j+180),round(240-y*j),2,2);
  until n>28;
  readln; closeGraph;
end.

2. Cykloida

Program Cykloida;
uses graph,crt;
var karta,tryb,n,i:integer;
begin
  karta:=detect; initGraph(karta,tryb,'');
  line(0,301,639,301);
  for i:=0 to 160 do
  begin
    setColor(white);
    fillEllipse(round(60*cos(1.9+i/19)+60+4*i),round(60*sin(1.9+i/19)+240),2,2);
    line(60+4*i,240,round(60*cos(1.9+i/19)+60+4*i),round(60*sin(1.9+i/19)+240));
    for n:=0 to 5 do
      begin
        setColor(n+1);
        arc(60+4*i,240,n*60-3*i,(n+1)*60-3*i,60);
      end;
    delay(100);
    setColor(black);
    circle(60+4*i,240,60);
    line(60+4*i,240,round(60*cos(1.9+i/19)+60+4*i),round(60*sin(1.9+i/19)+240));
  end;
  readln; closeGraph;
end.

3. Deska Galtona

program Deska_Galtona;
uses graph,crt;
var karta,tryb,n,k,i,wi,ko,ilO : integer;
    t:array[0..40] of integer;
begin
  karta:=vga; tryb:=vgaHi; initGraph(karta,tryb,'');
  randomize; bar(0,475,639,479);
  for n:=0 to 40 do
  for k:=1 to n+2 do fillEllipse(k*14+287-n*7,n*5+10,1,1);
  for i:=1 to 400 do
      begin
        ko:=308; wi:=10; fillEllipse(ko,wi,2,2);
        for n:=1 to 40 do
            begin
              setColor(black); setFillStyle(1,black); fillEllipse(ko,wi,2,2);
              if random<0.5 then ko:=ko-7 else ko:=ko+7; wi:=wi+5;
              setColor(lightRed); setFillStyle(1,lightRed); fillEllipse(ko,wi,2,2);
              delay(50);
            end;
        setColor(black); setFillStyle(1,black); fillEllipse(ko,wi,2,2);
        ilO:=(ko-28) div 14; t[ilO]:=t[ilO]+1;
        setColor(lightRed); setFillStyle(1,lightRed); fillEllipse(ko,477-t[ilO]*4,2,2);
      end;
  readLn; closeGraph;
end.

4. Dywan Ulama

program Dywan_Ulama;
uses graph;
var karta,tryb,pozX,pozY,D:integer;
    liczba,i:longInt;
procedure sprawdzenie;
var k,spr:longInt;
begin
  k:=1;
  spr:=1;
  repeat
    k:=k+1;
    if liczba mod k=0 then spr:=0;
   until (liczba mod k=0) or (k>sqrt(liczba));
   if spr=1 then putPixel(pozX,pozY,white);
end;
begin
   karta:=detect; initGraph(karta,tryb,'');
   liczba:=1; pozX:=320; pozY:=240; D:=0;
   repeat
      D:=D+2;
      for i:=1 to D do
      begin
        liczba:=liczba+1; pozY:=pozY-1; sprawdzenie;
      end;
      for i:=1 to D do
      begin
        liczba:=liczba+1; pozX:=pozX-1; sprawdzenie;
      end;
      for i:=1 to D do
      begin
        liczba:=liczba+1; pozY:=pozY+1; sprawdzenie;
      end;
      for i:=1 to D do
      begin
        liczba:=liczba+1; pozX:=pozX+1; sprawdzenie;
      end;
      pozX:=pozX+1; pozY:=pozY+1;
   until liczba>576000;
   readLn; closeGraph;
end.

5. Dywan Sierpińskiego

program dywan_Sierpinskiego;
uses graph,crt; var karta,tryb,prz,skala:integer;
     x,y,xNowe,yNowe:real;
const t:array[1..48] of real=
     (0.3,-0.0,-0.6, 0.0, 0.3, 0.6, 0.3,-0.0, 0.0, 0.0, 0.3, 0.6,
      0.3, 0.0, 0.6, 0.0, 0.3, 0.6, 0.3,-0.0,-0.6, 0.0, 0.3,-0.0,
      0.3, 0.0, 0.6, 0.0, 0.3,-0.0, 0.3, 0.0,-0.6,-0.0, 0.3,-0.6,
      0.3, 0.0, 0.0,-0.0, 0.3,-0.6, 0.3, 0.0, 0.6, 0.0, 0.3,-0.6);
begin
  karta:=detect; initGraph(karta,tryb,'c:\tp\bgi'); randomize;
  x := 0; y := 0; skala:=180;
  repeat
    prz := random(8);
    xNowe:=t[prz*6+1]*x+t[prz*6+2]*y+t[prz*6+3];
    ynowe:=t[prz*6+4]*x+t[prz*6+5]*y+t[prz*6+6];
    x := xNowe; y := yNowe;
    putPixel(round(x*skala+320),round(-y*skala+240),prz+2);
  until keyPressed;
  readLn; closeGraph;
end.
dywan-Si.jpg (40533 bytes)

6. Ekstrema funkcji

Program Ekstrema_funkcji_Metoda_naturalna;
{$N+}
uses graph;
var karta,tryb,n:integer;
    x,y,Dx,y1,y2:extended;
function f(x:extended):extended;
begin
  f:=x+3/4-2*sin(x)-0.065
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  setColor(darkGray);
  for n:=1 to 32 do line(n*20,0,n*20,479);
  for n:=1 to 24 do line(0,n*20,639,n*20);
  setColor(white); line(0,240,639,240); line(320,0,320,479);
  x:=-16; Dx:=0.1;
  repeat
    x:=x+Dx;
    y:=f(x); y1:=f(x+Dx); y2:=f(x+2*Dx);
    if (y1<y) and (y1<y2) then Dx:=Dx/10;
    if (y1>y) and (y1>y2) then Dx:=Dx/10;
    if (Dx<1e-17) or ((y=y1)and(Dx<0.1)) then
        begin
          if abs(y)<12 then writeln('x=',x:22:18,',  f(x)=',y:22:18);
          Dx:=0.1;
        end;
    if abs(y)<12 then
    putPixel(round(x*20+320),round(-y*20+240),yellow);
  until x>16;
  readLn; closeGraph;
end.

7. Figury Sierpińskiego

program Figury_Sierpinskiego;
uses Graph,crt;
var  karta,tryb,los,n_kat:integer;
     x,y,r,skok:real;
begin
  karta:=detect; initGraph(karta,tryb,'');
  n_kat:=3; skok:=0.5; r:=120/skok; x:=0; y:=0;
  repeat
    putPixel(round(x+320),round(y+240),los);
    los := random(n_kat) + 1;
    x:=x+(r*cos(los*2*pi/n_kat)-x)*skok;
    y:=y+(r*sin(los*2*pi/n_kat)-y)*skok;
  until keyPressed;
  closeGraph;
end.
tr-sier.gif (3411 bytes)

8. Funkcja pierwotna

Program Funkcja_pierwotna;
uses graph;
var karta,tryb,n,j,k:integer;
    x,Dx,pierwotna:real;
function f(x:real):real;
begin
  f:=cos(x);
end;
begin
  karta:=detect; initgraph(karta,tryb,'');
  j:=40;
  setColor(darkGray);
  for n:=-320 div j to 320 div j do line(320+n*j,0,320+n*j,479);
  for n:=-240 div j to 240 div j do line(0,240+n*j,639,240+n*j);
  setColor(white);
  line(0,240,639,240); line(320,0,320,479);
  x:=-320/j; pierwotna:=0; Dx:=0.001;
  repeat
    x:=x+Dx;
    putPixel(round(x*j+320),round(-f(x)*j+240),lightBlue);
    pierwotna:=pierwotna+f(x)*Dx;
    for k:=-5 to 5 do
        putPixel(round(x*j+320),round(-pierwotna*j+240+k*j),lightRed);
  until x>320/j;
  readln; closegraph;
end.

9. Krzywe - epicykloidy

Program Epicykle;
uses graph,crt;
var karta,tryb,n:integer;
    x,y,r,alfa,beta:real;
begin
  karta:=detect; initGraph(karta,tryb,'');
  alfa:=0;
  repeat
    r:=120; beta:=alfa;
    x:=r*cos(alfa)+320;
    y:=r*sin(alfa)+240;
    fillEllipse(round(x),round(y),1,1);
    for n:=1 to 5 do
        begin
          r:=r/2; beta:=beta*5;
          x:=x+r*cos(beta);
          y:=y+r*sin(beta);
          putPixel(round(x),round(y),n+10);
        end;
    alfa:=alfa+0.0005;
  until (keyPressed) or (alfa>=2*pi);
  readLn; closegraph;
end.
epicykle.jpg (45720 bytes)

10. Krzywe - obwarzanek

Program Obwarzanek;
uses graph,crt;
var karta,tryb,n:integer;
    x,y,r,alfa,beta:real;
const tk:array[1..4] of integer=
(lightCyan,lightRed,yellow,lightBlue);
begin
  karta:=detect; initGraph(karta,tryb,'');
  alfa:=0;
  repeat
    r:=160; beta:=alfa;
    x:=r*cos(alfa)+320;
    y:=r*sin(alfa)+240;
    setColor(red);
    fillEllipse(round(x),round(y),1,1);
    r:=r/6; beta:=beta*12;
    for n:=1 to 4 do
        begin
          x:=x+r*cos(beta+n*pi/2);
          y:=y+r*sin(beta+n*pi/2);
          setFillStyle(1,tk[n]); setColor(tk[n]);
          fillEllipse(round(x),round(y),7,7);
        end;
    alfa:=alfa+0.005;
  until (keyPressed) or (alfa>=2*pi);
  readLn; closegraph;
end.
obwarzank.gif (6884 bytes)

11. Kwadrat sito

Program Sito;
uses Graph;
var  karta,tryb,n,x,y,bok,gr:integer;
begin
  karta:=detect;
  initGraph(karta,tryb,'');
  n:=1;
  gr:=1;
  bok:=256;
  rectangle(0,0,bok,bok);
  repeat
    gr:=gr div 2;
    bok:=bok div 2;
    for x:=0 to n-1 do
      for y:=0 to n-1 do
        bar(bok+2*x*bok-gr,bok+2*y*bok-gr,
            bok+2*x*bok+gr,bok+2*y*bok+gr);
    n:=n*2;
    readLn;
  until bok=1;
  CloseGraph;
end.

12. Liczba e

Program e;
uses crt;
var n,k:integer;
    a:real;
begin
  clrScr;
  for n:=1 to 100 do
  begin
    a:=1+1/n;
    for k:=1 to n-1 do a:=a*(1+1/n);
    writeLn(n,'.  ',a:1:10);
  end;
  readLn;
end.

13. Liczba p

program Liczba_pi_Algorytm_Gaussa_Legendrea;
{$N+}
uses crt;
var a, b, t, x, y:extended;
begin
  clrScr;
  a:=1; b:=1/sqrt(2); t:=1/4; x:=1;
  writeLn(a:22:18,b:22:18,t:22:18);
  writeLn('pi=',(a+b)*(a+b)/(4*t):22:18);
  repeat
    y:=a;
    a:=(a+b)/2;
    b:=sqrt(b*y);
    t:=t-x*(y-a)*(y-a);
    x:=2*x;
    writeLn(a:22:18,b:22:18,t:22:18);
    writeLn('pi=',(a+b)*(a+b)/(4*t):22:18);
  until a-b<0.0000000000000000001;
  writeln('pi=',pi:22:18);
  readLn;
end.

14. Liczby pierwsze

program Liczba_pierwsza;
uses crt;
var liczba,n:longint;
begin
   clrScr;
   liczba:=2147483647;
   for n:=2 to round(sqrt(liczba)) do
      if liczba mod n=0 then
         begin
           writeLn(liczba,'-liczba zlozona'); readLn; exit;
         end;
   textColor(lightRed);
   writeLn(liczba,'-liczba pierwsza');
   readLn;
end.

15. Miejsca zerowe funkcji

program Miejsca_zerowe_Metoda_stycznych;
   {$N+}
   uses crt;
   var x : extended;
function f (x: extended): extended;
   begin
      f :=sin(x);
   end;
begin
   clrScr;
   x := 2;
   repeat
      x:=x-f(x)/(f(x+0.000001)-f(x))*0.000001;
      writeln('x = ',x:22:18,'  f(x) = ',f(x):22:18);
   until (abs(f(x)) < 1e-17);
   readLn;
end.

16. Monotoniczność funkcji

Program Ekstrema_funkcji_Metoda_naturalna;
{$N+}
uses graph;
var karta,tryb,n,j,kolor:integer;
    x,y,Dx,y1,y2:extended;
function f(x:extended):extended;
begin
  f:=x*x/(2*x*x-x-2)
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  j:=20;
  setColor(darkGray);
  for n:=-320 div j to 320 div j do line(n*j+320,0,n*j+320,479);
  for n:=-240 div j to 240 div j do line(0,n*j+240,639,n*j+240);
  setColor(white); line(0,240,639,240); line(320,0,320,479);
  x:=-320/j; Dx:=0.00025;
  repeat
    x:=x+Dx;
    y:=f(x); y1:=f(x+Dx); y2:=f(x+2*Dx);
    if y1>y then kolor:=yellow else kolor:=lightRed;
    if abs(y)<240/j then putPixel(round((x+Dx)*j+320),round(-y1*j+240),kolor);
    if (y1<y) and (y1<y2) and (abs(y1)<240/j) then writeln('x=',x+Dx:18:14);
    if (y1>y) and (y1>y2) and (abs(y1)<240/j) then writeln('x=',x+Dx:18:14);
    if y*y1<0 then writeLn('x=',x+2*Dx:18:14);
  until x>320/j;
  readLn; closeGraph;
end.

17. Nwd - algorytm Euklidesa

Program Najwiekszy_wspolny_dzielnik;
uses crt;
var a,b,nwd,r:integer;
begin
  clrScr;
  a:=1995;
  b:=1957;
  repeat
    writeLn(a,' = ',a div b,'*',b,' + ',a mod b);
    r:=a mod b;
    a:=b;
    b:=r;
  until r=0;
  writeLn('Nwd = ',a);
  readLn;
end.

18. Nww

program NWW;
uses crt;
var a,b,dz:longInt;
begin
  clrScr;
  a:=30;
  b:=105;
  dz:=1;
  while dz*a mod b<>0 do dz:=dz+1;
  writeLn('NWW(',a,',',b,') = ',dz*a);
  readLn;
end.

19. Permutacje

program Permutacje;
uses crt;
var n,k,dl_slowa,il_permut,spr,poz,i,max:longInt;
    slowo_wyj,slowo_0,slowo,slowo_st:string;
    x:char;
    t:array[1..255] of integer;
    key:char;
const slowo_max:string='abcdefghijklmnoprstuvwxyz';
procedure sprawdz_i_wstaw(x:char;nr:integer);
begin
  for k:=poz to dl_slowa do
  if (slowo_st[k]=x) and (t[ord(x)]=0)
     then begin
            slowo[nr]:=x; spr:=1;
            t[ord(x)]:=1;
          end;
end;
begin
  clrScr;
  slowo_0:='AABEGLR';
  dl_slowa:=length(slowo_0);
  slowo:=copy(slowo_max,1,dl_slowa);
  slowo_st:=slowo;
  il_permut:=1;
  writeLn(il_permut,'. ',slowo_0);
  max:=1; for n:=1 to dl_slowa do max:=max*n;
  repeat
    for n:=1 to 255 do t[n]:=0;
    n:=1;
    while slowo[dl_slowa-n]>slowo[dl_slowa-n+1] do n:=n+1;
    poz:=dl_slowa-n;
    i:=0;
    spr:=0;
    repeat
      x:=char(ord(slowo[poz])+1+i);
      sprawdz_i_wstaw(x,poz);
      i:=i+1;
    until spr=1;
    x:='!';
    for n:=1 to dl_slowa-poz do
    begin
      i:=0;
      spr:=0;
      repeat
        x:=char(ord(x)+1);
        sprawdz_i_wstaw(x,poz+n);
        i:=i+1;
      until spr=1;
    end;
    il_permut:=il_permut+1;
    slowo_wyj:='';
    for i:=1 to dl_slowa do slowo_wyj:=slowo_wyj+slowo_0[ord(slowo[i])-96];
    writeLn(il_permut,'. ',slowo_wyj);
    slowo_st:=slowo;
{    key:=readKey;}
  until (slowo_wyj='ALGEBRA') or (il_permut=max);
  readLn;
end.

20. Pochodna funkcji

Program Pochodna;
uses Graph;
var karta,tryb,n,siatka,j:integer;
    x,y:real;
function f(x:real):real;
begin
  f:=sin(x);
end;
function g(x:real):real;
begin
  g:=(f(x+0.000001)-f(x))/0.000001;
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  j:=36;
  setColor(darkGray); rectangle(0,0,639,479);
  for n:=-320 div j to 320 div j do
  begin
    line(320+n*j,0,320+n*j,479);
    line(0,240+n*j,639,240+n*j);
  end;
  setcolor(white);
  line(0,240,639,240); line(630,235,639,240);
  line(630,245,639,240); outtextxy(630,250,'X');
  line(320,0,320,479); line(315,9,320,0);
  line(320,0,325,9); outtextxy(330,8,'Y');
  x:=-320/j;
  repeat
    x:=x+1/j/2;
    y:=240-f(x)*j;
    setColor(lightBlue); setFillStyle(1,lightBlue);
    if abs(y)<480 then
       fillEllipse(round(x*j+320),round(y),1,1);
    y:=240-g(x)*j;
    setColor(lightRed); setFillStyle(1,lightRed);
    if abs(y)<480 then
       fillEllipse(round(x*j+320),round(y),1,1);
  until x>320/j;
  readln; closeGraph;
end.
test-po.jpg (85814 bytes)

21. Pola figur płaskich.

Program Pole_figury_plaskiej;
uses Graph;
var karta,tryb,x,y,k,n,bialy,czarny,siatka:integer;
    psw,psz:longint;
const czworokat:array[1..5,1..2] of integer=
    ((50,120),(400,100),(500,285),(210,420),(50,120));
    j:integer = 64;
begin
  karta:=vga; tryb:=vgaHi; initGraph(karta,tryb,'');
  fillPoly(4,czworokat);
  setColor(cyan);
  siatka:=16; psw:=0; psz:=0;
  for n:=0 to 440 div siatka do
  for k:=0 to 560 div siatka do
  begin
    bialy:=0;
    czarny:=0;
    for x:=k*siatka to (k+1)*siatka-1 do
    for y:=n*siatka to (n+1)*siatka-1 do
      if getPixel(x,y)=white then bialy:=1 else czarny:=1;
    rectangle(k*siatka-1,n*siatka-1,(k+1)*siatka-1,(n+1)*siatka-1);
    if (bialy=1) and (czarny=0) then
    begin
      inc(psw);
      setFillStyle(1,lightRed);
      bar(k*siatka,n*siatka,(k+1)*siatka-1,(n+1)*siatka-1);
    end;
    if (bialy=1) and (czarny=1) then
    begin
      inc(psz);
      setFillStyle(1,lightBlue);
      bar(k*siatka,n*siatka,(k+1)*siatka-1,(n+1)*siatka-1);
    end;
  end;
  setColor(black);
  drawPoly(5,czworokat);
  writeLn('P.s.z.=',(psz+psw)/j/j*siatka*siatka:6:4,
               '  P.s.w.=',psw/j/j*siatka*siatka:6:4);
  readLn; closeGraph;
end.

22. Pole pod funkcją

Program Pole_pod_funkcja;
uses Graph;
var karta,tryb,n,k,iprz,j:integer;
    x,y,x1,x2,Dx,pole:real;
function f(x:real):real;
begin
  f:=(x*x*x-5*x)/5
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  j:=20;
  setColor(darkGray);
  for n:=-320 div j to 320 div j do line(320+n*j,0,320+n*j,479);
  for n:=-240 div j to 240 div j do line(0,240+n*j,639,240+n*j);
  setColor(white);
  line(0,240,639,240); line(320,0,320,479);
  setColor(lightBlue);
  x1:=-3; x2:=4;
  x:=-320/j; Dx:=0.00025;
  repeat
    x:=x+Dx;
    y:=f(x);
    if abs(y)<240/j then putPixel(round(x*j+320),round(-y*j+240),lightBlue);
    if (x>x1) and (x<x2) then line(round(x*j+320),round(-y*j+240),
                                   round(x*j+320),240);
  until x>320/j;

  setColor(lightRed);
  iprz:=20; pole:=0; Dx:=(x2-x1)/iprz;
  for n:=1 to iprz do
  begin
    x:=x1+n*Dx-Dx/2;
    pole:=pole+f(x)*Dx;
    rectangle(round(j*(x1+(n-1)*Dx)+320),round(-j*f(x)+240),
              round(j*(x1+n*Dx)+320),240);
  end;
  setColor(white); line(0,240,639,240); line(320,0,320,479);
  writeLn(' Pole = ',pole:1:4);

  readln; closeGraph;
end.

23. Potęga =1999

Program Potega_1999;
uses crt;
var n,i,poz,iloczyn,pamiec,podstawa,wypis:longInt;
    t:array[1..64000] of byte;
begin
  clrScr; t[1]:=1; podstawa:=2; poz:=1;
  for i:=1 to 64000 do
  begin
    pamiec:=0;
    for n:=1 to poz do
    begin
      iloczyn:=t[n]*podstawa;
      t[n]:=(iloczyn+pamiec) mod 10;
      pamiec:=(iloczyn+pamiec) div 10;
    end;
    t[n+1]:=pamiec; if pamiec>=1 then poz:=poz+1;
    write(podstawa,'^',i,' = ');
    wypis:=1; if poz>10 then wypis:=poz-10;
    for n:=poz downTo wypis  do write(t[n]);
    if poz>11 then writeLn('...') else writeLn;
    if poz>3 then if (t[poz]=1)and(t[poz-1]=9)and(t[poz-2]=9)and(t[poz-3]=9) then readLn;
  end;
  readLn;
end.

24. Przekształcenia izometryczne

Program Translacja;
uses Graph;
var karta,tryb:integer;
    x,y,xnowe,ynowe:longint;
begin
  karta:=vga; tryb:=vgaHi; initGraph(karta,tryb,'c:\tp\bgi');
  setTextStyle(triplexFont,horizDir,5);
  outTextXY(30,430,'Matematyka');
  rectangle(20,435,300,479);
  fillEllipse(130,420,50,50);
  for x:=0 to 300 do
  for y:=0 to 110 do
   if getpixel(x,479-y)=white then
   begin
     xnowe:=x+250;
     ynowe:=y+200;
     putPixel(xnowe,479-ynowe,lightRed);
   end;
   readLn;
   closeGraph;
end.

25. Przekształcenia afiniczne.

program Trzy_przeksztalcenia_afiniczne;
uses graph,crt; var karta,tryb,prz,skala:integer;
     x,y,xNowe,yNowe:real;
const t:array[1..18] of real= (0.5,-0.8,0.5,0.0,0.5,-0.1,
      0.5,0.0,0.0,0.0,0.5,0.4,0.5,0.6,-0.4,0.0,0.6,-0.4);
begin
  karta:=detect; initGraph(karta,tryb,'c:\tp\bgi'); randomize;
  x := 0; y := 0; skala:=180;
  repeat
    prz := random(3);
    xNowe:=t[prz*6+1]*x+t[prz*6+2]*y+t[prz*6+3];
    ynowe:=t[prz*6+4]*x+t[prz*6+5]*y+t[prz*6+6];
    x := xNowe; y := yNowe;
    putPixel(round(x*skala+320),round(-y*skala+240),prz+2);
  until keyPressed;
  readLn; closeGraph;
end.

26. Reszta ab mod c.

program Reszta;
{$N+}
uses  crt;
var a:extended;
function potegaModulo(a,b,c:extended):extended;
var reszta:extended;
begin
  reszta:=1;
  while b>0 do
        begin
          if int(b/2)<>b/2 then reszta:=reszta*a-int(reszta/c*a)*c;
          a:=a*a-int(a/c*a)*c;
          b:=int(b/2);
        end;
  potegaModulo:=reszta;
end;
begin
  clrScr;
  a:=4905289;
  writeLn(a:1:0,' -> ',potegaModulo(a,4321,948581743):1:0);
  readLn;
end.

27. Rozkład na czynniki pierwsze

Program Rozklad_na_czynniki_pierwsze;
uses crt;
var liczba,n:longInt;
begin
  clrscr;
  liczba:=1995;
  n:=2;
  repeat
    if liczba mod n=0 then
    begin
      writeLn(liczba:15,' ł ',n);
      liczba:=liczba div n;
    end
    else
    n:=n+1;
  until n>sqrt(liczba);
  if liczba<>1
    then writeLn(liczba:15,' ł ',liczba);
  write(1:15,' ł');
  readln;
end.

28. Rzut kostką

Program Rzut_kostka;
uses graph;
var karta,tryb,n,los,il_rz:integer;
    ilosc,czestosc:string;
    t:array[1..6] of integer;
begin
  karta:=detect; initGraph(karta,tryb,'');
  for n:=1 to 6 do t[n]:=0;
  il_rz:=1500; randomize;
  for n:=1 to il_rz do
  begin
    los:=random(6)+1;
    inc(t[los]);
    line(los*85,455-t[los],los*85+37,455-t[los]);
    line(los*85+40,455-t[los],los*85+55,455-15-t[los]);
  end;
  for n:=1 to 6 do
  begin
    str(t[n],ilosc);
    outTextxy(n*85+20,441-t[n],ilosc);
    str(t[n]/il_rz:1:4,czestosc);
    outTextxy(n*85+10,411-t[n],czestosc);
  end;
  readln;
  closeGraph;
end.

29. Rzut monetą

Program Rzut_moneta;
uses graph;
var karta,tryb:integer;
    n,il_rz,il_o,il_r:longInt;
    x,y,los:real;
begin
  karta:=detect; initGraph(karta,tryb,'');
  randomize;
  il_rz:=30000; il_o:=0; il_r:=0;
  for n:=1 to il_rz do
  begin
    los:=random;
    if los<=0.5 then
    begin
      il_o:=il_o+1;
      x:=il_o/100*cos(il_o*pi/180);
      y:=il_o/100*sin(il_o*pi/180);
      fillEllipse(round(x+200),round(y+200),1,1);
    end
    else
    begin
      il_r:=il_r+1;
      x:=il_r/100*cos(il_r*pi/180);
      y:=il_r/100*sin(il_r*pi/180);
      fillEllipse(round(x+400),round(y+200),1,1);
    end;
  end;
  writeln('  Ilosc orlow = ',il_o:1,'               Ilosc reszek = ',il_r:1);
  writeLn('Czestosc orla = ',il_o/il_rz:1:4,'           Czestosc reszki = ',il_r/il_rz:1:4);
  readln;
  closeGraph;
end.

30. Schemat Bernoulliego

Program Schemat_Bernouliego_symulacje;
uses graph,crt;
const n=40; il_ucz=5000; g=1;
var karta,tryb:integer;
    k,i,sukces:longInt;
    Dcz:real;
    czS,nS:string;
    tab:array[1..n] of longInt;
begin
  karta:=detect; initGraph(karta,tryb,'');
bar(0,0,639,479);
  randomize; for k:=1 to n do tab[k]:=0;
  setColor(darkGray);
  for k:=0 to 12 do
    begin
      str(0.01*k:1:2,czS); outTextXY(280-g*n div 2,448-k*25,czS);
      line(280-g*n div 2,460-k*25,340+g*n div 2,460-k*25);
    end;
  setColor(white);
setColor(black);
  line(315-g*n div 2,479,315-g*n div 2,140);
  line(280-g*n div 2,460,340+g*n div 2,460);
  outTextXY(317-g*n div 2,465,'0');
  str(n div 2,nS); outTextXY(312,465,nS);
  str(n,nS); outTextXY(315+g*n div 2,465,nS);
  for k:=1 to il_ucz do
    begin
      sukces:=0;
      for i:=1 to n do if random<0.5 then sukces:=sukces+1;
      tab[sukces]:=tab[sukces]+1;
      Dcz:=2500/il_ucz;
      line(g*sukces-g*n div 2+320,458-round(Dcz*tab[sukces]-Dcz),
           g*sukces-g*n div 2+320,458-round(Dcz*tab[sukces]));
      if keyPressed then exit;
   end;
   str(tab[n div 2]/il_ucz:1:4,czS); outTextXY(300,440-round(Dcz*tab[n div 2]),czS);
   readLn; closeGraph;
end.

31. Schemat Hornera

program Schemat_Hornera;
uses crt;
var n,x0,wartosc,w,blad:integer;
    dane:string;
const tab:array[1..10] of integer=
      (1,-2,3,4,-5,6,7,-8,-9,10);
begin
  clrScr;
  x0:=1;
  wartosc:=0;
  for n:=1 to 10 do
      wartosc:=x0*wartosc+tab[n];
  writeln(wartosc);
  readLn;
end.
7

32. Sieczna

Program Sieczna;
uses Graph;
var karta,tryb,n,siatka,j,xA,yA,xB,yB:integer;
    x,y,x1,x2,u:real;
function f(x:real):real;
begin
  f:=1/4*x*x+x-6;
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  j:=20; siatka:=20;
  setColor(darkGray); rectangle(0,0,639,479);
  for n:=-320 div siatka to 320 div siatka do
  begin
    line(320+n*siatka,0,320+n*siatka,479);
    line(0,240+n*siatka,639,240+n*siatka);
  end;
  setcolor(white);
  line(0,240,639,240); line(630,235,639,240); line(630,245,639,240);
  outtextxy(630,250,'X');
  line(320,0,320,479); line(315,9,320,0); line(320,0,325,9);
  outtextxy(330,8,'Y');
  for n:=-320 div j to 320 div j do
  begin
    line(320+n*j,238,320+n*j,242);
    line(318,240+n*j,322,240+n*j);
  end;
  x:=-320/j;
  repeat
    x:=x+1/j;
    putPixel(round(x*j+320),round(240-f(x)*j),yellow);
  until x>320/j;
  x2:=6;
  x1:=-1;
  u:=(f(x2)-f(x1))/(x2-x1); write('u = ',u:5:4);
  setColor(lightRed);
  xA:=round(x1*j+320); yA:=round(240-f(x1)*j); fillEllipse(xA,yA,3,3);
  xB:=round(x2*j+320); yB:=round(240-f(x2)*j); fillEllipse(xB,yB,3,3);
  line(0,round(u*xA+yA),639,round(u*(xA-639)+yA));
  line(xB,yB,xB,yA); line(xB,yA,xA,yA);
  readln; closegraph;
end.

33. Sito Eratostenesa

program Sito_Eratostenesa;
uses crt;
const max=500;
var liczba,n:longInt;
    t:array[1..max] of byte;
begin
   clrScr;
   for n:=1 to max do t[n]:=0;
   for liczba:=2 to round(sqrt(max)) do
     if t[liczba]=0 then for n:=2 to max div liczba do t[liczba*n]:=1;
   for n:=2 to max do if t[n]=0 then write(n:5);
   readLn;
end.

34. Sortowanie

program sortowanie_liczb;
uses crt;
var tab:array[1..25] of integer;
    n,k,x:integer;

begin
  clrscr; randomize;
  for n:=1 to 25 do begin tab[n]:=round(random(100));write(tab[n],' ');end;
  for n:=1 to 25 do
     for k:=n+1 to 25 do begin if tab[n]>tab[k] then begin
         x:=tab[n]; tab[n]:=tab[k]; tab[k]:=x; end; end;
  writeln; for n:=1 to 25 do write(tab[n],' ');
  readln;
end.

35. Styczna

Program Styczna;
uses graph;
var karta,tryb,n:integer;
    skala,xp,yp,ip,ips:longInt;
    x,y,x0,y0,krok,h:real;
    xS,yS:string;
function f(x:real):real;
begin
  f:=x*x-4*x-2;
end;
procedure osie;
begin
 setColor(darkGray);setLineStyle(1,0,1);
 for n:=0 to 30 do line(xp mod ip+n*ip,0,xp mod ip+n*ip,380);
 for n:=0 to 22 do line(0,yp mod ip+n*ip,510,yp mod ip+n*ip);
 setLineStyle(0,0,1);
 for n:=0 to 2*(15 div skala) do
     line(xp mod ips+n*ips,0,xp mod ips+n*ips,380);
 for n:=0 to 2*(11 div skala) do
     line(0,yp mod ips+n*ips,510,yp mod ips+n*ips);
 rectangle(0,0,510,380);setColor(lightGray);setLineStyle(0,0,3);
 line(0,yp,510,yp);line(500,yp-5,508,yp);line(500,yp+5,508,yp);
 line(xp,0,xp,380); line(xp-5,10,xp,2); line(xp+5,10,xp,2);
 str(-16/skala+x0:2:4,xS); outTextXY(3,198,xS);
 str(16/skala+x0:2:4,xS);outTextXY(510-8*length(xS),198,xS);
 str(-12/skala+y0:2:4,yS); outTextXY(260,370,yS);
 str(12/skala+y0:2:4,yS); outTextXY(264,5,yS);
end;
procedure wykres;
begin
  x:=-16/skala+x0; krok:=0.005/skala;
  repeat
    x:=x+krok;
    y:=-f(x)*ips+yp;
    if (y>0) and (y<380) then
       putPixel(round(x*ips+xp),round(y),lightcyan);
    if x<x0 then h:=-0.0001/skala else h:=0.0001/skala;
    putPixel(round(x*ips+xp),
      round(-((f(x0+h)-f(x0))/h*(x-x0)+f(x0))*ips+yp),lightRed);
  until x>16/skala+x0;
  setColor(yellow);circle(255,190,2);
  str(x0:2:4,xS);str(y0:2:4,yS);
  outTextXY(260,200,'A ('+xS+', '+yS+')');
end;
begin
  karta:=vga; tryb:=vgaHi; initgraph(karta,tryb,'c:\tp\bgi');
  skala:=1; ip:=16; ips:=ip*skala;
  x0:=3; xp:=round(255-x0*ips);
  y0:=f(x0); yp:=round(190+y0*ips);
  osie; wykres;
  readln; closegraph;
end.

36. Suma sześcianów cyfr

program Suma_szescianow_cyfr;
uses crt;
var liczba,cyfra,suma,i:longInt;
    key:char;
begin
  clrScr;
  liczba:=123;
  write(liczba,' -> ');
  repeat
    suma:=0;
    repeat
        cyfra:=liczba mod 10;
        suma:=suma+cyfra*cyfra*cyfra;
        liczba:=liczba div 10;
    until liczba=0;
    write(suma,' -> ');
    liczba:=suma;
    key:=readKey;
  until (key=#27);
end.

37. Symbol Newtona n_po_k

program Obliczanie_n_po_k;
{$N+}
uses crt;
function silnia (s:integer):extended;
var i:integer;
    x:extended;
begin
  x:=1;
  for i:=1 to s do x:=x*i;
  silnia:=x;
end;
function n_po_k(n,k:integer):extended;
begin
  n_po_k:=silnia(n)/silnia(k)/silnia(n-k);
end;
begin
  clrScr;
  writeLn(n_po_k(10,5):1:0);
  readLn;
end.

38. Szeregi

program Szeregi;
{$N+}
uses crt;
var n:longint;
    suma:extended;
function a(n:real):real;
begin
  a:=1/n;
end;
begin
  clrscr;
  suma:=0;
  for n:=1 to 20 do
  begin
       suma:=suma+a(n);
       writeln('a(',n,') = ',a(n):17:17,'     S(',n,') = ',suma:17:17);
  end;
  readln;
end.

39. Szyfrowanie RSA

program Szyfrowanie;
uses crt;
   var
      blok, e, k: longInt;
   function reszta (a, b, c: longInt): longInt;
      var
         n, p: longInt;
   begin
      p := 1;
      for n := 1 to b do
         p := p * a;
      reszta := p mod c
   end;
{**********************************}
begin
   clrScr;
   blok := 352;
   e := 3;
   k := 901;
   writeLn('Szyfrowanie: ', blok : 10, ' -> ', reszta(blok, e, k) : 10);
   readLn;
end.

40. Trójkąt Pascala

program trojkat_Pascala;
uses graph;
var karta,tryb,n,k:integer;
    x,y:longInt;
    ilS:string;
    t:array[1..33] of longInt;
begin
  karta:=detect; initGraph(karta, tryb, '');
  setTextStyle(smallFont,0,1);
  for n:=1 to 33 do t[n]:=0;
  y:=1;
  for n:=1 to 33 do
      for k:=1 to n-1 do
            begin
              x:=y;
              y:=t[k];
              t[k]:=x+y;
              setColor(t[k] mod 2+3);
              str(t[k],ilS);
              setUserCharSize(1,length(ilS) div 2,5,4);
              outTextXY(320-10*n+k*20,12*n,ilS);
            end;
  readLn; closeGraph;
end.

41. Trójkąt Sierpińskiego

program trojkat_Sierpinskiego_max;
uses graph;
var karta, tryb, n, k, i, bok: integer;
    tr:array[1..3,1..2] of integer;
procedure trojkat (x, y, bok, znak: integer);
begin
  tr[1,1]:=x; tr[1,2]:=y;
  tr[2,1]:=x-bok div 2; tr[2,2]:=y-znak*bok div 2;
  tr[3,1]:=x+bok div 2; tr[3,2]:=y-znak*bok div 2;
  fillPoly(3,tr);
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  bok:=256; trojkat(bok,0,bok*2,-1);
  setFillStyle(1,black);
  i:=0;
  repeat
    readLn;
    for n:=0 to i do
      for k:=0 to i do
        if n and k = 0 then
          trojkat((n-k)*(bok div (i+1))+bok,
          (n+k-i)*(bok div (i+1))+bok,bok div (i+1),1);
    i:=2*i+1;
  until i>64;
  readLn; closeGraph;
end.

42. Twierdzenie o liczbach pierwszych i jego zastosowanie do szyfrowania RSA

program Twierdzenie_o_liczbach_pierwszych_i_jego_zastosowanie_do_szyfrowania_RSA;
{$N+}
uses crt;
var  i,p,q,k,N,M,a,a1,e,d:integer;
     potega,potega1,potega2:extended;
     reszta,reszta1,reszta2:integer;
function pierwsza(a:integer):boolean;
  var n:integer;
  begin
    pierwsza:=false;
    for n:=2 to round(sqrt(a)) do if a mod n=0 then exit;
    pierwsza:=true;
  end;
function NdoM(a,b:integer):extended;
  var n:integer;
      x:extended;
  begin
    x:=1;
    for n:=1 to b do x:=x*a;
    NdoM:=x;
  end;
function nwd(a,b:integer):integer;
  var r:integer;
  begin
    repeat
      r:=a mod b; a:=b; b:=r;
    until r=0;
    nwd:=a;
  end;
procedure liczba_d;
var m:integer;
begin
  a:=0;
  repeat
    a:=a+1; m:=a*(p-1)*(q-1)+1;
  until m mod e=0;
  d:= m div e;
end;

{******* program gl˘wny *********}
begin
  clrScr; randomize;
    repeat
      repeat
        repeat
          repeat
            p:=random(12)+2;
          until pierwsza(p)=true;
          repeat
            q:=random(12)+2;
          until (pierwsza(q)=true) and (p<>q);
          k := p * q;
          M := (p-1)*(q-1)+1;
          N := random(12)+2;
          potega:=NdoM(N,M);
        until (N<k) and (potega<1e14);
        reszta:=round(potega-int(potega/k)*k);

        repeat                                       
          e:=random(5)+2;
        until (nwd(e,p-1)=1) and (nwd(e,q-1)=1);
        liczba_d;
        potega1:=NdoM(N,e);
      until potega1<1e14;
      reszta1:=round(potega1-int(potega1/k)*k);
      potega2:=NdoM(reszta1,d);
    until (potega2<1e14) and (reszta1<>N);
    reszta2:=round(potega2-int(potega2/k)*k);

    textColor(green);                                   { Twierdzenie }
    writeLn('TW.2.');
    write('   Jezeli p,q-r˘zne liczby pierwsze i ');
    textColor(lightBlue); write('N');
    textColor(green); write('<p*q, to ');
    textColor(lightBlue); write('N');
    textColor(green); write('^(p-1)*(q-1)+1 mod p*q = ');
    textColor(lightBlue); writeLn('N');
    textColor(white); for i:=1 to 76 do write('_');

    textColor(green); writeLn; writeLn;                   { przyklad }
    write('Przyklad:');
    textColor(white);
    write('   p=',p:1,',  q=',q:1,',  p*q=',p*q:1,',  N=');
    textColor(lightBlue);
    write(N:1);
    textColor(white);
    writeLn(',  (p-1)*(q-1)+1=',M:1);
    textColor(lightBlue);
    write('              ',N:1);
    textColor(white);
    write('^',M:1,' mod ',k:1,' = ',potega:1:0,' mod ',k:1,' = ');
    textColor(lightBlue);
    write(reszta:1);

    textColor(green); writeLn; writeLn;                   { uog˘lnienie }
    writeLn('Uog˘lnienie:');
    write('  Jezeli p,q-r˘zne liczby pierwsze i ');
    textColor(lightBlue); write('N');
    textColor(green); write('<p*q, to ');
    textColor(lightBlue); write('N');
    textColor(green); write('^a*(p-1)*(q-1)+1 mod p*q = ');
    textColor(lightBlue); writeLn('N');
    textColor(green);
    writeLn('                                           gdzie a = 1, 2, 3, ...');

    for a1:=1 to 3 do
    begin
      textColor(white);
      write('     np.    a=',a1:1,'  p=',p:1,',  q=',q:1,',  p*q=',p*q:1,'  N=');
      textColor(lightBlue);
      write(N:1);
      M:=a1*(p-1)*(q-1)+1;
      potega:=NdoM(N,M);
      reszta:=round(potega-int(potega/k)*k);
      textColor(white);
      writeLn(',  a*(p-1)*(q-1)+1=',M:1);
      textColor(lightBlue);
      write('         ',N:1);
      textColor(white);
      write('^',M:1,' mod ',k:1,' = ',potega:1:0,' mod ',k:1,' = ');
      textColor(lightBlue); write(reszta:1);
      writeLn;
    end;

    writeLn;
    a1:=a;
    M:=a1*(p-1)*(q-1)+1;
    potega:=NdoM(N,M);
    reszta:=round(potega-int(potega/k)*k);
    textColor(green);
    writeLn('Zastosowanie:');                             { Zastosowanie-szyfrowanie RSA }
    textColor(lightBlue);
    write('  N');
    textColor(green);
    write('^M mod k = (');
    textColor(lightBlue);
    write('N');
    textColor(green);
    write('^e)^d mod k = (');
    textColor(lightBlue);
    write('N');
    textColor(green);
    write('^e mod k)^d mod k = ');
    textColor(lightRed);
    write('X');
    textColor(green);
    write('^d mod k = ');
    textColor(lightBlue);
    writeLn('N');
    textColor(green);
    writeLn('    gdzie M = a*(p-1)*(q-1)+1 = e*d i e,d wzglednie pierwsze z p-1 i q-1,');
    textColor(white);
    writeLn('    np.  a=',a:1,',  p=',p:1,',  q=',q:1,',  e=',e:1,',  d=',d:1,',  M=',M:1,',  k=',k:1);
    writeLn;
    textColor(lightBlue);
    write(N:1);
    textColor(white);
    write('^',M:1,' mod ',k:1,' = (');
    textColor(lightBlue);
    write(N:1);
    textColor(white);
    write('^',e:1,' mod ',k:1,')');

    write('^',d:1,' mod ',k:1,' = ');
    textColor(lightRed);
    write(reszta1:1);
    textColor(white);
    write('^',d:1,' mod ',k:1,' = ');
    write(potega2:1:0,' mod ',k:1,' = ');
    textColor(lightBlue); write(reszta2:1);

    textColor(white);writeLn;
    readLn;
end.

43. Twierdzenie o resztach

program Tw_1a_o_resztach;
uses crt;
var a,b,c,x,y:longInt;
begin
  clrScr;
  writeLn('Tw.1a.     (a+b) mod c = ((a mod c)+(b mod c)) mod c');
  writeLn('-----------------------------------------------------');
  randomize;
  a:=random(40);
  b:=random(30);
  c:=random(20)+1;
  x:=a mod c;
  y:=b mod c;
  textColor(lightGray);
  writeLn('Przyklad:  a = ',a,',    b = ',b,',    c = ',c,',');
  writeLn;
  writeLn(' L = (',a,'+',b,') mod ',c,' = ');
  writeLn('   = ',a+b,' mod ',c,' = ');
  textColor(lightRed);
  writeLn('   = ',(a+b) mod c);
  textColor(lightGray);
  writeLn(' P = ((',a,' mod ',c,')+(',b,' mod ',c,')) mod ',c,' = ');
  writeLn('   = (',x,'+',y,') mod ',c,' = ');
  writeLn('   = ',x+y,' mod ',c,' = ');
  textColor(lightRed);
  writeLn('   = ',(x+y) mod c);
  textColor(lightGray);
  writeLn(' L = P');
  readLn;
end.

44. Układ współrzędnych w przestrzeni

Program XYZ;
uses Graph;
var karta,tryb,x,y,z,n,xN,xP,yP,xA,yC,yA:integer;
begin
  karta:=vga; tryb:=vgaHi; initGraph(karta,tryb,'c:\tp\bgi');
  line(0,240,639,240); for n:=0 to 32 do putPixel(n*20,238,white);
  line(320,0,320,479); for n:=0 to 24 do putPixel(318,n*20,white);
  line(0,479,639,0);
  for n:=0 to 64 do putPixel(n*10-3,479-round(240/320*n*10),white);
  x:=5; y:=6; z:=7;
  xN:=320+x*20;
  xP:=320-y*10;
  xA:=XP+x*20;
  yP:=240+round(240/320*y*10);
  yA:=YP-z*20;
  yC:=240-z*20;
  setColor(yellow);
  line(xP,yP,xA,yP);line(xA,yP,xN,240);line(xN,240,xN,yC);line(xA,yA,xN,yC);
  line(xA,yA,xP,yA);line(xP,yA,320,yC);line(320,yC,xN,yC);line(xP,yP,xP,yA);
  line(xA,yA,xA,yP);line(xP,yP,320,240);line(320,240,xN,240);line(320,240,320,yC);
  fillEllipse(xA,yA,3,3);
  readLn; closeGraph;
end.

45. Wklęsłość - wypukłość funkcji

Program wkleslosc_wypuklosc;
{$N+}
uses Graph;
var karta,tryb,n,siatka,j,kolor:integer;
    x,y,dx,y1,y2,y3,xpp:extended;
function f(x:extended):extended;
begin
  f:=x*x/(2*x*x-x-2);
end;
begin
  karta:=detect; initGraph(karta,tryb,'c:\tp\bgi');
  j:=20;
  setColor(darkGray);
  for n:=-320 div j to 320 div j do line(n*j+320,0,n*j+320,479);
  for n:=-240 div j to 240 div j do line(0,n*j+240,639,n*j+240);
  setColor(white); line(0,240,639,240); line(320,0,320,479);
  x:=-320/j;  Dx:=0.00025;
  repeat
    x:=x+Dx;
    y:=f(x);
    y1:=f(x+Dx);
    y2:=f(x+2*Dx);
    y3:=f(x+3*Dx);
    if y1-y>y2-y1 then kolor:=yellow else kolor:=lightRed;
    xpp:=(2*x+3*Dx)/2;
    if abs(y)<240/j then putPixel(round(xpp*j+320),round(-f(xpp)*j+240),kolor);
    if (((y2-y1<y1-y) and (y2-y1<y3-y2)) or ((y2-y1>y1-y) and (y2-y1>y3-y2))) and
       (abs(y)<240/j) and (abs(y1)<240/j) and (abs(y2)<240/j) and (abs(y3)<240/j) then
       writeLn('xpp=',xpp:18:14,',  ypp=',f(xpp):18:14);

  until x>320/j;
  readln; closeGraph;
end.

46. Wielościany foremne

Program Sprawdzenie_ilosci_wieloscianow_foremnych;
uses crt;
var x,y,k,s,w:integer;
begin
  clrScr;
  for x:=3 to 50 do
  for y:=3 to 50 do
  for k:=6 to 50 do
  if abs(2/x+2/y-2/k-1)<0.0000001 then
  writeLn('x=',x,' y=',y,' k=',k,' w=',2*k/y:2:0,' s=',2*k/x:2:0);
  writeLn('Koniec obliczeä');
  readLn;
end.

47. Wykresy funkcji

Program Wykresy_funkcji;
uses Graph;
var karta,tryb,n,siatka,j:integer;
    x,y:real;
function f(x:real):real;
begin
  f:=3/(x-2);
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  j:=36; siatka:=36;
  setColor(darkGray); rectangle(0,0,639,479);
  for n:=-320 div siatka to 320 div siatka do line(320+n*siatka,0,320+n*siatka,479);
  for n:=-240 div siatka to 240 div siatka do line(0,240+n*siatka,639,240+n*siatka);
  setcolor(white);
  line(0,240,639,240); line(630,235,639,240); line(630,245,639,240); outtextxy(630,250,'X');
  line(320,0,320,479); line(315,9,320,0); line(320,0,325,9); outtextxy(330,8,'Y');
  for n:=-320 div j to 320 div j do line(320+n*j,238,320+n*j,242);
  for n:=-240 div j to 240 div j do line(318,240+n*j,322,240+n*j);
  x:=-320/j;  setColor(lightBlue); setFillStyle(1,lightBlue);
  repeat
    x:=x+1/j/2;
    y:=240-f(x)*j;
    if abs(y)<480 then fillEllipse(round(x*j+320),round(y),1,1);
  until x>320/j;
  readln; closeGraph;
end.

48. Wykresy skalowane

Program Wykresy_skalowane;
{$N+}
uses Graph;
var karta,tryb:integer;
    n,xSiatki,ySiatki,j,xp,yp,skala:longInt;
    x,y,x0,y0:extended;
    xS,yS:string;
function f(x:real):real;
begin
  f:=1/4*x*x+x-6;
end;
begin
  karta:=detect; initGraph(karta,tryb,'');
  skala:=2;
  xSiatki:=20; ySiatki:=20;
  x0:=0; y0:=f(x0);
  j:=40*skala; xp:=round(319-x0*j); yp:=round(240+y0*j);
  setColor(darkGray); rectangle(0,0,639,479);
  for n:=-320 div xSiatki to 320 div xSiatki do
      line(320+n*xSiatki,0,320+n*xSiatki,479);
  for n:=-240 div xSiatki to 240 div xSiatki do
      line(0,240+n*ySiatki,639,240+n*ySiatki);
  setcolor(white);
  line(0,yp,639,yp); line(630,yp-5,639,yp);
  line(630,yp+5,639,yp); outtextxy(630,yp+5,'X');
  line(xp,0,xp,479); line(xp-5,9,xp,0);
  line(xp,0,xp+5,9); outtextxy(xp+10,18,'Y');
  for n:=0 div j to 640 div j do
      line(xp mod j+n*j,yp-2,xp mod j+n*j,yp+2);
  for n:=0 div j to 480 div j do
      line(xp-2,yp mod j+n*j,xp+2,yp mod j+n*j);
  setColor(white);
  str(-320/j+x0:2:4,xS); outTextXY(5,243,xS);
  str(320/j+x0:2:4,xS);
  outTextXY(625-8*length(xS),243,xS);
  str(-240/j+y0:2:4,yS); outTextXY(332,472,yS);
  str(240/j+y0:2:4,yS);  outTextXY(332,2,yS);
  fillEllipse(319,240,2,2);
  str(x0:1:4,xS);str(y0:1:4,yS);
  outTextXY(322,243,'A ('+xS+', '+yS+')');
  x:=-320/j+x0;
  repeat
    x:=x+1/j;
    y:=-f(x)*j+yp;
    if (y>=0) and (y<480) then
        putPixel(round(x*j+xp),round(y),lightBlue);
  until x>320/j+x0;
  readln; closeGraph;
end.
wykresy.jpg (92520 bytes)

49. Wykresy nierówności.

program Wykresy_nierownosci_kolor;
uses graph;
var karta,tryb:integer;
    x,y,w:real;
begin
  karta:=detect; initgraph(karta,tryb,'');
  x:=-16;
  repeat
    x:=x+1/10;
    y:=-12;
    repeat
      y:=y+1/10;
      w:=sin(x*x/y-y*y/x);
      if w>0 then 
       putpixel (round(x*20)+320,round(240-y*20),round(5*w+1));
    until y>12;
  until x>16;
  readln; closegraph;
end.
obrazy.jpg (106433 bytes)

50. Zamiana liczby binarnej na dziesiętną

program Binarne_na_rzeczywiste;
uses crt;
var n: longInt;
    RZ, p: real;
    Bin: string;
begin
  clrScr;
  Bin:='1010101,1100110011';
  p:=1;
  n:=2;
  while (Bin[n]<>',') and (n<=length(Bin)) do
    begin
      p:=p*2;
      n:=n+1;
    end;
  write(Bin,' -> ');
  Rz:=0;
  for n:=1 to length(Bin) do
    begin
      if Bin[n]='1' then Rz:=Rz+p;
      if Bin[n]<>',' then p:=p/2;
    end;
  write(Rz:1:11);
  readLn;
end.

51. Zamiana liczby dziesiętnej na binarną

Program Dziesietne_na_binarne;
uses crt;
var liczbaDz:integer;
    liczBin:string;
begin
  clrScr;
  liczbaDz:=85;
  write(liczbaDz,'    -    ');
  liczBin:='';
  repeat
    liczBin:=chr(liczbaDz mod 2+48) +liczBin;
    liczbaDz:=liczbaDz div 2;
  until liczbaDz=0;
  writeLn(liczBin);
  readLn;
end.

52. Zamiana liter na kody ASCII

program Zamiana_tekstu_na_liczbe;
{$N+} uses  crt;
var   n:integer;
      liczba,potega255:extended;
      tekst:string;
procedure zamienTekstNaLiczbe(tekst:string);
begin
  liczba:=0;
  potega255:=1;
  for n:=length(tekst) downto 1 do
      begin
        liczba:=liczba+ord(tekst[n])*potega255;
        potega255:=potega255*255;
      end;
end;
begin
  clrScr;
  tekst:='Kom';
  zamienTekstNaLiczbe(tekst);
  writeLn(tekst,'=',liczba:1:0);
  readLn;
end.

53. Zamiana ułamków zwykłych na dziesiętne do 1000 cyfr po przecinku

Program Ulamki_zwykle_na_dziesietne;
uses crt;
var licznik,mianownik,iloscMiejsc:longInt;
begin
   clrScr;
   licznik:=133;
   mianownik:=74;
   iloscMiejsc:=0;
   write(licznik,'/',mianownik,' = ',licznik div mianownik,',');
   repeat;
     licznik:=(licznik mod mianownik)*10;
     write(licznik div mianownik);
     inc(iloscMiejsc);
   until iloscMiejsc>1000;
   write('...');
   readLn;
end.

54. Zbiory punktów

program Zaba;
uses Graph;
var  karta,tryb:integer;
     n_kat,i,x,y,r,los:longInt;
     skok: real;
begin
  karta:=detect; initGraph(karta,tryb,'');
  n_kat := 3;
  skok := 1 / 2;
  r := 200;
  for i := 1 to 10000 do
    begin
      putPixel(x + 320, y + 240, yellow);
      los := random(n_kat) + 1;
      x:=round(x+(r*cos(los*2*pi/n_kat)-x)*skok);
      y:=round(y+(r*sin(los*2*pi/n_kat)-y)*skok);
   end;
   readLn; closeGraph;
end.
fra-ifs.jpg (85802 bytes)

55. Zbiory Julii

Program Zbior_Julii;
uses crt,graph;
var  karta,tryb,n,k,i,obr,siatka:integer;
     x,y,xst,yst,Re_c,Im_c,xpocz,xkon,ypocz,ykon,krok_x,krok_y:real;
begin
  karta:=detect; initgraph(karta,tryb,'');
  xpocz:=-1.8; xkon:=1.8; ypocz:=-1.3; ykon:=1.3;
  krok_x:=(xkon-xpocz)/630; krok_y:=(ykon-ypocz)/420;
  for n:=1 to 630 do
  for k:=1 to 420 do
  begin
    Re_c:=xpocz+n*krok_x; Im_c:=ypocz+k*krok_y;
    xst:=Re_c; yst:=Im_c; i:=0;
    repeat
        x:=xst*xst-yst*yst;
        y:=2*xst*yst-1;
        xst:=x;
        yst:=y;
        i:=i+1;
    until (x*x+y*y>8) or (i>12);
    if keyPressed then exit;
    if i>12 then putPixel(n,420-k+30,white);
    putPixel(n,420-k+30,i);
  end;
  readln; closeGraph;
end.

56. Zbiór Mandelbrota

Program Zbior_Mandelbrota;
uses crt,graph;
var  karta,tryb,n,k,i:integer;
     x,y,xnowe,ynowe,cX,cY:real;
begin
  karta:=detect; initgraph(karta,tryb,'');
  for n:=120 to 639 do
  for k:=0 to 479 do
  begin
    x:=n*3/639-2; cX:=x; y:=k*2/479-1; 
    cY:=y; i:=0;
    repeat
        xnowe:=x*x-y*y+cX;
        ynowe:=2*x*y+cY;
        x:=xnowe;
        y:=ynowe;
        i:=i+1;
    until (x*x+y*y>2) or (i>30);
    if keyPressed then exit;
    if i>30 then putPixel(n,k,white);
  end;
  readLn; closeGraph;
end.
Mandel.jpg (65270 bytes)

57. Wieże Hanoi (rekurencja)

program Wieze_Hanoi;
uses graph;
var   karta,tryb,n,ilK,ypocz,gr,j:integer;
      t :array[1..3,1..12] of integer;
      tw:array[1..3] of integer;
procedure przeloz_krazek(skad, dokad : integer);
begin
  tw[dokad]:=tw[dokad]+1; t[dokad,tw[dokad]]:=t[skad,tw[skad]];
  setFillStyle(1,black); setColor(black);
  fillEllipse(skad*210-100,ypocz-tw[skad]*gr,t[skad,tw[skad]]*j,gr div 2-1);
  t[skad,tw[skad]]:=0; tw[skad]:=tw[skad]-1;
  setFillStyle(1,t[dokad,tw[dokad]]);
  fillEllipse(dokad*210-100,ypocz-tw[dokad]*gr,t[dokad,tw[dokad]]*j,gr div 2-1);
  readLn;
end;
procedure przeloz(ile, skad, dokad, roboczy : integer);
begin
  if ile=1 then przeloz_krazek(skad, dokad)
  else begin
         przeloz(ile-1, skad, roboczy, dokad);
         przeloz_krazek(skad, dokad);
         przeloz(ile-1, roboczy, dokad, skad)
       end;
end;
begin
  karta:=vga; tryb:=vgaHi; initGraph(karta, tryb,'');
  writeLn('Nacisnij dowolny klawisz');
  ilK:=3; j:=19-ilK; gr:=30; j:=19-ilK; ypocz:=420;
  for n:=1 to ilK do t[1,n]:=ilK-n+1;
  tw[1]:=ilK;
  for n:=1 to tw[1] do
    begin
      setFillStyle(1,t[1,n]);
      fillEllipse(1*210-100,ypocz-n*gr,t[1,n]*j,gr div 2-1);
    end;
  readLn;
  przeloz(ilK,1,3,2);
  closeGraph;
end.
wieze-Hanoi.gif (612 bytes)