uses
windows;
{$RANGECHECKS ON}
type pt =object
x,y:single;
end;
type line=object
start,finish:pt
end;
type
Arrpt=array of pt;
arrline=array of line;
function rotate(pivot:pt;p:pt;a:single):pt; // not gdi
var
t:pt;
begin
t.x:=(Cos(a*0.0174533)*(p.x-pivot.x)-Sin(a*0.0174533)*(p.y-pivot.y)) +pivot.x;
t.y:=(Sin(a*0.0174533)*(p.x-pivot.x)+Cos(a*0.0174533)*(p.y-pivot.y)) +pivot.y;
exit(t);
end;
function centroid(p:arrpt):pt; // not gdi
var i:int32;
var ans:pt;
begin
ans.x:=0;
ans.y:=0;
for i:=0 to high(p) do
begin
ans.x:=ans.x+p[i].x;
ans.y:=ans.y+p[i].y;
end;
ans.x:=ans.x/length(p);
ans.y:=ans.y/length(p);
exit(ans);
end;
function rotatepolygon(p:arrpt;angle:single):arrpt; // not gdi
var c:pt;
var i:int32;
var ans:arrpt=nil;
begin
setlength(ans,length(p));
c:=centroid(p);
for i:=0 to high(p) do ans[i]:=rotate(c,p[i],angle);
exit(ans);
end;
function rotatelines(pivot:pt;L:arrline;angle:single):arrline; // not gdi
var
i:int32;
begin
for i:=0 to high(L) do
begin
L[i].start:=rotate(pivot,L[i].start,angle);
L[i].finish:=rotate(pivot,L[i].finish,angle);
end;
exit(L);
end;
procedure switch(var a:single;var b: single); // not gdi used in getlines
var temp: single;
begin
temp := a; a := b; b := temp;
end;
function GetLines(p:Arrpt;gap:int32):arrline; // not gdi
type
Arr2D = array of array of single;
var
sy:single=1e6;
by:single=-1e6;
dx,dy:single;
a:Arr2D=nil;
i,j,y,k,count:int32;
S:array of single=nil;
xi:array of single=nil;
ans:arrline=nil;
begin
count:=-1;
SetLength(a, length(p)+1, 2);
For i :=0 To high(p) do
begin
a[i,0]:=p[i].x;
a[i,1]:=p[i].y;
If (Sy>p[i].y) Then Sy:=p[i].y;
If (By<p
[i
].y) Then By
:=p
[i
].y; end;
setlength(xi,length(a)+1);
setlength(S,length(a)+1);
a[high(a),0] := a[0,0];
a[high(a),1] := a[0,1];
For i:=0 To high(a)-1 do
begin
dy:=a[i+1,1]-a[i,1];
dx:=a[i+1,0]-a[i,0];
If (dy=0.0) Then S[i]:=1.0;
If (dx=0.0) Then S[i]:=0.0;
If (dy<>0) And (dx<>0) Then S[i]:=dx/dy;
end;
For y:=trunc(Sy-1) To trunc(By+1) do
begin
k:=0;
For i:=0 To high(a)-1 do
begin
If ((a[i,1]<=y) And (a[i+1,1]>y)) Or (a[i,1]>y) And (a[i+1,1]<=y) Then
begin
xi[k]:=(a[i,0]+S[i]*(y-a[i,1]));
k:=k+1;
End;
end;
For j:=0 To k-2 do
begin
For i:=0 To k-2 do
begin
If xi[i]>xi[i+1] Then Switch (xi[i],xi[i+1]);
end;
end;
i:=0;
while (i< k-1) do
begin
if (y mod gap=0) then
begin
count:=count+1;
setlength(ans,count+1);
ans[count].start.x:=xi[i];
ans[count].start.y:=y;
ans[count].finish.x:=xi[i+1]+1;
ans[count].finish.y:=y;
end;
i:=i+2
end;
end;
exit(ans);
End;
function createpolygon(p:pt;num:int32):Arrpt; // not GDI, rough way to get a polygon
const pi=3.141592653589793;
var
z,step:single;
t:arrpt=nil;
temp:pt;
counter:int32=0;
begin
step:=2*pi/num;
z:=0;
while (z<=2*pi) do
begin
counter:=counter+1;
temp.x:=p.x+(50+random(300))*cos(z);
temp.y:=p.y+(50+random(300))*sin(z);
setlength(t,counter);
t[counter-1].x:=temp.x;
t[counter-1].y:=temp.y;
z:=z+step;
end;
exit(t);
end;
///////////////////////// gdi stuff //////////////////////////
procedure drawpolygon(h:hdc;p:arrpt;colour:longword);
var i:int32;
begin
SetDCPenColor(h,colour);
for i:=0 to high(p)-1 do
begin
MoveToEx(h,trunc(p[i].x),trunc(p[i].y),nil);
LineTo(h, trunc(p[i+1].x),trunc(p[i+1].y));
end;
MoveToEx(h,trunc(p[high(p)].x),trunc(p[high(p)].y),nil);
LineTo(h, trunc(p[0].x),trunc(p[0].y));
end;
procedure drawlines(h:hdc;L:arrline;colour:longword);
var i:int32;
begin
SetDCPenColor(h,colour);
for i:=0 to high(L) do
begin
MoveToEx(h,trunc(L[i].start.x),trunc(L[i].start.y),nil);
LineTo(h, trunc(L[i].finish.x),trunc(L[i].finish.y));
end;
end;
procedure setfontsize(h:hdc;size:integer;style:pchar);
begin
SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style));
End;
procedure setfontcolours(h:hdc;text:longword;background:longword);
begin
SetTextColor(h,text) ;
SetBkColor(h,background);
End;
procedure text(h:hdc;x:integer;y:integer;s:pchar);
Var l:integer;
begin
l:=Length(s);
textouta(h,x,y,s,L);
End;
procedure ClearScreen(h:hdc;colour:longint);
begin
SetDCBrushColor(h,colour);
SetDCPenColor(h,colour);
rectangle(h,0,0,1024,768);
End;
procedure hidecursor();
var
consoleHandle:handle;
info:CONSOLE_CURSOR_INFO;
begin
consolehandle := GetStdHandle(STD_OUTPUT_HANDLE);
info.dwSize := 100;
info.bVisible := FALSE;
SetConsoleCursorInfo(consoleHandle, @info);
End;
const
DC_BRUSH=18;
DC_PEN=19;
var
Memhdc,WorkingScreen:hdc;
p:hwnd;
Membitmap:HBITMAP;
sysmenu:qword;
pts:arrpt;
centre:pt;
numsides:int32;
s:ansistring;
lines:arrline;
newpoints:arrpt;
newlines:arrline;
begin
p:=getconsolewindow();
setwindowpos(p, HWND_TOPMOST, 100, 100, 1024, 768,SWP_SHOWWINDOW);
WorkingScreen:=GetDC(p);
Memhdc := CreateCompatibleDC(WorkingScreen);
Membitmap := CreateCompatibleBitmap(WorkingScreen, 1024, 768);
SelectObject(Memhdc, Membitmap);
SelectObject(Memhdc,GetStockObject(DC_BRUSH));
SelectObject(Memhdc,GetStockObject(DC_PEN));
setfontsize(Memhdc,35,'comic sans ms');
setfontcolours(Memhdc,rgb(200,100,0),0);
//'some console instructions
sysMenu := GetSystemMenu(p, False);
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND) ; // 'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND); //'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND); //'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND); //'non resizable console
hidecursor();
ShowScrollBar(p, SB_BOTH, FALSE);
SetBkMode (Memhdc, TRANSPARENT);
centre.x:=1024/2;
centre.y:=768/2;
While true do
begin
//non GDI
numsides:=(4+random(8));
pts:=createpolygon(centre,numsides);
newpoints:=rotatepolygon(pts,45);
lines:=GetLines(newpoints,10);
newlines:=rotatelines(centroid(pts),lines,-45);
// GDI
clearscreen(Memhdc,rgb(55,255,255));
text(Memhdc,10,60,'Press escape to finish.');
str(numsides,s);
text(Memhdc,10,700,'Number of sides ');
text(Memhdc,230,700,pchar(s));
drawpolygon(Memhdc,pts,rgb(200,0,0)); //original polygon
drawlines(Memhdc,newlines,rgb(0,0,0)); // angled lines
BitBlt(WorkingScreen, 0, 0, 1024, 768,Memhdc, 0, 0,SRCCOPY);
If (GetAsyncKeyState($1B)<>0) Then //' escape key
begin
DeleteObject(Membitmap);
DeleteDC (Memhdc);
GetSystemMenu(p,true);
Exit;
end;
sleep(1000);
end;
end.