SP w Piotrowicach
Forum Szkoły Podstawowej nr 3 w Piotrowicach

Pascal - Animacje i inne programy

Greif - 2007-11-08, 00:07
Temat postu: Animacje i inne programy
działa bez modułu Graph

Kod:
program animacja;
uses crt;
var
divider : integer;
dd      : integer;
ekr     : array[0..64000] of byte;
procedure rysuj (divider : integer);
var
x,y:integer;
py:integer;
col:byte;
w:word;
begin
w:=0;
for y:=-100 to 99 do
begin
py:=y*y;
for x:=-160 to 159 do
begin
col:=(py+x*x) div divider;
ekr[w]:=col;
inc(w);
end;
end;
for w:=0 to 64000 do
mem[$a000:w] :=ekr[w];
end;
procedure TrybPaleta;
var
c:byte;
begin
asm
mov ax,13h
int 10h
end;
for c:=0 to 255 do
begin
port[$3c8]:=c;
port[$3c9]:=0;
port[$3c9]:=32+round(31*sin(c/pi));
port[$3c9]:=32-round(31*sin(c/pi));
end;
end;
begin
TrybPaleta;
divider:=5;
dd:=1;
repeat
Rysuj(divider);
divider:=divider+dd;
if (divider<2) or (divider>100) then dd := -dd;
until keypressed;
end.


Zmienna tablicowa i szukanie maximum
Kod:
Program maximum;
type tablica=array[1..20] of real;
var a: tablica;
i,n: integer;max:real;
begin
write (' Podaj ilo&#732;c element˘w ciˇgu '); readln (n);
for i:=1 to n do
begin write (' Podaj element ',i,' ' );
readln (a[i]);
end;
max:=a[1];
for i:=2 to n do
if a[i]>max then max:=a[i];
writeln (' Najwi&#169;kszy element to ',max:8:4);
readln
end.


krzywa Hilberta

Kod:
program krzywaH;
USES GRAPH;
VAR
  GRDRIVER : INTEGER;
  GRMODE  : INTEGER;
  ERRCODE  : INTEGER;
  X,Y,H,I,N: INTEGER;
PROCEDURE GRAPHINIT;
BEGIN
  GRDRIVER := DETECT;
  INITGRAPH(GRDRIVER,GRMODE,'c:\tp7\bgi');
  ERRCODE := GRAPHRESULT;
  if ERRCODE <> GROK THEN
    BEGIN
    WRITELN('blad grafiki:',
            GRAPHERRORMSG(ERRCODE));
    HALT(1);
    END;
END;
PROCEDURE PLOT;
BEGIN
    LINETO(X,Y);
END;
PROCEDURE B(I:INTEGER); FORWARD;
PROCEDURE C(I:INTEGER); FORWARD;
PROCEDURE D(I:INTEGER); FORWARD;
PROCEDURE A(I:INTEGER);
BEGIN
  IF I > 0 THEN
        BEGIN
        D(I-1); X := X - H; PLOT;
        A(I-1); Y := Y + H; PLOT;
        A(I-1); X := X + H; PLOT;
        B(I-1);
        END;
END;
PROCEDURE B(I:INTEGER);
BEGIN
  IF I > 0 THEN
        BEGIN
        C(I-1); Y := Y - H; PLOT;
        B(I-1); X := X + H; PLOT;
        B(I-1); Y := Y + H; PLOT;
        A(I-1);
        END;
END;
PROCEDURE C(I:INTEGER);
BEGIN
  IF I > 0 THEN
        BEGIN
        B(I-1); X := X + H; PLOT;
        C(I-1); Y := Y - H; PLOT;
        C(I-1); X := X - H; PLOT;
        D(I-1);
        END;
END;
PROCEDURE D(I:INTEGER);
BEGIN
  IF I > 0 THEN
        BEGIN
        A(I-1); Y := Y + H; PLOT;
        D(I-1); X := X - H; PLOT;
        D(I-1); Y := Y - H; PLOT;
        C(I-1);
        END;
END;
BEGIN
  REPEAT
      WRITE('Stopien zlozonosci ( 1-7 ):');
      READLN(N);
  UNTIL ( N=0 ) OR ( ( N >= 1 ) AND ( N <= 7 )) ;
  IF N=0 THEN HALT(1);
  GRAPHINIT;
  H := GETMAXY;
  X := GETMAXX DIV 2;
  Y := GETMAXY DIV 2;
  I := 0;
  WHILE ( I < N ) DO
      BEGIN
      H := H DIV 2;
      X := X + ( H DIV 2 ); Y := Y - ( H DIV 2 );
      I := I + 1;
      END;
  MOVETO(X,Y);
  A(N);
  READLN;
  CLOSEGRAPH;
END.



i link do opisu paradoksu Hilberta o zbiorach nieskończonych

http://bazawiedzy.xorg.pl...s-hilberta.html

Funkcje tekstowe
Kod:
program funkcje_tekstowe;
uses crt;
var text1,text2:string;
    poz,dlugosc:integer;
    zn:char;

function lacz(var tx1,tx2:string):string;  {odpowiednik CONCAT}
var tx3:string;
begin
  tx3:=tx1+tx2;  {zwykle polaczenie dwoch lancuchow}
  lacz:=tx3;
end;
function kopy(var tx1:string; poz,dl:word):string;  {odpowiednik COPY}
var tx2:string;
    i:integer;
begin
  tx2:='';
  i:=poz;
  repeat
    tx2:=tx2+tx1[i];{do tx2 dodajemy kolejne elementy z lancucha 1 od pozycji}
    inc(i);             {zwiekszenie i o 1}
  until i=dl+poz;
  kopy:=tx2;
end;
function pozycja(var tx1,tx2:string):word;  {odpowiednik POS}
var i,j,poz,l1,l2:word;
    tx3:string;
begin
  l1:=length(tx1);
  l2:=length(tx2);
  i:=1;
  poz:=0;
  tx3:='';
  while i<=l2 do
    begin
      for j:=i to (l1+i-1) do tx3:=tx3+tx2[j];  {tworzymy lancuch w ktorym zawarte}
      if tx3=tx1 then                 {sa kolejne znaki z lancucha 2, o dl lancucha 1}
        begin               {i porownujemy go z lancuchem 1}
          poz:=i;
          i:=l2;
        end;
      inc(i);
      tx3:='';
    end;
  pozycja:=poz;
end;
function wstaw(var tx1,tx2:string; poz:word):string;  {odpowiednik INSERT}
var tx3,tx4:string;
    i,l2:integer;
begin
  l2:=length(tx2);
  i:=1;
  tx3:='';
  while i<poz do
    begin
      tx3:=tx3+tx2[i];{tworzymy lancuch z elementow lancucha 2, przed miejscem wstawienia 1}
      inc(i);
    end;
  i:=poz;
  tx4:='';
  while i<=l2 do
    begin
      tx4:=tx4+tx2[i];{tworzymy lancuch z elem. lancucha 2, po miejscu wstawienia 1}
      inc(i);
    end;
  wstaw:=tx3+tx1+tx4;{laczymy lancuch przed, ten do wstawienia, i ten po}
end;
function kasuj(var tx1:string; poz,dl:word):string;  {odpowiednik DELETE}
var tx2,tx3:string;
    i,l1:integer;
begin
  l1:=length(tx1);
  tx2:='';
  i:=1;
  while i<poz do
    begin
      tx2:=tx2+tx1[i];{tworzymy lancuch do miejsca od ktorego kasujemy}
      inc(i);
    end;
  tx3:='';
  i:=poz+dl;
  while i<=l1 do
    begin
      tx3:=tx3+tx1[i];{tworzymy lancuch od miejsca do ktorego kasujemy}
      inc(i);
    end;
  kasuj:=tx2+tx3; {laczymy to co przed miejscem kasowania, i za tym miejscem}
end;
procedure teksty;  {wprpwadzenie tekstow do pamieci}
begin
  write('Podaj pierwszy lancuch: ');  readln(text1);
  write('Podaj drugi lancuch: ');  readln(text2);
end;
procedure p1;  {procedura wykonujaca wybor 1}
begin
  clrscr;
  teksty;
  write('Wynik: '); textcolor(15); writeln(lacz(text1,text2));
  textcolor(7);
  writeln('Uzywajac CONCAT: ',concat(text1,text2));
  readln;
end;
procedure p2;  {procedura wykonujaca wybor 2}
begin
  clrscr;
  write('Podaj lancuch: ');  readln(text1);
  write('Podaj pozycje: ');  readln(poz);
  write('Podaj dlugosc: ');  readln(dlugosc);
  write('Wynik: '); textcolor(15); writeln(kopy(text1,poz,dlugosc));
  textcolor(7);
  writeln('Uzywajac COPY: ',copy(text1,poz,dlugosc));
  readln;
end;
procedure p3;  {procedura wykonujaca wybor 3}
begin
  clrscr;
  teksty;
  write('Miejsce wystepowania: '); textcolor(15); writeln(pozycja(text1,text2));
  textcolor(7);
  writeln('Uzywajac POS: ',pos(text1,text2));
  readln;
end;
procedure p4;  {procedura wykonujaca wybor 4}
begin
  clrscr;
  teksty;
  write('Podaj pozycje: ');  readln(poz);
  write('Wynik: '); textcolor(15); writeln(wstaw(text1,text2,poz));
  textcolor(7);
  insert(text1,text2,poz);
  writeln('Uzywajac INSERT: ',text2);
  readln;
end;
procedure p5;  {procedura wykonujaca wybor 5}
begin
  clrscr;
  write('Podaj lancuch: ');  readln(text1);
  write('Podaj pozycje: ');  readln(poz);
  write('Podaj dlugosc: ');  readln(dlugosc);
  write('Wynik: '); textcolor(15); writeln(kasuj(text1,poz,dlugosc));
  textcolor(7);
  delete(text1,poz,dlugosc);
  writeln('Uzywajac DELETE: ',text1);
  readln;
end;

begin
  repeat
    clrscr;
    writeln('1 - Laczenie dwoch lancuchow tekstowych (CONCAT)');
    writeln('2 - Wyciecie z tekstu fragmentu (COPY)');
    writeln('3 - Miejsce wystepowania tekstu w tekscie (POS)');
    writeln('4 - Wstawienie tekstu do tekstu (INSERT)');
    writeln('5 - Kasowanie w tekscie lancucha (DELETE)');
    writeln('6,ESC - Koniec');
    gotoxy(1,9);
    writeln('UWAGA - Program nie sprawdza czy podane wartosci sa poprawne.');
    zn:=readkey;
    case upcase(zn) of
      '1':p1;
      '2':p2;
      '3':p3;
      '4':p4;
      '5':p5;
      '6':;
      #27:;
    else
      begin
        write('Zy klawisz');
        delay(500);
      end;
    end;
  until (zn='6') or (zn=#27);
end.


brakuje chr i ord.

Czy to jest litera alfabetu angielskiego?
Kod:

program znak_eng;
uses CRT;
var z:char; x:byte; tak_nie:char;
procedure eng(x:byte);
var eng:byte;
begin
writeln;
write ('  Podaj znak ');
readln(z);
writeln;
writeln ('  Kod ASCII znaku ',ord(z));
writeln;
x:=ord(z);
if (65<=x) and (x<=90) or (95<=x) and (x<=122) then writeln ('  Znak < '
,z,' >  JEST litera alfabetu angielskiego.          Naci¶nij ENTER')
else
    writeln ('  Znak < ',z,' >  NIE JEST litera alfabetu angielskiego.          NACI¦NIJ ENTER');
    end;
begin
CLRSCR;
repeat
eng(x);
readln;
writeln ('  Jeszcze raz t/n?');
tak_nie:=readkey;
until tak_nie<>'t';
end.


Grafika
Kod:
program grafikatxt;

uses Graph;
var Karta, Tryb, x, y, z : Integer;
    napis : string;
begin
DetectGraph(Karta, Tryb);
InitGraph(Karta, Tryb, '');
if GraphResult<>grOk then halt;

SetColor(yellow); { ustawiam kolor napisu, figur }
SetBkColor(blue); { ustawiam tlo }

{ wylosujmy cos w rozsadnych granicach - chodzi mi o zmienna z }
randomize;
x:=random(11);
y:=0; { 0 - domyslny - poziomo, 1 to pionowo }
z:=random(3); {wielkosc czcionki}

SetTextStyle(x,y,z);

Napis:='Graph nie jest trudny';
{ wypisz po srodku ekranu }
OutTextXY(GetMaxX div 2-TextWidth(Napis) div 2,GetMaxY div 2-TextHeight(Napis) div 2,
          Napis);

readln;
CloseGraph;
End.


aby zobaczyć zmiany losowe należy uruchomić kilka razy

===
Ze stronki
http://www.dzyszla.aplus...._teksty-14.html
Kod:
Program Soud;

Uses Crt;

Var
 Hz, dl, sp: Integer;
 Active    : Byte;
 ch        : Char;

Procedure UpDate;
Begin
 TextColor(8);
 GotoXY(1,1);
 Writeln('0,1 - Cz&#169;stotliwo&#732;&#8224;: ',Hz,' Hz');
 Writeln('2 - Du&#710;go&#732;&#8224; trwania: ',dl,' ms');
 Writeln('3 - Du&#710;go&#732;&#8224; przerwy: ',sp,' ms');
 TextColor(red);
 Writeln; Writeln('ESC - Koniec');
End;

BEGIN
ClrScr;
Active:=1;
UpDate;
GotoXY(1,1);
TextColor(15);
Writeln('0,1 - Cz&#169;stotliwo&#732;&#8224;: ',Hz,' Hz');
GotoXY(1,15);
TextColor(Green);
Writeln('Do zmiany parametr˘w s&#710;uµˇ przyciski:');
Writeln('0   - r&#169;cznie ustala cz&#169;stotliwo&#732;&#8224;;');
Writeln('1-3 - wyb˘r parametru do zmiany.');
Writeln;
Writeln('+   - zmienia warto&#732;&#8224; aktywnego parametru o 1 wyµej;');
Writeln('-   - zmienia warto&#732;&#8224; aktywnego parametru o 1 w d˘&#710;;');
Writeln('*   - zmienia cz&#169;stotliwo&#732;c o 100, a pozosta&#710;e o 10 w g˘r&#169;;');
Writeln('/   - zmienia cz&#169;stotliwo&#732;&#8224; o 100, a pozosta&#710;e o 10 w d˘&#710;.');
Writeln;
Writeln('.   - &#732;lepy los.');
 While ch<>#27 do
 Begin
  ch:=' ';
  if keypressed then ch:=readkey;
  Case ch of
  '1': Begin
        Active:=1;
        UpDate;
        GotoXY(1,1);
        TextColor(15);
        Writeln('0,1 - Cz&#169;stotliwo&#732;&#8224;: ',Hz,' Hz');
       End;
  '2': Begin
        Active:=2;
        UpDate;
        GotoXY(1,2);
        TextColor(15);
        Writeln('2 - Du&#710;go&#732;&#8224; trwania: ',dl,' ms');
       End;
  '3': Begin
        Active:=3;
        UpDate;
        GotoXY(1,3);
        TextColor(15);
        Writeln('3 - Du&#710;go&#732;&#8224; przerwy: ',sp,' ms');
       End;
  '+': Begin
        If Active=1 Then Hz:=Hz+1;
        If Active=2 Then dl:=dl+1;
        If Active=3 Then sp:=sp+1;
       End;
  '-': Begin
        If Active=1 Then Hz:=Hz-1;
        If Active=2 Then dl:=dl-1;
        If Active=3 Then sp:=sp-1;
       End;
  '*': Begin
        If Active=1 Then Hz:=Hz+100;
        If Active=2 Then dl:=dl+10;
        If Active=3 Then sp:=sp+10;
       End;
  '/': Begin
        If Active=1 Then Hz:=Hz-100;
        If Active=2 Then dl:=dl-10;
        If Active=3 Then sp:=sp-10;
       End;
  '0': Begin
        GotoXy(22,1);
        TextColor(15);
        Read(Hz);
       End;
  ',': Begin
        Hz:=Random(12000)+19;
        dl:=Random(999)+1;
        sp:=Random(1000);
       End;
  End;
  If Hz<19 Then Hz:=19;
  If dl<1 Then dl:=1;
  If sp<0 Then sp:=0;
  If Ch<>' ' Then
  Begin
   TextColor(14);
   GotoXY(22,1);
   Write(Hz,' Hz ');
   GotoXY(22,2);
   Write(dl,' ms ');
   GotoXy(22,3);
   Write(sp,' ms ');
  End;
  If sp>0 Then
  Begin
   Nosound;
   Delay(sp);
  End;
  Sound(Hz);
  delay(dl);
 End;
 NoSound;
END.


Sortowanie b±belkowe
1. Przykład z wykładów (babelki)
2. Drugi przykł±d z wykładów (babelki2), poprawiony bo miałem Ľle w wykładach, brakowało UNTIL.
3. Jaki¶ z netu też z sortowaniem b±belkowym losowo wybranych liczb

Kod:
Program babelki;
uses CRT; const n=20;
type tablica=array[1..n] of real;
var a:tablica;
    zam,i,liczba:integer;
    x:real;

begin
    clrscr;
    write('Podaj ilo&#732;&#8224; liczb --> ');readln(liczba);
       for i:=1 to liczba do
          begin
             write ('Podaj element ',i,' tablicy --> ');
             readln(a[i]);
          end;
    repeat
       zam:=0;
          for i:=1 to liczba-1 do
             if a[i]>a[i+1] then
                begin
                   x:=a[i];
                   a[i]:=a[i+1];
                   a[i+1]:=x;
                   zam:=zam+1;
                end;
       until zam=0;
             writeln;
             writeln('Ciˇg posortowany');
             for i:=1 to liczba do
                 writeln(a[i]);
                 writeln('Naci&#732;nij ENTER...');
             readln;

end.

Kod:
Program babelki2;
uses CRT; const n=20;
type tablica=array[1..n] of integer;
var a:tablica;
    zam,i,liczba:integer;
    x:integer;
    koniec:boolean;
begin
    clrscr;
    write('Podaj ilo&#732;&#8224; liczb --> ');readln(liczba);
       for i:=1 to liczba do
          begin
             write ('Podaj element ',i,' tablicy --> ');
             readln(a[i]);
          end;
    repeat
       koniec:=false;
       while not koniec do
          begin
             koniec:=true;
                for i:=1 to liczba-1 do
                   if a[i]>a[i+1] then
                      begin
                         x:=a[i];
                         a[i]:=a[i+1];
                         a[i+1]:=x;
                         koniec:=false;
                      end;
          end;
   until koniec;
writeln('Ciˇg posortowany');
   for i:=1 to liczba do
      writeln(a[i]:10:0);
      writeln('Naci&#732;nij ENTER...');
   readln;
end.

Kod:
{***************************************
  Algorytm sortowania metod? babelkowa
  Autor: Tomek Kaminski
  Mail: unvector@wp.pl
  GG: 1797411
***************************************}
program BubbleSort;
uses
  crt;
const
  ile = 200;     {ile liczb do sortowania}
var
  tab : array[1..ile] of integer;
  i, j : integer;
  ok : boolean;
  w : char;

begin
  repeat
    clrscr;
    writeln('ALGORYTM SORTOWANIA METODA BABELKOWA');
    writeln;
    randomize;
    textcolor(7+128);
    write('Generowanie liczb: ');
    textcolor(7);
    for i:=1 to ile do
    begin
      tab[i]:=random(ile+1);
      write(tab[i], ' ');
    end;
    writeln;
    textcolor(7+128);
    write('Sortowanie liczb: ');
    textcolor(7);
    repeat
      ok:=false;
      for i:=1 to ile do
        if tab[i]>tab[i+1] then
        begin
          j:=tab[i];
          tab[i]:=tab[i+1];
          tab[i+1]:=j;
          ok:=true;
        end;
    until ok=false;
    for i:=1 to ile do
      write(tab[i], ' ');
    writeln;
    writeln;
    write('Jeszcze raz ? (T/N): ');
    readln(w);
  until (w='n') or (w='N');
  clrscr;
end.


Powered by phpBB modified by Przemo © 2003 phpBB Group