paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 14:19:29 +02:00
Code Issues Packages Projects Releases Wiki Activity
236a77964f
fpc/rtl/linux/graph.pp
peter e64becf81c * moved getopts to inc/, all supported OS's need argc,argv exported 
+ strpas, strlen are now exported in the systemunit
  * removed logs
  * removed $ifdef ver_above
1998-05-12 10:42:41 +00:00

1397 lines
33 KiB
ObjectPascal
Raw Blame History

unit Graph;
{ *********************************************************************
$Id$
Copyright 1997,1998 Matthias K"oppe <mkoeppe@cs.uni-magdeburg.de>
This library is free software in the sense of the GNU Library GPL;
see `License Conditions' below.
Info:
This unit provides the functions of Borland's Graph unit for linux,
it uses the SVGAlib to do the actual work, so you must have svgalib
on your system
This version requires Free Pascal 0.99.5 or higher.
Large parts have not yet been implemented or tested.
History:
Date Version Who Comments
---------- -------- ------- -------------------------------------
25-Sep-97 0.1 mkoeppe Initial multi-target version.
05-Oct-97 0.1.1 mkoeppe Linux: Added mouse use. Improved clipping.
Added bitmap functions.
??-Oct-97 0.1.2 mkoeppe Fixed screenbuf functions.
07-Feb-98 0.1.3 mkoeppe Fixed a clipping bug in DOS target.
12-Apr-98 0.1.4 mkoeppe Linux: Using Michael's re-worked SVGALIB
interface; prepared for FPC 0.99.5; removed
dependencies.
15-Apr-98 0.1.5 michael Renamed to graph, inserted needed SVGlib
declarations here so it can be used independently
of the svgalib unit. Removed things that are NOT
part of Borland's Graph from the unit interface.
License Conditions:
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*********************************************************************}
{
Functions not currently implemented :
-------------------------------------
SetWriteMode
SetLineStyle
SetFillPattern
SetUserCharSize
SetTextStyle
FillPoly
FloodFill
GetArcCoords
Arc
SetAspectRatio
PieSlice
Sector
(please remove what you implement fom this list)
}
interface
{ ---------------------------------------------------------------------
Constants
---------------------------------------------------------------------}
const
NormalPut = 0;
CopyPut = 0;
XORPut = 1;
ORPut = 2;
ANDPut = 3;
NotPut = 4;
BackPut = 8;
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
Border = 16;
SolidLn = 0;
DottedLn = 1;
CenterLn = 2;
DashedLn = 3;
UserBitLn = 4;
EmptyFill = 0;
SolidFill = 1;
LineFill = 2;
LtSlashFill = 3;
SlashFill = 4;
BkSlashFill = 5;
LtBkSlashFill = 6;
HatchFill = 7;
XHatchFill = 8;
InterleaveFill = 9;
WideDotFill = 10;
CloseDotFill = 11;
UserFill = 12;
NormWidth = 1;
ThickWidth = 3;
const
LeftText = 0;
CenterText = 1;
RightText = 2;
BottomText = 0;
TopText = 2;
BaseLine = 3;
LeadLine = 4;
{ ---------------------------------------------------------------------
Types
---------------------------------------------------------------------}
Type
FillPatternType = array[1..8] of byte;
ArcCoordsType = record
x,y : integer;
xstart,ystart : integer;
xend,yend : integer;
end;
RGBColor = record
r,g,b,i : byte;
end;
PaletteType = record
Size : integer;
Colors : array[0..767]of Byte;
end;
LineSettingsType = record
linestyle : word;
pattern : word;
thickness : word;
end;
TextSettingsType = record
font : word;
direction : word;
charsize : word;
horiz : word;
vert : word;
end;
FillSettingsType = record
pattern : word;
color : longint;
end;
PointType = record
x,y : integer;
end;
ViewPortType = record
x1,y1,x2,y2 : integer;
Clip : boolean;
end;
const
fillpattern : array[0..12] of FillPatternType = (
($00,$00,$00,$00,$00,$00,$00,$00), { Hintergrundfarbe }
($ff,$ff,$ff,$ff,$ff,$ff,$ff,$ff), { Vordergrundfarbe }
($ff,$ff,$00,$00,$ff,$ff,$00,$00), { === }
($01,$02,$04,$08,$10,$20,$40,$80), { /// }
($07,$0e,$1c,$38,$70,$e0,$c1,$83), { /// als dicke Linien }
($07,$83,$c1,$e0,$70,$38,$1c,$0e), { \\\ als dicke Linien }
($5a,$2d,$96,$4b,$a5,$d2,$69,$b4), { \ \\ \ }
($ff,$88,$88,$88,$ff,$88,$88,$88), { K<>stchen }
($18,$24,$42,$81,$81,$42,$24,$18), { Rauten }
($cc,$33,$cc,$33,$cc,$33,$cc,$33), { "Mauermuster" }
($80,$00,$08,$00,$80,$00,$08,$00), { weit auseinanderliegende Punkte }
($88,$00,$22,$00,$88,$00,$22,$00), { dichte Punkte}
(0,0,0,0,0,0,0,0) { benutzerdefiniert }
);
{ ---------------------------------------------------------------------
Function Declarations
---------------------------------------------------------------------}
{ Retrieving coordinates }
function GetX: Integer;
function GetY: Integer;
{ Pixel-oriented routines }
procedure PutPixel(X, Y: Integer; Pixel: Word);
function GetPixel(X, Y: Integer): Word;
{ Line-oriented primitives }
procedure SetWriteMode(WriteMode: Integer);
procedure LineTo(X, Y: Integer);
procedure LineRel(Dx, Dy: Integer);
procedure MoveTo(X, Y: Integer);
procedure MoveRel(Dx, Dy: Integer);
procedure Line(x1, y1, x2, y2: Integer);
procedure SetLineStyle(LineStyle: Word; Pattern: Word; Thickness: Word);
{ Linearly bounded primitives }
procedure Rectangle(x1, y1, x2, y2: Integer);
procedure Bar(x1, y1, x2, y2: Integer);
procedure Bar3D(x1, y1, x2, y2: Integer; Depth: Word; Top: Boolean);
procedure DrawPoly(NumPoints: Word; var PolyPoints);
procedure FillPoly(NumPoints: Word; var PolyPoints);
procedure SetFillStyle(Pattern: Word; Color: Word);
procedure SetFillPattern(Pattern: FillPatternType; Color: Word);
procedure FloodFill(X, Y: Integer; Border: Word);
{ Nonlinearly bounded primitives }
procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
procedure GetArcCoords(var ArcCoords: ArcCoordsType);
procedure Circle(X, Y: Integer; Radius: Word);
procedure Ellipse(X, Y: Integer; StAngle, EndAngle: Word; XRadius, YRadius : Word);
procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
procedure SetAspectRatio(Xasp, Yasp: Word);
procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
procedure Sector(X, Y: Integer; StAngle, EndAngle, XRadius, YRadius: Word);
{ Color routines }
procedure SetBkColor(ColorNum: Word);
procedure SetColor(Color: Word);
{ Bitmap utilities }
procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);
function ImageSize(x1, y1, x2, y2: Integer): LongInt;
{ Text routines}
procedure OutText(TextString: string);
procedure OutTextXY(X, Y: Integer; TextString: string);
procedure SetTextJustify(Horiz, Vert: Word);
procedure SetTextStyle(Font, Direction: Word; CharSize: Word);
procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word);
{ Graph clipping method }
procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
{ Init/Done }
procedure InitVideo;
procedure DoneVideo;
{ Other }
function GetResX: Integer;
function GetResY: Integer;
function GetAspect: Real;
const
NoGraphics: Boolean = false;
implementation
uses Objects, Linux;
{ ---------------------------------------------------------------------
SVGA bindings.
---------------------------------------------------------------------}
{ Link with VGA, gl and c libraries }
{$linklib vga}
{$linklib gl}
{$linklib c}
{ Constants }
const
{ VGA modes }
TEXT = 0; { Compatible with VGAlib v1.2 }
G320x200x16 = 1;
G640x200x16 = 2;
G640x350x16 = 3;
G640x480x16 = 4;
G320x200x256 = 5;
G320x240x256 = 6;
G320x400x256 = 7;
G360x480x256 = 8;
G640x480x2 = 9;
G640x480x256 = 10;
G800x600x256 = 11;
G1024x768x256 = 12;
G1280x1024x256 = 13; { Additional modes. }
G320x200x32K = 14;
G320x200x64K = 15;
G320x200x16M = 16;
G640x480x32K = 17;
G640x480x64K = 18;
G640x480x16M = 19;
G800x600x32K = 20;
G800x600x64K = 21;
G800x600x16M = 22;
G1024x768x32K = 23;
G1024x768x64K = 24;
G1024x768x16M = 25;
G1280x1024x32K = 26;
G1280x1024x64K = 27;
G1280x1024x16M = 28;
G800x600x16 = 29;
G1024x768x16 = 30;
G1280x1024x16 = 31;
G720x348x2 = 32; { Hercules emulation mode }
G320x200x16M32 = 33; { 32-bit per pixel modes. }
G640x480x16M32 = 34;
G800x600x16M32 = 35;
G1024x768x16M32 = 36;
G1280x1024x16M32 = 37;
{ additional resolutions }
G1152x864x16 = 38;
G1152x864x256 = 39;
G1152x864x32K = 40;
G1152x864x64K = 41;
G1152x864x16M = 42;
G1152x864x16M32 = 43;
G1600x1200x16 = 44;
G1600x1200x256 = 45;
G1600x1200x32K = 46;
G1600x1200x64K = 47;
G1600x1200x16M = 48;
G1600x1200x16M32 = 49;
GLASTMODE = 49;
{ Text }
WRITEMODE_OVERWRITE = 0;
WRITEMODE_MASKED = 1;
FONT_EXPANDED = 0;
FONT_COMPRESSED = 2;
{ Types }
type
pvga_modeinfo = ^vga_modeinfo;
vga_modeinfo = record
width,
height,
bytesperpixel,
colors,
linewidth, { scanline width in bytes }
maxlogicalwidth, { maximum logical scanline width }
startaddressrange, { changeable bits set }
maxpixels, { video memory / bytesperpixel }
haveblit, { mask of blit functions available }
flags: Longint; { other flags }
{ Extended fields: }
chiptype, { Chiptype detected }
memory, { videomemory in KB }
linewidth_unit: Longint; { Use only a multiple of this as parameter for
set_displaystart }
linear_aperture: PChar; { points to mmap secondary mem aperture of card }
aperture_size: Longint; { size of aperture in KB if size>=videomemory.}
set_aperture_page: procedure (page: Longint);
{ if aperture_size<videomemory select a memory page }
extensions: Pointer; { points to copy of eeprom for mach32 }
{ depends from actual driver/chiptype.. etc. }
end;
PGraphicsContext = ^TGraphicsContext;
TGraphicsContext = record
ModeType: Byte;
ModeFlags: Byte;
Dummy: Byte;
FlipPage: Byte;
Width: LongInt;
Height: LongInt;
BytesPerPixel: LongInt;
Colors: LongInt;
BitsPerPixel: LongInt;
ByteWidth: LongInt;
VBuf: pointer;
Clip: LongInt;
ClipX1: LongInt;
ClipY1: LongInt;
ClipX2: LongInt;
ClipY2: LongInt;
ff: pointer;
end;
{ vga functions }
function vga_init: Longint; Cdecl; External;
function vga_getdefaultmode: Longint; Cdecl; External;
function vga_hasmode(mode: Longint): Boolean; Cdecl; External;
function vga_getmodeinfo(mode: Longint): pvga_modeinfo; Cdecl; External;
function vga_setmode(mode: Longint): Longint; Cdecl; External;
{ gl functions }
procedure gl_setpixel(x, y, c: LongInt); Cdecl; External;
function gl_getpixel(x, y: LongInt): LongInt; cdecl; external;
procedure gl_line(x1, y1, x2, y2, c: LongInt); Cdecl; External;
procedure gl_fillbox(x, y, w, h, c: LongInt); Cdecl; External;
procedure gl_circle(x, y, r, c: LongInt ); Cdecl; External;
procedure gl_getbox(x, y, w, h: LongInt; dp: pointer); Cdecl; External;
procedure gl_putbox(x, y, w, h: LongInt; dp: pointer); Cdecl; External;
procedure gl_disableclipping; Cdecl; External;
procedure gl_enableclipping; Cdecl; External;
procedure gl_putboxpart(x, y, w, h, bw, bh: LongInt; b: pointer; xo, yo: LongInt); Cdecl; External;
function gl_rgbcolor(r, g, b: LongInt): LongInt; Cdecl; External;
function gl_setcontextvga(m: LongInt): LongInt; Cdecl; External;
function gl_allocatecontext: PGraphicsContext; Cdecl; External;
procedure gl_getcontext(gc: PGraphicsContext); Cdecl; External;
procedure gl_setrgbpalette; Cdecl; External;
procedure gl_freecontext(gc: PGraphicsContext); Cdecl; External;
procedure gl_setclippingwindow(x1, y1, x2, y2: LongInt); Cdecl; External;
procedure gl_setwritemode(wm: LongInt); Cdecl; External;
procedure gl_setfontcolors(bg, fg: LongInt); Cdecl; External;
procedure gl_writen(x, y, n: LongInt; s: PChar); Cdecl; External;
procedure gl_setfont(fw, fh: LongInt; fdp: pointer); Cdecl; External;
procedure gl_copyboxfromcontext(var gc: TGraphicsContext; x1, y1, w, h, x2, y2: LongInt); Cdecl; External;
procedure gl_setcontext(gc: PGraphicsContext); Cdecl; External;
function gl_setcontextvgavirtual(m: LongInt): LongInt; cdecl; external;
procedure gl_font8x8; Cdecl; External;
{ ---------------------------------------------------------------------
Types, constants and variables
---------------------------------------------------------------------}
var
DrawDelta: TPoint;
CurX, CurY: Integer;
TheColor, TheFillColor: LongInt;
IsVirtual: Boolean;
PhysicalScreen, BackScreen: PGraphicsContext;
ColorTable: array[0..15] of LongInt;
const
BgiColors: array[0..15] of LongInt
= ($000000, $000080, $008000, $008080,
$800000, $800080, $808000, $C0C0C0,
$808080, $0000FF, $00FF00, $00FFFF,
$FF0000, $FF00FF, $FFFF00, $FFFFFF);
const
DoUseMarker: Boolean = true;
TheMarker: Char = '~';
TextColor: LongInt = 15;
MarkColor: LongInt = 15;
BackColor: LongInt = 0;
FontWidth: Integer = 8;
FontHeight: Integer = 8;
var
sHoriz, sVert: Word;
{ initialisierte Variablen }
const
SourcePage: Word = 0;
DestPage: Word = 0;
{ Retrieves the capabilities for the current mode }
const
vmcImage = 1;
vmcCopy = 2;
vmcSaveRestore = 4;
vmcBuffer = 8;
vmcBackPut = 16;
{ ---------------------------------------------------------------------
Graphics Vision Layer
---------------------------------------------------------------------}
{ Types and constants }
var
SizeX, SizeY: Word;
{ Draw origin and clipping rectangle }
var
DrawOrigin: TPoint;
ClipRect: TRect;
MetaClipRect: TRect;
MetaOrigin: TPoint;
{ Font attributes }
const
ftNormal = 0;
ftBold = 1;
ftThin = 2;
ftItalic = 4;
var
sFont, sColor:Word;
sCharSpace: Integer;
{ Not used
sMarker: Char;
sAttr: Word; }
{ Windows-style text metric }
type
PTextMetric = ^TTextMetric;
TTextMetric = record
tmHeight: Integer;
tmAscent: Integer;
tmDescent: Integer;
tmInternalLeading: Integer;
tmExternalLeading: Integer;
tmAveCharWidth: Integer;
tmMaxCharWidth: Integer;
tmWeight: Integer;
tmItalic: Byte;
tmUnderlined: Byte;
tmStruckOut: Byte;
tmFirstChar: Byte;
tmLastChar: Byte;
tmDefaultChar: Byte;
tmBreakChar: Byte;
tmPitchAndFamily: Byte;
tmCharSet: Byte;
tmOverhang: Integer;
tmDigitizedAspectX: Integer;
tmDigitizedAspectY: Integer;
end;
{ Bitmap utilities }
type
PBitmap = ^TBitmap;
TBitmap = record
Width, Height: Integer;
Data: record end;
end;
{ Storing screen regions }
type
TVgaBuf = record
Bounds: TRect;
Mem: Word;
Size: Word;
end;
const
pbNone = 0;
pbCopy = 1;
pbClear = 2;
type
PScreenBuf = ^TScreenBuf;
TScreenBuf = record
Mode: Word;
Rect: TRect;
Size: LongInt;
Info: LongInt
end;
{ Procedures and functions }
procedure SetColors;
var
i: Integer;
begin
for i:=0 to 15 do
ColorTable[i] := gl_rgbcolor(BgiColors[i] shr 16,
(BgiColors[i] shr 8) and 255,
BgiColors[i] and 255)
end;
procedure InitVideo;
var
VgaMode: Integer;
ModeInfo: pvga_modeinfo;
begin
if NoGraphics
then begin
SizeX := 640;
SizeY := 480
end
else begin
VgaMode := vga_getdefaultmode;
if (VgaMode = -1) then VgaMode := G320X200X256;
if (not vga_hasmode(VgaMode))
then begin
WriteLn('BGI: Mode not available.');
Halt(1)
end;
ModeInfo := vga_getmodeinfo(VgaMode);
{IsVirtual := (ModeInfo^.colors = 16) or (ModeInfo^.flags and IS_MODEX <> 0);}
IsVirtual := true;
{ We always want a back screen (for buffering). }
if IsVirtual
then begin
{ Create virtual screen }
gl_setcontextvgavirtual(VgaMode);
BackScreen := gl_allocatecontext;
gl_getcontext(BackScreen)
end;
vga_setmode(VgaMode);
gl_setcontextvga(VgaMode); { Physical screen context. }
PhysicalScreen := gl_allocatecontext;
gl_getcontext(PhysicalScreen);
if (PhysicalScreen^.colors = 256) then gl_setrgbpalette;
SetColors;
SizeX := PhysicalScreen^.Width;
SizeY := PhysicalScreen^.Height
end
end;
procedure DoneVideo;
begin
if not NoGraphics
then begin
if IsVirtual then gl_freecontext(BackScreen);
vga_setmode(TEXT)
end
end;
procedure SetDelta;
begin
if ClipRect.Empty
then begin
DrawDelta.X := 10000;
DrawDelta.Y := 10000;
end
else begin
DrawDelta.X := DrawOrigin.X;
DrawDelta.y := DrawOrigin.y
end
end;
procedure SetDrawOrigin(x, y: Integer);
begin
DrawOrigin.x := x;
DrawOrigin.y := y;
SetDelta;
end;
procedure SetDrawOriginP(var P: TPoint);
begin
SetDrawOrigin(P.x, P.y)
end;
procedure SetClipRect(x1, y1, x2, y2: Integer);
begin
Cliprect.Assign(x1, y1, x2, y2);
if not NoGraphics
then begin
if ClipRect.Empty
then gl_setclippingwindow(0, 0, 0, 0)
else gl_setclippingwindow(x1, y1, x2 - 1, y2 - 1);
{gl_enableclipping(0);}
end;
SetDelta
end;
procedure SetClipRectR(var R: TRect);
begin
SetClipRect(R.A.X, R.A.Y, R.B.X, R.B.Y);
end;
procedure SetMetaOrigin(x, y: Integer);
begin
MetaOrigin.x := x;
MetaOrigin.y := y
end;
procedure SetMetaOriginP(P: TPoint);
begin
SetMetaOrigin(P.x, P.y)
end;
procedure SetMetaClipRect(x1, y1, x2, y2: Integer);
begin
MetaCliprect.Assign(x1, y1, x2, y2)
end;
procedure SetMetaClipRectR(var R: TRect);
begin
MetaCliprect := R
end;
function GetBuffer(Size: Word): pointer;
begin
{ No metafiling available. }
GetBuffer := nil
end;
Procedure HoriLine(x1,y1,x2: Integer);
begin
Line(x1, y1, x2, y1)
end;
Procedure VertLine(x1,y1,y2: Integer);
begin
Line(x1, y1, x1, y2)
end;
procedure FillCircle(xm, ym, r: Integer);
begin
FillEllipse(xm, ym, r, r)
end;
{ Text routines }
function TextWidth(s: string): Integer;
var
i: Integer;
begin
if DoUseMarker
then begin
For i := Length(s) downto 1 do
If s[i] = TheMarker then Delete(s, i, 1);
If s = ''
then TextWidth := 0
else TextWidth := Length(s) * FontWidth
end
else TextWidth := Length(s) * FontWidth
end;
function TextHeight(s: string): Integer;
begin
TextHeight := FontHeight
end;
procedure OutText(TextString: string);
begin
OutTextXY(GetX, GetY, TextString)
end;
procedure OutTextXY(X, Y: Integer; TextString: string);
var
P, Q: PChar;
i: Integer;
col: Boolean;
begin
if NoGraphics or (TextString='') then Exit;
gl_setwritemode(FONT_COMPRESSED + WRITEMODE_MASKED);
case sHoriz of
CenterText : Dec(x, TextWidth(TextString) div 2);
RightText : Dec(x, TextWidth(TextString));
end; { case }
case sVert of
CenterText : Dec(y, TextHeight(TextString) div 2);
BottomText, BaseLine : Dec(y, TextHeight(TextString));
end; { case }
MoveTo(X, Y);
P := @TextString[1]; Q := P;
col := false;
gl_setfontcolors(BackColor, TextColor);
For i := 1 to Length(TextString) do
begin
If (Q[0] = TheMarker) and DoUseMarker
then begin
If col then gl_setfontcolors(BackColor, MarkColor)
else gl_setfontcolors(BackColor, TextColor);
If Q <> P then begin
gl_writen(CurX, CurY, Q-P, P);
MoveRel(FontWidth * (Q-P), 0)
end;
col := not col;
P := Q + 1
end;
{Inc(Q)} Q := Q + 1
end;
If col then gl_setfontcolors(BackColor, MarkColor)
else gl_setfontcolors(BackColor, TextColor);
If Q <> P then begin
gl_writen(CurX, CurY, Q-P, P);
MoveRel(FontWidth * (Q-P), 0)
end
end;
procedure SetTextJustify(Horiz, Vert: Word);
begin
sHoriz := Horiz; sVert := Vert;
end;
procedure SetTextStyle(Font, Direction: Word; CharSize: Word);
begin
end;
procedure SetUserCharSize(MultX, DivX, MultY, DivY: Word);
begin
end;
procedure SetKern(Enable: Boolean);
begin
end;
procedure SetMarker(Marker: Char);
begin
TheMarker := Marker
end;
procedure SetTextParams(Font: Word; CharSpace: Integer; Color: Word;
UseMarker: Boolean);
type
pp = ^pointer;
function FixCol(Col: Byte): Byte;
{ SVGALIB cannot write black characters... }
begin
if Col=0 then FixCol := 1 else FixCol := Col
end; { FixCol }
begin
sColor := Color; sCharSpace := CharSpace; sFont := Font;
if not NoGraphics then begin
TextColor := ColorTable[FixCol(Color and 15)];
MarkColor := ColorTable[FixCol((Color shr 8) and 15)];
DoUseMarker := UseMarker;
gl_setfont(8, 8, (pp(@gl_font8x8))^);
end
end;
function GetResX: Integer;
begin
GetResX := 96;
end; { GetResX }
function GetResY: Integer;
begin
GetResY := 96
end; { GetResY }
function GetAspect: Real;
begin
GetAspect := 1.0
end; { GetAspect }
procedure SetViewPort(x1, y1, x2, y2: Integer; Clip: Boolean);
begin
SetDrawOrigin(x1, y1);
if Clip then SetClipRect(x1, y1, x2+1, y2+1)
else SetClipRect(0, 0, SizeX, SizeY)
end;
{ VGAMEM }
type
TImage = record
end;
procedure CopyScreen(x1, y1, x2, y2, x3, y3: Integer);
begin
if not NoGraphics and (x2 > x1) and (y2 > y1)
then gl_copyboxfromcontext(PhysicalScreen^, x1, y1, x2 - x1, y2 - y1, x3, y3);
end;
{ BGI-like Image routines
}
function CopyImage(Image: pointer): pointer;
begin
CopyImage := nil
end;
function CutImage(x1, y1, x2, y2: Integer): pointer;
var
Image: PBitmap;
begin
GetMem(Image, ImageSize(x1, y1, x2, y2));
if Image <> nil
then GetImage(x1, y1, x2, y2, Image^);
CutImage := Image;
end;
procedure GetImageExtent(Image: pointer; var Extent: Objects.TPoint);
begin
if Image = nil
then begin
Extent.X := 0;
Extent.Y := 0
end
else begin
Extent.X := PBitmap(Image)^.Width;
Extent.Y := PBitmap(Image)^.Height
end;
end;
procedure FreeImage(Image: pointer);
var
P: TPoint;
begin
if Image <> nil
then begin
GetImageExtent(Image, P);
FreeMem(Image, ImageSize(0, 0, P.x - 1, P.y - 1));
end;
end;
function LoadImage(var S: TStream): pointer;
begin
LoadImage := nil
end;
function MaskedImage(Image: pointer): pointer;
begin
MaskedImage := nil;
end;
procedure PasteImage(X, Y: Integer; Image: pointer; BitBlt: Word);
begin
if Image <> nil then PutImage(X, Y, Image^, BitBlt)
end;
procedure StoreImage(var S: TStream; Image: pointer);
begin
end;
{ Storing screen regions }
function PrepBuf(var R: Objects.TRect; Action: Word; var Buf: TVgaBuf): Boolean;
begin
if BackScreen <> nil
then begin
Buf.Bounds := R;
gl_setcontext(BackScreen);
gl_disableclipping;
case Action of
pbCopy : gl_copyboxfromcontext(PhysicalScreen^,
R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y,
R.A.X, R.A.Y);
pbClear : gl_fillbox(R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y, 0);
end;
PrepBuf := true;
SetDrawOrigin(0, 0);
SetClipRectR(R);
end
else PrepBuf := false
end; { PrepBuf }
procedure EndBufDraw;
begin
if not NoGraphics
then gl_setcontext(PhysicalScreen);
end; { EndBufDraw }
procedure ReleaseBuf(var Buf: TVgaBuf);
begin
end; { ReleaseBuf }
procedure PasteRectAt(var R: Objects.TRect; P: Objects.TPoint; var Buf: TVgaBuf);
begin
if not NoGraphics and (BackScreen <> nil)
then gl_copyboxfromcontext(BackScreen^,
R.A.X, R.A.Y, R.B.X - R.A.X, R.B.Y - R.A.Y,
P.X, P.Y);
end;
procedure PasteRect(var R: Objects.TRect; var Buf: TVgaBuf);
begin
PasteRectAt(R, R.A, Buf);
end; { PasteRect }
function StoreScreen(x1, y1, x2, y2: Integer): PScreenBuf;
var
s: LongInt;
p: pointer;
SaveOrigin: TPoint;
function NewScreenBuf(AMode: Word; AnInfo: LongInt): PScreenBuf;
var
p: PScreenBuf;
Begin
New(p);
p^.Mode := AMode;
p^.Size := s;
p^.Rect.Assign(x1, y1, x2, y2);
p^.Info := AnInfo;
NewScreenBuf := p
End;
Begin
{ General Images }
s := 0;
SaveOrigin := DrawOrigin;
SetDrawOrigin(0, 0);
p := CutImage(x1, y1, x2-1, y2-1);
SetDrawOriginP(SaveOrigin);
If p <> nil
then StoreScreen := NewScreenBuf(2, LongInt(p))
else StoreScreen := nil
End;
procedure FreeScreenBuf(Buf: PScreenBuf);
Begin
If Buf <> nil then Begin
case Buf^.Mode of
2 : FreeImage(pointer(Buf^.Info));
end;
Dispose(Buf)
End
End;
procedure DrawScreenBufAt(Buf: PScreenBuf; x3, y3: Integer);
var
SaveOrigin: TPoint;
Begin
If Buf <> nil then
case Buf^.Mode of
2 :
begin
SaveOrigin := DrawOrigin;
SetDrawOrigin(0, 0);
PasteImage(x3, y3, pointer(Buf^.Info), NormalPut);
SetDrawOriginP(SaveOrigin);
end
end
End;
procedure DrawScreenBuf(Buf: PScreenBuf);
Begin
If Buf <> nil then
DrawScreenBufAt(Buf, Buf^.Rect.A.x, Buf^.Rect.A.y)
End;
function GetVgaMemCaps: Word;
begin
GetVgaMemCaps := vmcCopy
end;
procedure GetTextMetrics(var Metrics: TTextMetric);
begin
with Metrics do
begin
tmHeight := 8;
tmAscent := 8;
tmDescent := 0;
tmInternalLeading := 0;
tmExternalLeading := 0;
tmAveCharWidth := 8;
tmMaxCharWidth := 8;
tmWeight := 700;
tmItalic := 0;
tmUnderlined := 0;
tmStruckOut := 0;
tmFirstChar := 0;
tmLastChar := 255;
tmDefaultChar := 32;
tmBreakChar := 32;
tmPitchAndFamily := 0;
tmCharSet := 0;
tmOverhang := 0;
tmDigitizedAspectX := 100;
tmDigitizedAspectY := 100
end;
end;
{ ---------------------------------------------------------------------
Real graph implementation
---------------------------------------------------------------------}
function GetX: Integer;
begin
GetX := CurX - DrawDelta.X
end;
function GetY: Integer;
begin
GetY := CurY - DrawDelta.Y
end;
{ Pixel-oriented routines }
procedure PutPixel(X, Y: Integer; Pixel: Word);
begin
if not NoGraphics
then gl_setpixel(X + DrawDelta.X, Y + DrawDelta.Y, Pixel)
end;
function GetPixel(X, Y: Integer): Word;
begin
if NoGraphics
then GetPixel := 0
else GetPixel := gl_getpixel(X + DrawDelta.X, Y + DrawDelta.Y)
end;
{ Line-oriented primitives }
procedure SetWriteMode(WriteMode: Integer);
begin
{ Graph.SetWriteMode(WriteMode) }
end;
procedure LineTo(X, Y: Integer);
begin
if not NoGraphics
then gl_line(CurX, CurY, X + DrawDelta.X, Y + DrawDelta.Y, TheColor);
CurX := X + DrawDelta.X;
CurY := Y + DrawDelta.Y
end;
procedure LineRel(Dx, Dy: Integer);
begin
if not NoGraphics
then gl_line(CurX, CurY, CurX + Dx, CurY + Dy, TheColor);
CurX := CurX + Dx;
CurY := CurY + Dy
end;
procedure MoveTo(X, Y: Integer);
begin
CurX := X + DrawDelta.X;
CurY := Y + DrawDelta.Y
end;
procedure MoveRel(Dx, Dy: Integer);
begin
CurX := CurX + Dx;
CurY := CurY + Dy
end;
procedure Line(x1, y1, x2, y2: Integer);
begin
if not NoGraphics
then gl_line(x1 + DrawDelta.X, y1 + DrawDelta.Y,
x2 + DrawDelta.X, y2 + DrawDelta.Y, TheColor)
end;
procedure SetLineStyle(LineStyle: Word; Pattern: Word; Thickness: Word);
begin
end;
procedure SetFillPattern(Pattern: FillPatternType; Color: Word);
begin
end;
{ Linearly bounded primitives }
procedure Rectangle(x1, y1, x2, y2: Integer);
begin
MoveTo(x1, y1);
LineTo(x2, y1);
LineTo(x2, y2);
LineTo(x1, y2);
LineTo(x1, y1)
end;
procedure Bar(x1, y1, x2, y2: Integer);
var
R: TRect;
begin
if not NoGraphics
then begin
R.Assign(x1 + DrawDelta.X, y1 + DrawDelta.Y,
x2 + DrawDelta.X + 1, y2 + DrawDelta.Y + 1);
R.Intersect(ClipRect);
if not R.Empty
then gl_fillbox(R.A.X, R.A.Y,
R.B.X - R.A.X, R.B.Y - R.A.Y, TheFillColor)
end;
end;
procedure Bar3D(x1, y1, x2, y2: Integer; Depth: Word; Top: Boolean);
begin
Bar(x1,y1,x2,y2);
Rectangle(x1,y1,x2,y2);
if top then begin
Moveto(x1,y1);
Lineto(x1+depth,y1-depth);
Lineto(x2+depth,y1-depth);
Lineto(x2,y1);
end;
Moveto(x2+depth,y1-depth);
Lineto(x2+depth,y2-depth);
Lineto(x2,y2);
end;
procedure DrawPoly(NumPoints: Word; var PolyPoints);
type
ppointtype = ^pointtype;
var
i : longint;
begin
line(ppointtype(@polypoints)[NumPoints-1].x,
ppointtype(@polypoints)[NumPoints-1].y,
ppointtype(@polypoints)[0].x,
ppointtype(@polypoints)[0].y);
for i:=0 to NumPoints-2 do
line(ppointtype(@polypoints)[i].x,
ppointtype(@polypoints)[i].y,
ppointtype(@polypoints)[i+1].x,
ppointtype(@polypoints)[i+1].y);
end;
procedure FillPoly(NumPoints: Word; var PolyPoints);
begin
end;
procedure SetFillStyle(Pattern: Word; Color: Word);
begin
TheFillColor := ColorTable[Color]
end;
procedure FloodFill(X, Y: Integer; Border: Word);
begin
end;
{ Nonlinearly bounded primitives
}
procedure GetArcCoords(var ArcCoords: ArcCoordsType);
begin
end;
procedure Arc(X, Y: Integer; StAngle, EndAngle, Radius: Word);
begin
end;
procedure Circle(X, Y: Integer; Radius: Word);
begin
if not NoGraphics
then gl_circle(X + DrawDelta.X, Y + DrawDelta.Y, Radius, TheColor)
end;
procedure Ellipse(X, Y: Integer;
StAngle, EndAngle: Word; XRadius, YRadius : Word);
begin
end;
procedure FillEllipse(X, Y: Integer; XRadius, YRadius : Word);
begin
Bar(X - XRadius, Y - YRadius, X + XRadius, Y + YRadius);
end;
procedure SetAspectRatio(Xasp, Yasp: Word);
begin
end;
procedure PieSlice(X, Y: Integer; StAngle, EndAngle, Radius: Word);
begin
end;
procedure Sector(X, Y: Integer;
StAngle, EndAngle, XRadius, YRadius: Word);
begin
end;
{ Color routines
}
procedure SetBkColor(ColorNum: Word);
begin
BackColor := ColorTable[ColorNum];
end;
procedure SetColor(Color: Word);
begin
TheColor := ColorTable[Color];
end;
procedure GetImage(x1, y1, x2, y2: Integer; var BitMap);
var
SaveClipRect: TRect;
begin
with TBitmap(Bitmap) do
begin
Width := x2 - x1 + 1;
Height := y2 - y1 + 1;
if not NoGraphics
then begin
{gl_disableclipping(0);}
SaveClipRect := ClipRect;
SetClipRect(0, 0, SizeX, SizeY);
gl_getbox(x1 + DrawDelta.X, y1 + DrawDelta.Y,
x2 - x1 + 1, y2 - y1 + 1, @Data);
SetClipRectR(SaveClipRect)
end;
end;
end;
procedure PutImage(X, Y: Integer; var BitMap; BitBlt: Word);
var
R: TRect;
SaveClipRect: TRect;
begin
if not NoGraphics then
with TBitmap(Bitmap) do
begin
{gl_putbox(x + DrawDelta.X, y + DrawDelta.Y, Width, Height, @Data)}
R.Assign(X + DrawDelta.X, Y + DrawDelta.Y,
X + DrawDelta.X + Width, Y + DrawDelta.Y + Height);
R.Intersect(ClipRect);
if not R.Empty
then begin
{gl_disableclipping(0);}
SaveClipRect := ClipRect;
SetClipRect(0, 0, SizeX, SizeY);
gl_putboxpart(R.A.X, R.A.Y,
R.B.X - R.A.X, R.B.Y - R.A.Y,
Width, Height,
@Data,
R.A.X - X, R.A.Y - Y);
SetClipRectR(SaveClipRect);
end;
end;
end; { PutImage }
function ImageSize(x1, y1, x2, y2: Integer): LongInt;
begin
if NoGraphics
then ImageSize := SizeOf(TBitmap)
else ImageSize := SizeOf(TBitmap)
+ LongInt(x2 - x1 + 1) * LongInt(y2 - y1 + 1) * PhysicalScreen^.BytesPerPixel;
end;
begin
{ Give up root permissions if we are root. }
if geteuid = 0 then vga_init;
end.
{
$Log$
Revision 1.2 1998-05-12 10:42:47 peter
* moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit
* removed logs
* removed $ifdef ver_above
Revision 1.1 1998/04/15 13:40:11 michael
+ Initial implementation of graph unit
}
Reference in New Issue View Git Blame Copy Permalink