OldComp.cz http://oldcomp.cz/ |
|
Naháním algoritmus nebo program pro „čárovou“ grafiku http://oldcomp.cz/viewtopic.php?f=113&t=8557 |
Stránka 6 z 7 |
Autor: | faraon [ 17.05.2020, 08:48 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Kytky můžou být orientované svisle nebo vodorovně: Příloha: kytky.png [ 7.61 KiB | Zobrazeno 10300 krát ] Kód: 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:=0 to v do begin a:=6.2831853*i/v; x1:=xs+round(r*cos(a)); y1:=ys+round(r*sin(a)); a:=6.2831853*(i+0.5)/v; x2:=xs+round(r*cos(a)); y2:=ys+round(r*sin(a)); a:=6.2831853*(i+1)/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; Opět podle sudého nebo lichého čísla v posledním parametru a s ridší konstantou N=20: Kód: kytka(1100, 400,350,1,0); kytka( 400, 600,350,1,1); kytka(1100,1300,350,4,0); kytka( 400,1500,350,4,1); A s tím by už měl jít vykreslit libovolný obrazec ze začátku vlákna. |
Autor: | faraon [ 17.05.2020, 09:11 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Tak ještě jedna změna, s tímhle by měly jít vykreslit úplně stejně jako na těch obrázcích: Kód: PROCEDURE MINI(X1,Y1,X2,Y2,X3,Y3:INTEGER); CONST J = 50; (*ROZLISITELNOST KRESBY*) N = 20 {50}; (*DELENI*) VAR I,X,Y : INTEGER; BEGIN QMOVA(X2,Y2); FOR I:=1 TO J DO BEGIN IF I MOD 2=1 THEN (*KRESLENI JEDNIM TAHEM TAM*) QVECTA(X1,Y1) ELSE QVECTA(X3,Y3); X :=(X2-X1) DIV N+X1; Y :=(Y2-Y1) DIV N+Y1; X2:=(X3-X2) DIV N+X2; Y2:=(Y3-Y2) DIV N+Y2; QVECTA(X2,Y2); X3:=(X1-X3) DIV N+X3; Y3:=(Y1-Y3) DIV N+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; Měli tam nesprávné nastavení počátečního bodu kreslení na (X1,Y1) místo (X2,Y2), takže chyběla první čára. U těch rotačních kreseb tvořila vnitřní kříž. Takže ten QORG klidně mohl být také špatně, chyby útočí ve smečkách |
Autor: | tomascz [ 17.05.2020, 09:16 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Chválím za přepisy! Připomíná mi to obrázky kreslené kyblíkem barvy (ideálně ještě s dodatečným závažím, aby to mělo nějakou váhu), na který působí fyzikálními zákony - v angličtině "pendlum painting". https://www.youtube.com/watch?v=9wEQlWo6Ddc |
Autor: | faraon [ 17.05.2020, 10:05 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Pořád ještě to není úplně přesné. A když tam tu další chybějící čáru dokreslím, tak to zase v tom místě vychází moc hustě. Ale pokud se v jednom z těch větvení v MINI změní 1 na 0, tak to umí háčkovat dečky! S konstantami J i N na 20: Příloha:
|
Autor: | Panda38 [ 17.05.2020, 11:15 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Možná ještě přidat trochu animace? |
Autor: | faraon [ 17.05.2020, 11:25 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
No pěkné, jenže tohle ten TP pod DOSBoxem nestíhá ani náhodou, a na reálném plotteru bys jednu sekvenci rýsoval možná do zimy Co takhle přenést Petra do Linuxu? Na Raspberry Pi by mohl dost slušně konkurovat Scratchi! |
Autor: | ub880d [ 17.05.2020, 14:17 ] | ||
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku | ||
faraon píše: Pořád ještě to není úplně přesné. A když tam tu další chybějící čáru dokreslím, tak to zase v tom místě vychází moc hustě. skus najskor vykreslit [x1,y1]->[x2,y2] a [x2,y2]->[x3,y3] a az potom vyratavat nove [x1,y1], [x2,y2] a [x3,y3]v ramci roznorodosti jazykov prikladam ukazku v php ;] (pridana pripona .txt, neviem ci je .php povolene na upload) EDIT: este.. v tom Tvojom programe bude treba tie prve qvect (na zaciatku cyklu) zmenit na qmove a to qmove este pred cyklom mozes potom vyhodit
|
Autor: | Nostalcomp [ 18.05.2020, 14:12 ] | |||
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku | |||
Ještě jsem našel toto:
|
Autor: | faraon [ 18.05.2020, 21:54 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
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: Příloha: 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. |
Autor: | tomascz [ 19.05.2020, 10:44 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Skvělá práce! Jen s umísťováním BEGINu a ENDu na stejnou úroveň jako příkazy, které "obklopují," jsem se zatím nesetkal - trochu hůř se to čte... Kód: if 0=(o mod 2) then begin mini(x1,y1,xs,ys,x2,y2); mini(x3,y3,xs,ys,x2,y2) end; vs if 0=(o mod 2) then begin mini(x1,y1,xs,ys,x2,y2); mini(x3,y3,xs,ys,x2,y2) end; nebo if 0=(o mod 2) then begin mini(x1,y1,xs,ys,x2,y2); mini(x3,y3,xs,ys,x2,y2) end; Ale to je věc zvyku. Sám mám ošklivý zlozvyk dávat v C++ i C#/CLR prefix "T" u struktur/enumerací a "C" u tříd Tak nějak mi ten kód pak přijde intuitivnější... |
Autor: | Panda38 [ 19.05.2020, 11:10 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
tomascz píše: ...Jen s umísťováním BEGINu a ENDu na stejnou úroveň jako příkazy, které "obklopují," jsem se zatím nesetkal - trochu hůř se to čte... Na to mi přijdou závorky v C přehlednější, líp to opticky ohraničuje blok. Kód: if (0==o%2) { mini(x1,y1,xs,ys,x2,y2); mini(x3,y3,xs,ys,x2,y2); } if (0==o%2) { mini(x1,y1,xs,ys,x2,y2); mini(x3,y3,xs,ys,x2,y2); } Prefix u tříd a struktur mi nepřijde zlozvyk, odliší se to tak od jmen proměnných. |
Autor: | faraon [ 19.05.2020, 19:07 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Whitesmiths: https://www.slant.co/topics/2478/~best-indentation-style-in-c Ale ne tak docela. Já jsem kdysi vyzkoušel spoustu různých stylů, ale žádný mi úplně nevyhovoval. Pak jsem v jedné prastaré učebnici Algolu narazil právě na tohle, a prakticky na první pohled jsem zjistil že je to právě to co hledám. Pascal: Kód: for i:=1 to 10 do begin writeln(i) end C: Kód: for (i=1;i<=10;++i) { printf("%d\n",i); } Python: Kód: for i in range(1,11): print(i) BASIC: Kód: FOR I=1 TO 10 PRINT I NEXT I Karel: Kód: OPAKUJ 5-KRÁT KE-ZDI VLEVO-VBOK KONEC Od té doby jsem to používal ve všech jazycích, s výjimkou FORTRANu. Ten má svoje děrnoštítkové formátování a nutit mu cokoliv jiného by byla urážka. Naopak třeba v Pythonu mi to moc pomáhá! Má to prosté schéma: Klíčové slovo - mezera - zarovnaný blok. A když si z té mezery za klíčovým slovem udělám/myslím čáru dolů, poznám okamžitě co do bloku patří, kde končí, a jaké věci se v něm vnořují. Pro mě je tohle nejpřehlednější, hlavně při čmárání programů ručně na papír P.S: Mimochodem, kopenogramy nejsou ani trochu mrtvá záležitost, naopak jsou dnes mnohem živější než v osmdesátých letech Příloha: Blockly10.png [ 5.97 KiB | Zobrazeno 10060 krát ] |
Autor: | faraon [ 23.05.2020, 13:03 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Konečně je tady i BASICová verze! Jede to v QBasicu, ale neměly by tam snad být žádné nepřenositelné speciality. Akorát to WHILE INKEY$ = "": WEND je čekání na stisk klávesy. Pochopitelně je ten program mnohem pomalejší a výsledek hnusnější Příloha: Příloha: Řádek 30 není nutný, takhle to počítá trochu rychleji. Konstanta na řádku 50 také nemusí být konstantní, stačí proměnná. A snažil jsem se nepoužívat GOTO, až na pár výjimečných případů: Kód: 10 REM PROGRAM GRAFIK;
20 REM (*CAROVA GRAFIKA*) 30 DEFINT A-Z: DEFSNG U 50 CONST pipi = 6.2831853#: REM (* 2*PI pro vypocty paprsku *) 60 REM vypocet posunu k dalsimu bodu 70 DEF fnp (a, b) = INT((b - a) / qN + a + .5) 100 REM ********************************************************************** 110 PRINT " * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *" 111 PRINT " * GRAFIK TURBO, rozsirene demo pro Aritma Minigraf 0507 k IQ151 *" 112 PRINT " * ============================================================= *" 113 PRINT " * pro pokracovani mackej ENTER... *" 114 PRINT " * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *" 120 WHILE INKEY$ = "": WEND 130 SCREEN 12: REM graficky rezim 640x480 140 GOSUB 999 150 a = 0: b = 0: GOSUB 1000: REM QORG(0,0); 160 a = 5: GOSUB 1100: REM QSPEED(5); 200 a = 20: b = 20: c = 3: GOSUB 1400 201 REM (* puvodni obrazek *) 202 a = 1500: b = 0: c = 750: d = 750: e = 750: f = 500: GOSUB 1500 203 a = 0: b = 0: c = 750: d = 750: e = 750: f = 500: GOSUB 1500 204 a = 1500: b = 0: c = 750: d = 750: e = 900: f = 2100: GOSUB 1500 205 a = 0: b = 0: c = 750: d = 750: e = 600: f = 2100: GOSUB 1500 206 a = 900: b = 2100: c = 750: d = 750: e = 750: f = 2100: GOSUB 1500 207 a = 600: b = 2100: c = 750: d = 750: e = 750: f = 2100: GOSUB 1500 208 WHILE INKEY$ = "": WEND 209 GOSUB 999 300 a = 50: b = 20: c = 5: GOSUB 1400: REM qconf(); 301 a = 0: b = 0: c = 0: d = 2100: e = 1500: f = 2100: GOSUB 1500 302 a = 0: b = 0: c = 1500: d = 0: e = 1500: f = 2100: GOSUB 1500 303 a = 1500: b = 2100: c = 0: d = 2100: e = 0: f = 0: GOSUB 1500 304 a = 1500: b = 2100: c = 1500: d = 0: e = 0: f = 0: GOSUB 1500 305 WHILE INKEY$ = "": WEND 306 GOSUB 999 400 a = 20: b = 10: c = 0: GOSUB 1400 401 a = 1125: b = 350: c = 350: d = 5: e = 1: GOSUB 1800 402 a = 20: b = 10: c = 1: GOSUB 1400 403 a = 375: b = 350: c = 350: d = 5: e = 1: GOSUB 1800 404 a = 20: b = 10: c = 2: GOSUB 1400 405 a = 1125: b = 1050: c = 350: d = 5: e = 1: GOSUB 1800 406 a = 20: b = 10: c = 3: GOSUB 1400 407 a = 375: b = 1050: c = 350: d = 5: e = 1: GOSUB 1800 408 a = 20: b = 10: c = 4: GOSUB 1400 409 a = 1125: b = 1750: c = 350: d = 5: e = 1: GOSUB 1800 410 a = 20: b = 10: c = 5: GOSUB 1400 411 a = 375: b = 1750: c = 350: d = 5: e = 1: GOSUB 1800 412 WHILE INKEY$ = "": WEND 413 GOSUB 999 500 a = 20: b = 10: c = 0: GOSUB 1400 501 a = 1125: b = 350: c = 350: d = 5: e = 1: GOSUB 1900 502 a = 20: b = 10: c = 1: GOSUB 1400 503 a = 375: b = 350: c = 350: d = 5: e = 1: GOSUB 1900 504 a = 20: b = 10: c = 2: GOSUB 1400 505 a = 1125: b = 1050: c = 350: d = 5: e = 1: GOSUB 1900 506 a = 20: b = 10: c = 3: GOSUB 1400 507 a = 375: b = 1050: c = 350: d = 5: e = 1: GOSUB 1900 508 a = 20: b = 10: c = 4: GOSUB 1400 509 a = 1125: b = 1750: c = 350: d = 5: e = 1: GOSUB 1900 510 a = 20: b = 10: c = 5: GOSUB 1400 511 a = 375: b = 1750: c = 350: d = 5: e = 1: GOSUB 1900 989 WHILE INKEY$ = "": WEND: SCREEN 0: END 990 REM ********************************************************************** 991 REM * reset listu, smazani vseho 992 REM * procedure reset; 995 CLS 996 LINE (0, 0)-(639, 479), 15, BF 997 COLOR 0 998 RETURN 999 GOTO 990 1000 REM ********************************************************************* 1001 REM * inicializace pera do pocatecni polohy x,y 1002 REM * v rozsahu 0,0..1500,2100 1003 REM * procedure qorg(a,b); 1010 IF a < 0 THEN a = 0 1011 IF a > 1500 THEN a = 1500 1012 IF b < 0 THEN b = 0 1013 IF b > 2100 THEN b = 2100 1020 qpenx = a 1021 qpeny = b 1030 RETURN 1100 REM ********************************************************************* 1101 REM * nastaveni rychlosti kresleni 0..5 1102 REM * 5 = maximalni 1103 REM * 1 = minimalni 1104 REM * 0 = mimo limit, zelva 1105 REM * procedure qspeed(a); 1110 IF a < 0 THEN a = 0 1111 IF a > 5 THEN a = 5 1120 qpenspeed = 32767 1130 FOR i = 1 TO a 1131 qpenspeed = INT(qpenspeed / 8) 1132 NEXT i 1140 RETURN 1200 REM ********************************************************************* 1201 REM * posun pera na absolutni pozici x,y 1202 REM * v rozsahu 0,0..1500,2100 1203 REM * procedure qmova(a,b); 1210 IF a < 0 THEN a = 0 1211 IF a > 1500 THEN a = 1500 1212 IF b < 0 THEN b = 0 1213 IF b > 2100 THEN b = 2100 1220 qpenx = a 1221 qpeny = b 1230 RETURN 1300 REM ********************************************************************* 1301 REM * nakresleni cary z aktualni pozice na absolutni x,y 1302 REM * okraje papiru nejsou hlidane 1303 REM * procedure qvecta(a,b); 1310 LINE (5 + qpeny * 3 / 10, 465 - qpenx * 3 / 10)-(5 + b * 3 / 10, 465 - a * 3 / 10) 1311 qpenx = a 1312 qpeny = b 1320 REM (* zpomalovaci smycka *) 1321 FOR t = qpenspeed TO 0 STEP -1: NEXT t 1330 RETURN 1400 REM ********************************************************************* 1401 REM * konfigurace procedury MINI 1402 REM * qJ = pocet opakovani 1403 REM * qN = delitel pro posun 1404 REM * qM = mod kresleni 1405 REM * procedure qconf(a,b,c); 1410 qJ = a: IF a < 1 THEN qJ = 1 1411 qN = b: IF b < 2 THEN qN = 2 1412 qM = c: IF c < 0 THEN qM = 0 1420 RETURN 1450 REM ********************************************************************* 1451 REM * otoci body do dalsi pozice 1452 REM * procedure otocit; 1460 X = fnp(X1, X2) 1461 Y = fnp(Y1, Y2) 1462 X2 = fnp(X2, X3) 1463 Y2 = fnp(Y2, Y3) 1464 X3 = fnp(X3, X1) 1465 Y3 = fnp(Y3, Y1) 1466 X1 = X 1467 Y1 = Y 1470 RETURN 1500 REM ********************************************************************* 1501 REM * kresleni dvou car ve tvaru L do zmensujici se spiraly 1502 REM * PROCEDURE MINI(a,b,c,d,e,f); 1503 REM * CONST J = 50; (*ROZLISITELNOST KRESBY*) 1504 REM * N = 50; (*DELENI*) 1510 X1 = a: Y1 = b: X2 = c: Y2 = d: X3 = e: Y3 = f 1511 IF qM = 5 THEN GOTO 1640 1512 IF qM = 4 THEN GOTO 1620 1513 IF qM = 3 THEN GOTO 1600 1514 IF qM = 2 THEN GOTO 1580 1515 IF qM = 1 THEN GOTO 1550 1520 REM ********************************************************************* 1521 REM * 0 = puvodni kreslici rutina 1522 REM * procedure mode0; 1530 a = X1: b = Y1: GOSUB 1200 1531 FOR i = 1 TO qJ 1532 a = X3: b = Y3: IF (i / 2) <> INT(i / 2) THEN a = X1: b = Y1 1533 GOSUB 1300: REM (*KRESLENI JEDNIM TAHEM TAM*) 1534 X = fnp(X1, X2) 1535 Y = fnp(Y1, Y2) 1536 X2 = fnp(X2, X3) 1537 Y2 = fnp(Y2, Y3) 1538 a = X2: b = Y2: GOSUB 1300 1539 X3 = fnp(X3, X1) 1540 Y3 = fnp(Y3, Y1) 1541 X1 = X 1542 Y1 = Y 1543 a = X3: b = Y3: IF (i / 2) = INT(i / 2) THEN a = X1: b = Y1 1544 GOSUB 1300: REM (*KRESLENI JEDNIM TAHEM ZPET*) 1545 NEXT i 1546 RETURN 1550 REM ********************************************************************* 1551 REM * 1 = opraveny zacatek kresleni 1552 REM * procedure mode1; 1560 a = X3: b = Y3: GOSUB 1200 1561 a = X2: b = Y2: GOSUB 1300 1562 a = X1: b = Y1: GOSUB 1300 1563 FOR i = 1 TO qJ 1564 a = X3: b = Y3: IF (i / 2) <> INT(i / 2) THEN a = X1: b = Y1 1565 GOSUB 1300 1566 X = fnp(X1, X2) 1567 Y = fnp(Y1, Y2) 1568 X2 = fnp(X2, X3) 1569 Y2 = fnp(Y2, Y3) 1570 a = X2: b = Y2: GOSUB 1300 1571 X3 = fnp(X3, X1) 1572 Y3 = fnp(Y3, Y1) 1573 X1 = X 1574 Y1 = Y 1575 a = X3: b = Y3: IF (i / 2) = INT(i / 2) THEN a = X1: b = Y1 1576 GOSUB 1300 1578 NEXT i 1579 RETURN 1580 REM ********************************************************************* 1581 REM * 2 = 2 cary tam a zpet 1582 REM * procedure mode2; 1590 FOR i = 1 TO qJ 1591 a = X3: b = Y3: IF (i / 2) <> INT(i / 2) THEN a = X1: b = Y1 1592 GOSUB 1200 1593 a = X2: b = Y2: GOSUB 1300 1594 a = X3: b = Y3: IF (i / 2) = INT(i / 2) THEN a = X1: b = Y1 1595 GOSUB 1300 1596 GOSUB 1450 1597 NEXT i 1598 RETURN 1600 REM ******************************************************************* 1601 REM * 3 = 3 cary tam a zpet 1602 REM * procedure mode3; 1610 a = X1: b = Y1: GOSUB 1200 1611 FOR i = 1 TO qJ 1612 a = X3: b = Y3: IF (i / 2) <> INT(i / 2) THEN a = X1: b = Y1 1613 GOSUB 1300 1614 a = X2: b = Y2: GOSUB 1300 1615 a = X3: b = Y3: IF (i / 2) = INT(i / 2) THEN a = X1: b = Y1 1616 GOSUB 1300 1617 GOSUB 1450 1618 NEXT i 1619 RETURN 1620 REM ********************************************************************* 1621 REM * 4 = trojuhelnikova spirala 1622 REM * procedure mode4; 1630 a = X1: b = Y1: GOSUB 1200 1631 FOR i = 1 TO qJ 1632 a = X2: b = Y2: GOSUB 1300 1633 GOSUB 1450 1634 a = X3: b = Y3: GOSUB 1300 1635 a = X1: b = Y1: GOSUB 1300 1636 NEXT i 1637 RETURN 1640 REM ********************************************************************* 1641 REM * 5 = uplne trojuhelniky 1642 REM * procedure mode5; 1650 FOR i = 1 TO qJ 1651 a = X1: b = Y1: GOSUB 1200 1652 a = X2: b = Y2: GOSUB 1300 1653 a = X3: b = Y3: GOSUB 1300 1654 a = X1: b = Y1: GOSUB 1300 1655 GOSUB 1450 1656 NEXT i 1657 RETURN 1800 REM ********************************************************************* 1801 REM * rotace kytky 1802 REM * kxs,kys = souradnice stredu 1803 REM * kr = polomer 1804 REM * kv = pocet vrcholu 1805 REM * ko = orientace 1806 REM * 0 = nahore hrot 1807 REM * 1 = nahore list 1808 REM * procedure kytka(a,b,c,d,e); 1810 kxs = a: kys = b: kr = c: kv = d: ko = e 1811 IF kv < 2 THEN kv = 2 1812 FOR k = 1 TO kv 1813 u = pipi * (k - 1) / kv 1814 kx1 = kxs + INT(kr * COS(u) + .5) 1815 ky1 = kys + INT(kr * SIN(u) + .5) 1816 u = pipi * (k - .5) / kv 1817 kx2 = kxs + INT(kr * COS(u) + .5) 1818 ky2 = kys + INT(kr * SIN(u) + .5) 1819 u = pipi * k / kv 1820 kx3 = kxs + INT(kr * COS(u) + .5) 1821 ky3 = kys + INT(kr * SIN(u) + .5) 1830 IF (ko / 2) <> INT(ko / 2) THEN GOTO 1840 1831 a = kx1: b = ky1: c = kxs: d = kys: e = kx2: f = ky2: GOSUB 1500 1832 a = kx3: b = ky3: c = kxs: d = kys: e = kx2: f = ky2: GOSUB 1500 1833 GOTO 1850 1840 a = kx2: b = ky2: c = kxs: d = kys: e = kx1: f = ky1: GOSUB 1500 1841 a = kx2: b = ky2: c = kxs: d = kys: e = kx3: f = ky3: GOSUB 1500 1850 NEXT k 1851 RETURN 1900 REM ********************************************************************* 1901 REM * rotace vetrniku 1902 REM * vxs,vys = souradnice stredu 1903 REM * vr = polomer 1904 REM * vv = pocet vrcholu 1905 REM * vs = smer 1906 REM * 0 = toci doleva 1907 REM * 1 = toci doprava 1908 REM * procedure vetrnik(a,b,c,d,e); 1910 vxs = a: vys = b: vr = c: vv = d: vs = e 1911 IF vv < 3 THEN vv = 3 1912 FOR v = 1 TO vv 1913 u = pipi * (v - 1) / vv 1914 vx1 = vxs + INT(vr * COS(u) + .5) 1915 vy1 = vys + INT(vr * SIN(u) + .5) 1916 u = pipi * v / vv 1917 vx2 = vxs + INT(vr * COS(u) + .5) 1918 vy2 = vys + INT(vr * SIN(u) + .5) 1920 a = vx1: b = vy1: c = vxs: d = vys: e = vx2: f = vy2 1921 IF (s / 2) = INT(s / 2) THEN a = vx2: b = vy2: c = vxs: d = vys: e = vx1: f = vy1 1922 GOSUB 1500 1930 NEXT v 1931 RETURN |
Autor: | VesSoft [ 24.06.2020, 18:42 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
Ahoj, podobnou grafiku jsem kdysi dělal na IQ 151 se zapisovačem XY4121. Na githubu jsem našel kód, o který se rád podělím. Není jen můj, algoritmus jsem tenkrát někde opsal, podle komentáře asi v časopisu Elektronika č.6/1988 Kód: 0 REM E6/88-32 MATYAS/VESELY 1 XB=750:YB=1050:REM STRED 2 AX=750:AY=40:REM SOUR. BODU 3 BX =1313:BY=725 5 CX=1313:CY=1375 6 DX=750:DY=1700 7 EX=187:EY=1375 8 FX=187:FY=725 9 D=.05:I=50:REM KROK;POCET 10 SPEED 4 20 ORG0,0 30 XA=AX:YA=AY:XC=BX:YC=BY 40 GOSUB 520 50 XA=CX:YA=CY 60 GOSUB 520 70 XC=DX:YC=DY 80 GOSUB520 90 XA=EX:YA=EY 100 GOSUB 520 110 XC=FX:YC=FY 120 GOSUB 520 130 XA=AX:YA=AY 140 GOSUB 520 145 MOVA0,0 150 END 520 X1=XA:Y1=YA:X2=XB:Y2=YB:X3=XC:Y3=YC 530 FOR J=1 TO I 540 MOVAY1,X1 550 VECTA Y2,X2 560 VECTA Y3,X3 565 REMVECTA Y1,X1:REM TRETI STR 570 X=INT((X2-X1)*D+X1) 580 Y=INT((Y2-Y1)*D+Y1) 590 X2=INT((X3-X2)*D+X2) 600 Y2=INT((Y3-Y2)*D+Y2) 610 X3=INT((X1-X3)*D+X3) 620 Y3=INT((Y1-Y3)*D+Y3) 630 X1=X:Y1=Y 640 NEXT J 650 RETURN ORG je definice počátku kreslení MOVA je přesun pera na absolutní souřadnici bez kreslení VECTA je pohyb na abs. souřadnici s perem dole, tedy kreslení Jestli najdu trochu času, zkusím to předělat na vykreslování na obrazovce, ať to běží v emulátoru |
Autor: | l00k [ 04.07.2020, 08:49 ] |
Předmět příspěvku: | Re: Naháním algoritmus nebo program pro „čárovou“ grafiku |
dělá to tohle Příloha:
|
Stránka 6 z 7 | Všechny časy jsou v UTC + 1 hodina [ Letní čas ] |
Powered by phpBB® Forum Software © phpBB Group http://www.phpbb.com/ |