paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 01:09:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

* removed unnecesasry graphfv stuff

Browse Source
This commit is contained in:
peter 2004-11-03 20:33:05 +00:00
parent 054f6bff3a
commit 2fce45424e
13 changed files with 508 additions and 4457 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
fv/app.pas
View File

@ -59,10 +59,7 @@ USES
{$ENDIF}
{$ENDIF}
Dos,
{$ifdef USE_VIDEO_API}
Video,
{$endif USE_VIDEO_API}
GFVGraph, { GFV standard unit }
FVCommon, Memory, { GFV standard units }
Objects, Drivers, Views, Menus, HistList, Dialogs,
MsgBox;
@ -660,8 +657,7 @@ END;
CONSTRUCTOR TProgram.Init;
VAR I: Integer; R: TRect;
BEGIN
R.Assign(0, 0, -(GetMaxX(TextModeGFV)+1),
-(GetMaxY(TextModeGFV)+1)); { Full screen area }
R.Assign(0, 0, -(ScreenWidth+1), -(ScreenHeight+1)); { Full screen area }
Inherited Init(R); { Call ancestor }
Application := @Self; { Set application ptr }
InitScreen; { Initialize screen }
@ -670,8 +666,6 @@ BEGIN
Options := 0; { No options set }
Size.X := ScreenWidth; { Set x size value }
Size.Y := ScreenHeight; { Set y size value }
RawSize.X := ScreenWidth * SysFontWidth - 1; { Set rawsize x }
RawSize.Y := ScreenHeight * SysFontHeight - 1; { Set rawsize y }
InitStatusLine; { Create status line }
InitMenuBar; { Create a bar menu }
InitDesktop; { Create desktop }
@ -686,11 +680,9 @@ END;
DESTRUCTOR TProgram.Done;
VAR I: Integer;
BEGIN
{$ifdef USE_VIDEO_API}
{ Do not free the Buffer of Video Unit }
If Buffer = Views.PVideoBuf(VideoBuf) then
Buffer:=nil;
{$endif USE_VIDEO_API}
If (Desktop <> Nil) Then Dispose(Desktop, Done); { Destroy desktop }
If (MenuBar <> Nil) Then Dispose(MenuBar, Done); { Destroy menu bar }
If (StatusLine <> Nil) Then
@ -801,28 +793,18 @@ BEGIN
video unit capabilities, the mono modus can't be handled
}
Drivers.InitVideo;
{$ifdef USE_VIDEO_API}
if (ScreenMode.Col div ScreenMode.Row<2) then
{$else not USE_VIDEO_API}
if (GetMaxX(true) div GetMaxY(true) <2) then
{$endif USE_VIDEO_API}
ShadowSize.X := 1
else
ShadowSize.X := 2;
ShadowSize.Y := 1;
ShowMarkers := False;
{$ifdef USE_VIDEO_API}
if ScreenMode.color then
{$else not USE_VIDEO_API}
if ScreenMode<>smMono then
{$endif USE_VIDEO_API}
AppPalette := apColor
else
AppPalette := apBlackWhite;
{$ifdef USE_VIDEO_API}
Buffer := Views.PVideoBuf(VideoBuf);
{$endif USE_VIDEO_API}
END;
@ -884,19 +866,14 @@ PROCEDURE TProgram.SetScreenMode (Mode: Word);
var
R: TRect;
begin
if TextModeGFV then
begin
HideMouse;
DoneMemory;
InitMemory;
InitScreen;
{$ifdef USE_VIDEO_API}
Buffer := Views.PVideoBuf(VideoBuf);
{$endif USE_VIDEO_API}
R.Assign(0, 0, ScreenWidth, ScreenHeight);
ChangeBounds(R);
ShowMouse;
end;
HideMouse;
DoneMemory;
InitMemory;
InitScreen;
Buffer := Views.PVideoBuf(VideoBuf);
R.Assign(0, 0, ScreenWidth, ScreenHeight);
ChangeBounds(R);
ShowMouse;
end;
procedure TProgram.SetScreenVideoMode(const Mode: TVideoMode);
@ -909,14 +886,8 @@ begin
InitMouse;
InitMemory;
InitScreen;
{$ifdef USE_VIDEO_API}
Video.SetVideoMode(Mode);
{$else USE_VIDEO_API}
SetVideoMode(Mode);
{$endif USE_VIDEO_API}
{$ifdef USE_VIDEO_API}
Buffer := Views.PVideoBuf(VideoBuf);
{$endif USE_VIDEO_API}
R.Assign(0, 0, ScreenWidth, ScreenHeight);
ChangeBounds(R);
ShowMouse;
@ -1009,14 +980,9 @@ BEGIN
InitResource;
InitMsgBox;
Inherited Init; { Call ancestor }
if (TextModeGFV) then
begin
{ init mouse and cursor }
{$ifdef USE_VIDEO_API}
Video.SetCursorType(crHidden);
{$endif USE_VIDEO_API}
Mouse.SetMouseXY(1,1);
end;
{ init mouse and cursor }
Video.SetCursorType(crHidden);
Mouse.SetMouseXY(1,1);
END;
{--TApplication-------------------------------------------------------------}
@ -1196,7 +1162,10 @@ END;
END.
{
$Log$
Revision 1.22 2002-09-22 19:42:52 hajny
Revision 1.23 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.22 2002/09/22 19:42:52 hajny
+ FPC/2 support added
Revision 1.21 2002/09/09 08:04:05 pierre

20
fv/asciitab.pas
View File

@ -36,17 +36,6 @@ UNIT AsciiTab;
{==== Compiler directives ===========================================}
{$IFNDEF PPC_FPC}{ FPC doesn't support these switches }
{$F-} { Near calls are okay }
{$A+} { Word Align Data }
{$B-} { Allow short circuit boolean evaluations }
{$O+} { This unit may be overlaid }
{$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
{$P-} { Normal string variables }
{$N-} { No 80x87 code generation }
{$E+} { Emulation is on }
{$ENDIF}
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
@ -202,8 +191,8 @@ begin
begin
If MouseInView(Event.Where) then
begin
xpos:=(Event.Where.X -RawOrigin.X) div SysFontWidth;
ypos:=(Event.Where.Y -RawOrigin.Y) div SysFontHeight;
xpos:=Event.Where.X-Origin.X;
ypos:=Event.Where.Y-Origin.Y;
SetTo(xpos, ypos);
exit;
end;
@ -334,7 +323,10 @@ end;
END.
{
$Log$
Revision 1.3 2002-05-30 22:23:15 pierre
Revision 1.4 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.3 2002/05/30 22:23:15 pierre
* current char color changed
Revision 1.2 2002/05/30 14:52:53 pierre

8
fv/buildfv.pas
View File

@ -9,10 +9,7 @@ uses
fvcommon,
objects,
drivers,
fileio,
memory,
gfvgraph,
fvconsts,
resource,
views,
@ -37,7 +34,10 @@ implementation
end.
{
$Log$
Revision 1.6 2004-11-02 23:53:19 peter
Revision 1.7 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.6 2004/11/02 23:53:19 peter
* fixed crashes with ide and 1.9.x
Revision 1.5 2002/09/07 15:06:36 peter

460
fv/callspec.pas
View File

@ -1,460 +0,0 @@
{
$Id$
This unit provides compiler-independent mechanisms to call special
functions, i.e. local functions/procedures, constructors, methods,
destructors, etc. As there are no procedural variables for these
special functions, there is no Pascal way to call them directly.
Copyright (c) 1997 Matthias K"oppe <mkoeppe@csmd.cs.uni-magdeburg.de>
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.
****************************************************************************}
unit CallSpec;
{
As of this version, the following compilers are supported. Please
port CallSpec to other compilers (including earlier versions) and
send your code to the above address.
Compiler Comments
--------------------------- -------------------------------------
Turbo Pascal 6.0
Borland/Turbo Pascal 7.0
FPC Pascal 0.99.8
}
interface
{$i platform.inc}
{
The frame pointer points to the local variables of a procedure.
Use CurrentFramePointer to address the locals of the current procedure;
use PreviousFramePointer to addess the locals of the calling procedure.
}
type
{$ifdef BIT_16}
FramePointer = Word;
{$endif}
{$ifdef BIT_32}
FramePointer = pointer;
{$endif}
function CurrentFramePointer: FramePointer;
function PreviousFramePointer: FramePointer;
{ This version of CallSpec supports four classes of special functions.
(Please write if you need other classes.)
For each, two types of argument lists are allowed:
`Void' indicates special functions with no explicit arguments.
Sample: constructor T.Init;
`Pointer' indicates special functions with one explicit pointer argument.
Sample: constructor T.Load(var S: TStream);
}
{ Constructor calls.
Ctor Pointer to the constructor.
Obj Pointer to the instance. NIL if new instance to be allocated.
VMT Pointer to the VMT (obtained by TypeOf()).
returns Pointer to the instance.
}
function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;
function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;
{ Method calls.
Method Pointer to the method.
Obj Pointer to the instance. NIL if new instance to be allocated.
returns Pointer to the instance.
}
function CallVoidMethod(Method: pointer; Obj: pointer): pointer;
function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;
{ Local-function/procedure calls.
Func Pointer to the local function (which must be far-coded).
Frame Frame pointer of the wrapping function.
}
function CallVoidLocal(Func: pointer; Frame: FramePointer): pointer;
function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer;
{ Calls of functions/procedures local to methods.
Func Pointer to the local function (which must be far-coded).
Frame Frame pointer of the wrapping method.
Obj Pointer to the object that the method belongs to.
}
function CallVoidMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer): pointer;
function CallPointerMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer; Param1: pointer): pointer;
implementation
{$ifdef PPC_FPC}
{$ifdef CPUI386}
{$ASMMODE ATT}
{$endif CPUI386}
{ This indicates an FPC version which uses the same call scheme for
method-local and procedure-local procedures, but which expects the
ESI register be loaded with the Self pointer in method-local procs. }
type
VoidLocal = function(_EBP: FramePointer): pointer;
PointerLocal = function(_EBP: FramePointer; Param1: pointer): pointer;
VoidMethodLocal = function(_EBP: FRAMEPOINTER): pointer;
PointerMethodLocal = function(_EBP: FRAMEPOINTER; Param1: pointer): pointer;
VoidConstructor = function(VMT: pointer; Obj: pointer): pointer;
PointerConstructor = function(VMT: pointer; Obj: pointer; Param1: pointer): pointer;
VoidMethod = function(Obj: pointer): pointer;
PointerMethod = function(Obj: pointer; Param1: pointer): pointer;
function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;
begin
{$ifdef VER1_0}
{ load the object pointer }
{$ifdef CPUI386}
asm
movl Obj, %esi
end;
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l Obj, a5
end;
{$endif CPU68K}
{$endif VER1_0}
CallVoidConstructor := VoidConstructor(Ctor)(VMT, Obj)
end;
function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;
begin
{$ifdef VER1_0}
{ load the object pointer }
{$ifdef CPUI386}
asm
movl Obj, %esi
end;
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l Obj, a5
end;
{$endif CPU68K}
{$endif VER1_0}
CallPointerConstructor := PointerConstructor(Ctor)(VMT, Obj, Param1)
end;
function CallVoidMethod(Method: pointer; Obj: pointer): pointer;
begin
{$ifdef VER1_0}
{ load the object pointer }
{$ifdef CPUI386}
asm
movl Obj, %esi
end;
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l Obj, a5
end;
{$endif CPU68K}
{$endif VER1_0}
CallVoidMethod := VoidMethod(Method)(Obj)
end;
function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;
begin
{$ifdef VER1_0}
{ load the object pointer }
{$ifdef CPUI386}
asm
movl Obj, %esi
end;
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l Obj, a5
end;
{$endif CPU68K}
{$endif VER1_0}
CallPointerMethod := PointerMethod(Method)(Obj, Param1)
end;
function CallVoidLocal(Func: pointer; Frame: FramePointer): pointer;
begin
CallVoidLocal := VoidLocal(Func)(Frame)
end;
function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer;
begin
CallPointerLocal := PointerLocal(Func)(Frame, Param1)
end;
function CallVoidMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer): pointer;
begin
{$ifdef VER1_0}
{ load the object pointer }
{$ifdef CPUI386}
asm
movl Obj, %esi
end;
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l Obj, a5
end;
{$endif CPU68K}
{$endif VER1_0}
CallVoidMethodLocal := VoidMethodLocal(Func)(Frame)
end;
function CallPointerMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer; Param1: pointer): pointer;
begin
{$ifdef VER1_0}
{ load the object pointer }
{$ifdef CPUI386}
asm
movl Obj, %esi
end;
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l Obj, a5
end;
{$endif CPU68K}
{$endif VER1_0}
CallPointerMethodLocal := PointerMethodLocal(Func)(Frame, Param1)
end;
function CurrentFramePointer: FramePointer;assembler;
{$ifdef CPUI386}
asm
movl %ebp,%eax
end ['EAX'];
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l a6, d0
end['D0'];
{$endif CPU68K}
{$ifdef CPUPOWERPC}
asm
mr r3,r1
end;
{$endif CPUPOWERPC}
function PreviousFramePointer: FramePointer;assembler;
{$ifdef CPUI386}
asm
movl (%ebp),%eax
end ['EAX'];
{$endif CPUI386}
{$ifdef CPU68K}
asm
move.l (a6), d0
end['D0'];
{$endif CPU68K}
{$ifdef CPUPOWERPC}
asm
lwz r3,0(r1)
end;
{$endif CPUPOWERPC}
{$endif PPC_FPC}
{$ifdef PPC_BP}
type
VoidConstructor = function(VmtOfs: Word; Obj: pointer): pointer;
PointerConstructor = function(Param1: pointer; VmtOfs: Word; Obj: pointer): pointer;
VoidMethod = function(Obj: pointer): pointer;
PointerMethod = function(Param1: pointer; Obj: pointer): pointer;
function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;
begin
CallVoidConstructor := VoidConstructor(Ctor)(Ofs(VMT^), Obj)
end;
function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;
begin
CallPointerConstructor := PointerConstructor(Ctor)(Param1, Ofs(VMT^), Obj)
end;
function CallVoidMethod(Method: pointer; Obj: pointer): pointer;
begin
CallVoidMethod := VoidMethod(Method)(Obj)
end;
function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;
begin
CallPointerMethod := PointerMethod(Method)(Param1, Obj)
end;
function CallVoidLocal(Func: pointer; Frame: FramePointer): pointer; assembler;
asm
{$IFDEF Windows}
MOV AX,[Frame]
AND AL,0FEH
PUSH AX
{$ELSE}
push [Frame]
{$ENDIF}
call dword ptr Func
end;
function CallPointerLocal(Func: pointer; Frame: FramePointer; Param1: pointer): pointer; assembler;
asm
mov ax, word ptr Param1
mov dx, word ptr Param1+2
push dx
push ax
{$IFDEF Windows}
MOV AX,[Frame]
AND AL,0FEH
PUSH AX
{$ELSE}
push [Frame]
{$ENDIF}
call dword ptr Func
end;
function CallVoidMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer): pointer; assembler;
asm
{$IFDEF Windows}
MOV AX,[Frame]
AND AL,0FEH
PUSH AX
{$ELSE}
push [Frame]
{$ENDIF}
call dword ptr Func
end;
function CallPointerMethodLocal(Func: pointer; Frame: FramePointer; Obj: pointer; Param1: pointer): pointer; assembler;
asm
mov ax, word ptr Param1
mov dx, word ptr Param1+2
push dx
push ax
{$IFDEF Windows}
MOV AX,[Frame]
AND AL,0FEH
PUSH AX
{$ELSE}
push [Frame]
{$ENDIF}
call dword ptr Func
end;
function CurrentFramePointer: FramePointer; assembler;
asm
mov ax, bp
end;
function PreviousFramePointer: FramePointer; assembler;
asm
mov ax, ss:[bp]
end;
{$endif PPC_BP}
end.
{
$Log$
Revision 1.4 2004-02-06 20:56:38 jonas
+ powerpc support
Revision 1.3 2004/02/06 20:08:58 jonas
* version from FV
Revision 1.4 2003/11/12 15:49:59 peter
* fix crash with 1.9
Revision 1.3 2001/07/30 08:27:58 pierre
* fix I386 compilation problem
Revision 1.2 2001/07/29 20:23:18 pierre
* support for m68k cpu
Revision 1.1 2001/01/29 21:56:04 peter
* updates for new fpcmake
Revision 1.1 2001/01/29 11:31:26 marco
* added from API. callspec renamed to .pp
Revision 1.1 2000/07/13 06:29:38 michael
+ Initial import
Revision 1.1 2000/01/06 01:20:30 peter
* moved out of packages/ back to topdir
Revision 1.1 1999/12/23 19:36:47 peter
* place unitfiles in target dirs
Revision 1.1 1999/11/24 23:36:37 peter
* moved to packages dir
Revision 1.2 1998/12/16 21:57:16 peter
* fixed currentframe,previousframe
+ testcall to test the callspec unit
Revision 1.1 1998/12/04 12:48:24 peter
* moved some dirs
Revision 1.5 1998/12/04 09:53:44 peter
* removed objtemp global var
Revision 1.4 1998/11/24 17:14:24 peter
* fixed esi loading
Date Version Who Comments
---------- -------- ------- -------------------------------------
19-Sep-97 0.1 mkoeppe Initial version.
22-Sep-97 0.11 fk 0.9.3 support added, self isn't expected
on the stack in local procedures of methods
23-Sep-97 0.12 mkoeppe Cleaned up 0.9.3 conditionals.
03-Oct-97 0.13 mkoeppe Fixed esi load in FPC 0.9
22-Oct-98 0.14 pfv 0.99.8 support for FPC
}

176
fv/dialogs.pas
View File

@ -53,14 +53,9 @@ USES
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
{$IFDEF PPC_FPC}
OS2Def, DosCalls, PMWIN, { Standard units }
{$ELSE}
OS2Def, OS2Base, OS2PMAPI, { Standard units }
{$ENDIF}
{$ENDIF}
GFVGraph, { GFV standard unit }
FVCommon, FVConsts, Objects, Drivers, Views, Validate; { Standard GFV units }
{***************************************************************************}
@ -1028,7 +1023,7 @@ USES App,HistList; { Standard GFV unit }
{---------------------------------------------------------------------------}
{ LEFT AND RIGHT ARROW CHARACTER CONSTANTS }
{---------------------------------------------------------------------------}
CONST LeftArr = #17; RightArr = #16;
CONST LeftArr = '<'; RightArr = '>';
{---------------------------------------------------------------------------}
{ TButton MESSAGES }
@ -1380,12 +1375,12 @@ BEGIN
If (State AND sfFocused = 0) Then Color := 1 { Not focused colour }
Else Color := 2; { Focused colour }
If CanScroll(-1) Then WriteStr(0, 0, LeftArr, 4); { Set left scroll mark }
If CanScroll(1) Then WriteStr(-(RawSize.X + 1 -
If CanScroll(1) Then WriteStr(-(Size.X + 1 -
TextWidth(RightArr)), 0, RightArr, 4); { Set right scroll mark }
If (Data <> Nil) Then S := Copy(Data^, FirstPos+1,
Length(Data^)-FirstPos) Else S := ''; { Fetch data string }
X := TextWidth(LeftArr); { left arrow width }
While (TextWidth(S) > ((RawSize.X+1)-X-TextWidth(
While (TextWidth(S) > (Size.X-X-TextWidth(
RightArr))) Do Delete(S, Length(S), 1); { Cut to right length }
If (State AND sfFocused <> 0) Then Begin
L := SelStart - FirstPos; { Selected left end }
@ -1422,35 +1417,13 @@ END;
{ DrawCursor -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TInputLine.DrawCursor;
VAR I, X: Sw_Integer; S: String;
BEGIN
If (State AND sfFocused <> 0) Then
Begin { Focused window }
if (TextModeGFV) then
begin
Cursor.Y:=0;
Cursor.X:=CurPos-FirstPos+1;
ResetCursor;
end
else
begin
X := TextWidth(LeftArr); { Preset x position }
I := 0; { Preset cursor width }
If (Data <> Nil) Then Begin { Data pointer valid }
S := Copy(Data^, FirstPos+1, CurPos-FirstPos); { Copy the string }
X := X + TextWidth(S); { Calculate position }
If (State AND sfCursorIns <> 0) Then { Check insert mode }
If ((CurPos+1) <= Length(Data^)) Then
I := TextWidth(Data^[CurPos+1]) { Insert caret width }
Else I := FontWidth; { At end use fontwidth }
End;
If (State AND sfCursorIns <> 0) Then Begin { Insert mode }
If ((CurPos+1) <= Length(Data^)) Then { Not beyond end }
WriteStr(-X, 0, Data^[CurPos+1], 5) { Create block cursor }
Else ClearArea(X, 0, X+I, FontHeight, Green);{ Line cursor }
End Else ClearArea(X, 0, X+I, FontHeight, Green);{ Line cursor }
End;
end;
Cursor.Y:=0;
Cursor.X:=CurPos-FirstPos+1;
ResetCursor;
end;
END;
{--TInputLine---------------------------------------------------------------}
@ -1540,9 +1513,9 @@ Delta, Anchor, OldCurPos, OldFirstPos, OldSelStart, OldSelEnd: Sw_Integer;
FUNCTION MouseDelta: Sw_Integer;
BEGIN
If (Event.Where.X <= RawOrigin.X+TextWidth(LeftArr))
If (Event.Where.X <= Origin.X+TextWidth(LeftArr))
Then MouseDelta := -1 Else { To left of text area }
If ((Event.Where.X-RawOrigin.X) >= RawSize.X -
If ((Event.Where.X-Origin.X) >= Size.X -
TextWidth(RightArr)) Then MouseDelta := 1 { To right of text area }
Else MouseDelta := 0; { In area return 0 }
END;
@ -1550,7 +1523,7 @@ Delta, Anchor, OldCurPos, OldFirstPos, OldSelStart, OldSelEnd: Sw_Integer;
FUNCTION MousePos: Sw_Integer;
VAR Mp, Tw, Pos: Sw_Integer; S: String;
BEGIN
Mp := Event.Where.X - RawOrigin.X; { Mouse position }
Mp := Event.Where.X - Origin.X; { Mouse position }
If (Data <> Nil) Then S := Copy(Data^, FirstPos+1,
Length(Data^)-FirstPos) Else S := ''; { Text area string }
Tw := TextWidth(LeftArr); { Text width }
@ -1747,8 +1720,8 @@ BEGIN
If (Data <> Nil) Then OldData := Copy(Data^,
FirstPos+1, CurPos-FirstPos) { Text area string }
Else OldData := ''; { Empty string }
Delta := FontWidth; { Safety = 1 char }
While (TextWidth(OldData) > ((RawSize.X+1)-Delta)
Delta := 1; { Safety = 1 char }
While (TextWidth(OldData) > (Size.X-Delta)
- TextWidth(LeftArr) - TextWidth(RightArr)) { Check text fits }
Do Begin
Inc(FirstPos); { Advance first pos }
@ -1776,7 +1749,7 @@ BEGIN
If (Data = Nil) Then S := '' Else { Data ptr invalid }
S := Copy(Data^, FirstPos+1, Length(Data^)
- FirstPos); { Fetch max string }
CanScroll := (TextWidth(S)) > (RawSize.X -
CanScroll := (TextWidth(S)) > (Size.X -
TextWidth(LeftArr) - TextWidth(RightArr)); { Check scroll right }
End Else CanScroll := False; { Zero so no scroll }
END;
@ -1863,24 +1836,8 @@ END;
PROCEDURE TButton.DrawFocus;
VAR B: Byte; I, J, Pos: Sw_Integer;
Bc: Word; Db: TDrawBuffer;
StoreUseFixedFont: boolean;
C : char;
BEGIN
If not TextModeGFV then Begin
If DownFlag Then B := 7 Else B := 0; { Shadow colour }
GraphRectangle(0, 0, RawSize.X, RawSize.Y, B); { Draw backing shadow }
GraphRectangle(1, 1, RawSize.X-1, RawSize.Y-1, B); { Draw backing shadow }
If DownFlag Then B := 0 Else B := 15; { Highlight colour }
GraphLine(0, RawSize.Y, 0, 0, B);
GraphLine(1, RawSize.Y-1, 1, 1, B); { Left highlights }
GraphLine(0, 0, RawSize.X, 0, B);
GraphLine(1, 1, RawSize.X-1, 1, B); { Top highlights }
If DownFlag Then B := 8 Else B := 7; { Select backing }
If (State AND sfFocused <> 0) AND
(DownFlag = False) Then B := 14; { Show as focused }
GraphRectangle(2, 2, RawSize.X-2, RawSize.Y-2, B); { Draw first border }
GraphRectangle(3, 3, RawSize.X-3, RawSize.Y-3, B); { Draw next border }
End;
If (State AND sfDisabled <> 0) Then { Button disabled }
Bc := GetColor($0404) Else Begin { Disabled colour }
Bc := GetColor($0501); { Set normal colour }
@ -1892,50 +1849,40 @@ BEGIN
If (Title <> Nil) Then Begin { We have a title }
If (Flags AND bfLeftJust = 0) Then Begin { Not left set title }
I := CTextWidth(Title^); { Fetch title width }
I := (RawSize.X - I) DIV 2; { Centre in button }
End Else I := FontWidth; { Left edge of button }
If not TextModeGFV then Begin
MoveCStr(Db[0], Title^, Bc); { Move title to buffer }
GOptions := GOptions OR goGraphView; { Graphics co-ords mode }
StoreUseFixedFont:=UseFixedFont;
UseFixedFont:=false;
WriteLine(I, FontHeight DIV 2, CStrLen(Title^),
1, Db); { Write the title }
GOptions := GOptions AND NOT goGraphView; { Return to normal mode }
UseFixedFont:=StoreUseFixedFont;
End Else Begin
I:=I div SysFontWidth;
If DownFlag then
I := (Size.X - I) DIV 2; { Centre in button }
End
Else
I := 1; { Left edge of button }
If DownFlag then
begin
MoveChar(Db[0],' ',GetColor(8),1);
Pos:=1;
end
else
pos:=0;
For j:=0 to I-1 do
MoveChar(Db[pos+j],' ',Bc,1);
MoveCStr(Db[I+pos], Title^, Bc); { Move title to buffer }
For j:=pos+CStrLen(Title^)+I to size.X-2 do
MoveChar(Db[j],' ',Bc,1);
If not DownFlag then
Bc:=GetColor(8);
MoveChar(Db[Size.X-1],' ',Bc,1);
WriteLine(0, 0, Size.X,
1, Db); { Write the title }
If Size.Y>1 then Begin
Bc:=GetColor(8);
if not DownFlag then
begin
MoveChar(Db[0],' ',GetColor(8),1);
Pos:=1;
end
else
pos:=0;
For j:=0 to I-1 do
MoveChar(Db[pos+j],' ',Bc,1);
MoveCStr(Db[I+pos], Title^, Bc); { Move title to buffer }
For j:=pos+CStrLen(Title^)+I to size.X-2 do
MoveChar(Db[j],' ',Bc,1);
If not DownFlag then
Bc:=GetColor(8);
MoveChar(Db[Size.X-1],' ',Bc,1);
WriteLine(0, 0, Size.X,
1, Db); { Write the title }
If Size.Y>1 then Begin
Bc:=GetColor(8);
if not DownFlag then
begin
c:='Ü';
MoveChar(Db,c,Bc,1);
WriteLine(Size.X-1, 0, 1, 1, Db);
end;
MoveChar(Db,' ',Bc,1);
if DownFlag then c:=' '
else c:='ß';
MoveChar(Db[1],c,Bc,Size.X-1);
WriteLine(0, 1, Size.X, 1, Db);
End;
c:='Ü';
MoveChar(Db,c,Bc,1);
WriteLine(Size.X-1, 0, 1, 1, Db);
end;
MoveChar(Db,' ',Bc,1);
if DownFlag then c:=' '
else c:='ß';
MoveChar(Db[1],c,Bc,Size.X-1);
WriteLine(0, 1, Size.X, 1, Db);
End;
End;
END;
@ -1995,9 +1942,9 @@ END;
PROCEDURE TButton.HandleEvent (Var Event: TEvent);
VAR Down: Boolean; C: Char; ButRect: TRect;
BEGIN
ButRect.A := RawOrigin; { Get origin point }
ButRect.B.X := RawOrigin.X + RawSize.X; { Calc right side }
ButRect.B.Y := RawOrigin.Y + RawSize.Y; { Calc bottom }
ButRect.A := Origin; { Get origin point }
ButRect.B.X := Origin.X + Size.X; { Calc right side }
ButRect.B.Y := Origin.Y + Size.Y; { Calc bottom }
If (Event.What = evMouseDown) Then Begin { Mouse down event }
If NOT MouseInView(Event.Where) Then Begin { If point not in view }
ClearEvent(Event); { Clear the event }
@ -2091,11 +2038,8 @@ BEGIN
Dispose(P); { Dispose prior item }
End;
Sel := 0;
if TextModeGFV then
begin
SetCursor(2,0);
ShowCursor;
end;
SetCursor(2,0);
ShowCursor;
EnableMask := $FFFFFFFF; { Enable bit masks }
END;
@ -2120,8 +2064,6 @@ BEGIN
EnableMask := $FFFFFFFF; { Enable all masks }
Options := Options OR ofVersion20; { Set version 2 mask }
End;
If (Options AND ofGFVModeView <> 0) Then { GFV mode view check }
S.Read(Id, Sizeof(Id)); { Read view id }
Strings.Load(S); { Load string data }
SetButtonState(0, True); { Set button state }
END;
@ -2271,8 +2213,7 @@ BEGIN
End;
WriteBuf(K, K+I, Size.X-K-K, 1, B); { Write buffer }
End;
if TextModeGFV then
SetCursor(Column(Sel)+2,Row(Sel));
SetCursor(Column(Sel)+2,Row(Sel));
END;
{--TCluster-----------------------------------------------------------------}
@ -2340,8 +2281,6 @@ BEGIN
S.Write(w, SizeOf(Word)); { Write value }
S.Write(Sel, SizeOf(Sel)); { Write select item }
End;
If (Options AND ofGFVModeView <> 0) Then { GFV mode view check }
S.Write(Id, SizeOf(Id)); { Write new id value }
Strings.Store(S); { Store strings }
END;
@ -2952,14 +2891,14 @@ BEGIN
T := Copy(S, I, P-I); { String to write }
Case Just Of
0: J := 0; { Left justify }
1: J := (RawSize.X - TextWidth(T)) DIV 2; { Centre justify }
2: J := RawSize.X - TextWidth(T); { Right justify }
1: J := (Size.X - TextWidth(T)) DIV 2; { Centre justify }
2: J := Size.X - TextWidth(T); { Right justify }
End;
While (J < 0) Do Begin { Text to long }
J := J + TextWidth(T[1]); { Add width to J }
Delete(T, 1, 1); { Delete the char }
End;
WriteStr(-J, -(Y*FontHeight), T, 1); { Write the text }
WriteStr(-J, -Y, T, 1); { Write the text }
While (P <= L) AND (P-I <= Size.X) AND ((S[P] = #13) OR (S[P] = #10))
Do Inc(P); { Remove CR/LF }
Inc(Y); { Next line }
@ -4229,7 +4168,10 @@ END;
END.
{
$Log$
Revision 1.25 2004-11-03 12:09:08 peter
Revision 1.26 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.25 2004/11/03 12:09:08 peter
* textwidth doesn't support ~ anymore, added CTextWidth with ~ support
Revision 1.24 2004/11/03 10:37:24 peter

320
fv/drivers.pas
View File

@ -87,10 +87,6 @@ USES
{$ifdef HasSysMsgUnit}
SysMsg,
{$endif HasSysMsgUnit}
{$IFDEF GRAPH_API} { GRAPH CODE }
Graph, { Standard unit }
{$ENDIF}
GFVGraph, { GFV graphics unit }
FVCommon, Objects; { GFV standard units }
{***************************************************************************}
@ -278,11 +274,7 @@ TYPE
END;
PEvent = ^TEvent;
{$ifdef USE_VIDEO_API}
TVideoMode = Video.TVideoMode; { Screen mode }
{$else not USE_VIDEO_API}
TVideoMode = Sw_Word; { Screen mode }
{$endif USE_VIDEO_API}
{---------------------------------------------------------------------------}
{ ERROR HANDLER FUNCTION DEFINITION }
@ -577,16 +569,6 @@ CONST
SaveInt09 : Pointer = Nil; { Compatability only }
SysErrorFunc : TSysErrorFunc = {$ifdef FPC}@{$endif}SystemError; { System error ptr }
{---------------------------------------------------------------------------}
{ >>> NEW INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES <<< }
{---------------------------------------------------------------------------}
CONST
TextModeGFV : Boolean = False; { DOS/DPMI textmode op }
UseFixedFont : Boolean = True;
DefLineNum : Sw_Integer = 25; { Default line number }
DefFontHeight : Sw_Integer = 0; { Default font height }
SysFontWidth : Sw_Integer = 8; { System font width }
SysFontHeight : Sw_Integer = 16; { System font height }
{***************************************************************************}
{ UNINITIALIZED PUBLIC VARIABLES }
@ -600,11 +582,7 @@ VAR
MouseButtons: Byte; { Mouse button state }
ScreenWidth : Byte; { Screen text width }
ScreenHeight: Byte; { Screen text height }
{$IFNDEF Use_Video_API}
ScreenMode : Sw_Word; { Screen mode }
{$Else Use_Video_API}
ScreenMode : TVideoMode; { Screen mode }
{$Endif Use_Video_API}
MouseWhere : TPoint; { Mouse position }
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
@ -613,11 +591,6 @@ VAR
{ API Units }
USES
FVConsts,
{$IFDEF GRAPH_API} { GRAPH CODE }
{$ifdef win32}
win32gr,
{$endif}
{$ENDIF GRAPH_API} { GRAPH CODE }
Keyboard,Mouse;
{***************************************************************************}
@ -789,7 +762,6 @@ END;
{---------------------------------------------------------------------------}
{ DetectVideo -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB }
{---------------------------------------------------------------------------}
{$IFDEF Use_Video_API}
procedure DetectVideo;
VAR
@ -800,107 +772,6 @@ begin
GetVideoMode(CurrMode);
ScreenMode:=CurrMode;
end;
{$else not Use_Video_API}
PROCEDURE DetectVideo;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
ASSEMBLER;
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASM
MOV AH, $0F; { Set function id }
PUSH BP; { Safety!! save reg }
INT $10; { Get current crt mode }
POP BP; { Restore register }
PUSH AX; { Hold result }
MOV AX, $1130; { Set function id }
MOV BH, 0; { Zero register }
MOV DL, 0; { Zero register }
PUSH BP; { Safety!! save reg }
INT $10; { Get ext-video mode }
POP BP; { Restore register }
POP AX; { Recover held value }
MOV DH, AH; { Transfer high mode }
CMP DL, 25; { Check screen ht }
SBB AH, AH; { Subtract borrow }
INC AH; { Make #1 if in high }
MOV CL, 1; { Preset value of 1 }
OR DL, DL; { Test for zero }
JNZ @@1; { Branch if not zero }
MOV CL, 0 { Set value to zero }
MOV DL, 24; { Zero = 24 lines }
@@1:
INC DL; { Add one line }
MOV ScreenWidth, DH; { Hold screen width }
MOV ScreenHeight, DL; { Hold screen height }
MOV HiResScreen, CL; { Set hires mask }
CMP AL, smMono; { Is screen mono }
JZ @@Exit1; { Exit of mono }
CMP AL, smBW80; { Is screen B&W }
JZ @@Exit1; { Exit if B&W }
MOV AX, smCO80; { Else set to colour }
@@Exit1:
MOV ScreenMode, AX; { Hold screen mode }
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
ASM
MOVB $0x0F, %AH; { Set function id }
PUSHL %EBP; { Save register }
INT $0x10; { Get current crt mode }
POPL %EBP; { Restore register }
PUSHL %EAX; { Hold result }
MOVW $0x1130, %AX; { Set function id }
MOVB $0, %BH; { Zero register }
MOVB $0, %DL; { Zero register }
PUSHL %EBP; { Safety!! save reg }
INT $0x10; { Get ext-video mode }
POPL %EBP; { Restore register }
POPL %EAX; { Recover held value }
MOVB %AH, %DH; { Transfer high mode }
CMPB $25, %DL; { Check screen ht }
SBB %AH, %AH; { Subtract borrow }
INCB %AH; { Make #1 if in high }
MOVB $1, %CL; { Preset value of 1 }
ORB %DL, %DL; { Test for zero }
JNZ .L_JMP1; { Branch if not zero }
MOVB $0, %CL; { Set value to zero }
MOVB $24, %DL; { Zero = 24 lines }
.L_JMP1:
INCB %DL; { Add one line }
MOVB %DH, SCREENWIDTH; { Hold screen width }
MOVB %DL, SCREENHEIGHT; { Hold screen height }
MOVB %CL, HIRESSCREEN; { Set hires mask }
CMPB $07, %AL; { Is screen mono }
JZ .L_Exit1; { Exit of mono }
CMPB $02, %AL; { Is screen B&W }
JZ .L_Exit1; { Exit if B&W }
MOVW $03, %AX; { Else set to colour }
.L_Exit1:
MOVW %AX, SCREENMODE; { Hold screen mode }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
VAR Dc: HDC;
BEGIN
Dc := GetDc(0); { Get screen context }
If ((GetDeviceCaps(Dc, BitsPixel) > 1) OR { Colour capacity }
(GetDeviceCaps(Dc, Planes) > 1)) Then { Colour capacity }
ScreenMode := smCO80 Else ScreenMode := smMono; { Screen mode }
ReleaseDc(0, Dc); { Release context }
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
VAR Ps: Hps; Dc: Hdc; Colours: LongInt;
BEGIN
Ps := WinGetPS(HWND_Desktop); { Get desktop PS }
Dc := GpiQueryDevice(Ps); { Get gpi context }
DevQueryCaps(Dc, Caps_Phys_Colors, 1, Colours); { Colour capacity }
If (Colours> 2) Then ScreenMode := smCO80 { Colour screen }
Else ScreenMode := smMono; { Mono screen }
WinReleasePS(Ps); { Release desktop PS }
END;
{$ENDIF}
{$endif not Use_Video_API}
{---------------------------------------------------------------------------}
{ DetectMouse -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 19May98 LdB }
@ -1176,8 +1047,8 @@ begin
if Mouse.PollMouseEvent(e) then
begin
Mouse.GetMouseEvent(e);
MouseWhere.X:=e.x * SysFontWidth;
MouseWhere.Y:=e.y * SysFontHeight;
MouseWhere.X:=e.x;
MouseWhere.Y:=e.y;
Event.Double:=false;
case e.Action of
MouseActionMove :
@ -1324,124 +1195,33 @@ const
{---------------------------------------------------------------------------}
PROCEDURE InitVideo;
VAR
{$ifdef GRAPH_API}
I, J: Integer;
Ts : TextSettingsType;
{$else not GRAPH_API}
I, J: Integer;
{$IFDEF OS_WINDOWS}
Dc, Mem: HDc; TempFont: TLogFont; Tm: TTextmetric;
{$ENDIF}
{$IFDEF OS_OS2}
Ts, Fs: Sw_Integer; Ps: HPs; Tm: FontMetrics;
{$ENDIF}
{$ENDIF}
{$ifdef USE_VIDEO_API}
StoreScreenMode : TVideoMode;
{$endif USE_VIDEO_API}
StoreScreenMode : TVideoMode;
BEGIN
if VideoInitialized then
begin
{$ifdef USE_VIDEO_API}
StoreScreenMode:=ScreenMode;
{$endif USE_VIDEO_API}
DoneVideo;
{$ifdef USE_VIDEO_API}
end
else
begin
if VideoInitialized then
begin
StoreScreenMode:=ScreenMode;
DoneVideo;
end
else
StoreScreenMode.Col:=0;
{$endif USE_VIDEO_API}
end;
{$ifdef GRAPH_API}
if Not TextmodeGFV then
begin
{$ifdef go32v2}
I := VGA;
J := VGAHi;
{$else not go32v2}
{$ifdef win32}
I := VESA;
J := mLargestWindow16;
DefFontHeight:=8;
{$else not win32}
I := Detect; { Detect video card }
J := 0; { Zero select mode }
{$endif win32}
{$endif go32v2}
InitGraph(I, J, ''); { Initialize graphics }
I := Graph.GetMaxX; { Fetch max x size }
J := Graph.GetMaxY; { Fetch max y size }
If (DefFontHeight = 0) Then { Font height not set }
J := (Graph.GetMaxY+1) DIV DefLineNum { Approx font height }
Else J := DefFontHeight; { Use set font height }
I := J DIV (TextHeight('H')+4); { Approx magnification }
If (I < 1) Then I := 1; { Must be 1 or above }
GetTextSettings(Ts); { Get text style }
SetTextStyle(Ts.Font, Ts.Direction, I); { Set new font settings }
SysFontWidth := TextWidth('H'); { Transfer font width }
SysFontHeight := TextHeight('H')+4; { Transfer font height }
ScreenWidth := (Graph.GetMaxX+1) DIV
SysFontWidth; { Calc screen width }
if ScreenWidth > MaxViewWidth then
ScreenWidth := MaxViewWidth;
ScreenHeight := (Graph.GetMaxY+1) DIV
SysFontHeight; { Calc screen height }
UseFixedFont:=true;
{$ifdef USE_VIDEO_API}
if assigned(Video.VideoBuf) then
FreeMem(Video.VideoBuf);
GetMem(Video.VideoBuf,sizeof(word)*ScreenWidth*ScreenHeight);
if assigned(Video.OldVideoBuf) then
FreeMem(Video.OldVideoBuf);
GetMem(Video.OldVideoBuf,sizeof(word)*ScreenWidth*ScreenHeight);
GetMem(GFVGraph.SpVideoBuf,sizeof(pextrainfo)*(ScreenWidth+1)*(ScreenHeight+1));
FillChar(Video.VideoBuf^,sizeof(word)*ScreenWidth*ScreenHeight,#0);
FillChar(Video.OldVideoBuf^,sizeof(word)*ScreenWidth*ScreenHeight,#0);
FillChar(GFVGraph.SpVideoBuf^,sizeof(pextrainfo)*(ScreenWidth+1)*(ScreenHeight+1),#0);
ScreenMode.color:=true;
ScreenMode.col:=ScreenWidth;
ScreenMode.row:=ScreenHeight;
GfvGraph.SysFontWidth:=SysFontWidth;
GfvGraph.SysFontHeight:=SysFontHeight;
GfvGraph.TextScreenWidth:=ScreenWidth;
GfvGraph.TextScreenHeight:=ScreenHeight;
SetupExtraInfo;
{$endif USE_VIDEO_API}
{$ifdef win32}
SetGraphHooks;
{$endif}
end
else
{$endif GRAPH_API}
begin
Video.InitVideo;
{$ifdef USE_VIDEO_API}
GetVideoMode(ScreenMode);
If (StoreScreenMode.Col<>0) and
((StoreScreenMode.color<>ScreenMode.color) or
(StoreScreenMode.row<>ScreenMode.row) or
(StoreScreenMode.col<>ScreenMode.col)) then
begin
Video.SetVideoMode(StoreScreenMode);
GetVideoMode(ScreenMode);
end;
{$endif USE_VIDEO_API}
if ScreenWidth > MaxViewWidth then
ScreenWidth := MaxViewWidth;
ScreenWidth:=Video.ScreenWidth;
ScreenHeight:=Video.ScreenHeight;
SetViewPort(0,0,ScreenWidth,ScreenHeight,true,true);
I := ScreenWidth*8 -1; { Mouse width }
J := ScreenHeight*8 -1; { Mouse height }
SysScreenWidth := I + 1;
SysScreenHeight := J + 1;
SysFontWidth := 8; { Font width }
SysFontHeight := 8; { Font height }
end;
VideoInitialized:=true;
Video.InitVideo;
GetVideoMode(ScreenMode);
If (StoreScreenMode.Col<>0) and
((StoreScreenMode.color<>ScreenMode.color) or
(StoreScreenMode.row<>ScreenMode.row) or
(StoreScreenMode.col<>ScreenMode.col)) then
begin
Video.SetVideoMode(StoreScreenMode);
GetVideoMode(ScreenMode);
end;
if ScreenWidth > MaxViewWidth then
ScreenWidth := MaxViewWidth;
ScreenWidth:=Video.ScreenWidth;
ScreenHeight:=Video.ScreenHeight;
VideoInitialized:=true;
END;
{---------------------------------------------------------------------------}
@ -1451,28 +1231,7 @@ PROCEDURE DoneVideo;
BEGIN
if not VideoInitialized then
exit;
{$ifdef GRAPH_API}
if Not TextmodeGFV then
begin
{$ifdef USE_VIDEO_API}
FreeMem(Video.VideoBuf,sizeof(word)*ScreenWidth*ScreenHeight);
Video.VideoBuf:=nil;
FreeMem(Video.OldVideoBuf,sizeof(word)*ScreenWidth*ScreenHeight);
Video.OldVideoBuf:=nil;
FreeExtraInfo;
{$endif USE_VIDEO_API}
CloseGraph;
{$ifdef win32}
UnsetGraphHooks;
{$endif}
end
else
{$endif GRAPH_API}
{$ifdef USE_video_api}
Video.DoneVideo;
{$else not USE_video_api}
; { nothing to do }
{$endif not USE_video_api}
Video.DoneVideo;
VideoInitialized:=false;
END;
@ -1481,18 +1240,7 @@ END;
{---------------------------------------------------------------------------}
PROCEDURE ClearScreen;
BEGIN
{$ifdef GRAPH_API}
if Not TextmodeGFV then
begin
Graph.ClearDevice;
end
else
{$endif GRAPH_API}
{$ifdef USE_video_api}
Video.ClearScreen;
{$else not USE_video_api}
; { nothing to do }
{$endif not USE_video_api}
Video.ClearScreen;
END;
{---------------------------------------------------------------------------}
@ -1500,8 +1248,6 @@ END;
{---------------------------------------------------------------------------}
PROCEDURE SetVideoMode (Mode: Sw_Word);
BEGIN
If (Mode > $100) Then DefLineNum := 50 { 50 line mode request }
Else DefLineNum := 24; { Normal 24 line mode }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
@ -1690,12 +1436,7 @@ END;
BEGIN
ButtonCount := DetectMouse; { Detect mouse }
DetectVideo; { Detect video }
{ text mode is the default mode }
TextModeGFV:=True;
InitKeyboard;
{$ifdef Graph_API}
TextModeGFV:=false;
{$endif Graph_API}
{$ifdef HasSysMsgUnit}
InitSystemMsg;
{$endif HasSysMsgUnit}
@ -1710,7 +1451,10 @@ BEGIN
END.
{
$Log$
Revision 1.39 2004-11-02 23:53:19 peter
Revision 1.40 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.39 2004/11/02 23:53:19 peter
* fixed crashes with ide and 1.9.x
Revision 1.38 2003/10/01 16:20:27 marco

732
fv/fileio.pas
View File

@ -1,732 +0,0 @@
{ $Id$ }
{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********}
{ }
{ System independent FILE I/O control }
{ }
{ Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer }
{ ldeboer@attglobal.net - primary e-mail address }
{ ldeboer@projectent.com.au - backup e-mail address }
{ }
{****************[ THIS CODE IS FREEWARE ]*****************}
{ }
{ This sourcecode is released for the purpose to }
{ promote the pascal language on all platforms. You may }
{ redistribute it and/or modify with the following }
{ DISCLAIMER. }
{ }
{ This SOURCE CODE is distributed "AS IS" WITHOUT }
{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR }
{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ }
{*****************[ SUPPORTED PLATFORMS ]******************}
{ 16 and 32 Bit compilers }
{ DOS - Turbo Pascal 7.0 + (16 Bit) }
{ DPMI - Turbo Pascal 7.0 + (16 Bit) }
{ - FPC 0.9912+ (GO32V2) (32 Bit) }
{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) }
{ - Delphi 1.0+ (16 Bit) }
{ WIN95/NT - Delphi 2.0+ (32 Bit) }
{ - Virtual Pascal 2.0+ (32 Bit) }
{ - Speedsoft Sybil 2.0+ (32 Bit) }
{ - FPC 0.9912+ (32 Bit) }
{ OS2 - Virtual Pascal 1.0+ (32 Bit) }
{ - Speed Pascal 1.0+ (32 Bit) }
{ - C'T patch to BP (16 Bit) }
{ LINUX - FPC 1.0.2+ (32 Bit) }
{ }
{******************[ REVISION HISTORY ]********************}
{ Version Date Fix }
{ ------- --------- --------------------------------- }
{ 1.00 12 Jun 96 First DOS/DPMI platform release }
{ 1.10 12 Mar 97 Windows conversion added. }
{ 1.20 29 Aug 97 Platform.inc sort added. }
{ 1.30 12 Jun 98 Virtual pascal 2.0 code added. }
{ 1.40 10 Sep 98 Checks run & commenting added. }
{ 1.50 28 Oct 98 Fixed for FPC version 0.998 }
{ Only Go32v2 supported no Go32v1 }
{ 1.60 14 Jun 99 References to Common.pas added. }
{ 1.61 07 Jul 99 Speedsoft SYBIL 2.0 code added. }
{ 1.62 03 Nov 99 FPC windows support added. }
{ 1.70 10 Nov 00 Revamp using changed common unit }
{**********************************************************}
UNIT FileIO;
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}
{==== Compiler directives ===========================================}
{$IFNDEF PPC_FPC} { FPC doesn't support these switches }
{$F-} { Short calls are okay }
{$A+} { Word Align Data }
{$B-} { Allow short circuit boolean evaluations }
{$O+} { This unit may be overlaid }
{$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
{$P-} { Normal string variables }
{$E+} { Emulation is on }
{$N-} { No 80x87 code generation }
{$ENDIF}
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$IFNDEF OS_UNIX}
{$S-} { Disable Stack Checking }
{$ENDIF}
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}
{$IFDEF OS_DOS} { DOS/DPMI ONLY }
{$IFDEF PPC_FPC} { FPC COMPILER }
{$IFNDEF GO32V2} { MUST BE GO32V2 }
This only works in GO32V2 mode in FPC!
{$ENDIF}
{$ENDIF}
{$ENDIF}
USES
{$IFDEF WIN16} WinTypes, WinProcs, {$ENDIF} { Stardard BP units }
FVCommon; { Standard GFV unit }
{***************************************************************************}
{ PUBLIC CONSTANTS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ FILE ACCESS MODE CONSTANTS }
{---------------------------------------------------------------------------}
CONST
fa_Create = $3C00; { Create new file }
fa_OpenRead = $3D00; { Read access only }
fa_OpenWrite = $3D01; { Write access only }
fa_Open = $3D02; { Read/write access }
{---------------------------------------------------------------------------}
{ FILE SHARE MODE CONSTANTS }
{---------------------------------------------------------------------------}
CONST
fm_DenyAll = $0010; { Exclusive file use }
fm_DenyWrite = $0020; { Deny write access }
fm_DenyRead = $0030; { Deny read access }
fm_DenyNone = $0040; { Deny no access }
{$IFDEF OS_DOS} { DOS/DPMI CODE }
CONST
HFILE_ERROR = -1; { File handle error }
{$ENDIF}
{***************************************************************************}
{ PUBLIC TYPE DEFINITIONS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ ASCIIZ FILENAME }
{---------------------------------------------------------------------------}
TYPE
AsciiZ = Array [0..255] Of Char; { Filename array }
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ FILE CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-FileClose----------------------------------------------------------
The file opened by the handle is closed. If close action is successful
true is returned but if the handle is invalid or a file error occurs
false will be returned.
14Nov00 LdB
---------------------------------------------------------------------}
FUNCTION FileClose (Handle: THandle): Boolean;
{-FileOpen-----------------------------------------------------------
Given a valid filename to file that exists, is not locked with a valid
access mode the file is opened and the file handle returned. If the
name or mode is invalid or an error occurs the return will be zero.
27Oct98 LdB
---------------------------------------------------------------------}
FUNCTION FileOpen (Const FileName: AsciiZ; Mode: Word): THandle;
{-SetFileSize--------------------------------------------------------
The file opened by the handle is set the given size. If the action is
successful zero is returned but if the handle is invalid or a file error
occurs a standard file error value will be returned.
21Oct98 LdB
---------------------------------------------------------------------}
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
{-SetFilePos---------------------------------------------------------
The file opened by the handle is set the given position in the file.
If the action is successful zero is returned but if the handle is invalid
the position is beyond the file size or a file error occurs a standard
file error value will be returned.
21Oct98 LdB
---------------------------------------------------------------------}
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
Var Actual: LongInt): Word;
{-FileRead-----------------------------------------------------------
The file opened by the handle has count bytes read from it an placed
into the given buffer. If the read action is successful the actual bytes
transfered is returned in actual and the function returns zero. If an
error occurs the function will return a file error constant and actual
will contain the bytes transfered before the error if any.
22Oct98 LdB
---------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
{-FileWrite----------------------------------------------------------
The file opened by the handle has count bytes written to it from the
given buffer. If the write action is successful the actual bytes
transfered is returned in actual and the function returns zero. If an
error occurs the function will return a file error constant and actual
will contain the bytes transfered before the error if any.
22Oct98 LdB
---------------------------------------------------------------------}
FUNCTION FileWrite (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{$IFDEF OS_WINDOWS} { WIN/NT UNITS }
{$IFNDEF PPC_SPEED} { NON SPEED COMPILER }
{$IFDEF WIN32} { WIN32 COMPILER }
USES Windows; { Standard unit }
{$ENDIF}
TYPE LongWord = LongInt; { Type fixup }
{$ELSE} { SPEEDSOFT COMPILER }
USES WinNT, WinBase; { Standard units }
{$ENDIF}
{$ENDIF}
{$IFDEF OS_OS2} { OS2 COMPILERS }
{$IFDEF PPC_VIRTUAL} { VIRTUAL PASCAL UNITS }
USES OS2Base; { Standard unit }
{$ENDIF}
{$IFDEF PPC_SPEED} { SPEED PASCAL UNITS }
USES BseDos, Os2Def; { Standard units }
{$ENDIF}
{$IFDEF PPC_BPOS2} { C'T PATCH TO BP UNITS }
USES DosTypes, DosProcs; { Standard units }
{$ENDIF}
{$IFDEF PPC_FPC} { FPC UNITS }
USES DosCalls, OS2Def; { Standard units }
{$ENDIF}
{$ENDIF}
{$IFDEF OS_UNIX} { LINUX COMPILER }
USES
{$ifdef VER1_0}
linux;
{$else}
Baseunix,unix;
{$endif}
{$ENDIF}
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ FileClose -> Platforms DOS/DPMI/WIN/NT/OS2/LINUX - Updated 14Nov00 LdB }
{---------------------------------------------------------------------------}
FUNCTION FileClose (Handle: THandle): Boolean;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
MOV BX, Handle; { DOS file handle }
MOV AX, $3E00; { Close function }
PUSH BP; { Store register }
INT $21; { Close the file }
POP BP; { Reload register }
MOV AL, True; { Preset true }
JNC @@Exit1; { Return success }
MOV AL, False; { Return failure }
@@Exit1:
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
VAR Regs: TRealRegs;
BEGIN
Regs.RealEBX := Handle; { Transfer handle }
Regs.RealEAX := $3E00; { Close file function }
SysRealIntr($21, Regs); { Call DOS interrupt }
If (Regs.RealFlags AND $1 = 0) Then { Check carry flag }
FileClose := True Else FileClose := False; { Return true/false }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
BEGIN
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
If (_lclose(Handle) = 0) Then FileClose := True { Close the file }
Else FileClose := False; { Closure failed }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
FileClose := CloseHandle(Handle); { Close the file }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
BEGIN
If (DosClose(Handle) = 0) Then FileClose := True { Try to close file }
Else FileClose := False; { Closure failed }
END;
{$ENDIF}
{$IFDEF OS_UNIX} { LINUX CODE }
BEGIN
{$ifdef ver1_0}
fdClose(Handle);
FileClose := LinuxError <= 0
{$else}
FileClose:=fpclose(Handle)=0;
{$endif}; { Close the file }
END;
{$ENDIF}
{---------------------------------------------------------------------------}
{ FileOpen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 27Oct98 LdB }
{---------------------------------------------------------------------------}
FUNCTION FileOpen (Const FileName: AsciiZ; Mode: Word): THandle;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
MOV AX, Mode; { Mode to open file }
XOR CX, CX; { No attributes set }
PUSH DS; { Save segment }
LDS DX, FileName; { Filename to open }
PUSH BP; { Store register }
INT $21; { Open/create file }
POP BP; { Restore register }
POP DS; { Restore segment }
JNC @@Exit2; { Check for error }
XOR AX, AX; { Open fail return 0 }
@@Exit2:
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
VAR Regs: TRealRegs;
BEGIN
SysCopyToDos(LongInt(@FileName), 256); { Transfer filename }
Regs.RealEDX := Tb MOD 16;
Regs.RealDS := Tb DIV 16; { Linear addr of Tb }
Regs.RealEAX := Mode; { Mode to open with }
Regs.RealECX := 0; { No attributes set }
SysRealIntr($21, Regs); { Call DOS int 21 }
If (Regs.RealFlags AND 1 <> 0) Then FileOpen := 0{ Error encountered }
Else FileOpen := Regs.RealEAX AND $FFFF; { Return file handle }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
VAR Hnd: Integer; OpenMode: Sw_Word;
{$IFDEF BIT_16} Buf: TOfStruct; {$ENDIF} { 16 BIT VARIABLES }
{$IFDEF BIT_32} ShareMode, Flags: LongInt; {$ENDIF} { 32 BIT VARIABLES }
BEGIN
{$IFDEF BIT_16} { 16 BIT WINDOW CODE }
If (Mode = fa_Create) Then OpenMode := of_Create { Set create mask bit }
Else OpenMode := Mode AND $00FF; { Set open mask bits }
Hnd := OpenFile(FileName, Buf, OpenMode); { Open the file }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
If (Mode = fa_Create) Then Begin { Create file }
OpenMode := Generic_Read OR Generic_Write; { Set access mask bit }
Flags := Create_Always; { Create always mask }
End Else Begin { Open the file }
OpenMode := Generic_Read; { Read only access set }
If (Mode AND $0001 <> 0) Then { Check write flag }
OpenMode := OpenMode AND NOT Generic_Read; { Write only access set }
If (Mode AND $0002 <> 0) Then { Check read/write flag }
OpenMode := OpenMode OR Generic_Write; { Read/Write access }
Flags := Open_Existing; { Open existing mask }
End;
ShareMode := file_Share_Read OR
file_Share_Write; { Deny none flag set }
Hnd := CreateFile(FileName, OpenMode, ShareMode,
Nil, Flags, File_Attribute_Normal, 0); { Open the file }
{$ENDIF}
If (Hnd <> -1) Then FileOpen := Hnd Else { Return handle }
FileOpen := 0; { Return error }
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
VAR OpenFlags, OpenMode: Word; Handle, ActionTaken: Sw_Word;
BEGIN
If (Mode = fa_Create) Then Begin { Create file }
OpenMode := Open_Flags_NoInherit OR
Open_Share_DenyNone OR
Open_Access_ReadWrite; { Open mode }
OpenFlags := OPEN_ACTION_CREATE_IF_NEW OR
OPEN_ACTION_REPLACE_IF_EXISTS; { Open flags }
End Else Begin
OpenMode := Mode AND $00FF OR
Open_Share_DenyNone; { Set open mode bits }
OpenFlags := OPEN_ACTION_OPEN_IF_EXISTS; { Set open flags }
End;
{$IFDEF PPC_BPOS2} { C'T patched COMPILER }
If (DosOpen(@FileName, Handle, ActionTaken, 0, 0,
OpenFlags, OpenMode, 0) = 0) Then
FileOpen := Handle Else FileOpen := 0; { Return handle/fail }
{$ELSE} { OTHER OS2 COMPILERS }
{$IFDEF PPC_FPC}
If (DosOpen(@FileName, Longint(Handle), ActionTaken, 0, 0,
OpenFlags, OpenMode, Nil) = 0) Then
FileOpen := Handle Else FileOpen := 0; { Return handle/fail }
{$ELSE}
If (DosOpen(FileName, Handle, ActionTaken, 0, 0,
OpenFlags, OpenMode, Nil) = 0) Then
FileOpen := Handle Else FileOpen := 0; { Return handle/fail }
{$ENDIF}
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_UNIX}
{$ifndef ver1_0}
var tmp : ansistring;
{$endif}
BEGIN
if mode = fa_Create then mode := Open_Creat or Open_RdWr else
if mode = fa_OpenRead then mode := Open_RdOnly else
if mode = fa_OpenWrite then mode := Open_WrOnly else
if mode = fa_Open then mode := Open_RdWr;
{$ifdef ver1_0}
FileOpen := fdOpen(FileName,mode);
{$else}
tmp:=filename;
FileOpen := fpopen(tmp,longint(mode));
{$endif}
END;
{$ENDIF}
{---------------------------------------------------------------------------}
{ SetFileSize -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 26Feb97 LdB }
{---------------------------------------------------------------------------}
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
MOV DX, FileSize.Word[0]; { Load file position }
MOV CX, FileSize.Word[2];
MOV BX, Handle; { Load file handle }
MOV AX, $4200; { Load function id }
PUSH BP; { Store register }
INT $21; { Position the file }
POP BP; { Reload register }
JC @@Exit3; { Exit if error }
XOR CX, CX; { Force truncation }
MOV BX, Handle; { File handle }
MOV AX, $4000; { Load function id }
PUSH BP; { Store register }
INT $21; { Truncate file }
POP BP; { Reload register }
JC @@Exit3; { Exit if error }
XOR AX, AX; { Return successful }
@@Exit3:
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
VAR Regs: TRealRegs;
BEGIN
Regs.RealEDX := FileSize AND $FFFF; { Lo word of filesize }
Regs.RealECX := (FileSize SHR 16) AND $FFFF; { Hi word of filesize }
Regs.RealEBX := LongInt(Handle); { Load file handle }
Regs.RealEAX := $4000; { Load function id }
SysRealIntr($21, Regs); { Call DOS int 21 }
If (Regs.RealFlags AND 1 <> 0) Then
SetFileSize := Regs.RealEAX AND $FFFF { Error encountered }
Else SetFileSize := 0; { Return successful }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
VAR {$IFDEF BIT_16} Buf, {$ENDIF} Actual: LongInt;
BEGIN
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
Actual := _llseek(Handle, FileSize, 0); { Position file }
If (Actual = FileSize) Then Begin { No position error }
Actual := _lwrite(Handle, Pointer(@Buf), 0); { Truncate the file }
If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error }
SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
Actual := SetFilePointer(Handle, FileSize, Nil, 0);{ Position file }
If (Actual = FileSize) Then Begin { No position error }
If SetEndOfFile(Handle) Then SetFileSize := 0 { No truncate error }
Else SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
BEGIN
{$IFDEF PPC_BPOS2} { C'T patched COMPILER }
SetFileSize := DosNewSize(Handle, FileSize); { Truncate the file }
{$ELSE} { OTHER OS2 COMPILERS }
SetFileSize := DosSetFileSize(Handle, FileSize); { Truncate the file }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_UNIX}
VAR
Actual : LongInt;
BEGIN
Actual := {$ifdef ver1_0}fdSeek{$else} fplseek{$endif}(Handle, FileSize, 0); { Position file }
If (Actual = FileSize) Then Begin { No position error }
if ({$ifdef ver1_0}fdTruncate{$else}fpftruncate{$endif}(Handle,FileSize)){$ifndef ver1_0}=0{$endif} { Truncate the file }
Then SetFileSize := 0 { No truncate error }
else SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error }
END;
{$ENDIF}
{---------------------------------------------------------------------------}
{ SetFilePos -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Feb97 LdB }
{---------------------------------------------------------------------------}
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
Var Actual: LongInt): Word;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
MOV AX, MoveType; { Load move type }
MOV AH, $42; { Load function id }
MOV DX, Pos.Word[0]; { Load file position }
MOV CX, Pos.Word[2];
MOV BX, Handle; { Load file handle }
PUSH BP; { Store register }
INT $21; { Position the file }
POP BP; { Reload register }
JC @@Exit6;
LES DI, Actual; { Actual var addr }
MOV ES:[DI], AX;
MOV ES:[DI+2], DX; { Update actual }
XOR AX, AX; { Set was successful }
@@Exit6:
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
VAR Regs: TRealRegs;
BEGIN
Actual := 0; { Zero actual count }
Regs.RealEAX := ($42 SHL 8) + Byte(MoveType); { Set function id }
Regs.RealEBX := LongInt(Handle); { Fetch file handle }
Regs.RealEDX := Pos AND $FFFF; { Keep low word }
Regs.RealECX := Pos SHR 16; { Keep high word }
SysRealIntr($21, Regs); { Call dos interrupt }
If (Regs.RealFlags AND $1 = 0) Then Begin
Actual := Lo(Regs.RealEDX) SHL 16 +
Lo(Regs.RealEAX); { Current position }
SetFilePos := 0; { Function successful }
End Else SetFilePos := Lo(Regs.RealEAX); { I/O error returned }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WINDOWS CODE }
BEGIN
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
Actual := _llseek(Handle, Pos, MoveType); { Position file }
If (Actual <> -1) Then SetFilePos := 0 Else { No position error }
SetFilePos := 107; { File position error }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
Actual := SetFilePointer(Handle, Pos, Nil, MoveType);{ Position file }
If (Actual <> -1) Then SetFilePos := 0 Else { No position error }
SetFilePos := 107; { File position error }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
BEGIN
{$IFDEF PPC_BPOS2}
If (DosChgFilePtr(Handle, Pos, MoveType, Actual)=0){ Set file position }
Then SetFilePos := 0 Else SetFilePos := 107; { File position error }
{$ELSE} { OTHER OS2 COMPILERS }
If (DosSetFilePtr(Handle, Pos, MoveType, Actual)=0){ Set file position }
Then SetFilePos := 0 Else SetFilePos := 107; { File position error }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_UNIX}
BEGIN
Actual := {$ifdef ver1_0}fdSeek{$else}fplseek{$endif}(Handle, Pos, MoveType);
If (Actual <> -1) Then SetFilePos := 0 Else { No position error }
SetFilePos := 107; { File position error }
END;
{$ENDIF}
{---------------------------------------------------------------------------}
{ FileRead -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct98 LdB }
{---------------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
XOR AX, AX; { Zero register }
LES DI, Actual; { Actual var address }
MOV ES:[DI], AX; { Zero actual var }
PUSH DS; { Save segment }
LDS DX, Buf; { Data destination }
MOV CX, Count; { Amount to read }
MOV BX, Handle; { Load file handle }
MOV AX, $3F00; { Load function id }
PUSH BP; { Store register }
INT $21; { Read from file }
POP BP; { Reload register }
POP DS; { Restore segment }
JC @@Exit4; { Check for error }
LES DI, Actual; { Actual var address }
MOV ES:[DI], AX; { Update bytes moved }
XOR AX, AX; { Return success }
@@Exit4:
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
BEGIN
Actual := System.Do_Read(LongInt(Handle),
LongInt(@Buf), Count); { Read data from file }
FileRead := InOutRes; { I/O status returned }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
BEGIN
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
Actual := _lread(Handle, Pointer(@Buf), Count); { Read from file }
If (Actual = Count) Then FileRead := 0 Else { No read error }
FileRead := 104; { File read error }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
If ReadFile(Handle, Buf, Count, DWord(Actual),
Nil) AND (Actual = Count) Then FileRead := 0 { No read error }
Else FileRead := 104; { File read error }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
BEGIN
If (DosRead(Handle, Buf, Count, Actual) = 0) AND { Read from file }
(Actual = Count) Then FileRead := 0 Else { No read error }
FileRead := 104; { File read error }
END;
{$ENDIF}
{$IFDEF OS_UNIX}
BEGIN
Actual := {$ifdef ver1_0}fdRead{$else} fpread{$endif}(Handle, Buf, Count);
if (Actual = Count) Then FileRead := 0 { No read error }
Else FileRead := 104; { File read error }
END;
{$ENDIF}
{---------------------------------------------------------------------------}
{ FileWrite -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct98 LdB }
{---------------------------------------------------------------------------}
FUNCTION FileWrite (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
{$IFDEF OS_DOS} { DOS/DPMI CODE }
{$IFDEF ASM_BP} { BP COMPATABLE ASM }
ASSEMBLER;
ASM
XOR AX, AX; { Zero register }
LES DI, Actual; { Actual var address }
MOV ES:[DI], AX; { Zero actual var }
PUSH DS; { Save segment }
LDS DX, Buf; { Data source buffer }
MOV CX, Count; { Amount to write }
MOV BX, Handle; { Load file handle }
MOV AX, $4000; { Load function id }
PUSH BP; { Store register }
INT $21; { Write to file }
POP BP; { Reload register }
POP DS; { Restore segment }
JC @@Exit5; { Check for error }
LES DI, Actual; { Actual var address }
MOV ES:[DI], AX; { Update bytes moved }
XOR AX, AX; { Write successful }
@@Exit5:
END;
{$ENDIF}
{$IFDEF ASM_FPC} { FPC COMPATABLE ASM }
BEGIN
Actual := System.Do_Write(LongInt(Handle),
LongInt(@Buf), Count); { Write data to file }
FileWrite := InOutRes; { I/O status returned }
END;
{$ENDIF}
{$ENDIF}
{$IFDEF OS_WINDOWS} { WIN/NT CODE }
BEGIN
{$IFDEF BIT_16} { 16 BIT WINDOWS CODE }
Actual := _lwrite(Handle, Pointer(@Buf), Count); { Write to file }
If (Actual = Count) Then FileWrite := 0 Else { No write error }
FileWrite := 105; { File write error }
{$ENDIF}
{$IFDEF BIT_32} { 32 BIT WINDOWS CODE }
If WriteFile(Handle, Buf, Count, DWord(Actual),
Nil) AND (Actual = Count) Then FileWrite := 0 { No write error }
Else FileWrite := 105; { File write error }
{$ENDIF}
END;
{$ENDIF}
{$IFDEF OS_OS2} { OS2 CODE }
BEGIN
If (DosWrite(Handle, Buf, Count, Actual) = 0) AND { Write to file }
(Actual = Count) Then FileWrite := 0 Else { No write error }
FileWrite := 105; { File write error }
END;
{$ENDIF}
{$IFDEF OS_UNIX}
BEGIN
Actual := {$ifdef ver1_0}fdWrite{$else}fpwrite{$endif}(Handle, Buf, Count);
If (Actual = Count) Then FileWrite := 0 Else { No write error }
FileWrite := 105; { File write error }
END;
{$ENDIF}
END.
{
$Log$
Revision 1.12 2003-11-12 22:31:17 marco
* linuxerror dependancy removed for 1.1
Revision 1.11 2003/10/01 16:20:27 marco
* baseunix fixes for 1.1
Revision 1.10 2002/10/13 20:52:09 hajny
* mistyping corrected
Revision 1.9 2002/10/12 19:39:00 hajny
* FPC/2 support
Revision 1.8 2002/09/22 19:42:22 hajny
+ FPC/2 support added
Revision 1.7 2002/09/07 15:06:36 peter
* old logs removed and tabs fixed
Revision 1.6 2002/06/04 11:12:41 marco
* Renamefest
}

7
fv/gadgets.pas
View File

@ -214,7 +214,7 @@ begin
ColourOfs := 2; { Set colour offset }
Inherited DrawBackGround; { Clear the backgound }
ColourOfs := HOfs; { Reset any offset }
WriteStr(-(RawSize.X-TextWidth(S)+1), 0, S, 2); { Write the string }
WriteStr(-(Size.X-TextWidth(S)), 0, S, 2); { Write the string }
END;
Function THeapView.Comma ( n : LongInt) : String;
@ -303,7 +303,10 @@ END;
END.
{
$Log$
Revision 1.5 2002-09-07 15:06:36 peter
Revision 1.6 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.5 2002/09/07 15:06:36 peter
* old logs removed and tabs fixed
}

836
fv/gfvgraph.pas
View File

@ -1,836 +0,0 @@
{ $Id$ }
{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********}
{ }
{ System independent GFV GRAPHICS UNIT }
{ }
{ Copyright (c) 1999, 2000 by Leon de Boer }
{ ldeboer@attglobal.net - primary e-mail address }
{ ldeboer@projectent.com.au - backup e-mail address }
{ }
{ This unit provides the interlink between the graphics }
{ used in GFV and the graphics API for the different }
{ operating systems. }
{ }
{****************[ THIS CODE IS FREEWARE ]*****************}
{ }
{ This sourcecode is released for the purpose to }
{ promote the pascal language on all platforms. You may }
{ redistribute it and/or modify with the following }
{ DISCLAIMER. }
{ }
{ This SOURCE CODE is distributed "AS IS" WITHOUT }
{ WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR }
{ ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED. }
{ }
{*****************[ SUPPORTED PLATFORMS ]******************}
{ 16 and 32 Bit compilers }
{ WINDOWS - Turbo Pascal 7.0 + (16 Bit) }
{ - Delphi 1.0+ (16 Bit) }
{ WIN95/NT - Delphi 2.0+ (32 Bit) }
{ - Virtual Pascal 2.0+ (32 Bit) }
{ - Speedsoft Sybil 2.0+ (32 Bit) }
{ - FPC 0.9912+ (32 Bit) }
{ OS2 - Virtual Pascal 1.0+ (32 Bit) }
{ - Speed Pascal 1.0+ (32 Bit) }
{ }
{*****************[ REVISION HISTORY ]*********************}
{ Version Date Fix }
{ ------- --------- ---------------------------------- }
{ 1.00 26 Nov 99 Unit started from relocated code }
{ originally from views.pas }
{ 1.01 21 May 00 GetMaxX and GetMaxY added. }
{ 1.02 05 Dec 00 Fixed DOS/DPMI implementation. }
{**********************************************************}
UNIT GFVGraph;
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}
{==== Compiler directives ===========================================}
{$IFNDEF PPC_FPC} { FPC doesn't support these switches }
{$F-} { Near far calls are okay }
{$A+} { Word Align Data }
{$B-} { Allow short circuit boolean evaluations }
{$O+} { This unit may be overlaid }
{$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
{$E+} { Emulation is on }
{$N-} { No 80x87 code generation }
{$ENDIF}
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}
{$IFDEF GRAPH_API} { GRAPH CODE }
USES Graph; { Standard unit }
{$ENDIF}
{***************************************************************************}
{ PUBLIC CONSTANTS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ STANDARD COLOUR CONSTANTS }
{---------------------------------------------------------------------------}
CONST
Black = 0; { Black }
Blue = 1; { Blue }
Green = 2; { Green }
Cyan = 3; { Cyan }
Red = 4; { Red }
Magenta = 5; { Magenta }
Brown = 6; { Brown }
LightGray = 7; { Light grey }
DarkGray = 8; { Dark grey }
LightBlue = 9; { Light blue }
LightGreen = 10; { Light green }
LightCyan = 11; { Light cyan }
LightRed = 12; { Light red }
LightMagenta = 13; { Light magenta }
Yellow = 14; { Yellow }
White = 15; { White }
{---------------------------------------------------------------------------}
{ WRITE MODE CONSTANTS }
{---------------------------------------------------------------------------}
CONST
NormalPut = 0; { Normal overwrite }
CopyPut = 0; { Normal put image }
AndPut = 1; { AND colour write }
OrPut = 2; { OR colour write }
XorPut = 3; { XOR colour write }
NotPut = 4; { NOT colour write }
{---------------------------------------------------------------------------}
{ CLIP CONTROL CONSTANTS }
{---------------------------------------------------------------------------}
CONST
ClipOn = True; { Clipping on }
ClipOff = False; { Clipping off }
{---------------------------------------------------------------------------}
{ VIDEO CARD DETECTION CONSTANTS }
{---------------------------------------------------------------------------}
CONST
Detect = 0; { Detect video }
{$IFDEF GRAPH_API} { DOS CODE ONLY }
{---------------------------------------------------------------------------}
{ DOS GRAPHICS SOLID FILL BAR AREA CONSTANT }
{---------------------------------------------------------------------------}
CONST
SolidFill = Graph.SolidFill;
LowAscii : boolean = true;
type
textrainfo = array[0..0] of word;
pextrainfo = ^textrainfo;
TSpVideoBuf = array [0..0] of pextrainfo;
PSpVideoBuf = ^TSpVideoBuf;
const
SpVideoBuf : PSpVideoBuf = nil;
{$ELSE not GRAPH_API }
CONST
SolidFill = 0;
{$ENDIF not GRAPH_API}
{***************************************************************************}
{ PUBLIC TYPE DEFINITIONS }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ ViewPortType RECORD DEFINITION }
{---------------------------------------------------------------------------}
TYPE
ViewPortType = PACKED RECORD
X1, Y1, X2, Y2: Integer; { Corners of viewport }
Clip : Boolean; { Clip status }
END;
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ GRAPHICS MODE CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-SetWriteMode-------------------------------------------------------
Sets the current write mode constant all subsequent draws etc. are
then via the set mode.
26Nov99 LdB
---------------------------------------------------------------------}
PROCEDURE SetWriteMode (Mode: Byte; TextMode: Boolean);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ VIEWPORT CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-GetViewSettings----------------------------------------------------
Returns the current viewport and clip parameters in the variable.
26Nov99 LdB
---------------------------------------------------------------------}
PROCEDURE GetViewSettings (Var CurrentViewPort: ViewPortType; TextMode: Boolean);
{-SetViewPort--------------------------------------------------------
Set the current viewport and clip parameters to that requested.
26Nov99 LdB
---------------------------------------------------------------------}
PROCEDURE SetViewPort (X1, Y1, X2, Y2: Integer; Clip, TextMode: Boolean);
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ GRAPHICS DEVICE CAPACITY ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-GetMaxX------------------------------------------------------------
Returns X coordinate of maximum value that can be entered in any
graphics routine, that is the actual screen width in pixels - 1.
21May2000 LdB
---------------------------------------------------------------------}
FUNCTION GetMaxX (TextMode: Boolean): Integer;
{-GetMaxY------------------------------------------------------------
Returns Y coordinate of maximum value that can be entered in any
graphics routine, that is the actual screen height in pixels - 1.
21May2000 LdB
---------------------------------------------------------------------}
FUNCTION GetMaxY (TextMode: Boolean): Integer;
PROCEDURE SetColor(Color: Word);
PROCEDURE SetFillStyle (Pattern: Word; Color: Word);
PROCEDURE Bar (X1, Y1, X2, Y2: Integer);
PROCEDURE Line(X1, Y1, X2, Y2: Integer);
PROCEDURE Rectangle(X1, Y1, X2, Y2: Integer);
PROCEDURE OutTextXY(X,Y: Integer; TextString: String);
{$IFDEF GRAPH_API}
procedure GraphUpdateScreen(Force: Boolean);
procedure SetExtraInfo(x,y,xi,yi : longint; color : word);
procedure SetupExtraInfo;
procedure FreeExtraInfo;
Const
{ Possible cursor types for video interface }
crHidden = 0;
crUnderLine = 1;
crBlock = 2;
crHalfBlock = 3;
EmptyVideoBufCell : pextrainfo = nil;
{ from video unit }
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
{ Position the cursor to the given position }
function GetCursorType: Word;
{ Return the cursor type: Hidden, UnderLine or Block }
procedure SetCursorType(NewType: Word);
{ Set the cursor to the given type }
{$ENDIF GRAPH_API}
{***************************************************************************}
{ INITIALIZED PUBLIC VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ INITIALIZED DOS/DPMI/WIN/NT/OS2 VARIABLES }
{---------------------------------------------------------------------------}
CONST
WriteMode : Byte = 0; { Current write mode }
SysScreenWidth : Integer = 640; { Default screen width }
SysScreenHeight: Integer = 480; { Default screen height}
{$ifdef USE_VIDEO_API}
SysFontWidth : Integer = 8; { System font width }
SysFontHeight : Integer = 16; { System font height }
TextScreenWidth : Integer = 80;
TextScreenHeight : Integer = 25;
{$endif USE_VIDEO_API}
{$ifdef DEBUG}
const
WriteDebugInfo : boolean = false;
{$endif DEBUG}
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{$ifdef USE_VIDEO_API}
USES video; { Standard unit }
{$ENDIF}
{***************************************************************************}
{ PRIVATE INITIALIZED VARIABLES }
{***************************************************************************}
{---------------------------------------------------------------------------}
{ DOS/DPMI/WIN/NT/OS2 INITIALIZED VARIABLES }
{---------------------------------------------------------------------------}
CONST
FillCol : Integer = 0;
Cxp : Integer = 0; { Current x position }
Cyp : Integer = 0; { Current y position }
ViewPort: ViewPortType = (X1:0; Y1:0; X2: 639;
Y2: 479; Clip: True); { Default viewport }
{***************************************************************************}
{ INTERFACE ROUTINES }
{***************************************************************************}
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ GRAPHICS MODE CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ SetWriteMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB }
{---------------------------------------------------------------------------}
PROCEDURE SetWriteMode (Mode: Byte; TextMode: Boolean);
BEGIN
{$IFDEF GRAPH_API} { GRAPH CODE }
If TextMode Then
WriteMode := Mode { Hold write mode }
Else Graph.SetWriteMode(Mode); { Call graph proc }
{$ELSE not GRAPH_API}
WriteMode := Mode; { Hold write mode }
{$ENDIF not GRAPH_API}
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ VIEW PORT CONTROL ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ GetViewSettings -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB }
{---------------------------------------------------------------------------}
PROCEDURE GetViewSettings (Var CurrentViewPort: ViewPortType; TextMode: Boolean);
{$IFDEF GRAPH_API}
VAR Ts: Graph.ViewPortType;
{$ENDIF GRAPH_API}
BEGIN
{$IFNDEF GRAPH_API}
CurrentViewPort := ViewPort; { Textmode viewport }
{$ELSE GRAPH_API}
If TextMode Then CurrentViewPort := ViewPort { Textmode viewport }
Else Begin
Graph.GetViewSettings(Ts); { Get graph settings }
CurrentViewPort.X1 := Ts.X1; { Transfer X1 }
CurrentViewPort.Y1 := Ts.Y1; { Transfer Y1 }
CurrentViewPort.X2 := Ts.X2; { Transfer X2 }
CurrentViewPort.Y2 := Ts.Y2; { Transfer Y2 }
CurrentViewPort.Clip := Ts.Clip; { Transfer clip mask }
End;
{$ENDIF GRAPH_API}
END;
{---------------------------------------------------------------------------}
{ SetViewPort -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB }
{---------------------------------------------------------------------------}
PROCEDURE SetViewPort (X1, Y1, X2, Y2: Integer; Clip, TextMode: Boolean);
BEGIN
{$IFDEF GRAPH_API}
If TextMode Then Begin { TEXT MODE GFV }
{$ENDIF GRAPH_API}
If (X1 < 0) Then X1 := 0; { X1 negative fix }
If (X1 >SysScreenWidth) Then
X1 := SysScreenWidth; { X1 off screen fix }
If (Y1 < 0) Then Y1 := 0; { Y1 negative fix }
If (Y1 > SysScreenHeight) Then
Y1 := SysScreenHeight; { Y1 off screen fix }
If (X2 < 0) Then X2 := 0; { X2 negative fix }
If (X2 > SysScreenWidth) Then
X2 := SysScreenWidth; { X2 off screen fix }
If (Y2 < 0) Then Y2 := 0; { Y2 negative fix }
If (Y2 > SysScreenHeight) Then
Y2 := SysScreenHeight; { Y2 off screen fix }
ViewPort.X1 := X1; { Set X1 port value }
ViewPort.Y1 := Y1; { Set Y1 port value }
ViewPort.X2 := X2; { Set X2 port value }
ViewPort.Y2 := Y2; { Set Y2 port value }
ViewPort.Clip := Clip; { Set port clip value }
{$ifdef DEBUG}
If WriteDebugInfo then
Writeln(stderr,'New ViewPort(',X1,',',Y1,',',X2,',',Y2,')');
{$endif DEBUG}
Cxp := X1; { Set current x pos }
Cyp := Y1; { Set current y pos }
{$IFDEF GRAPH_API}
End Else Begin { GRAPHICS MODE GFV }
Graph.SetViewPort(X1, Y1, X2, Y2, Clip); { Call graph proc }
X1:=X1 div SysFontWidth;
X2:=X2 div SysFontWidth;
Y1:=Y1 div SysFontHeight;
Y2:=Y2 div SysFontHeight;
If (X1 < 0) Then X1 := 0; { X1 negative fix }
If (X1 >SysScreenWidth) Then
X1 := SysScreenWidth; { X1 off screen fix }
If (Y1 < 0) Then Y1 := 0; { Y1 negative fix }
If (Y1 > SysScreenHeight) Then
Y1 := SysScreenHeight; { Y1 off screen fix }
If (X2 < 0) Then X2 := 0; { X2 negative fix }
If (X2 > SysScreenWidth) Then
X2 := SysScreenWidth; { X2 off screen fix }
If (Y2 < 0) Then Y2 := 0; { Y2 negative fix }
If (Y2 > SysScreenHeight) Then
Y2 := SysScreenHeight; { Y2 off screen fix }
ViewPort.X1 := X1; { Set X1 port value }
ViewPort.Y1 := Y1; { Set Y1 port value }
ViewPort.X2 := X2; { Set X2 port value }
ViewPort.Y2 := Y2; { Set Y2 port value }
ViewPort.Clip := Clip; { Set port clip value }
Cxp := X1; { Set current x pos }
Cyp := Y1; { Set current y pos }
End;
{$ENDIF GRAPH_API}
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ GRAPHICS DEVICE CAPACITY ROUTINES }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{---------------------------------------------------------------------------}
{ GetMaxX - Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetMaxX (TextMode: Boolean): Integer;
BEGIN
{$IFDEF GRAPH_API}
If TextMode Then
{$ENDIF GRAPH_API}
GetMaxX := SysScreenWidth-1 { Screen width }
{$IFDEF GRAPH_API}
Else GetMaxX := Graph.GetMaxX; { Call graph func }
{$ENDIF GRAPH_API}
END;
{---------------------------------------------------------------------------}
{ GetMaxY - Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Dec2000 LdB }
{---------------------------------------------------------------------------}
FUNCTION GetMaxY (TextMode: Boolean): Integer;
BEGIN
{$IFDEF GRAPH_API}
If TextMode Then
{$ENDIF GRAPH_API}
GetMaxY := SysScreenHeight-1 { Screen height }
{$IFDEF GRAPH_API}
Else GetMaxY := Graph.GetMaxY; { Call graph func }
{$ENDIF GRAPH_API}
END;
PROCEDURE SetColor(Color: Word);
BEGIN
{$IFDEF GRAPH_API}
Graph.SetColor(Color); { Call graph proc }
{$ENDIF GRAPH_API}
END;
PROCEDURE SetFillStyle (Pattern: Word; Color: Word);
BEGIN
{$IFDEF GRAPH_API}
Graph.SetFillStyle(Pattern, Color); { Call graph proc }
{$ENDIF GRAPH_API}
END;
PROCEDURE Bar (X1, Y1, X2, Y2: Integer);
BEGIN
{$IFDEF GRAPH_API}
Graph.Bar(X1, Y1, X2, Y2); { Call graph proc }
{$ENDIF GRAPH_API}
END;
PROCEDURE Line(X1, Y1, X2, Y2: Integer);
BEGIN
{$IFDEF GRAPH_API}
Graph.Line(X1, Y1, X2, Y2); { Call graph proc }
{$ENDIF GRAPH_API}
END;
PROCEDURE Rectangle(X1, Y1, X2, Y2: Integer);
BEGIN
{$IFDEF GRAPH_API}
Graph.Rectangle(X1, Y1, X2, Y2); { Call graph proc }
{$ENDIF GRAPH_API}
END;
PROCEDURE OutTextXY(X,Y: Integer; TextString: string);
{$IFDEF GRAPH_API}
var
i,j,xi,yj,xs,ys : longint;
Ts: Graph.ViewPortType;
Txs : TextSettingsType;
tw, th : integer;
color : word;
{$ENDIF GRAPH_API}
BEGIN
{$IFDEF GRAPH_API}
Graph.OutTextXY(X, Y, TextString); { Call graph proc }
if true then
begin
Graph.GetViewSettings(Ts);
Graph.GetTextSettings(Txs);
tw:=TextWidth(TextString);
th:=TextHeight(TextString);
case Txs.Horiz of
centertext : Xs:=(tw shr 1);
lefttext : Xs:=0;
righttext : Xs:=tw;
end;
case txs.vert of
centertext : Ys:=-(th shr 1);
bottomtext : Ys:=-th;
toptext : Ys:=0;
end;
x:=x-xs;
y:=y+ys;
For j:=0 to tw-1 do
For i:=0 to th-1 do
begin
xi:=x+i+Ts.x1;
yj:=y+j+Ts.y1;
Color:=GetPixel(xi,yj);
SetExtraInfo(xi div SysFontWidth,yj div SysFontHeight,
xi mod SysFontWidth,yj mod SysFontHeight, Color);
end;
end;
{$ENDIF GRAPH_API}
END;
{$IFDEF GRAPH_API}
{ from video unit }
Const
CursorX : longint = -1;
CursorY : longint = -1;
CursorType : byte = crHidden;
CursorIsVisible : boolean = false;
LineReversed = true;
LineNormal = false;
TYPE
TCursorInfo = array[0..7] of boolean;
CONST
DefaultCursors: Array[crUnderline..crHalfBlock] of TCursorInfo =
(
(LineNormal, LineNormal, LineNormal, LineNormal, LineNormal, LineNormal, LineNormal, LineReversed),
(LineReversed, LineReversed, LineReversed, LineReversed, LineReversed, LineReversed, LineReversed, LineReversed),
(LineNormal, LineNormal, LineNormal, LineNormal, LineReversed, LineReversed, LineReversed, LineReversed)
);
Procedure XorPutCursor;
var
j,YSCale : longint;
Ts: Graph.ViewPortType;
StoreColor : longint;
begin
if CursorType=crHidden then
exit;
Yscale:=(SysFontHeight+1) div 8;
Graph.GetViewSettings(Ts);
graph.SetWriteMode(graph.XORPut);
StoreColor:=Graph.GetColor;
Graph.SetColor(White);
if (CursorX*SysFontWidth>=Ts.X1) and (CursorX*SysFontWidth<Ts.X2) and
(CursorY*SysFontHeight>=Ts.Y1) and (CursorY*SysFontHeight<Ts.Y2) then
for j:=0 to SysFontHeight-1 do
begin
if DefaultCursors[CursorType][(j*8) div SysFontHeight] then
begin
Graph.MoveTo(CursorX*SysFontWidth-Ts.X1,CursorY*SysFontHeight+j-Ts.Y1);
Graph.LineRel(SysFontWidth-1,0);
end;
end;
Graph.SetColor(StoreColor);
graph.SetWriteMode(graph.CopyPut);
end;
Procedure HideCursor;
begin
If CursorIsVisible then
begin
XorPutCursor;
CursorIsVisible:=false;
end;
end;
Procedure ShowCursor;
begin
If not CursorIsVisible then
begin
XorPutCursor;
CursorIsVisible:=true;
end;
end;
{ Position the cursor to the given position }
procedure SetCursorPos(NewCursorX, NewCursorY: Word);
begin
HideCursor;
CursorX:=NewCursorX;
CursorY:=NewCursorY;
ShowCursor;
end;
{ Return the cursor type: Hidden, UnderLine or Block }
function GetCursorType: Word;
begin
GetCursorType:=CursorType;
end;
{ Set the cursor to the given type }
procedure SetCursorType(NewType: Word);
begin
HideCursor;
CursorType:=NewType;
ShowCursor;
end;
const
SetExtraInfoCalled : boolean = false;
procedure SetExtraInfo(x,y,xi,yi : longint; color : word);
var
i,k,l : longint;
extrainfo : pextrainfo;
begin
i:=y*TextScreenWidth+x;
if not assigned(SpVideoBuf^[i]) or (SpVideoBuf^[i]=EmptyVideoBufCell) then
begin
GetMem(SpVideoBuf^[i],SysFontHeight*SysFontWidth*Sizeof(word));
FillChar(SpVideoBuf^[i]^,SysFontHeight*SysFontWidth*Sizeof(word),#255);
end;
extrainfo:=SpVideoBuf^[i];
l:=yi*SysFontWidth + xi;
if l>=SysFontHeight*SysFontWidth then
RunError(219);
extrainfo^[l]:=color;
SetExtraInfoCalled:=true;
end;
procedure SetupExtraInfo;
begin
if not assigned(EmptyVideoBufCell) then
begin
GetMem(EmptyVideoBufCell,SysFontHeight*SysFontWidth*Sizeof(word));
FillChar(EmptyVideoBufCell^,SysFontHeight*SysFontWidth*Sizeof(word),#255);
end;
end;
procedure FreeExtraInfo;
var
i : longint;
begin
HideCursor;
if assigned(SpVideoBuf) then
begin
for i:=0 to (TextScreenWidth+1)*(TextScreenHeight+1) - 1 do
if assigned(SpVideoBuf^[i]) and (SpVideoBuf^[i]<>EmptyVideoBufCell) then
FreeMem(SpVideoBuf^[i],SysFontHeight*SysFontWidth*Sizeof(word));
if assigned(EmptyVideoBufCell) then
FreeMem(EmptyVideoBufCell,SysFontHeight*SysFontWidth*Sizeof(word));
FreeMem(SpVideoBuf,sizeof(pextrainfo)*(TextScreenWidth+1)*(TextScreenHeight+1));
SpVideoBuf:=nil;
end;
end;
{define Use_ONLY_COLOR}
procedure GraphUpdateScreen(Force: Boolean);
var
smallforce : boolean;
i,x,y : longint;
xi,yi,k,l : longint;
ch : char;
attr : byte;
color : word;
SavedColor : longint;
{$ifndef Use_ONLY_COLOR}
SavedBkColor,CurBkColor : longint;
{$endif not Use_ONLY_COLOR}
CurColor : longint;
NextColor,NextBkColor : longint;
StoreFillSettings: FillSettingsType;
Ts: Graph.ViewPortType;
{$ifdef debug}
ChangedCount, SpecialCount : longint;
{$endif debug}
begin
{$ifdef USE_VIDEO_API}
if force or SetExtraInfoCalled then
smallforce:=true
else
begin
asm
movl VideoBuf,%esi
movl OldVideoBuf,%edi
movl VideoBufSize,%ecx
shrl $2,%ecx
repe
cmpsl
orl %ecx,%ecx
jz .Lno_update
movb $1,smallforce
.Lno_update:
end;
end;
if SmallForce then
begin
{$ifdef debug}
SpecialCount:=0;
ChangedCount:=0;
{$endif debug}
SetExtraInfoCalled:=false;
SavedColor:=Graph.GetColor;
{$ifndef Use_ONLY_COLOR}
SavedBkColor:=Graph.GetBkColor;
CurBkColor:=SavedBkColor;
{$endif not Use_ONLY_COLOR}
CurColor:=SavedColor;
Graph.GetViewSettings(Ts);
Graph.SetViewPort(0,0,Graph.GetMaxX,Graph.GetMaxY,false);
Graph.GetFillSettings(StoreFillSettings);
{$ifdef Use_ONLY_COLOR}
Graph.SetFillStyle(SolidFill,0);
{$else not Use_ONLY_COLOR}
Graph.SetFillStyle(EmptyFill,0);
{$endif not Use_ONLY_COLOR}
Graph.SetWriteMode(CopyPut);
Graph.SetTextJustify(LeftText,TopText);
for y := 0 to TextScreenHeight - 1 do
begin
for x := 0 to TextScreenWidth - 1 do
begin
i:=y*TextScreenWidth+x;
if (OldVideoBuf^[i]<>VideoBuf^[i]) or
(assigned(SpVideoBuf^[i]) and (SpVideoBuf^[i]<>EmptyVideoBufCell)) then
begin
ch:=chr(VideoBuf^[i] and $ff);
if ch<>#0 then
begin
{$ifdef debug}
Inc(ChangedCount);
{$endif debug}
if (SpVideoBuf^[i]=EmptyVideoBufCell) then
SpVideoBuf^[i]:=nil;
Attr:=VideoBuf^[i] shr 8;
NextColor:=Attr and $f;
NextBkColor:=(Attr and $70) shr 4;
{$ifndef Use_ONLY_COLOR}
if NextBkColor<>CurBkColor then
begin
Graph.SetBkColor(NextBkColor);
CurBkColor:=NextBkColor;
end;
{$else Use_ONLY_COLOR}
if NextBkColor<>CurColor then
begin
Graph.SetColor(NextBkColor);
CurColor:=NextBkColor;
end;
{$endif Use_ONLY_COLOR}
if (x=CursorX) and (y=CursorY) then
HideCursor;
Graph.Bar(x*SysFontWidth,y*SysFontHeight,(x+1)*SysFontWidth-1,(y+1)*SysFontHeight-1);
if assigned(SpVideoBuf^[i]) then
begin
{$ifdef debug}
Inc(SpecialCount);
{$endif debug}
For yi:=0 to SysFontHeight-1 do
For xi:=0 to SysFontWidth-1 do
begin
l:=yi*SysFontWidth + xi;
color:=SpVideoBuf^[i]^[l];
if color<>$ffff then
Graph.PutPixel(x*SysfontWidth+xi,y*SysFontHeight+yi,color);
end;
end;
if NextColor<>CurColor then
begin
Graph.SetColor(NextColor);
CurColor:=NextColor;
end;
{ SetBkColor does change the palette index 0 entry...
which leads to troubles if we want to write in dark }
(* if (CurColor=0) and (ch<>' ') and assigned(SpVideoBuf^[i]) then
begin
Graph.SetBkColor(0);
CurBkColor:=0;
end; *)
if ch<>' ' then
Graph.OutTextXY(x*SysFontWidth,y*SysFontHeight+2,ch);
if (x=CursorX) and (y=CursorY) then
ShowCursor;
end;
OldVideoBuf^[i]:=VideoBuf^[i];
if assigned(SpVideoBuf^[i]) then
begin
if (SpVideoBuf^[i]=EmptyVideoBufCell) then
SpVideoBuf^[i]:=nil
else
begin
FreeMem(SpVideoBuf^[i],SysFontHeight*SysFontWidth*sizeof(word));
SpVideoBuf^[i]:=EmptyVideoBufCell;
end;
end;
end;
end;
end;
Graph.SetFillStyle(StoreFillSettings.pattern,StoreFillSettings.color);
Graph.SetColor(SavedColor);
{$ifndef Use_ONLY_COLOR}
Graph.SetBkColor(SavedBkColor);
{$endif not Use_ONLY_COLOR}
Graph.SetViewPort(TS.X1,Ts.Y1,ts.X2,ts.Y2,ts.Clip);
end;
{$else not USE_VIDEO_API}
RunError(219);
{$endif USE_VIDEO_API}
end;
{$ENDIF GRAPH_API}
END.
{
$Log$
Revision 1.18 2002-09-07 15:06:36 peter
* old logs removed and tabs fixed
Revision 1.17 2002/08/22 13:40:49 pierre
* several graphic mode improovements
Revision 1.16 2002/06/06 06:41:14 pierre
+ Cursor functions for UseFixedFont case
Revision 1.15 2002/05/31 12:37:47 pierre
* try to enhance graph mode
Revision 1.14 2002/05/29 22:15:57 pierre
* fix build failure in non graph mode
Revision 1.13 2002/05/29 19:35:31 pierre
* fix GraphUpdateScreen procedure
Revision 1.12 2002/05/28 19:42:32 pierre
* fix non graphic mode compilation
Revision 1.11 2002/05/28 19:13:44 pierre
+ GraphUpdateScreen function
}

149
fv/menus.pas
View File

@ -94,7 +94,6 @@ USES
{$ENDIF}
{$ENDIF}
GFVGraph, { GFV standard unit }
Objects, Drivers, Views; { GFV standard units }
{***************************************************************************}
@ -408,16 +407,12 @@ CONST
{---------------------------------------------------------------------------}
{ INITIALIZED PUBLIC VARIABLES }
{---------------------------------------------------------------------------}
CONST
AdvancedMenus: Boolean = False; { Advanced menus }
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
{$ifndef GRAPH_API}
USES
Video;
{$endif not GRAPH_API}
CONST
SubMenuChar : array[boolean] of char = ('>',#16);
@ -496,8 +491,8 @@ VAR AutoSelect: Boolean; Action: MenuAction; Ch: Char; Res: Word; R: TRect;
PROCEDURE TrackMouse;
VAR Mouse: TPoint; R: TRect;
BEGIN
Mouse.X := E.Where.X - RawOrigin.X; { Local x position }
Mouse.Y := E.Where.Y - RawoRigin.Y; { Local y position }
Mouse.X := E.Where.X - Origin.X; { Local x position }
Mouse.Y := E.Where.Y - oRigin.Y; { Local y position }
Current := Menu^.Items; { Start with current }
While (Current <> Nil) Do Begin
GetItemRectX(Current, R); { Get item rectangle }
@ -539,8 +534,8 @@ VAR AutoSelect: Boolean; Action: MenuAction; Ch: Char; Res: Word; R: TRect;
MouseInOwner := False; { Preset false }
If (ParentMenu <> Nil) AND (ParentMenu^.Size.Y = 1)
Then Begin { Valid parent menu }
Mouse.X := E.Where.X - ParentMenu^.RawOrigin.X;{ Local x position }
Mouse.Y := E.Where.Y - ParentMenu^.RawOrigin.Y;{ Local y position }
Mouse.X := E.Where.X - ParentMenu^.Origin.X;{ Local x position }
Mouse.Y := E.Where.Y - ParentMenu^.Origin.Y;{ Local y position }
ParentMenu^.GetItemRectX(ParentMenu^.Current,R);{ Get item rect }
MouseInOwner := R.Contains(Mouse); { Return result }
End;
@ -666,8 +661,8 @@ BEGIN
If (E.What AND (evMouseDown+evMouseMove) <> 0)
Then PutEvent(E); { Put event on queue }
GetItemRectX(Current, R); { Get area of item }
R.A.X := R.A.X DIV FontWidth + Origin.X; { Left start point }
R.A.Y := R.B.Y DIV FontHeight + Origin.Y;{ Top start point }
R.A.X := R.A.X + Origin.X; { Left start point }
R.A.Y := R.B.Y + Origin.Y;{ Top start point }
R.B.X := Owner^.Size.X; { X screen area left }
R.B.Y := Owner^.Size.Y; { Y screen area left }
Target := TopMenu^.NewSubView(R, SubMenu,
@ -896,10 +891,6 @@ END;
PROCEDURE TMenuView.GetItemRect (Item: PMenuItem; Var R: TRect);
BEGIN
GetItemRectX(Item,R);
R.A.X:=R.A.X div SysFontWidth;
R.A.Y:=R.A.Y div SysFontHeight;
R.B.X:=R.B.X div SysFontWidth;
R.B.Y:=R.B.Y div SysFontHeight;
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
@ -954,13 +945,8 @@ BEGIN
End;
MoveCStr(B, ' '+P^.Name^+' ', Color); { Name to buffer }
WriteBuf(I, 0, J, 1, B); { Write the string }
K := I*FontWidth; { X start position }
K := I; { X start position }
L := K + CTextWidth(' '+P^.Name^+' '); { X end position }
If AdvancedMenus Then Begin
GraphLine(K, 0, L, 0, White); { Redraw top line }
GraphLine(K, FontHeight-1, L,
FontHeight-1, DarkGray); { Redraw lower line }
End;
End;
Inc(I, J); { Advance position }
End;
@ -1001,8 +987,6 @@ BEGIN
P := P^.Next; { Next item }
End;
End;
If AdvancedMenus Then BiColorRectangle(0, 0,
RawSize.X, RawSize.Y, White, DarkGray, False); { Draw 3d effect }
END;
{--TMenuBar-----------------------------------------------------------------}
@ -1012,10 +996,10 @@ PROCEDURE TMenuBar.GetItemRectX (Item: PMenuItem; Var R: TRect);
VAR I: Integer; P: PMenuItem;
BEGIN
I := 0; { Preset to zero }
R.Assign(0, 0, 0, FontHeight); { Initial rect size }
R.Assign(0, 0, 0, 1); { Initial rect size }
P := Menu^.Items; { First item }
While (P <> Nil) Do Begin { While valid item }
R.A.X := I*FontWidth; { Move area along }
R.A.X := I; { Move area along }
If (P^.Name <> Nil) Then Begin { Valid name }
R.B.X := R.A.X+CTextWidth(' ' + P^.Name^ + ' ');{ Add text width }
I := I + CStrLen(P^.Name^) + 2; { Add item length }
@ -1052,7 +1036,7 @@ BEGIN
P := P^.Next; { Move to next item }
End;
End;
W := 5 + (W DIV FontWidth); { Longest text width }
W := 5 + W; { Longest text width }
R.Copy(Bounds); { Copy the bounds }
If (R.A.X + W < R.B.X) Then R.B.X := R.A.X + W { Shorten if possible }
Else R.A.X := R.B.X - W; { Insufficent space }
@ -1061,9 +1045,7 @@ BEGIN
Else R.A.Y := R.B.Y - H; { Insufficent height }
Inherited Init(R); { Call ancestor }
State := State OR sfShadow; { Set shadow state }
Options := Options OR ofPreProcess; { View pre processes }
if TextModeGFV then
Options := Options OR ofFramed;
Options := Options OR ofFramed or ofPreProcess; { View pre processes }
Menu := AMenu; { Hold menu }
ParentMenu := AParentMenu; { Hold parent }
END;
@ -1095,12 +1077,9 @@ BEGIN
CSelect := GetColor($0604); { Selected colour }
CDisabled := GetColor($0202); { Disabled colour }
CSelectDisabled := GetColor($0505); { Selected, but disabled }
If TextModeGFV then
Begin
Color := CNormal; { Normal colour }
CreateBorder(UpperLine);
WriteBuf(0, 0, Size.X, 1, B); { Write the line }
End;
Color := CNormal; { Normal colour }
CreateBorder(UpperLine);
WriteBuf(0, 0, Size.X, 1, B); { Write the line }
Y := 1;
If (Menu <> Nil) Then Begin { We have a menu }
P := Menu^.Items; { Start on first }
@ -1116,96 +1095,47 @@ BEGIN
end
else
If (P = Current) Then Color := CSelect; { Select colour }
If TextModeGFV or UseFixedFont then
Begin
If Not TextModeGFV then
MoveChar(B, ' ', Color, Size.X); { Clear buffer }
If TextModeGFV then
CreateBorder(NormalLine);
Index:=2;
End
Else
Begin
MoveChar(B, ' ', Color, Size.X-4); { Clear buffer }
Index:=0;
End;
CreateBorder(NormalLine);
Index:=2;
S := ' ' + P^.Name^ + ' '; { Menu string }
MoveCStr(B[Index], S, Color); { Transfer string }
if P^.Command = 0 then
MoveChar(B[Size.X - 4],SubMenuChar[LowAscii],
Byte(Color), 1) else
If (P^.Command <> 0) AND(P^.Param <> Nil)
Then Begin
if TextModeGFV or UseFixedFont then
MoveCStr(B[Size.X - 3 - Length(P^.Param^)], P^.Param^, Color) { Add param chars }
else
If (P^.Command <> 0) AND(P^.Param <> Nil) Then
Begin
MoveCStr(B[Size.X - 3 - Length(P^.Param^)], P^.Param^, Color); { Add param chars }
S := S + ' - ' + P^.Param^; { Add to string }
End;
If (OldItem = Nil) OR (OldItem = P) OR
(Current = P) Then Begin { We need to fix draw }
If TextModeGFV or UseFixedFont then
Begin
if TextModeGFV then
WriteBuf(0, Y, Size.X, 1, B) { Write the whole line }
else
WriteBuf(1, Y, Size.X-2, 1, B[1]);
end
Else
WriteBuf(2, Y, CStrLen(S), 1, B); { Write the line }
(Current = P) Then
Begin { We need to fix draw }
WriteBuf(0, Y, Size.X, 1, B); { Write the whole line }
If (P = Current) Then Begin { Selected item }
Tx := 2 * FontWidth; { X offset }
Ty := Y * FontHeight; { Y offset }
BicolorRectangle(Tx, Ty, Tx + CTextWidth(S)
- 1, Ty + FontHeight - 1, White,
DarkGray, False); { Draw higlight box }
Tx := 2; { X offset }
Ty := Y; { Y offset }
End;
End;
End Else Begin { no text NewLine }
Color := CNormal; { Normal colour }
If TextModeGFV then
Begin
CreateBorder(SeparationLine);
WriteBuf(0, Y, Size.X, 1, B); { Write the line }
End;
CreateBorder(SeparationLine);
WriteBuf(0, Y, Size.X, 1, B); { Write the line }
End;
Inc(Y); { Next line down }
P := P^.Next; { fetch next item }
End;
End;
If TextModeGFV then
Begin
Color := CNormal; { Normal colour }
CreateBorder(LowerLine);
WriteBuf(0, Size.Y-1, Size.X, 1, B); { Write the line }
End;
Color := CNormal; { Normal colour }
CreateBorder(LowerLine);
WriteBuf(0, Size.Y-1, Size.X, 1, B); { Write the line }
END;
{--TMenuBox-----------------------------------------------------------------}
{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB }
{---------------------------------------------------------------------------}
PROCEDURE TMenuBox.DrawBackGround;
VAR X, Y, Y2: Integer; P : PMenuItem;
BEGIN
Y2 := FontHeight DIV 2; { Intra offset }
Y := FontHeight; { Initial position }
X := 3*FontWidth; { 2 offset }
Inherited DrawBackGround; { Call ancestor }
If (Menu <> Nil) Then Begin { We have a menu }
P := Menu^.Items; { Start on first }
While (P <> Nil) Do Begin
If (P^.Name = Nil) Then { Item has no string }
BiColorRectangle(X, Y+Y2, RawSize.X-X,
Y+Y2+1, White, DarkGray, True); { Draw 3d line effect }
Inc(Y, FontHeight); { Down one line }
P := P^.Next; { Next item now }
End;
End;
BiColorRectangle(3, 3, RawSize.X-3, RawSize.Y-3,
White, DarkGray, False); { Draw 3d effect }
BiColorRectangle(5, 5, RawSize.X-5, RawSize.Y-5,
White, DarkGray, True); { Draw 3d effect }
BiColorRectangle(0, 0, RawSize.X, RawSize.Y,
White, DarkGray, False); { Draw 3d effect }
END;
{--TMenuBox-----------------------------------------------------------------}
@ -1214,14 +1144,14 @@ END;
PROCEDURE TMenuBox.GetItemRectX (Item: PMenuItem; Var R: TRect);
VAR X, Y: Integer; P: PMenuItem;
BEGIN
Y := FontHeight; { Initial y position }
Y := 1; { Initial y position }
P := Menu^.Items; { Initial item }
While (P <> Item) Do Begin { Valid item }
Inc(Y, FontHeight); { Inc position }
Inc(Y); { Inc position }
P := P^.Next; { Next item }
End;
X := 2 * FontWidth; { Left/Right margin }
R.Assign(X, Y, RawSize.X - X, Y + FontHeight); { Assign area }
X := 2; { Left/Right margin }
R.Assign(X, Y, Size.X - X, Y + 1); { Assign area }
END;
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
@ -1469,7 +1399,7 @@ VAR Mouse: TPoint; T, Tt: PStatusItem;
VAR X, Xi: Word; T: PStatusItem;
BEGIN
ItemMouseIsIn := Nil; { Preset fail }
If (Mouse.Y < 0) OR (Mouse.Y > FontHeight) { Outside view height }
If (Mouse.Y < 0) OR (Mouse.Y > 1) { Outside view height }
Then Exit; { Not in view exit }
X := 0; { Zero x position }
T := Items; { Start at first item }
@ -1493,8 +1423,8 @@ BEGIN
evMouseDown: Begin
T := Nil; { Preset ptr to nil }
Repeat
Mouse.X := Event.Where.X - RawOrigin.X; { Local x position }
Mouse.Y := Event.Where.Y - RawOrigin.Y; { Local y position }
Mouse.X := Event.Where.X - Origin.X; { Local x position }
Mouse.Y := Event.Where.Y - Origin.Y; { Local y position }
Tt := ItemMouseIsIn; { Find selected item }
If (T <> Tt) Then { Item has changed }
DrawSelect(Tt); { Draw new item }
@ -1587,8 +1517,6 @@ BEGIN
I := I + Length(HintBuf); { Hint length }
End;
WriteLine(0, 0, I, 1, B); { Write the buffer }
If AdvancedMenus Then BicolorRectangle(0, 0,
RawSize.X, RawSize.Y, White, DarkGray, False); { Add 3d effect }
END;
{***************************************************************************}
@ -1759,7 +1687,10 @@ END;
END.
{
$Log$
Revision 1.18 2004-11-03 12:09:08 peter
Revision 1.19 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.18 2004/11/03 12:09:08 peter
* textwidth doesn't support ~ anymore, added CTextWidth with ~ support
Revision 1.17 2004/11/02 23:53:19 peter

27
fv/platform.inc
View File

@ -152,14 +152,6 @@ FOR FPC THESE ARE THE TRANSLATIONS
{$DEFINE BP_VMTLink}
{$DEFINE CPU86}
{---------------------------------------------------------------------------}
{ BORLAND 16 BIT DPMI changes protected mode - Updated 27Aug98 LdB }
{---------------------------------------------------------------------------}
{$IFDEF DPMI}
{$UNDEF PROC_Real}
{$DEFINE PROC_Protected}
{$ENDIF}
{---------------------------------------------------------------------------}
{ FPC 32 BIT COMPILER changes ASM, 32 bits etc - Updated 27Aug98 LdB }
{---------------------------------------------------------------------------}
@ -174,20 +166,9 @@ FOR FPC THESE ARE THE TRANSLATIONS
{$DEFINE ASM_FPC}
{$UNDEF BP_VMTLink}
{$DEFINE Use_API}
{$DEFINE Use_Video_API}
{$DEFINE NO_WINDOW}
{$ENDIF}
{$IFDEF NoAPI}
{$UNDEF Use_API}
{$UNDEF Use_Video_API}
{$UNDEF NO_WINDOW}
{$ENDIF UseAPI}
{$ifdef GRAPH_API}
{undef Use_Video_API}
{$endif GRAPH_API}
{---------------------------------------------------------------------------}
{ FPC LINUX COMPILER changes operating system - Updated 27Aug98 LdB }
{ Note: Other linux compilers would need to change other details }
@ -301,7 +282,8 @@ FOR FPC THESE ARE THE TRANSLATIONS
{$DEFINE PPC_DELPHI3}
{$DEFINE PPC_DELPHI4}
{$DEFINE PPC_DELPHI5}
{$UNDEF BP_VMTLink}
{$UNDEF BP_VMTLink
}
{$ENDIF}
{---------------------------------------------------------------------------}
@ -410,7 +392,10 @@ FOR FPC THESE ARE THE TRANSLATIONS
{
$Log$
Revision 1.11 2004-02-06 20:59:29 jonas
Revision 1.12 2004-11-03 20:33:05 peter
* removed unnecesasry graphfv stuff
Revision 1.11 2004/02/06 20:59:29 jonas
+ darwin support
Revision 1.10 2002/09/07 15:06:38 peter

1331
fv/views.pas
View File

File diff suppressed because it is too large Load Diff

836
fv/win32gr.pas
View File

@ -1,836 +0,0 @@
{
$Id$
Copyright (c) 2002 by Pierre Muller
This unit implements an the hooks needed for the win32 graph unit.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program 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 General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit win32gr;
interface
procedure SetGraphHooks;
procedure UnsetGraphHooks;
implementation
uses
windows,
drivers,
graph;
var
InputHandle : Handle;
StoredControlKeyState : longint;
lastir : INPUT_RECORD;
const
StoredChar : boolean = false;
const
KeyToAsciiCode : array [0..255] of char =
(
{ 00 } #0,
{ 01 VK_LBUTTON } #0,
{ 02 VK_RBUTTON } #0,
{ 03 VK_CANCEL } #0,
{ 04 VK_MBUTTON } #0,
{ 05 unassigned } #0,
{ 06 unassigned } #0,
{ 07 unassigned } #0,
{ 08 VK_BACK } #8,
{ 09 VK_TAB } #9,
{ 0A unassigned } #0,
{ 0B unassigned } #0,
{ 0C VK_CLEAR ?? } #0,
{ 0D VK_RETURN } #13,
{ 0E unassigned } #0,
{ 0F unassigned } #0,
{ 10 VK_SHIFT } #0,
{ 11 VK_CONTROL } #0,
{ 12 VK_MENU (Alt key) } #0,
{ 13 VK_PAUSE } #0,
{ 14 VK_CAPITAL (Caps Lock) } #0,
{ 15 Reserved for Kanji systems} #0,
{ 16 Reserved for Kanji systems} #0,
{ 17 Reserved for Kanji systems} #0,
{ 18 Reserved for Kanji systems} #0,
{ 19 Reserved for Kanji systems} #0,
{ 1A unassigned } #0,
{ 1B VK_ESCAPE } #27,
{ 1C Reserved for Kanji systems} #0,
{ 1D Reserved for Kanji systems} #0,
{ 1E Reserved for Kanji systems} #0,
{ 1F Reserved for Kanji systems} #0,
{ 20 VK_SPACE} ' ',
{ 21 VK_PRIOR (PgUp) } #0,
{ 22 VK_NEXT (PgDown) } #0,
{ 23 VK_END } #0,
{ 24 VK_HOME } #0,
{ 25 VK_LEFT } #0,
{ 26 VK_UP } #0,
{ 27 VK_RIGHT } #0,
{ 28 VK_DOWN } #0,
{ 29 VK_SELECT ??? } #0,
{ 2A OEM specific !! } #0,
{ 2B VK_EXECUTE } #0,
{ 2C VK_SNAPSHOT } #0,
{ 2D VK_INSERT } #0,
{ 2E VK_DELETE } #0,
{ 2F VK_HELP } #0,
{ 30 VK_0 '0' } '0',
{ 31 VK_1 '1' } '1',
{ 32 VK_2 '2' } '2',
{ 33 VK_3 '3' } '3',
{ 34 VK_4 '4' } '4',
{ 35 VK_5 '5' } '5',
{ 36 VK_6 '6' } '6',
{ 37 VK_7 '7' } '7',
{ 38 VK_8 '8' } '8',
{ 39 VK_9 '9' } '9',
{ 3A unassigned } #0,
{ 3B unassigned } #0,
{ 3C unassigned } #0,
{ 3D unassigned } #0,
{ 3E unassigned } #0,
{ 3F unassigned } #0,
{ 40 unassigned } #0,
{ 41 VK_A 'A' } 'A',
{ 42 VK_B 'B' } 'B',
{ 43 VK_C 'C' } 'C',
{ 44 VK_D 'D' } 'D',
{ 45 VK_E 'E' } 'E',
{ 46 VK_F 'F' } 'F',
{ 47 VK_G 'G' } 'G',
{ 48 VK_H 'H' } 'H',
{ 49 VK_I 'I' } 'I',
{ 4A VK_J 'J' } 'J',
{ 4B VK_K 'K' } 'K',
{ 4C VK_L 'L' } 'L',
{ 4D VK_M 'M' } 'M',
{ 4E VK_N 'N' } 'N',
{ 4F VK_O 'O' } 'O',
{ 50 VK_P 'P' } 'P',
{ 51 VK_Q 'Q' } 'Q',
{ 52 VK_R 'R' } 'R',
{ 53 VK_S 'S' } 'S',
{ 54 VK_T 'T' } 'T',
{ 55 VK_U 'U' } 'U',
{ 56 VK_V 'V' } 'V',
{ 57 VK_W 'W' } 'W',
{ 58 VK_X 'X' } 'X',
{ 59 VK_Y 'Y' } 'Y',
{ 5A VK_Z 'Z' } 'Z',
{ 5B unassigned } #0,
{ 5C unassigned } #0,
{ 5D unassigned } #0,
{ 5E unassigned } #0,
{ 5F unassigned } #0,
{ 60 VK_NUMPAD0 NumKeyPad '0' } '0',
{ 61 VK_NUMPAD1 NumKeyPad '1' } '1',
{ 62 VK_NUMPAD2 NumKeyPad '2' } '2',
{ 63 VK_NUMPAD3 NumKeyPad '3' } '3',
{ 64 VK_NUMPAD4 NumKeyPad '4' } '4',
{ 65 VK_NUMPAD5 NumKeyPad '5' } '5',
{ 66 VK_NUMPAD6 NumKeyPad '6' } '6',
{ 67 VK_NUMPAD7 NumKeyPad '7' } '7',
{ 68 VK_NUMPAD8 NumKeyPad '8' } '8',
{ 69 VK_NUMPAD9 NumKeyPad '9' } '9',
{ 6A VK_MULTIPLY } #0,
{ 6B VK_ADD } #0,
{ 6C VK_SEPARATOR } #0,
{ 6D VK_SUBSTRACT } #0,
{ 6E VK_DECIMAL } #0,
{ 6F VK_DIVIDE } #0,
{ 70 VK_F1 'F1' } #0,
{ 71 VK_F2 'F2' } #0,
{ 72 VK_F3 'F3' } #0,
{ 73 VK_F4 'F4' } #0,
{ 74 VK_F5 'F5' } #0,
{ 75 VK_F6 'F6' } #0,
{ 76 VK_F7 'F7' } #0,
{ 77 VK_F8 'F8' } #0,
{ 78 VK_F9 'F9' } #0,
{ 79 VK_F10 'F10' } #0,
{ 7A VK_F11 'F11' } #0,
{ 7B VK_F12 'F12' } #0,
{ 7C VK_F13 } #0,
{ 7D VK_F14 } #0,
{ 7E VK_F15 } #0,
{ 7F VK_F16 } #0,
{ 80 VK_F17 } #0,
{ 81 VK_F18 } #0,
{ 82 VK_F19 } #0,
{ 83 VK_F20 } #0,
{ 84 VK_F21 } #0,
{ 85 VK_F22 } #0,
{ 86 VK_F23 } #0,
{ 87 VK_F24 } #0,
{ 88 unassigned } #0,
{ 89 VK_NUMLOCK } #0,
{ 8A VK_SCROLL } #0,
{ 8B unassigned } #0,
{ 8C unassigned } #0,
{ 8D unassigned } #0,
{ 8E unassigned } #0,
{ 8F unassigned } #0,
{ 90 unassigned } #0,
{ 91 unassigned } #0,
{ 92 unassigned } #0,
{ 93 unassigned } #0,
{ 94 unassigned } #0,
{ 95 unassigned } #0,
{ 96 unassigned } #0,
{ 97 unassigned } #0,
{ 98 unassigned } #0,
{ 99 unassigned } #0,
{ 9A unassigned } #0,
{ 9B unassigned } #0,
{ 9C unassigned } #0,
{ 9D unassigned } #0,
{ 9E unassigned } #0,
{ 9F unassigned } #0,
{ A0 unassigned } #0,
{ A1 unassigned } #0,
{ A2 unassigned } #0,
{ A3 unassigned } #0,
{ A4 unassigned } #0,
{ A5 unassigned } #0,
{ A6 unassigned } #0,
{ A7 unassigned } #0,
{ A8 unassigned } #0,
{ A9 unassigned } #0,
{ AA unassigned } #0,
{ AB unassigned } #0,
{ AC unassigned } #0,
{ AD unassigned } #0,
{ AE unassigned } #0,
{ AF unassigned } #0,
{ B0 unassigned } #0,
{ B1 unassigned } #0,
{ B2 unassigned } #0,
{ B3 unassigned } #0,
{ B4 unassigned } #0,
{ B5 unassigned } #0,
{ B6 unassigned } #0,
{ B7 unassigned } #0,
{ B8 unassigned } #0,
{ B9 unassigned } #0,
{ BA OEM specific } #0,
{ BB OEM specific } #0,
{ BC OEM specific } #0,
{ BD OEM specific } #0,
{ BE OEM specific } #0,
{ BF OEM specific } #0,
{ C0 OEM specific } #0,
{ C1 unassigned } #0,
{ C2 unassigned } #0,
{ C3 unassigned } #0,
{ C4 unassigned } #0,
{ C5 unassigned } #0,
{ C6 unassigned } #0,
{ C7 unassigned } #0,
{ C8 unassigned } #0,
{ C9 unassigned } #0,
{ CA unassigned } #0,
{ CB unassigned } #0,
{ CC unassigned } #0,
{ CD unassigned } #0,
{ CE unassigned } #0,
{ CF unassigned } #0,
{ D0 unassigned } #0,
{ D1 unassigned } #0,
{ D2 unassigned } #0,
{ D3 unassigned } #0,
{ D4 unassigned } #0,
{ D5 unassigned } #0,
{ D6 unassigned } #0,
{ D7 unassigned } #0,
{ D8 unassigned } #0,
{ D9 unassigned } #0,
{ DA unassigned } #0,
{ DB OEM specific } #0,
{ DC OEM specific } #0,
{ DD OEM specific } #0,
{ DE OEM specific } #0,
{ DF OEM specific } #0,
{ E0 OEM specific } #0,
{ E1 OEM specific } #0,
{ E2 OEM specific } #0,
{ E3 OEM specific } #0,
{ E4 OEM specific } #0,
{ E5 unassigned } #0,
{ E6 OEM specific } #0,
{ E7 unassigned } #0,
{ E8 unassigned } #0,
{ E9 OEM specific } #0,
{ EA OEM specific } #0,
{ EB OEM specific } #0,
{ EC OEM specific } #0,
{ ED OEM specific } #0,
{ EE OEM specific } #0,
{ EF OEM specific } #0,
{ F0 OEM specific } #0,
{ F1 OEM specific } #0,
{ F2 OEM specific } #0,
{ F3 OEM specific } #0,
{ F4 OEM specific } #0,
{ F5 OEM specific } #0,
{ F6 unassigned } #0,
{ F7 unassigned } #0,
{ F8 unassigned } #0,
{ F9 unassigned } #0,
{ FA unassigned } #0,
{ FB unassigned } #0,
{ FC unassigned } #0,
{ FD unassigned } #0,
{ FE unassigned } #0,
{ FF unassigned } #0
);
KeyToQwertyScan : array [0..255] of byte =
(
{ 00 } 0,
{ 01 VK_LBUTTON } 0,
{ 02 VK_RBUTTON } 0,
{ 03 VK_CANCEL } 0,
{ 04 VK_MBUTTON } 0,
{ 05 unassigned } 0,
{ 06 unassigned } 0,
{ 07 unassigned } 0,
{ 08 VK_BACK } $E,
{ 09 VK_TAB } $F,
{ 0A unassigned } 0,
{ 0B unassigned } 0,
{ 0C VK_CLEAR ?? } 0,
{ 0D VK_RETURN } $1C,
{ 0E unassigned } 0,
{ 0F unassigned } 0,
{ 10 VK_SHIFT } 0,
{ 11 VK_CONTROL } 0,
{ 12 VK_MENU (Alt key) } 0,
{ 13 VK_PAUSE } 0,
{ 14 VK_CAPITAL (Caps Lock) } 0,
{ 15 Reserved for Kanji systems} 0,
{ 16 Reserved for Kanji systems} 0,
{ 17 Reserved for Kanji systems} 0,
{ 18 Reserved for Kanji systems} 0,
{ 19 Reserved for Kanji systems} 0,
{ 1A unassigned } 0,
{ 1B VK_ESCAPE } $1,
{ 1C Reserved for Kanji systems} 0,
{ 1D Reserved for Kanji systems} 0,
{ 1E Reserved for Kanji systems} 0,
{ 1F Reserved for Kanji systems} 0,
{ 20 VK_SPACE} $39,
{ 21 VK_PRIOR (PgUp) } $49,
{ 22 VK_NEXT (PgDown) } $51,
{ 23 VK_END } $4F,
{ 24 VK_HOME } $47,
{ 25 VK_LEFT } $4B,
{ 26 VK_UP } $48,
{ 27 VK_RIGHT } $4D,
{ 28 VK_DOWN } $50,
{ 29 VK_SELECT ??? } 0,
{ 2A OEM specific !! } 0,
{ 2B VK_EXECUTE } 0,
{ 2C VK_SNAPSHOT } 0,
{ 2D VK_INSERT } $52,
{ 2E VK_DELETE } $53,
{ 2F VK_HELP } 0,
{ 30 VK_0 '0' } 11,
{ 31 VK_1 '1' } 2,
{ 32 VK_2 '2' } 3,
{ 33 VK_3 '3' } 4,
{ 34 VK_4 '4' } 5,
{ 35 VK_5 '5' } 6,
{ 36 VK_6 '6' } 7,
{ 37 VK_7 '7' } 8,
{ 38 VK_8 '8' } 9,
{ 39 VK_9 '9' } 10,
{ 3A unassigned } 0,
{ 3B unassigned } 0,
{ 3C unassigned } 0,
{ 3D unassigned } 0,
{ 3E unassigned } 0,
{ 3F unassigned } 0,
{ 40 unassigned } 0,
{ 41 VK_A 'A' } $1E,
{ 42 VK_B 'B' } $30,
{ 43 VK_C 'C' } $2E,
{ 44 VK_D 'D' } $20,
{ 45 VK_E 'E' } $12,
{ 46 VK_F 'F' } $21,
{ 47 VK_G 'G' } $22,
{ 48 VK_H 'H' } $23,
{ 49 VK_I 'I' } $17,
{ 4A VK_J 'J' } $24,
{ 4B VK_K 'K' } $25,
{ 4C VK_L 'L' } $26,
{ 4D VK_M 'M' } $32,
{ 4E VK_N 'N' } $31,
{ 4F VK_O 'O' } $18,
{ 50 VK_P 'P' } $19,
{ 51 VK_Q 'Q' } $10,
{ 52 VK_R 'R' } $13,
{ 53 VK_S 'S' } $1F,
{ 54 VK_T 'T' } $14,
{ 55 VK_U 'U' } $16,
{ 56 VK_V 'V' } $2F,
{ 57 VK_W 'W' } $11,
{ 58 VK_X 'X' } $2D,
{ 59 VK_Y 'Y' } $15,
{ 5A VK_Z 'Z' } $2C,
{ 5B unassigned } 0,
{ 5C unassigned } 0,
{ 5D unassigned } 0,
{ 5E unassigned } 0,
{ 5F unassigned } 0,
{ 60 VK_NUMPAD0 NumKeyPad '0' } 11,
{ 61 VK_NUMPAD1 NumKeyPad '1' } 2,
{ 62 VK_NUMPAD2 NumKeyPad '2' } 3,
{ 63 VK_NUMPAD3 NumKeyPad '3' } 4,
{ 64 VK_NUMPAD4 NumKeyPad '4' } 5,
{ 65 VK_NUMPAD5 NumKeyPad '5' } 6,
{ 66 VK_NUMPAD6 NumKeyPad '6' } 7,
{ 67 VK_NUMPAD7 NumKeyPad '7' } 8,
{ 68 VK_NUMPAD8 NumKeyPad '8' } 9,
{ 69 VK_NUMPAD9 NumKeyPad '9' } 10,
{ 6A VK_MULTIPLY } 0,
{ 6B VK_ADD } 0,
{ 6C VK_SEPARATOR } 0,
{ 6D VK_SUBSTRACT } 0,
{ 6E VK_DECIMAL } 0,
{ 6F VK_DIVIDE } 0,
{ 70 VK_F1 'F1' } $3B,
{ 71 VK_F2 'F2' } $3C,
{ 72 VK_F3 'F3' } $3D,
{ 73 VK_F4 'F4' } $3E,
{ 74 VK_F5 'F5' } $3F,
{ 75 VK_F6 'F6' } $40,
{ 76 VK_F7 'F7' } $41,
{ 77 VK_F8 'F8' } $42,
{ 78 VK_F9 'F9' } $43,
{ 79 VK_F10 'F10' } $44,
{ 7A VK_F11 'F11' } $57,
{ 7B VK_F12 'F12' } $58,
{ 7C VK_F13 } 0,
{ 7D VK_F14 } 0,
{ 7E VK_F15 } 0,
{ 7F VK_F16 } 0,
{ 80 VK_F17 } 0,
{ 81 VK_F18 } 0,
{ 82 VK_F19 } 0,
{ 83 VK_F20 } 0,
{ 84 VK_F21 } 0,
{ 85 VK_F22 } 0,
{ 86 VK_F23 } 0,
{ 87 VK_F24 } 0,
{ 88 unassigned } 0,
{ 89 VK_NUMLOCK } 0,
{ 8A VK_SCROLL } 0,
{ 8B unassigned } 0,
{ 8C unassigned } 0,
{ 8D unassigned } 0,
{ 8E unassigned } 0,
{ 8F unassigned } 0,
{ 90 unassigned } 0,
{ 91 unassigned } 0,
{ 92 unassigned } 0,
{ 93 unassigned } 0,
{ 94 unassigned } 0,
{ 95 unassigned } 0,
{ 96 unassigned } 0,
{ 97 unassigned } 0,
{ 98 unassigned } 0,
{ 99 unassigned } 0,
{ 9A unassigned } 0,
{ 9B unassigned } 0,
{ 9C unassigned } 0,
{ 9D unassigned } 0,
{ 9E unassigned } 0,
{ 9F unassigned } 0,
{ A0 unassigned } 0,
{ A1 unassigned } 0,
{ A2 unassigned } 0,
{ A3 unassigned } 0,
{ A4 unassigned } 0,
{ A5 unassigned } 0,
{ A6 unassigned } 0,
{ A7 unassigned } 0,
{ A8 unassigned } 0,
{ A9 unassigned } 0,
{ AA unassigned } 0,
{ AB unassigned } 0,
{ AC unassigned } 0,
{ AD unassigned } 0,
{ AE unassigned } 0,
{ AF unassigned } 0,
{ B0 unassigned } 0,
{ B1 unassigned } 0,
{ B2 unassigned } 0,
{ B3 unassigned } 0,
{ B4 unassigned } 0,
{ B5 unassigned } 0,
{ B6 unassigned } 0,
{ B7 unassigned } 0,
{ B8 unassigned } 0,
{ B9 unassigned } 0,
{ BA OEM specific } 0,
{ BB OEM specific } 0,
{ BC OEM specific } 0,
{ BD OEM specific } 0,
{ BE OEM specific } 0,
{ BF OEM specific } 0,
{ C0 OEM specific } 0,
{ C1 unassigned } 0,
{ C2 unassigned } 0,
{ C3 unassigned } 0,
{ C4 unassigned } 0,
{ C5 unassigned } 0,
{ C6 unassigned } 0,
{ C7 unassigned } 0,
{ C8 unassigned } 0,
{ C9 unassigned } 0,
{ CA unassigned } 0,
{ CB unassigned } 0,
{ CC unassigned } 0,
{ CD unassigned } 0,
{ CE unassigned } 0,
{ CF unassigned } 0,
{ D0 unassigned } 0,
{ D1 unassigned } 0,
{ D2 unassigned } 0,
{ D3 unassigned } 0,
{ D4 unassigned } 0,
{ D5 unassigned } 0,
{ D6 unassigned } 0,
{ D7 unassigned } 0,
{ D8 unassigned } 0,
{ D9 unassigned } 0,
{ DA unassigned } 0,
{ DB OEM specific } 0,
{ DC OEM specific } 0,
{ DD OEM specific } 0,
{ DE OEM specific } 0,
{ DF OEM specific } 0,
{ E0 OEM specific } 0,
{ E1 OEM specific } 0,
{ E2 OEM specific } 0,
{ E3 OEM specific } 0,
{ E4 OEM specific } 0,
{ E5 unassigned } 0,
{ E6 OEM specific } 0,
{ E7 unassigned } 0,
{ E8 unassigned } 0,
{ E9 OEM specific } 0,
{ EA OEM specific } 0,
{ EB OEM specific } 0,
{ EC OEM specific } 0,
{ ED OEM specific } 0,
{ EE OEM specific } 0,
{ EF OEM specific } 0,
{ F0 OEM specific } 0,
{ F1 OEM specific } 0,
{ F2 OEM specific } 0,
{ F3 OEM specific } 0,
{ F4 OEM specific } 0,
{ F5 OEM specific } 0,
{ F6 unassigned } 0,
{ F7 unassigned } 0,
{ F8 unassigned } 0,
{ F9 unassigned } 0,
{ FA unassigned } 0,
{ FB unassigned } 0,
{ FC unassigned } 0,
{ FD unassigned } 0,
{ FE unassigned } 0,
{ FF unassigned } 0
);
{ this procedure allows to hook keyboard messages }
function fvisioncharmessagehandler (Window: hwnd; AMessage, WParam,
LParam: Longint): Longint;
var
ir : INPUT_RECORD;
NumWritten : dword;
vKey : byte;
scancode : integer;
ach, ch : array[0..1] of char;
IsExtended : boolean;
begin
fvisioncharmessagehandler:=0;
if (AMessage = WM_CHAR) or (AMessage = WM_SYSCHAR) then
begin
if StoredChar then
begin
ach[0]:=chr(wparam and $ff);
ach[1]:=#0;
CharToOem(@ach,@ch);
{$ifdef DEBUG}
Write('key ',hexstr(lastir.Event.KeyEvent.wVirtualKeyCode,2));
Write(' scan ',hexstr(lastir.Event.KeyEvent.wVirtualScanCode,2));
if lastir.Event.KeyEvent.bKeyDown then
writeln(' pressed')
else
writeln(' released');
Writeln('char ',ach[0],'(',ch[0],')',' $',hexstr(wparam,2));
{$endif DEBUG}
Lastir.Event.KeyEvent.AsciiChar:=ch[0];
WriteConsoleInput(InputHandle,lastir,1,NumWritten);
StoredChar:=false;
end
else
begin
{$ifdef DEBUG}
Writeln('char ',chr(wparam and $ff),' $',hexstr(wparam,2),' ignored');
{$endif DEBUG}
ach[0]:=chr(wparam and $ff);
ach[1]:=#0;
CharToOem(@ach,@ch);
{$ifdef DEBUG}
Write('key ',hexstr(lastir.Event.KeyEvent.wVirtualKeyCode,2));
Write(' scan ',hexstr(lastir.Event.KeyEvent.wVirtualScanCode,2));
if lastir.Event.KeyEvent.bKeyDown then
writeln(' pressed')
else
writeln(' released');
Writeln('char ',ach[0],'(',ch[0],')',' $',hexstr(wparam,2));
{$endif DEBUG}
Lastir.Event.KeyEvent.AsciiChar:=ch[0];
WriteConsoleInput(InputHandle,lastir,1,NumWritten);
StoredChar:=false;
end;
exit;
end;
if StoredChar then
begin
{$ifdef DEBUG}
Write('key ',hexstr(lastir.Event.KeyEvent.wVirtualKeyCode,2));
Write(' scan ',hexstr(lastir.Event.KeyEvent.wVirtualScanCode,2));
if lastir.Event.KeyEvent.bKeyDown then
writeln(' pressed')
else
writeln(' released');
Writeln('char ',ach[0],'(',ch[0],')',' $',hexstr(wparam,2));
{$endif DEBUG}
WriteConsoleInput(InputHandle,lastir,1,NumWritten);
StoredChar:=false;
end;
fillchar(ir,sizeof(ir),#0);
ir.EventType:=KEY_EVENT;
with ir.Event.KeyEvent do
begin
vKey:=WParam and $ff;
wRepeatCount:=lparam and $ffff;
IsExtended:=(lParam and (1 shl 24))<>0;
if (AMessage = WM_KEYDOWN) or (AMessage = WM_SYSKEYDOWN) then
bKeyDown:=true;
wVirtualKeyCode:=vKey;
AsciiChar:=KeyToAsciiCode[vKey];
if AsciiChar<>#0 then
begin
{ Use lower chars }
if ((StoredControlKeyState and SHIFT_PRESSED)=0) and
((wVirtualKeyCode>=VK_A) and (wVirtualKeyCode<=VK_Z)) then
AsciiChar:=chr(ord(AsciiChar) + ord('a')-ord('A'));
if bKeyDown then
StoredChar:=true;
end;
scancode:=KeyToQwertyScan[vKey];
if scancode>0 then
wVirtualScanCode:=scancode;
case vKey of
VK_SHIFT :
if bKeyDown then
StoredControlKeyState:= StoredControlKeyState or SHIFT_PRESSED
else
StoredControlKeyState:= StoredControlKeyState and not SHIFT_PRESSED;
VK_CONTROL :
begin
if IsExtended then
begin
if bKeyDown then
StoredControlKeyState:= StoredControlKeyState or RIGHT_CTRL_PRESSED
else
StoredControlKeyState:= StoredControlKeyState and not RIGHT_CTRL_PRESSED;
end
else if bKeyDown then
StoredControlKeyState:= StoredControlKeyState or LEFT_CTRL_PRESSED
else
StoredControlKeyState:= StoredControlKeyState and not LEFT_CTRL_PRESSED;
end;
VK_MENU :
begin
if IsExtended then
begin
if bKeyDown then
StoredControlKeyState:= StoredControlKeyState or RIGHT_ALT_PRESSED
else
StoredControlKeyState:= StoredControlKeyState and not RIGHT_ALT_PRESSED;
end
else if bKeyDown then
StoredControlKeyState:= StoredControlKeyState or LEFT_ALT_PRESSED
else
StoredControlKeyState:= StoredControlKeyState and not LEFT_ALT_PRESSED;
end;
end;
dwControlKeyState:=StoredControlKeyState;
end;
if not StoredChar then
begin
{$ifdef DEBUG}
Write('key ',hexstr(ir.Event.KeyEvent.wVirtualKeyCode,2));
Write(' scan ',hexstr(ir.Event.KeyEvent.wVirtualScanCode,2));
if ir.Event.KeyEvent.bKeyDown then
writeln(' pressed')
else
writeln(' released');
{$endif DEBUG}
WriteConsoleInput(InputHandle,ir,1,NumWritten);
{ still copy for use for special keys not registered }
Lastir:=ir;
end
else
Lastir:=ir;
end;
{ this procedure allows to hook mouse messages }
function fvisionmousemessagehandler (Window: hwnd; AMessage, WParam,
LParam: Longint): Longint;
var
ir : INPUT_RECORD;
NumWritten : dword;
begin
fvisionmousemessagehandler:=0;
ir.EventType:=_MOUSE_EVENT;
with ir.Event.MouseEvent do
begin
dwMousePosition.x:=loword(LParam) div SysFontWidth;
dwMousePosition.y:=hiword(LParam) div SysFontHeight;
dwButtonState:=0;
if (wParam and MK_LBUTTON)<>0 then
dwButtonState:=dwButtonState or FROM_LEFT_1ST_BUTTON_PRESSED;
if (wParam and MK_MBUTTON)<>0 then
dwButtonState:=dwButtonState or FROM_LEFT_2ND_BUTTON_PRESSED;
if (wParam and MK_RBUTTON)<>0 then
dwButtonState:=dwButtonState or RIGHTMOST_BUTTON_PRESSED;
end;
WriteConsoleInput(InputHandle,ir,1,NumWritten);
end;
{$ifdef USE_NEW_WNDPROC}
Const
PreviousWindowProc: WndProc = nil;
function FvisionWindowProc(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall; export;
begin
case AMessage of
wm_lbuttondown,
wm_rbuttondown,
wm_mbuttondown,
wm_lbuttonup,
wm_rbuttonup,
wm_mbuttonup,
wm_lbuttondblclk,
wm_rbuttondblclk,
wm_mbuttondblclk:
{
This leads to problem, i.e. the menu etc doesn't work any longer
wm_nclbuttondown,
wm_ncrbuttondown,
wm_ncmbuttondown,
wm_nclbuttonup,
wm_ncrbuttonup,
wm_ncmbuttonup,
wm_nclbuttondblclk,
wm_ncrbuttondblclk,
wm_ncmbuttondblclk:
}
{ if assigned(mousemessagehandler) then }
FvisionWindowProc:=mousemessagehandler(window,amessage,wparam,lparam);
wm_keydown,
wm_keyup,
wm_syskeydown,
wm_syskeyup,
wm_syschar,
wm_char:
{ if assigned(charmessagehandler) then }
FvisionWindowProc:=charmessagehandler(window,amessage,wparam,lparam);
else
FvisionWindowProc:= CallWindowProc(PreviousWindowProc,Window,AMessage,WParam,LParam);
end;
end;
{$endif USE_NEW_WNDPROC}
procedure SetGraphHooks;
begin
{$ifdef USE_NEW_WNDPROC}
If not assigned (PreviousWindowProc) then
PreviousWindowProc:=WndProc(SetWindowLong(MainWindow,GWL_WNDPROC, longint(@fvisionWindowProc)));
{$else not USE_NEW_WNDPROC}
mousemessagehandler:=@fvisionmousemessagehandler;
charmessagehandler:=@fvisioncharmessagehandler;
{$endif USE_NEW_WNDPROC}
InputHandle:=GetStdHandle(STD_INPUT_HANDLE);
end;
procedure UnsetGraphHooks;
begin
mousemessagehandler:=nil;
charmessagehandler:=nil;
{$ifdef USE_NEW_WNDPROC}
SetWindowLong(MainWindow,GWL_WNDPROC, longint(PreviousWindowProc));
PreviousWindowProc:=nil;
{$endif USE_NEW_WNDPROC}
InputHandle:=UnusedHandle;
StoredControlKeyState:=0;
end;
end.
{
$Log$
Revision 1.6 2003-01-12 23:25:51 pierre
* fix win32 graph version compilation failure
Revision 1.5 2002/05/31 13:35:33 pierre
* recognize Enter key with kbEnter
Revision 1.4 2002/05/29 21:20:49 pierre
* better key translations
Revision 1.3 2002/05/29 19:34:27 pierre
* fix other keys
Revision 1.2 2002/05/28 19:12:26 pierre
* fix fvisioncharmessage
Revision 1.1 2002/05/24 09:35:20 pierre
first commit, not fully functional yet
}