mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-18 03:21:02 +02:00
310 lines
13 KiB
ObjectPascal
310 lines
13 KiB
ObjectPascal
{ $Id$ }
|
|
{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********}
|
|
{ }
|
|
{ System independent GRAPHICAL clone of GADGETS.PAS }
|
|
{ }
|
|
{ Interface Copyright (c) 1992 Borland International }
|
|
{ }
|
|
{ Copyright (c) 1999 by Leon de Boer }
|
|
{ ldeboer@attglobal.net - primary e-mail address }
|
|
{ ldeboer@starwon.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) }
|
|
{ }
|
|
{*******************[ DOCUMENTATION ]**********************}
|
|
{ }
|
|
{ This unit had to be for GFV due to some problems with }
|
|
{ the original Borland International implementation. }
|
|
{ }
|
|
{ First it used the DOS unit for it's time calls in the }
|
|
{ TClockView object. Since this unit can not be compiled }
|
|
{ under WIN/NT/OS2 we use a new unit TIME.PAS which was }
|
|
{ created and works under these O/S. }
|
|
{ }
|
|
{ Second the HeapView object accessed MemAvail from in }
|
|
{ the Draw call. As GFV uses heap memory during the Draw }
|
|
{ call the OldMem value always met the test condition in }
|
|
{ the update procedure. The consequence was the view }
|
|
{ would continually redraw. By moving the memavail call }
|
|
{ the update procedure this eliminates this problem. }
|
|
{ }
|
|
{ Finally the original object relied on the font char }
|
|
{ blocks being square to erase it's entire view area as }
|
|
{ it used a simple writeline call in the Draw method. }
|
|
{ Under GFV font blocks are not necessarily square and }
|
|
{ so both objects had their Draw routines rewritten. As }
|
|
{ the Draw had to be redone it was done in the GFV split }
|
|
{ drawing method to accelerate the graphical speed. }
|
|
{ }
|
|
{******************[ REVISION HISTORY ]********************}
|
|
{ Version Date Fix }
|
|
{ ------- --------- --------------------------------- }
|
|
{ 1.00 12 Nov 99 First multi platform release }
|
|
{**********************************************************}
|
|
|
|
UNIT Gadgets;
|
|
|
|
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
|
|
INTERFACE
|
|
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
|
|
|
|
{====Include file to sort compiler platform out =====================}
|
|
{$I Platform.inc}
|
|
{====================================================================}
|
|
|
|
{==== 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 }
|
|
{$I-} { Disable IO Checking }
|
|
{$Q-} { Disable Overflow Checking }
|
|
{$V-} { Turn off strict VAR strings }
|
|
{====================================================================}
|
|
|
|
USES FVConsts, Time, Objects, Drivers, Views, App; { Standard GFV units }
|
|
|
|
{***************************************************************************}
|
|
{ PUBLIC OBJECT DEFINITIONS }
|
|
{***************************************************************************}
|
|
|
|
{---------------------------------------------------------------------------}
|
|
{ THeapView OBJECT - ANCESTOR VIEW OBJECT }
|
|
{---------------------------------------------------------------------------}
|
|
TYPE
|
|
THeapViewMode=(HVNormal,HVComma,HVKb,HVMb);
|
|
|
|
THeapView = OBJECT (TView)
|
|
Mode : THeapViewMode;
|
|
OldMem: LongInt; { Last memory count }
|
|
constructor Init(var Bounds: TRect);
|
|
constructor InitComma(var Bounds: TRect);
|
|
constructor InitKb(var Bounds: TRect);
|
|
constructor InitMb(var Bounds: TRect);
|
|
PROCEDURE Update;
|
|
PROCEDURE DrawBackGround; Virtual;
|
|
Function Comma ( N : LongInt ) : String;
|
|
END;
|
|
PHeapView = ^THeapView; { Heapview pointer }
|
|
|
|
{---------------------------------------------------------------------------}
|
|
{ TClockView OBJECT - ANCESTOR VIEW OBJECT }
|
|
{---------------------------------------------------------------------------}
|
|
TYPE
|
|
TClockView = OBJECT (TView)
|
|
am : Char;
|
|
Refresh : Byte; { Refresh rate }
|
|
LastTime: Longint; { Last time displayed }
|
|
TimeStr : String[10]; { Time string }
|
|
CONSTRUCTOR Init (Var Bounds: TRect);
|
|
FUNCTION FormatTimeStr (H, M, S: Word): String; Virtual;
|
|
PROCEDURE Update; Virtual;
|
|
PROCEDURE DrawBackGround; Virtual;
|
|
END;
|
|
PClockView = ^TClockView; { Clockview ptr }
|
|
|
|
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
|
|
IMPLEMENTATION
|
|
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
|
|
|
|
{***************************************************************************}
|
|
{ OBJECT METHODS }
|
|
{***************************************************************************}
|
|
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
{ THeapView OBJECT METHODS }
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
|
|
constructor THeapView.Init(var Bounds: TRect);
|
|
begin
|
|
inherited Init(Bounds);
|
|
mode:=HVNormal;
|
|
OldMem := 0;
|
|
end;
|
|
|
|
constructor THeapView.InitComma(var Bounds: TRect);
|
|
begin
|
|
inherited Init(Bounds);
|
|
mode:=HVComma;
|
|
OldMem := 0;
|
|
end;
|
|
|
|
constructor THeapView.InitKb(var Bounds: TRect);
|
|
begin
|
|
inherited Init(Bounds);
|
|
mode:=HVKb;
|
|
OldMem := 0;
|
|
end;
|
|
|
|
constructor THeapView.InitMb(var Bounds: TRect);
|
|
begin
|
|
inherited Init(Bounds);
|
|
mode:=HVMb;
|
|
OldMem := 0;
|
|
end;
|
|
|
|
{--THeapView----------------------------------------------------------------}
|
|
{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
PROCEDURE THeapView.Update;
|
|
BEGIN
|
|
If (OldMem <> MemAvail) Then Begin { Memory differs }
|
|
OldMem := MemAvail; { Hold memory avail }
|
|
SetDrawMask(vdBackGnd OR vdInner); { Set draw masks }
|
|
DrawView; { Now redraw }
|
|
End;
|
|
END;
|
|
|
|
{--THeapView----------------------------------------------------------------}
|
|
{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
PROCEDURE THeapView.DrawBackGround;
|
|
VAR HOfs: Integer; S: String;
|
|
begin
|
|
case mode of
|
|
HVNormal :
|
|
Str(OldMem:Size.X, S);
|
|
HVComma :
|
|
S:=Comma(OldMem);
|
|
HVKb :
|
|
begin
|
|
Str(OldMem shr 10:Size.X-1, S);
|
|
S:=S+'K';
|
|
end;
|
|
HVMb :
|
|
begin
|
|
Str(OldMem shr 20:Size.X-1, S);
|
|
S:=S+'M';
|
|
end;
|
|
end;
|
|
HOfs := ColourOfs; { Hold any offset }
|
|
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 }
|
|
END;
|
|
|
|
Function THeapView.Comma ( n : LongInt) : String;
|
|
Var
|
|
num, loc : Byte;
|
|
s : String;
|
|
t : String;
|
|
Begin
|
|
Str (n,s);
|
|
Str (n:Size.X,t);
|
|
|
|
num := length(s) div 3;
|
|
if (length(s) mod 3) = 0 then dec (num);
|
|
|
|
delete (t,1,num);
|
|
loc := length(t)-2;
|
|
|
|
while num > 0 do
|
|
Begin
|
|
Insert (',',t,loc);
|
|
dec (num);
|
|
dec (loc,3);
|
|
End;
|
|
|
|
Comma := t;
|
|
End;
|
|
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
{ TClockView OBJECT METHODS }
|
|
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
|
|
|
|
{--TClockView---------------------------------------------------------------}
|
|
{ Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
CONSTRUCTOR TClockView.Init (Var Bounds: TRect);
|
|
BEGIN
|
|
Inherited Init(Bounds); { Call ancestor }
|
|
FillChar(LastTime, SizeOf(LastTime), #$FF); { Fill last time }
|
|
TimeStr := ''; { Empty time string }
|
|
Refresh := 1; { Refresh per second }
|
|
END;
|
|
|
|
{--TClockView---------------------------------------------------------------}
|
|
{ FormatStr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
FUNCTION TClockView.FormatTimeStr (H, M, S: Word): String;
|
|
VAR Hs, Ms, Ss: String;
|
|
BEGIN
|
|
Str(H, Hs); { Convert hour string }
|
|
While (Length(Hs) < 2) Do Hs := '0' + Hs; { Add lead zero's }
|
|
Str(M, Ms); { Convert min string }
|
|
While (Length(Ms) < 2) Do Ms := '0' + Ms; { Add lead zero's }
|
|
Str(S, Ss); { Convert sec string }
|
|
While (Length(Ss) < 2) Do Ss := '0' + Ss; { Add lead zero's }
|
|
FormatTimeStr := Hs + ':'+ Ms + ':' + Ss; { Return string }
|
|
END;
|
|
|
|
{--TClockView---------------------------------------------------------------}
|
|
{ Update -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
PROCEDURE TClockView.Update;
|
|
VAR Hour, Min, Sec, Sec100: Word;
|
|
BEGIN
|
|
GetTime(Hour, Min, Sec, Sec100); { Get current time }
|
|
If (Abs(Sec - LastTime) >= Refresh) Then Begin { Refresh time elapsed }
|
|
LastTime := Sec; { Hold second }
|
|
TimeStr := FormatTimeStr(Hour, Min, Sec); { Create time string }
|
|
SetDrawMask(vdBackGnd OR vdInner); { Set draw masks }
|
|
DrawView; { Now redraw }
|
|
End;
|
|
END;
|
|
|
|
{--TClockView---------------------------------------------------------------}
|
|
{ DrawBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Nov99 LdB }
|
|
{---------------------------------------------------------------------------}
|
|
PROCEDURE TClockView.DrawBackGround;
|
|
VAR HOfs: Integer;
|
|
BEGIN
|
|
HOfs := ColourOfs; { Hold any offset }
|
|
ColourOfs := 2; { Set colour offset }
|
|
Inherited DrawBackGround; { Clear the backgound }
|
|
ColourOfs := HOfs; { Reset any offset }
|
|
WriteStr(0, 0, TimeStr, 2); { Write the string }
|
|
END;
|
|
|
|
END.
|
|
{
|
|
$Log$
|
|
Revision 1.5 2002-09-07 15:06:36 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
}
|