Tak jsem to ještě pořádně přežvýkal, okomentoval, odstranil chyby (hlavně moje), doplnil pár drobností, a dosavadní výsledky experimentování rozdělil do šesti různých módů kreslení.
Příloha:
kresby.png [ 31.23 KiB | Zobrazeno 10120 krát ]
Příloha:
rotace.png [ 25.45 KiB | Zobrazeno 10120 krát ]
Teda, na to že to původně mělo jednapadesát řádků se mi to docela slušně rozlezlo.
Kód:
PROGRAM GRAFIK;
(*CAROVA GRAFIKA*)
uses Graph;
const PIPI = 6.2831853; (* 2*PI pro vypocty paprsku *)
VAR karta,rezim:integer; (* nastaveni grafiky *)
qpenx,qpeny,qpenspeed,qJ,qN,qM:integer; (* promenne plotteru *)
(*****************************************************************************
* reset listu, smazani vseho
*)
procedure reset;
begin
cleardevice;
floodfill(0,0,15);
setcolor(0);
end;
(*****************************************************************************
* inicializace pera do pocatecni polohy x,y
* v rozsahu 0,0..1500,2100
*)
procedure qorg(x,y:integer);
begin
if x<0 then x:=0 else
if x>1500 then x:=1500;
if y<0 then y:=0 else
if y>2100 then y:=2100;
qpenx:=y;
qpeny:=x
end;
(*****************************************************************************
* nastaveni rychlosti kresleni 0..5
* 5 = maximalni
* 1 = minimalni
* 0 = mimo limit, zelva
*)
procedure qspeed(r:integer);
begin
if r<0 then r:=0 else
if r>5 then r:=5;
qpenspeed:=32767;
while r>0 do
begin
qpenspeed:=qpenspeed div 8;
dec(r)
end
end;
(*****************************************************************************
* posun pera na absolutni pozici x,y
* v rozsahu 0,0..1500,2100
*)
procedure qmova(x,y:integer);
begin
if x<0 then x:=0 else
if x>1500 then x:=1500;
if y<0 then y:=0 else
if y>2100 then y:=2100;
qpenx:=x;
qpeny:=y
end;
(*****************************************************************************
* nakresleni cary z aktualni pozice na absolutni x,y
* okraje papiru nejsou hlidane
*)
procedure qvecta(x,y:integer);
var t,w:integer;
begin
line(5+qpeny*3 div 10,465-qpenx*3 div 10,5+y*3 div 10,465-x*3 div 10);
qpenx:=x;
qpeny:=y;
(* zpomalovaci smycka *)
for t:=qpenspeed downto 0 do w:=getgraphmode
end;
(*****************************************************************************
* konfigurace procedury MINI
* qJ = pocet opakovani
* qN = delitel pro posun
* qM = mod kresleni
*)
procedure qconf(j,n,m:integer);
begin
if j<1 then qJ:=1 else qJ:=j;
if n<2 then qN:=2 else qN:=n;
if m<0 then qM:=0 else qM:=m
end;
(*****************************************************************************
* kresleni dvou car ve tvaru L do zmensujici se spiraly
*)
PROCEDURE MINI(X1,Y1,X2,Y2,X3,Y3:INTEGER);
CONST J = 50; (*ROZLISITELNOST KRESBY*)
N = 50; (*DELENI*)
VAR I,X,Y : INTEGER;
(*******************************************************************
* 0 = puvodni kreslici rutina
*)
procedure mode0;
var i:integer;
begin
QMOVA(X1,Y1);
FOR I:=1 TO qJ DO
BEGIN
IF I MOD 2=1 THEN (*KRESLENI JEDNIM TAHEM TAM*)
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3);
X :=(X2-X1) DIV qN+X1;
Y :=(Y2-Y1) DIV qN+Y1;
X2:=(X3-X2) DIV qN+X2;
Y2:=(Y3-Y2) DIV qN+Y2;
QVECTA(X2,Y2);
X3:=(X1-X3) DIV qN+X3;
Y3:=(Y1-Y3) DIV qN+Y3;
X1:=X;
Y1:=Y;
IF NOT(I MOD 2=1) THEN (*KRESLENI JEDNIM TAHEM ZPET*)
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3)
END
end;
(*******************************************************************
* vypocet posunu k dalsimu bodu
*)
function posun(a,b:integer):integer;
begin
posun:=(b-a) DIV qN+a
end;
(*******************************************************************
* 1 = opraveny zacatek kresleni
*)
procedure mode1;
var i:integer;
begin
QMOVA(x3,y3);
qvecta(x2,y2);
qvecta(X1,Y1);
FOR I:=1 TO qJ DO
BEGIN
IF I MOD 2=1 THEN
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3);
X :=posun(X1,X2);
Y :=posun(Y1,Y2);
X2:=posun(X2,X3);
Y2:=posun(Y2,Y3);
QVECTA(X2,Y2);
X3:=posun(X3,X1);
Y3:=posun(Y3,Y1);
X1:=X;
Y1:=Y;
IF NOT(I MOD 2=1) THEN
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3)
END
end;
(*******************************************************************
* otoci body do dalsi pozice
*)
procedure otocit;
begin
X :=posun(X1,X2);
Y :=posun(Y1,Y2);
X2:=posun(X2,X3);
Y2:=posun(Y2,Y3);
X3:=posun(X3,X1);
Y3:=posun(Y3,Y1);
X1:=X;
Y1:=Y
end;
(*******************************************************************
* 2 = 2 cary tam a zpet
*)
procedure mode2;
var i:integer;
begin
FOR I:=1 TO qJ DO
BEGIN
IF I MOD 2=1 THEN
QmovA(X1,Y1)
ELSE
QmovA(X3,Y3);
QVECTA(X2,Y2);
IF NOT(I MOD 2=1) THEN
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3);
otocit
END
end;
(*******************************************************************
* 3 = 3 cary tam a zpet
*)
procedure mode3;
var i:integer;
begin
QMOVA(X1,Y1);
FOR I:=1 TO qJ DO
BEGIN
IF I MOD 2=1 THEN
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3);
QVECTA(X2,Y2);
IF NOT(I MOD 2=1) THEN
QVECTA(X1,Y1)
ELSE
QVECTA(X3,Y3);
otocit
END
end;
(*******************************************************************
* 4 = trojuhelnikova spirala
*)
procedure mode4;
var i:integer;
begin
QMOVA(X1,Y1);
FOR I:=1 TO qJ DO
BEGIN
QVECTA(X2,Y2);
otocit;
QVECTA(X3,Y3);
QVECTA(X1,Y1)
END
end;
(*******************************************************************
* 5 = uplne trojuhelniky
*)
procedure mode5;
var i:integer;
begin
FOR I:=1 TO qJ DO
BEGIN
QMOVA(X1,Y1);
QVECTA(X2,Y2);
QVECTA(X3,Y3);
QVECTA(X1,Y1);
otocit
END
end;
(*******************************************************************)
BEGIN
case qM of
5: mode5;
4: mode4;
3: mode3;
2: mode2;
1: mode1;
else mode0
end
END;
(*****************************************************************************
* rotace kytky
* xs,ys = souradnice stredu
* r = polomer
* v = pocet vrcholu
* o = orientace
* 0 = nahore hrot
* 1 = nahore list
*)
procedure kytka(xs,ys,r,v,o:integer);
var a:real;
i,x1,y1,x2,y2,x3,y3:integer;
begin
if v<2 then v:=2;
for i:=1 to v do
begin
a:=pipi*(i-1)/v;
x1:=xs+round(r*cos(a));
y1:=ys+round(r*sin(a));
a:=pipi*(i-0.5)/v;
x2:=xs+round(r*cos(a));
y2:=ys+round(r*sin(a));
a:=pipi*i/v;
x3:=xs+round(r*cos(a));
y3:=ys+round(r*sin(a));
if 0=(o mod 2) then
begin
mini(x1,y1,xs,ys,x2,y2);
mini(x3,y3,xs,ys,x2,y2)
end
else
begin
mini(x2,y2,xs,ys,x1,y1);
mini(x2,y2,xs,ys,x3,y3)
end
end
end;
(*****************************************************************************
* rotace vetrniku
* xs,ys = souradnice stredu
* r = polomer
* v = pocet vrcholu
* s = smer
* 0 = toci doleva
* 1 = toci doprava
*)
procedure vetrnik(xs,ys,r,v,s:integer);
var a:real;
i,x1,y1,x2,y2:integer;
begin
if v<3 then v:=3;
for i:=1 to v do
begin
a:=pipi*(i-1)/v;
x1:=xs+round(r*cos(a));
y1:=ys+round(r*sin(a));
a:=pipi*i/v;
x2:=xs+round(r*cos(a));
y2:=ys+round(r*sin(a));
if 0=(s mod 2) then
mini(x1,y1,xs,ys,x2,y2)
else
mini(x2,y2,xs,ys,x1,y1)
end
end;
(*****************************************************************************)
BEGIN
writeln;
writeln(' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ');
writeln(' * GRAFIK TURBO, rozsirene demo pro Aritma Minigraf 0507 k IQ151 * ');
writeln(' * ============================================================= * ');
writeln(' * pro pokracovani mackej ENTER... * ');
writeln(' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ');
readln;
karta:=9;
rezim:=2;
initgraph(karta,rezim,' ');
reset;
QORG(0,0);
QSPEED(5);
qconf(20,20,3);
(* puvodni obrazek *)
MINI(1500, 0, 750, 750, 750, 500);
MINI( 0, 0, 750, 750, 750, 500);
MINI(1500, 0, 750, 750, 900,2100);
MINI( 0, 0, 750, 750, 600,2100);
MINI( 900,2100, 750, 750, 750,2100);
MINI( 600,2100, 750, 750, 750,2100);
readln;
reset;
qconf(50,20,5);
mini( 0, 0, 0,2100,1500,2100);
mini( 0, 0,1500, 0,1500,2100);
mini(1500,2100, 0,2100, 0, 0);
mini(1500,2100,1500, 0, 0, 0);
readln;
reset;
qconf(20,10,0);
kytka(1125, 350,350,5,1);
qconf(20,10,1);
kytka( 375, 350,350,5,1);
qconf(20,10,2);
kytka(1125,1050,350,5,1);
qconf(20,10,3);
kytka( 375,1050,350,5,1);
qconf(20,10,4);
kytka(1125,1750,350,5,1);
qconf(20,10,5);
kytka( 375,1750,350,5,1);
readln;
reset;
qconf(20,10,0);
vetrnik(1125, 350,350,5,1);
qconf(20,10,1);
vetrnik( 375, 350,350,5,1);
qconf(20,10,2);
vetrnik(1125,1050,350,5,1);
qconf(20,10,3);
vetrnik( 375,1050,350,5,1);
qconf(20,10,4);
vetrnik(1125,1750,350,5,1);
qconf(20,10,5);
vetrnik( 375,1750,350,5,1);
readln;
closegraph;
END.
Má někdo chuť to přepsat do skutečného íkvéčka?
To by byly čáry, a teď se možná pokusím i o nějakou elipsu.