mogur
Coś już napisał
Dołączył: 15 Sty 2007
Posty: 41
Przeczytał: 0 tematów
Ostrzeżeń: 0/5
Skąd: Alwernia
|
 Wysłany: Wto 15:00, 16 Sty 2007 Temat postu: animacja |
|
|
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˜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©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
[link widoczny dla zalogowanych]
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
miłej zabawy
Post został pochwalony 0 razy
|
|
Greif
Administrator
Dołączył: 15 Sty 2007
Posty: 756
Przeczytał: 0 tematów
Ostrzeżeń: 0/5
Skąd: Piotrowice k.Oświęcimia
|
| Wysłany: Nie 2:11, 20 Maj 2007 Temat postu: Sound i sortowanie bąbelkowe |
|
|
Ze stronki
[link widoczny dla zalogowanych]
| 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©stotliwo˜†: ',Hz,' Hz');
Writeln('2 - Duˆgo˜† trwania: ',dl,' ms');
Writeln('3 - Duˆgo˜† przerwy: ',sp,' ms');
TextColor(red);
Writeln; Writeln('ESC - Koniec');
End;
BEGIN
ClrScr;
Active:=1;
UpDate;
GotoXY(1,1);
TextColor(15);
Writeln('0,1 - Cz©stotliwo˜†: ',Hz,' Hz');
GotoXY(1,15);
TextColor(Green);
Writeln('Do zmiany parametr˘w sˆuľĄ przyciski:');
Writeln('0 - r©cznie ustala cz©stotliwo˜†;');
Writeln('1-3 - wyb˘r parametru do zmiany.');
Writeln;
Writeln('+ - zmienia warto˜† aktywnego parametru o 1 wyľej;');
Writeln('- - zmienia warto˜† aktywnego parametru o 1 w d˘ˆ;');
Writeln('* - zmienia cz©stotliwo˜c o 100, a pozostaˆe o 10 w g˘r©;');
Writeln('/ - zmienia cz©stotliwo˜† o 100, a pozostaˆe o 10 w d˘ˆ.');
Writeln;
Writeln('. - ˜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©stotliwo˜†: ',Hz,' Hz');
End;
'2': Begin
Active:=2;
UpDate;
GotoXY(1,2);
TextColor(15);
Writeln('2 - Duˆgo˜† trwania: ',dl,' ms');
End;
'3': Begin
Active:=3;
UpDate;
GotoXY(1,3);
TextColor(15);
Writeln('3 - Duˆgo˜† 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˜† 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˜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˜† 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˜nij ENTER...');
readln;
end. |
| Kod: | {***************************************
Algorytm sortowania metod? babelkowa
Autor: Tomek Kaminski
Mail: [link widoczny dla zalogowanych]
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. |
Post został pochwalony 0 razy
|
|
