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

* colortxt added

Browse Source
This commit is contained in:
peter 2002-01-29 22:00:33 +00:00
parent 4fbfbf38dc
commit 4658d1d09d
8 changed files with 282 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
fv/Makefile
View File

@ -179,12 +179,12 @@ else
UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
endif
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
override PACKAGE_NAME=fvision
override PACKAGE_NAME=fv
override PACKAGE_VERSION=1.0.5
override TARGET_UNITS+=buildfv
override TARGET_IMPLICITUNITS+=app callspec colortxt dialogs drivers editors fileio fvcommon fvconsts gadgets histlist inplong memory menus msgbox resource statuses stddlg tabs time validate views gfvgraph
override TARGET_EXAMPLEDIRS+=test
override CLEAN_UNITS+=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
override INSTALL_UNITS+=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
override INSTALL_BUILDUNIT=buildfv
override INSTALL_FPCPACKAGE=y
override COMPILER_TARGETDIR+=.
ifdef REQUIRE_UNITSDIR
@ -925,7 +925,7 @@ ifdef INSTALL_UNITS
override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS))
endif
ifdef INSTALL_BUILDUNIT
override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT),$(INSTALLPPUFILES))
override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPPUFILES))
endif
ifdef INSTALLPPUFILES
override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))

11
fv/Makefile.fpc
View File

@ -3,11 +3,15 @@
#
[package]
name=fvision
name=fv
version=1.0.5
[target]
units=buildfv
implicitunits=app callspec colortxt dialogs drivers editors fileio \
fvcommon fvconsts gadgets histlist inplong memory \
menus msgbox resource statuses stddlg tabs time validate \
views gfvgraph
exampledirs=test
[libs]
@ -18,12 +22,9 @@ libversion=1.0
targetdir=.
[install]
units=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
buildunit=buildfv
fpcpackage=y
[clean]
units=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
[default]
fpcdir=..

6
fv/buildfv.pas
View File

@ -25,6 +25,7 @@ uses
stddlg,
tabs,
colortxt,
statuses,
histlist,
inplong,
@ -37,7 +38,10 @@ implementation
end.
{
$Log$
Revision 1.2 2001-08-05 02:03:13 peter
Revision 1.3 2002-01-29 22:00:33 peter
* colortxt added
Revision 1.2 2001/08/05 02:03:13 peter
* view redrawing and small cursor updates
* merged some more FV extensions

126
fv/colortxt.pas Normal file
View File

@ -0,0 +1,126 @@
unit ColorTxt;
{
TColoredText is a descendent of TStaticText designed to allow the writing
of colored text when color monitors are used. With a monochrome or BW
monitor, TColoredText acts the same as TStaticText.
TColoredText is used in exactly the same way as TStaticText except that
the constructor has an extra Byte parameter specifying the attribute
desired. (Do not use a 0 attribute, black on black).
}
{$i platform.inc}
{$ifdef PPC_FPC}
{$H-}
{$else}
{$F+,O+,E+,N+}
{$endif}
{$X+,R-,I-,Q-,V-}
{$ifndef OS_LINUX}
{$S-}
{$endif}
interface
uses
Objects, Drivers, Views, Dialogs, App;
type
PColoredText = ^TColoredText;
TColoredText = object(TStaticText)
Attr : Byte;
constructor Init(var Bounds: TRect; const AText: String; Attribute : Byte);
constructor Load(var S: TStream);
function GetTheColor : byte; virtual;
procedure Draw; virtual;
procedure Store(var S: TStream);
end;
const
RColoredText: TStreamRec = (
ObjType: 611;
VmtLink: Ofs(TypeOf(TColoredText)^);
Load: @TColoredText.Load;
Store: @TColoredText.Store
);
implementation
constructor TColoredText.Init(var Bounds: TRect; const AText: String;
Attribute : Byte);
begin
TStaticText.Init(Bounds, AText);
Attr := Attribute;
end;
constructor TColoredText.Load(var S: TStream);
begin
TStaticText.Load(S);
S.Read(Attr, Sizeof(Attr));
end;
procedure TColoredText.Store(var S: TStream);
begin
TStaticText.Store(S);
S.Write(Attr, Sizeof(Attr));
end;
function TColoredText.GetTheColor : byte;
begin
if AppPalette = apColor then
GetTheColor := Attr
else
GetTheColor := GetColor(1);
end;
procedure TColoredText.Draw;
var
Color: Byte;
Center: Boolean;
I, J, L, P, Y: Sw_Integer;
B: TDrawBuffer;
S: String;
begin
Color := GetTheColor;
GetText(S);
L := Length(S);
P := 1;
Y := 0;
Center := False;
while Y < Size.Y do
begin
MoveChar(B, ' ', Color, Size.X);
if P <= L then
begin
if S[P] = #3 then
begin
Center := True;
Inc(P);
end;
I := P;
repeat
J := P;
while (P <= L) and (S[P] = ' ') do Inc(P);
while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do Inc(P);
until (P > L) or (P >= I + Size.X) or (S[P] = #13);
if P > I + Size.X then
if J > I then P := J else P := I + Size.X;
if Center then J := (Size.X - P + I) div 2 else J := 0;
MoveBuf(B[J], S[I], Color, P - I);
while (P <= L) and (S[P] = ' ') do Inc(P);
if (P <= L) and (S[P] = #13) then
begin
Center := False;
Inc(P);
if (P <= L) and (S[P] = #10) then Inc(P);
end;
end;
WriteLine(0, Y, Size.X, 1, B);
Inc(Y);
end;
end;
end.

8
fvision/Makefile
View File

@ -179,12 +179,12 @@ else
UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
endif
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
override PACKAGE_NAME=fvision
override PACKAGE_NAME=fv
override PACKAGE_VERSION=1.0.5
override TARGET_UNITS+=buildfv
override TARGET_IMPLICITUNITS+=app callspec colortxt dialogs drivers editors fileio fvcommon fvconsts gadgets histlist inplong memory menus msgbox resource statuses stddlg tabs time validate views gfvgraph
override TARGET_EXAMPLEDIRS+=test
override CLEAN_UNITS+=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
override INSTALL_UNITS+=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
override INSTALL_BUILDUNIT=buildfv
override INSTALL_FPCPACKAGE=y
override COMPILER_TARGETDIR+=.
ifdef REQUIRE_UNITSDIR
@ -925,7 +925,7 @@ ifdef INSTALL_UNITS
override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS))
endif
ifdef INSTALL_BUILDUNIT
override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT),$(INSTALLPPUFILES))
override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPPUFILES))
endif
ifdef INSTALLPPUFILES
override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))

11
fvision/Makefile.fpc
View File

@ -3,11 +3,15 @@
#
[package]
name=fvision
name=fv
version=1.0.5
[target]
units=buildfv
implicitunits=app callspec colortxt dialogs drivers editors fileio \
fvcommon fvconsts gadgets histlist inplong memory \
menus msgbox resource statuses stddlg tabs time validate \
views gfvgraph
exampledirs=test
[libs]
@ -18,12 +22,9 @@ libversion=1.0
targetdir=.
[install]
units=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
buildunit=buildfv
fpcpackage=y
[clean]
units=$(subst $(PPUEXT),,$(wildcard *$(PPUEXT)))
[default]
fpcdir=..

6
fvision/buildfv.pas
View File

@ -25,6 +25,7 @@ uses
stddlg,
tabs,
colortxt,
statuses,
histlist,
inplong,
@ -37,7 +38,10 @@ implementation
end.
{
$Log$
Revision 1.2 2001-08-05 02:03:13 peter
Revision 1.3 2002-01-29 22:00:33 peter
* colortxt added
Revision 1.2 2001/08/05 02:03:13 peter
* view redrawing and small cursor updates
* merged some more FV extensions

126
fvision/colortxt.pas Normal file
View File

@ -0,0 +1,126 @@
unit ColorTxt;
{
TColoredText is a descendent of TStaticText designed to allow the writing
of colored text when color monitors are used. With a monochrome or BW
monitor, TColoredText acts the same as TStaticText.
TColoredText is used in exactly the same way as TStaticText except that
the constructor has an extra Byte parameter specifying the attribute
desired. (Do not use a 0 attribute, black on black).
}
{$i platform.inc}
{$ifdef PPC_FPC}
{$H-}
{$else}
{$F+,O+,E+,N+}
{$endif}
{$X+,R-,I-,Q-,V-}
{$ifndef OS_LINUX}
{$S-}
{$endif}
interface
uses
Objects, Drivers, Views, Dialogs, App;
type
PColoredText = ^TColoredText;
TColoredText = object(TStaticText)
Attr : Byte;
constructor Init(var Bounds: TRect; const AText: String; Attribute : Byte);
constructor Load(var S: TStream);
function GetTheColor : byte; virtual;
procedure Draw; virtual;
procedure Store(var S: TStream);
end;
const
RColoredText: TStreamRec = (
ObjType: 611;
VmtLink: Ofs(TypeOf(TColoredText)^);
Load: @TColoredText.Load;
Store: @TColoredText.Store
);
implementation
constructor TColoredText.Init(var Bounds: TRect; const AText: String;
Attribute : Byte);
begin
TStaticText.Init(Bounds, AText);
Attr := Attribute;
end;
constructor TColoredText.Load(var S: TStream);
begin
TStaticText.Load(S);
S.Read(Attr, Sizeof(Attr));
end;
procedure TColoredText.Store(var S: TStream);
begin
TStaticText.Store(S);
S.Write(Attr, Sizeof(Attr));
end;
function TColoredText.GetTheColor : byte;
begin
if AppPalette = apColor then
GetTheColor := Attr
else
GetTheColor := GetColor(1);
end;
procedure TColoredText.Draw;
var
Color: Byte;
Center: Boolean;
I, J, L, P, Y: Sw_Integer;
B: TDrawBuffer;
S: String;
begin
Color := GetTheColor;
GetText(S);
L := Length(S);
P := 1;
Y := 0;
Center := False;
while Y < Size.Y do
begin
MoveChar(B, ' ', Color, Size.X);
if P <= L then
begin
if S[P] = #3 then
begin
Center := True;
Inc(P);
end;
I := P;
repeat
J := P;
while (P <= L) and (S[P] = ' ') do Inc(P);
while (P <= L) and (S[P] <> ' ') and (S[P] <> #13) do Inc(P);
until (P > L) or (P >= I + Size.X) or (S[P] = #13);
if P > I + Size.X then
if J > I then P := J else P := I + Size.X;
if Center then J := (Size.X - P + I) div 2 else J := 0;
MoveBuf(B[J], S[I], Color, P - I);
while (P <= L) and (S[P] = ' ') do Inc(P);
if (P <= L) and (S[P] = #13) then
begin
Center := False;
Inc(P);
if (P <= L) and (S[P] = #10) then Inc(P);
end;
end;
WriteLine(0, Y, Size.X, 1, B);
Inc(Y);
end;
end;
end.