paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-11 15:47:51 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ SetActivePage

Browse Source 
+ SetVisualPage
  * Some bugfixes
  * Experimentation with new method for arc/ellipse
This commit is contained in:
carl 1999-05-05 02:16:40 +00:00
parent 4a1e9f1419
commit 040fa666a8
1 changed files with 107 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

158
rtl/inc/graph/graph.pp
View File

@ -445,6 +445,12 @@ TYPE
{ screen scan line with a word for each pixel in the scanline } { screen scan line with a word for each pixel in the scanline }
getscanlineproc = procedure (Y : integer; var data); getscanlineproc = procedure (Y : integer; var data);
{ changes the active display screen where we draw to... }
setactivepageproc = procedure (page: word);
{ changes the active display screen which we see ... }
setvisualpageproc = procedure (page: word);
{ this routine actually switches to the desired video mode. } { this routine actually switches to the desired video mode. }
initmodeproc = procedure; initmodeproc = procedure;
@ -480,6 +486,8 @@ TYPE
GetPixel : GetPixelProc; GetPixel : GetPixelProc;
PutPixel : PutPixelProc; PutPixel : PutPixelProc;
{ defaults possible ... } { defaults possible ... }
SetVisualPage : SetVisualPageProc;
SetActivePage : SetActivePageProc;
ClearViewPort : ClrViewProc; ClearViewPort : ClrViewProc;
PutImage : PutImageProc; PutImage : PutImageProc;
GetImage : GetImageProc; GetImage : GetImageProc;
@ -504,6 +512,8 @@ VAR
GetImage : GetImageProc; GetImage : GetImageProc;
ImageSize : ImageSizeProc; ImageSize : ImageSizeProc;
GetPixel : GetPixelProc; GetPixel : GetPixelProc;
SetVisualPage : SetVisualPageProc;
SetActivePage : SetActivePageProc;
GraphFreeMemPtr: graphfreememprc; GraphFreeMemPtr: graphfreememprc;
GraphGetMemPtr : graphgetmemprc; GraphGetMemPtr : graphgetmemprc;
@ -521,8 +531,6 @@ VAR
Procedure Closegraph; Procedure Closegraph;
procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word); procedure SetLineStyle(LineStyle: word; Pattern: word; Thickness: word);
procedure SetVisualPage(page : word);
procedure SetActivePage(page : word);
function GraphErrorMsg(ErrorCode: Integer): string; function GraphErrorMsg(ErrorCode: Integer): string;
Function GetMaxX: Integer; Function GetMaxX: Integer;
Function GetMaxY: Integer; Function GetMaxY: Integer;
@ -550,6 +558,7 @@ procedure SetFillStyle(Pattern : word; Color: word);
procedure SetFillPattern(Pattern: FillPatternType; Color: word); procedure SetFillPattern(Pattern: FillPatternType; Color: word);
procedure MoveRel(Dx, Dy: Integer); procedure MoveRel(Dx, Dy: Integer);
procedure MoveTo(X,Y: Integer); procedure MoveTo(X,Y: Integer);
{ -------------------- Color/Palette ------------------------------- } { -------------------- Color/Palette ------------------------------- }
procedure SetBkColor(ColorNum: Word); procedure SetBkColor(ColorNum: Word);
function GetColor: Word; function GetColor: Word;
@ -570,6 +579,7 @@ procedure SetFillPattern(Pattern: FillPatternType; Color: word);
{ -------------------- Circle related routines --------------------- } { -------------------- Circle related routines --------------------- }
procedure GetAspectRatio(var Xasp,Yasp : word); procedure GetAspectRatio(var Xasp,Yasp : word);
procedure SetAspectRatio(Xasp, Yasp : word); procedure SetAspectRatio(Xasp, Yasp : word);
procedure GetArcCoords(var ArcCoords: ArcCoordsType);
procedure Arc(X,Y : Integer; StAngle,EndAngle,Radius: word); procedure Arc(X,Y : Integer; StAngle,EndAngle,Radius: word);
@ -665,7 +675,6 @@ var
StartYViewPort: Integer; { absolute } StartYViewPort: Integer; { absolute }
ViewWidth : Integer; ViewWidth : Integer;
ViewHeight: Integer; ViewHeight: Integer;
VideoStart: Pointer; { ADDRESS OF CURRENT ACTIVE PAGE }
IsGraphMode : Boolean; { Indicates if we are in graph mode or not } IsGraphMode : Boolean; { Indicates if we are in graph mode or not }
@ -901,7 +910,7 @@ var
x := x + xinc2; x := x + xinc2;
y := y + yinc2; y := y + yinc2;
end; end;
CurrentColor := OldCurrentColor; CurrentColor := OldCurrentColor;
end; end;
end end
else else
@ -1224,15 +1233,14 @@ var
{ removed from inner loop to make faster } { removed from inner loop to make faster }
ConvFac:=Pi/180.0; ConvFac:=Pi/180.0;
Repeat Repeat
{ this used by both sin and cos } { this used by both sin and cos }
TempTerm := j*ConvFac; TempTerm := j*ConvFac;
{ Calculate points } { Calculate points }
xpt^[i]:=round(XRadius*Cos(TempTerm)); xpt^[i]:=round(XRadius*Cos(TempTerm));
{ calculate the value of y } { calculate the value of y }
ypt^[i]:=round(YRadius*Sin(TempTerm+Pi)); ypt^[i]:=round(YRadius*Sin(TempTerm+Pi));
if abs(ypt^[i]) > YRadius then ypt^[i] := 0; j:=j+Delta;
j:=j+Delta; inc(i);
inc(i);
Until j > DeltaAngle; Until j > DeltaAngle;
end end
else else
@ -1248,23 +1256,23 @@ var
{ removed from inner loop to make faster } { removed from inner loop to make faster }
ConvFac:=Pi/180.0; ConvFac:=Pi/180.0;
for Count:=0 to 2 do for Count:=0 to 2 do
Begin Begin
aval:=XRadius+Count-1; aval:=XRadius+Count-1;
bval:=YRadius+Count-1; bval:=YRadius+Count-1;
Delta := DeltaAngle / (NumOfPix[Count]); Delta := DeltaAngle / (NumOfPix[Count]);
aval:= (longint(aval)*10000) div XAspect; aval:= (longint(aval)*10000) div XAspect;
bval:= (longint(bval)*10000) div YAspect; bval:= (longint(bval)*10000) div YAspect;
j:=Delta+Stangle; j:=Delta+Stangle;
Repeat Repeat
{ this used by both sin and cos } { this used by both sin and cos }
TempTerm := j*ConvFac; TempTerm := j*ConvFac;
xpt^[i]:=round((aval)*Cos(TempTerm)); xpt^[i]:=round((aval)*Cos(TempTerm));
{ calculate the value of y } { calculate the value of y }
ypt^[i]:=round(bval*Sin(TempTerm+Pi)); ypt^[i]:=round(bval*Sin(TempTerm+Pi));
j:=j+Delta; j:=j+Delta;
inc(i); inc(i);
Until j > DeltaAngle; Until j > DeltaAngle;
end; end;
end; end;
{******************************************} {******************************************}
{ NOW ALL PIXEL POINTS ARE IN BUFFER } { NOW ALL PIXEL POINTS ARE IN BUFFER }
@ -1273,9 +1281,7 @@ var
Count:=0; Count:=0;
OldcurrentColor:=currentColor; OldcurrentColor:=currentColor;
Repeat Repeat
{$R-} PutPixel(xpt^[Count]+X,ypt^[Count]+Y,CurrentColor);
DirectPutPixel(xpt^[Count]+X,ypt^[Count]+Y);
{$R+}
inc(count); inc(count);
until Count>=i; until Count>=i;
@ -1284,10 +1290,8 @@ var
ArcCall.Y := Y; ArcCall.Y := Y;
ArcCall.XStart := xpt^[0] + X; ArcCall.XStart := xpt^[0] + X;
ArcCall.YStart := ypt^[0] + Y; ArcCall.YStart := ypt^[0] + Y;
{$R-}
ArcCall.XEnd := xpt^[Count-1] + X; ArcCall.XEnd := xpt^[Count-1] + X;
ArcCall.YEnd := ypt^[Count-1] + Y; ArcCall.YEnd := ypt^[Count-1] + Y;
{$R+}
CurrentColor:=OldCurrentColor; CurrentColor:=OldCurrentColor;
if LineInfo.Thickness=NormWidth then if LineInfo.Thickness=NormWidth then
Begin Begin
@ -1302,6 +1306,24 @@ var
end; end;
{********************************************************}
{ Procedure InternalEllipse() }
{--------------------------------------------------------}
{ This routine first calculates all points required to }
{ draw a circle to the screen, and stores the points }
{ to display in a buffer before plotting them. The }
{ aspect ratio of the screen is taken into account when }
{ calculating the values. }
{--------------------------------------------------------}
{ INPUTS: X,Y : Center coordinates of Ellipse. }
{ XRadius - X-Axis radius of ellipse. }
{ YRadius - Y-Axis radius of ellipse. }
{ stAngle, EndAngle: Start angle and end angles of the }
{ ellipse (used for partial ellipses and circles) }
{--------------------------------------------------------}
{ NOTE: - uses the current write mode. }
{ - Angles must both be between 0 and 360 }
{********************************************************}
(* (*
Procedure InternalEllipseDefault (x, y : integer; Procedure InternalEllipseDefault (x, y : integer;
xradius, yradius, stAngle, EndAngle : Word); xradius, yradius, stAngle, EndAngle : Word);
@ -1315,20 +1337,52 @@ const
Procedure PlotPoints; Procedure PlotPoints;
var
i,j: integer;
xm, ym: integer;
xp, yp: integer;
Begin Begin
If (Alpha>=StAngle) And (Alpha<=EndAngle) then ym := y-ya;
DirectPutPixel (x-xa,y-ya); yp := y+ya;
If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then xm := x-xa;
DirectPutPixel (x-xa,y+ya); xp := x+xa;
If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then if LineInfo.Thickness = Normwidth then
DirectPutPixel (x+xa,y+ya); Begin
If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then If (Alpha>=StAngle) And (Alpha<=EndAngle) then
DirectPutPixel (x+xa,y-ya); PutPixel (xm,ym, CurrentColor);
If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then
PutPixel (xm,yp, CurrentColor);
If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then
PutPixel (xp,yp, CurrentColor);
If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then
PutPixel (xp,ym, CurrentColor);
end
else
Begin
If (Alpha>=StAngle) And (Alpha<=EndAngle) then
for i:=-1 to 1 do
for j:=-1 to 1 do
PutPixel (xm+i,ym+j, CurrentColor);
If (180-Alpha>=StAngle) And (180-Alpha<=EndAngle) then
for i:=-1 to 1 do
for j:=-1 to 1 do
PutPixel (xm+i,yp+j, CurrentColor);
If (180+Alpha>=StAngle) And (180+Alpha<=EndAngle) then
for i:=-1 to 1 do
for j:=-1 to 1 do
PutPixel (xp+i,yp+j, CurrentColor);
If (360-Alpha>=StAngle) And (360-Alpha<=EndAngle) then
for i:=-1 to 1 do
for j:=-1 to 1 do
PutPixel (xp+i,ym+j, CurrentColor);
end;
End; End;
Begin Begin
StAngle:=StAngle MOD 361; StAngle:=StAngle MOD 361;
EndAngle:=EndAngle MOD 361; EndAngle:=EndAngle MOD 361;
StAngle := StAngle + 270;
EndAngle := EndAngle + 270;
If StAngle>EndAngle then If StAngle>EndAngle then
Begin Begin
StAngle:=StAngle Xor EndAngle; EndAngle:=EndAngle Xor StAngle; StAngle:=EndAngle Xor StAngle; StAngle:=StAngle Xor EndAngle; EndAngle:=EndAngle Xor StAngle; StAngle:=EndAngle Xor StAngle;
@ -1374,8 +1428,8 @@ Begin
Dec (error,twoXbSqr); Dec (error,twoXbSqr);
End; End;
End; End;
End;*) End;
*)
procedure PatternLineDefault(x1,x2,y: integer); procedure PatternLineDefault(x1,x2,y: integer);
{********************************************************} {********************************************************}
{ Draws a horizontal patterned line according to the } { Draws a horizontal patterned line according to the }
@ -1740,14 +1794,14 @@ end;
end; end;
procedure SetVisualPage(page : word); procedure SetVisualPageDefault(page : word);
begin begin
end; end;
procedure SetActivePage(page : word); procedure SetActivePageDefault(page : word);
begin begin
end; end;
Procedure DefaultHooks; Procedure DefaultHooks;
@ -1767,6 +1821,8 @@ end;
GetPixel := nil; GetPixel := nil;
{ optional...} { optional...}
SetActivePage := SetActivePageDefault;
SetVisualPage := SetVisualPageDefault;
ClearViewPort := ClearViewportDefault; ClearViewPort := ClearViewportDefault;
PutImage := DefaultPutImage; PutImage := DefaultPutImage;
GetImage := DefaultGetImage; GetImage := DefaultGetImage;