Category : Pascal Source Code
Archive   : EDITOR.ZIP
Filename : UTILITY.PAS

{

Utility - W. Russell Version 1.0
Contains Limit Read and Screen
saving and restoring

}



Unit Utility;
interface

uses Crt,Dos;

type TypeScreen = array [1..4096] of byte;
TypeCharacterSet = set of char;
TypeClock = record
Hour,
Minute,
Seconds : word;
end;

var Scrn : TypeScreen;
TimerOn : boolean;
TimerStPos : TypeClock;

procedure StartTimer;

function Timer : real; { Minutes.Seconds }

function UpCaseString ( Line : string ):string;

function FileExist (filename:string):boolean;

function PackedDate:string;

function PackedTime:string;

function StringOf ( AsciiValue,
Times : byte ):string;

procedure WriteXY ( X,
Y :byte;
Line :string);

procedure LimitRead (var Line: string; { Makes/Edits String }
Traditional, { Normal Background color }
Untouched, { Color of untouched selection }
Editmode, { Background color while editing }
TFore, { Traditional foreground }
UFore, { Untouched foreground }
EFore, { Editing mode foreground }
LineLength : byte;
ValidChars : TypeCharacterSet;
ExtMarkers : boolean; { Stop line if get Up/Dn }
BeginChar : char; { Null if none }
var LastChar : char ); { LastChar = EndMarker }


procedure SaveScreen;

procedure RestoreScreen;

implementation


procedure StartTimer;

var Sec100 : word; { Need a throw away byte }

begin
GetTime ( TimerStPos.Hour, TimerStPos.Minute, TimerStPos.Seconds, Sec100 );
TimerOn := True;
end;


function Timer : real;

var TimeDifference,
CurrentTime : TypeClock;
Sec100 : word;

begin
GetTime ( CurrentTime.Hour, CurrentTime.Minute, CurrentTime.Seconds, Sec100 );
If ( CurrentTime.Seconds < TimerStPos.Seconds ) then
with CurrentTime do
begin
Seconds := Seconds + 60;
If Minute = 0 then
begin
Minute := 59;
If Hour = 0 then
Hour := 23
else
Hour := Hour - 1;
end
else
Minute := Minute - 1;
end;
If ( CurrentTime.Minute < TimerStPos.Minute ) then
with CurrentTime do
begin
Minute := Minute + 60;
If Hour = 0 then
Hour := 23
else
Hour := Hour - 1;
end;
If ( CurrentTime.Hour < TimerStPos.Hour ) then
TimeDifference.Hour := (24-TimerStPos.Hour)+CurrentTime.Hour
else
TimeDifference.Hour := CurrentTime.Hour - TimerStPos.Hour;
TimeDifference.Minute := CurrentTime.Minute - TimerStPos.Minute;
TimeDifference.Seconds:= CurrentTime.Seconds - TimerStPos.Seconds;
If TimerOn then
Timer := ( TimeDifference.Hour * 60 ) + ( TimeDifference.Minute ) + ( TimeDifference.Seconds/100)
else
Timer := 0;
end;


function UpCaseString (Line : string ):string;

var i : byte;
work : string;

begin
work := '';
for i := 1 to length(line) do
work := work + UpCase(Line[i]);
UpCaseString := Work;
end;


procedure LimitRead (var Line: string;
Traditional, { Normal Background color }
Untouched, { Color of untouched selection }
Editmode, { Background color while editing }
TFore, { Traditional foreground }
UFore, { Untouched foreground }
EFore, { Editing mode foreground }
LineLength : byte;
ValidChars : TypeCharacterSet;
ExtMarkers : boolean; { Stop line if get arrow }
BeginChar : char; { Null if none }
var LastChar : char ); { LastChar = EndMarker }

var Key : char;
First,
Touched,
done : boolean;
x,y,n,x2,y2 : byte;
ChrStr : string;


procedure TouchLine;

var c, r : byte;

begin
Touched := True;
c := WhereX;
r := WhereY;
TextBackground (Editmode);
TextColor (EFore);
WriteXY ( x, y, StringOf (32, LineLength) );
WriteXY ( x, y, Line );
GotoXY (c, r);
end;



begin
Touched := False;
If Length(Line) = 0 then
Touched := True;
X := WhereX;
Y := WhereY;
TextBackground (Editmode);
TextColor (Efore);
If not Touched then
begin
TextBackground (UnTouched);
TextColor (UFore);
end;
WriteXY (x, y, StringOf(32,LineLength) );
n := 1; { Position inside string }
First := True;
done := False;
WriteXY ( x, y, Line );
GotoXY (X,Y);
while not done do
begin
key := readkey;
If ( First and (BeginChar <>#00) ) then
begin
First := False;
Key := BeginChar;
end;
If ( Key = #08 ) then
If ( n > 1 ) then
begin
If not touched then
TouchLine;
x2 := WhereX;
y2 := WhereY;
n := n-1;
Delete ( Line, n, 1);
WriteXY ( x, y, StringOf(32, LineLength ));
WriteXY ( x, y, Line );
GotoXY ( x2-1, y2 );
end;
If (( key = #13 ) or (key = #09)) then
done := True;
If Key = #00 then
begin
key := readkey;
If Key = #75 then
If n > 1 then
begin
If not touched then
TouchLine;
n := n-1;
GotoXY ( WhereX-1, WhereY );
end;
If Key = #77 then
If N < Length(Line)+1 then
begin
If not touched then
TouchLine;
n := n+1;
GotoXY ( WhereX+1, WhereY );
end;
If Key = #71 then
begin
If not touched then
TouchLine;
n := 1;
GotoXY (x,y);
end;
If Key = #79 then
begin
If not touched then
TouchLine;
n := Length(Line)+1;
GotoXY (x+n-1, y);
end;
If ExtMarkers then
begin
case Key of
#72 : Key := chr(172); { add 100 to normal chr }
#80 : Key := chr(180);
else
Key := #00;
end;
If Key <> #00 then
done := true;
end;
If not done then
Key := #00;
end;
If (Key <> #08 ) and (not done) and (Length(Line) < linelength) then
If Key in ValidChars then
begin
If not Touched then
begin
Line := '';
TouchLine;
n := 1;
end;
x2 := WhereX;
y2 := WhereY;
ChrStr := Key;
Insert ( ChrStr, line, n);
n := n + 1;
WriteXY ( x, y, Line );
GotoXY ( x2+1, y2 );
end;
end;
TextBackground (Traditional);
TextColor (TFore);
WriteXY ( x, y, StringOf(32,LineLength));
WriteXY ( x, y, Line );
Writeln ( output, '' );
LastChar := Key;
end;


function FileExist (filename:string):boolean;

var TextFile : text;
Exist : boolean;

begin
{$I-}
Exist := True;
assign (TextFile,filename);
reset (TextFile);
{$I+}
If IOResult > 0 then
Exist := False
else
Close (TextFile);
FileExist := Exist;
end;

function PackedDate : string;
var year,
month,
day,
dayofweek : word;
StrDay,
FullDate,
StrMonth,
StrYear,
weekday : string;

begin
GetDate ( year,month,day,dayofweek );
case DayOfWeek of
1 : Weekday := 'Monday';
2 : Weekday := 'Tuesday';
3 : Weekday := 'Wednesday';
4 : Weekday := 'Thursday';
5 : Weekday := 'Friday';
6 : Weekday := 'Saturday';
7 : Weekday := 'Sunday';
end;
case Month of
1 : StrMonth := 'January';
2 : StrMonth := 'February';
3 : StrMonth := 'March';
4 : StrMonth := 'April';
5 : StrMonth := 'May';
6 : StrMonth := 'June';
7 : StrMonth := 'July';
8 : StrMonth := 'August';
9 : StrMonth := 'September';
10 : StrMonth := 'October';
11 : StrMonth := 'November';
12 : StrMonth := 'December';
end;
Str (Year,StrYear);
Str (Day, StrDay );
FullDate := WeekDay+' '+StrMonth+' '+StrDay+', '+StrYear;
PackedDate := FullDate;
end;

function PackedTime : string;

var Hr,
Mn,
Sec,
Sec100 : word;
Min,
Hour,
AP : string;

begin
GetTime (Hr,Mn,Sec,Sec100);
AP := 'am';
If (Hr > 11) then
AP := 'pm';
If (Hr > 12) then
hr := hr-12;
Str (hr,hour);
Str (Mn,Min);
if (hour = '0') then
hour := '12';
if (length(min)=1) then
min := '0'+min;
PackedTime := Hour+':'+min+' '+ap;
end;

function StringOf (AsciiValue,Times : byte ):string;

var i : byte;
Ln: string;

begin
Ln := '';
for i := 1 to times do
Ln := Ln + Chr(AsciiValue);
StringOf := Ln;
end;

procedure WriteXY ( X, Y : byte;
Line : string );

begin
GotoXY (X,Y);
Writeln (output,Line);
end;




procedure SaveScreen;

begin

if ( ( mem [0000:1040] and 48) <> 48) then
move (mem[$B800:0], Scrn, 4096)
else
move (mem[$B000:0], Scrn, 4096);
end;



procedure RestoreScreen;

begin
if ((mem [0000:1040] and 48) <> 48) then
move (Scrn, mem[$B800:0], 4096)
else
move (Scrn, mem[$B000:0], 4096);
end;


begin
TimerOn := False;
end.