program grafische_Algorithmen; uses crt,graph,dos; const max_punkte = 2000; x_koo: array[1..16] of byte = (3,11,6,4,5,8,1,7,9,14,10,16,15,13,3,12); y_koo: array[1..16] of byte = (9,1,8,3,15,11,6,4,7,5,13,14,2,16,12,10); type punkt = record name : char; x,y : integer; end; line = record p1,p2 : punkt; end; punktmenge = array[0..max_punkte] of punkt; var pm : punktmenge; A : punkt; (* 'Anker' fr GrahamScan *) N,CN : integer; procedure lies_punkte; var i : integer; p : punkt; begin N:=16; for i:=1 to N do begin p.name:=chr(64+i); p.x:=x_koo[i]*20; p.y:=319-y_koo[i]*15 -40; pm[i]:=p; end; end; procedure lies_zufaellige_punkte( Anzahl : integer); var i : integer; p : punkt; begin randomize; for i:=1 to Anzahl do begin p.name:=' '; p.x:=random(360)+20; p.y:=random(260)+20; pm[i]:=p; end; N:=Anzahl; end; function init_grafik_modus : boolean; var gd,gm,ercode : integer; begin gd:=detect; initGraph(gd,gm,''); if GraphResult<>grOK then init_grafik_modus:=false else init_grafik_modus:=true; end; procedure plot_frame; begin rectangle(0,0,400,300); end; procedure plot_punktmenge(max : integer); var i : integer; begin for i:=1 to max do begin putpixel(pm[i].x , pm[i].y , 11); outtextxy(pm[i].x+4 , pm[i].y-10 ,pm[i].name ); end; end; procedure plot_polygon(max : integer); var i : integer; begin for i:=1 to max-1 do begin graph.line(pm[i].x , pm[i].y , pm[i+1].x , pm[i+1].y ); delay(200); end; end; function ccw(p0,p1,p2 : punkt) : integer; var dx1,dx2,dy1,dy2 : integer; begin dx1:=p1.x-p0.x; dy1:=p1.y-p0.y; dx2:=p2.x-p0.x; dy2:=p2.y-p0.y; if dx1*dy2 > dy1*dx2 then ccw:=1; if dx1*dy2 < dy1*dx2 then ccw:=-1; if dx1*dy2 = dy1*dx2 then begin if (dx1*dx2 < 0) or (dy1*dy2 < 0) then ccw:=-1 else if (dx1*dx1 + dy1*dy1) >= (dx2*dx2 + dy2*dy2) then ccw:=0 else ccw:=1; end; end; function intersect(l1,l2 : line) : boolean; begin intersect:=((ccw(l1.p1,l1.p2,l2.p1)*ccw(l1.p1,l1.p2,l2.p2)) <= 0) and ((ccw(l2.p1,l2.p2,l1.p1)*ccw(l2.p1,l2.p2,l1.p2)) <= 0) ; end; function theta(p1,p2 : punkt) : real; var dx,dy,ax,ay : integer; t : real; begin dx:=p2.x - p1.x; ax:=abs(dx); dy:=p2.y - p1.y; ay:=abs(dy); if (dx=0) and (dy=0) then t:=0 else t:=dy/(ax+ay); if dx<0 then t:=2-t else if dy<0 then t:=4+t; theta:=t*90.0; end; function wrap(max : integer) : integer; (* Ermittlung der konvexen Hlle von p *) var i,min,M : integer; minangle,v : real; t : punkt; begin min:=1; for i:=2 to max do if pm[i].y < pm[min].y then min:=i; M:=0; pm[max+1]:=pm[min]; minangle:=0.0; repeat M:=M+1; t:=pm[M]; pm[M]:=pm[min]; pm[min]:=t; min:=max+1; v:=minangle; minangle:=360.0; for i:=M+1 to max+1 do if theta(pm[M],pm[i]) > v then if theta(pm[M],pm[i]) < minangle then begin min:=i; minangle:=theta(pm[M],pm[min]); end; until min=max+1; wrap:=M; end; (* Modifiziertes Sortierverfahren, welches die Punktmenge PM in der Gr÷e *) (* ihrer polaren Winkel in Bezug auf den Punkt p1 mit der kleinsten *) (* Y-Koordinate ordnet, so da ein einfacher geschlossener Pfad entsteht *) (* ---> von GrahamScan ben÷tigt *) procedure qsort_modified(L,R :integer); var i,j : integer; t,v : punkt; (* v ist der knstliche Median *) begin if L<R then begin v:=pm[R]; i:=L-1; j:=R; repeat repeat i:=i+1 until theta(A,pm[i]) >= theta(A,v); repeat j:=j-1 until theta(A,pm[j]) <= theta(A,v); t:=pm[i]; pm[i]:=pm[j]; pm[j]:=t; until j<=i; pm[j]:=pm[i]; pm[i]:=pm[R]; pm[R]:=t; qsort_modified(L,i-1); qsort_modified(i+1,R); end; end; function grahamscan(max : integer) : integer; (* Ermittlung der konvexen Hlle von p *) var i,j,min,M : integer; l : line; t : punkt; begin min:=1; for i:=2 to max do if pm[i].y < pm[min].y then min:=i; for i:=1 to max do if (pm[i].y = pm[min].y) and (pm[i].x > pm[min].x) then min:=i; A:=pm[min]; t:=pm[1]; pm[1]:=pm[min]; pm[min]:=t; qsort_modified(1,max); { setLineStyle(dottedln ,0, normWidth ); plot_polygon(max); (* Anzeigen des einfach geschlossenen *) graph.line(pm[1].x,pm[1].y,pm[max].x,pm[max].y); setLineStyle(solidln,0,normWidth ); (* Pfades nach dem Sortieren *) } pm[0]:=pm[max]; M:=3; for i:=4 to max do begin while ccw(pm[M],pm[M-1],pm[i]) >= 0 do M:=M-1; M:=M+1; t:=pm[M]; pm[M]:=pm[i]; pm[i]:=t; end; grahamscan:=M; end; procedure show_convex_hull(max : integer); begin plot_polygon(max); graph.line(pm[1].x , pm[1].y , pm[max].x , pm[max].y ); end; procedure write_time( welches_mal : integer); var h,m,s,s1 : word; zeit,t : string; begin gettime(h,m,s,s1); zeit:=' '; str(h,t); zeit:=zeit + t + ':' ; str(m,t); zeit:=zeit + t + ':' ; str(s,t); zeit:=zeit + t + '.' ; str(s1,t); zeit:=zeit + t; if welches_mal = 1 then begin outtextxy(450,100,'Beginn: '); outtextxy(520,100,zeit); end else begin outtextxy(450,150,'Ende: '); outtextxy(520,150,zeit); end; end; (**************************** Main ************************) var Anzahl : integer; begin clrscr; writeln(' ********** Geometrische Algorithmen ************* '); writeln; writeln; write(' Anzahl der darzustellenden Punkte ? '); readln(Anzahl); lies_zufaellige_punkte(Anzahl); if init_grafik_modus then begin (* Teil 1 : Wrap *) plot_frame; plot_punktmenge(N); outtextxy(465,40,'WRAP-ALGORITHMUS'); write_time(1); CN:=wrap(N); write_time(2); show_convex_hull(CN); readln; (* Teil 2 : Graham-Scan *) cleardevice; lies_zufaellige_punkte(Anzahl); plot_frame; plot_punktmenge(N); outtextxy(480,40,'GRAHAM-SCAN'); write_time(1); CN:=GrahamScan(N); write_time(2); show_convex_hull(CN); readln; closeGraph; end else writeln('Fehler bei Grafik-Karten-Initialisierung !!! '); end.