{*************************************************************
 ***              MINI-LIBRARY - EXTENSIONS TO PASCAL      ***
 *************************************************************}
{A library of mini-methods for handling strings, numbers, etc, providing
some general purpose extensions to standard pascal}
{$I compflgs}
unit minilib;

INTERFACE

const
	dcUpTo  = $0000;  {Add num dec places - chops at that number}
	dcNone  = $0000;  {Same really, just don't add anything}
	dcFixed  = $0100;  {Add num dec places - chops at that number/fills in zeros}
	dcAll   = $0200;  {all decimal places available}

	dcAuto  = $0400;  {Defaults to dcAll here, but used in other routines, eg measures}
	dcBlankZero = $0800;  {Blank zeros}

	CR = #13;
	LF = #10;
	CRLF = CR+LF;

	{special tabs for tabsetting.  hi bit set so no confusion with
	lock markers, etc....}
	Tab 			= #137;
	RightSet 	= #146; {CtrlR - for display line}
	SkipTab 	= #138;

	{--- Name types ---}
	naDisplay = 1;  {for selector lines, display line summaries, etc}
	naAddress = 2;	{As it would be as the first line of an address}
	naDear    = 3;  {Suitable for "Dear ..."}
	naFull    = 4;	{The complete name in the appropriate reading order (eg for company just name, for person Mr Martin Hill}
	naInitials= 5;	{Initials of complete name - can be useful as an ID marker or reference}
	naReport  = 6;	{Name as it would be if looking down an alphabetical list - ie surname first for people}
	naRef	  = 7;  {Very small name, used as reference on screen to mark who it is - usually the first
											word of the surname, alias, etc}

	{really only used for people:}
	naFirstInit=8; 	{Mr M Hill, not Mr M C Hill}
	naSurname = 9;
	naTitlSur =10;	{Mr Hill}
	naFullInformal = 11;  {Martin Hill}

	{--- Justify types ----}
	juLeft = 1;
	juRight = 2;
	juCentre = 3;
	juFull = 4;


{=============== STRINGS =========================}
{Padding/Deleting}
function DelCharL(const S : string; const C : char) : string;
function DelCharR(S : string; const C : char) : string;
function DelSpaceL(const S : string) : string;
function DelSpaceR(const S : string) : string;
function DelSpace( const S : string) : string;
function DelAllChar(S : string; const C : char) : string;
function DelAllSpaces(const S : String) : String;
function DelNulR(  const S : string) : string;
function DelZeroR( const S : string) : string;
function DelTildes(const S : String) : String; {remove ~ characters}

function TrimCRLF(S : string) : string; {removes crlf's from rhs}

function TrimToNumL(S : string) : string; {removes non-numeric from lhs}
function TrimToNumR(S : string) : string; {removes non-numeric from rhs}
function TrimToNum(S : string) : string; {removes non-numeric from both sides}

function PadNulR(  const S : string; const NewLen : byte) : string;
function PadZero(  const S : string; const NewLen : byte) : string;
function PadSpaceL(const S : string; const NewLen : byte) : string;
function PadSpaceR(const S : string; const NewLen : byte) : string;

function SetLength(const S : string; const NewLen : byte) : string;

function Space(    const Len : byte) : string;
function Chars(    const Len : byte; C : char) : string;

function Right(const S : string; const N : byte) : string;  {the N right characters}
function UCase(s : string) : string;
function CapitalInitials(S : string) : string; {lower case, with capital first letter of each word}

{counting, finding}
function Count(const C : char; const S : string) : byte;  {number of occurences of char in String}
function CharPos(const Sub : string; const S : string) : byte;

{Comparing}
function MatchLength(const S1, S2 : string) : byte; {returns length that S1 matches S2}
function BestMatchLength(const Try1, Try2, Find : string) : integer; {Returns -1 if Try1 best, 1 if try2, 0 if equal}
function ComparePartialStrings(Partial, Full : string) : boolean; {for analysis/reports}

{Words & Lines}
function NumLines(const S : string) : byte; {shortcut to count}
function XPos(S : string) : byte; {number of chars since last crlf}

function NumWords(const S : string) : byte; {for now, expects a line - ie no crlf}
function WordNo(S : string; const Num : byte) : string;
function FirstWord(S : String) : string;
function LastWord(S : string) : string;
function WordAbout(const S : string; const P : integer) : string;
function DelLastWord(S : string) : string;

function GetLine(S : string; const LineNo : byte) : string;

function SplitAt(var Sentence : string; const Pos : integer) : string; {returns first part of string, chops down sentence}
function SplitBy(var Sentence : string; const Chars : string) : string;
function SplitByWord(var Sentence : string) : string;

function WordBreakPos(const S : string; const TestPoint : integer) : integer; {Returns pos of word break previous to N}

{Extracts just one line, given word break test point and line number}
function WordBreakLine(S : string; const TestPoint : integer; const Line : byte) : string;
function WordBreakString(S : string; const TestPoint, Tab : integer) : string;

{expects just one line - no crlf, etc}
procedure JustifyLine(var S : string; const Width, Justify : byte);

function TabOut(const S,Tabs : string; const Width : integer) : string;

{======== NAMES =====================}
function Initials( S : string)  : string;

function GetName(const SurName, ForName, Title, DearName : string; naType : byte; Maxlen : byte) : string;

{=============== NUMBER/STRING CONVERSIONS =========================}
var
	ValErr : integer;

{for fast numeric conversions}
function Units(const W : word) : char;
function Tens(const W : word) : char;

function GetNumbers(const S : string) : string;

function N2Str(L : longint) : string;
function R2Str(const R : real; const DecType : word; maxlen : word) : string;

function S2Num(const S : string) : longint;
function S2Real(S : string) : real;

{----- Number processing -----------}
function NumBits(x : longint) : byte; {the number of bits in x}
function Binary(x : longint) : string;
function Hex(x : longint) : string;
function Hex2Dec(H : string) : longint;
function AddOrdinator(No : integer) : string;  {add st, th, etc eg 1->1st}
function RoundUp(const R : real) : longint;
function InLongintRange(const R : real) : boolean;
function UnSign(const L : longint) : longint; {unsigns a value L}

function Exp2(x : byte) : longint; {returns 2 to the power of x}
function Exp10(x : byte) : longint; {returns 10 to the power of x}

{fractions}
function Frac2Real(const S : string) : real;
procedure Frac2Num(const S : String; var Numer, Denom : word);
function SimplifyFracStr(const S : string) : String;
procedure SimplifyFrac(var Numer, Denom : word);

function MakeBar(const Len : byte) : string; {makes a "proportion" bar}

function PakLint(const L : longint) : string; {returns four-char string of 4 longint bytes}
function UnPakLint(const S : string) : longint;
function RPakLint(L : longint) : string; {reversed of above paklint}

{---- PChar functions - extensions to strings unit ----}
procedure StrDel(var S : PChar; const Start, Count : word);
function StrFromPS(const PStr : string) : PChar; {reserves space, etc, converts pascal string to PChar}
procedure StrAppPS(var S : PChar; const PStr : string); {appends pascal string to pchar}
procedure StrPrefixPS(var S : PChar; const PStr : string); {adds pascal string to beginning of pchar}
function StrGetFirstLine(const PC : PChar) : string; {returns first line, ie up to crlf}

{---- Miscellaneous ----------------}
function Loc(x : pointer) : string;{}
function HeapLeft : string; {returns in hex}
function StackLeft : string; {ditto}

function MaxOf(const V1, V2 : longint) : longint;
function MinOf(const V1, V2 : longint) : longint;

IMPLEMENTATION

uses strings; {for pchar processing}

{*****************************************************************
 ***                                                           ***
 ***               STRING PROCESSING                           ***
 ***                                                           ***
 *****************************************************************}
{==== INTERNAL ROUTINES ========}
{--- Deleting ----}
function DelCharL(const S : string; const C : char) : string;
var B : byte;
begin
	B := 1; while (S[B]=C) and (B<length(S)) do inc(B);
	if B>1 then DelCharL := Copy(S,B,length(S)-B+1) else DelCharL := S;
end;

function DelCharR(S : string; const C : char) : String;
begin
	{keep decrementing line pointer until char has gone.  Need also to
	check for S[0]<>0 in case C is #0}
	while (S[length(S)] = C) and (S[0]<>#0) do dec(S[0]);
	DelCharR := S;
end;

function DelAllChar(S : string; const C : char) : string;
begin
	while Pos(C,S)>0 do system.Delete(S, pos(C,S), 1);
	DelAllChar := S;
end;


{--- Padding -----}
function PadCharL(S : string; const C : char; const NewLen : byte) : string;
begin
	if length(S)>NewLen then S:= DelCharL(S,C); {chop out existing chars}
	if length(S)<NewLen then S:= Chars(NewLen-length(S),C)+S;
	PadCharL := S;
end;

function PadCharR(S : string; const C : char; const NewLen : byte) : string;
begin
	if length(S)>NewLen then S := DelCharR(S,C);
	if length(S)<NewLen then S:= S + Chars(NewLen-length(S),C);
	PadCharR := S;
end;

{-- Trim CRLF's from RHS ----}
function TrimCRLF(S : string) : string;
begin
	while (S[0]>#1) and (S[length(S)-1] = #13) and (S[length(S)] = #10) do dec(S[0],2);
	TrimCRLF := S;
end;

function TrimToNumL(S : string) : string;
var I : byte;
begin
	I := 1;
	while (I<length(S)) and (pos(S[I], '0123456789')=0) do inc(I);
	TrimToNumL := Copy(S,I,length(S));
end;

function TrimToNumR(S : string) : string;
var I : byte;
begin
	I := length(S);
	while (I>0) and (pos(S[I], '0123456789')=0) do dec(I);
	TrimToNumR := Copy(S,1,I);
end;

function TrimToNum(S : string) : string;
begin
	TrimToNum := TrimToNumR(TrimToNumL(S));
end;

{============= SHORTCUTS TO CALLING ABOVE ===============}
{--- Deleting -----}
function DelSpaceL(const S : string) : string;
begin DelSpaceL := DelCharL(S, #32); end;

function DelSpaceR(const S : string) : string;
begin DelSpaceR := DelCharR(S, #32); end;

function DelSpace(const S : string) : string;
begin DelSpace := DelSpaceL(DelSpaceR(S)); end;

function DelNulR(const S : string) : string;
begin DelNulR := DelCharR(S, #0); end;

function DelTildes(const S : string) : string;
begin DelTildes := DelAllChar(S, '~'); end;

function DelZeroR(const S : string) : string;
begin DelZeroR := DelCharR(S, '0'); end;

function DelAllSpaces(const S : string) : string;
begin DelAllSpaces := DelAllChar(S, ' '); end;


{--- Padding -----}
function PadZero(const S : string; const NewLen : byte) : string;
begin PadZero := PadCharL(DelSpaceL(S),'0',NewLen); end; {chop out spaces}

function PadNulR(const S : string; const NewLen : byte) : string;
begin PadNulR := PadCharR(S, #0, NewLen); end;

function PadSpaceL(const S : string; const NewLen : byte) : string;
begin PadSpaceL := PadCharL(S, ' ', NewLen); end;

function PadSpaceR(const S : string; const NewLen : byte) : string;
begin PadSpaceR := PadCharR(S, ' ', NewLen); end;


{====== MORE STRINGS ===============}
function Space(const Len : byte) : string;
begin Space := Chars(Len, #32); end;

function Chars(const Len : byte; C : char) : string;
var S : string;
begin
	S[0] :=char(Len);
	FillChar(S[1], Len, C);
	Chars := S;
end;

function SetLength;
begin
	SetLength := PadSpaceR(Copy(S,1, NewLen),NewLen);
end;

{Takes last n chars}
function Right;
begin
	if length(S)>N then
		Right := copy(S,length(S)-N+1,N)
	else
		Right := S;
end;

{count number of occurances of a char in a string}
function Count;
var Num : byte;
		P : byte;
begin
	Num := 0;
	for P := 1 to length(S) do if S[P] = C then inc(Num);
	Count := Num;
end;

{finds first occurence of any of the chars in sub in S}
function CharPos;
var P, CP, C : byte;
begin
	CP := 0;
	for C := 1 to length(Sub) do begin
		P := Pos(Sub[C], S); {position of char}
		if P<>0 then if (P<CP) or (CP=0) then CP := P;
	end;
	CharPos := CP;
end;


{convert to upper case}
function UCase(s : string) : string;
var i : integer;
begin
	for I:=1 to length(S) do S[i] := UPcase(S[i]); {upper case each character}
	Ucase := S;
end;

{converts to lower case, each word with capital letter}
function CapitalInitials(S : string) : string;
var i : integer;
begin
	for I:=1 to length(S) do
		if (I =1) or (S[i-1]=' ') then
			S[i] := UPcase(S[i])
		else
			if (S[i]>#32) and (S[i]<#96) then S[i] := char(ord(S[i]) or 32);

	CapitalInitials := S;
end;


{**********************************************
 ***         COMPARING/MATCHING             ***
 **********************************************}
{returns length of matching string, starting from beginning}
function MatchLength(const S1, S2 : string) : byte;
var B : byte;
begin
	B := 1;
	while (S1[B]=S2[B]) and (B<=length(S1)) and (B<=length(S2)) do inc(B);
	MatchLength := B-1;
end;

{Finds whether string try1 or try2 matches "find" better - ie how many of
the starting chars match}
{Returns -1 if Try1 best, 1 if try2, 0 if equal}
function BestMatchLength(const Try1, Try2, Find : string) : integer;
var P1,P2 : byte;
begin
	P1 := MatchLength(Try1,Find);
	P2 := MatchLength(Try2,Find);
	if P1>P2 then BestMatchLength := -1
		else if P1=P2 then BestMatchLength := 0 else BestMatchLength := +1;
end;

{Used for search/analysis - eg comparing telephone numbers}
function ComparePartialStrings(Partial, Full : string) : boolean;
begin
	{convert to upper case & remove all spaces}
	Partial := DelAllSpaces(UCase(Partial));
	Full := DelAllSpaces(UCase(Full));

	{Do not select if full hasn't something but something is wanted}
	if (Full='') and (Partial<>'') then
		ComparePartialStrings := False
	else
		ComparePartialStrings := (Partial = '') or (Pos(Partial, Full)>0);

end;

{*************************************************
 ***         WORD PROCESSING (!)               ***
 *************************************************}
const
	PunctChars = '.,;:?!';
	WordBreakChars = PunctChars+' '; {full stop, commas and spaces separate words}

{finds number of characters since last CRLF}
function XPos(S : string) : byte;
var X : byte;
begin
	X := length(S)-1;
	while (X>0) and (Copy(S,X,2)<>CRLF) do dec(X);
	if X=0 then XPos := length(S) else XPos := length(S)-X-1;
end;

{locates end (forwards true) or start (forwards false) of word from startpoint}
function WordGapPos(S : String; StartPoint : byte; const Forwards : boolean) : byte;
begin
	{if on a space already...}
	if pos(S[StartPoint], WordBreakChars)<>0 then begin
		while (StartPoint>0) and (StartPoint<=length(S)) and
			(pos(S[StartPoint], WordBreakChars)<>0) do
				if Forwards then dec(StartPoint) else inc(StartPoint);

	end else begin
		while (StartPoint>0) and (StartPoint<=length(S)) and
			(pos(S[StartPoint], WordBreakChars)=0) do
				if Forwards then inc(StartPoint) else dec(StartPoint);

			if Forwards then dec(StartPoint) else inc(StartPoint); {return to end/start of word}
	end;

	WordGapPos := StartPoint;
end;

function DelLastWord;
var P : byte;
begin
	P := length(S);
	while (P>0) and (pos(S[P], WordBreakChars)>0) do dec(P); {skip spaces, etc at end}
	if P>0 then P := WordGapPos(S, P, False)-1; {search back from end of word}
	while (P>0) and (pos(S[P], WordBreakChars)>0) do dec(P); {skip spaces, etc between words}
	DelLastWord := Copy(S,1,P);
end;


function FirstWord(S : string) : string; {splits before space, comma, stop}
begin
	FirstWord := Copy(S,1, WordGapPos(S, 1, True));
end;

{Includes all spaces before word, and all punctuation marks after}
function UpToEndFirstWord(S : string) : string; {as above but includes all spaces before word}
var P : word;
		W : string;
begin
	P := 1;
	while (P<length(S)) and (S[P]=' ') do inc(P);
{	UpToEndFirstWord := Copy(S,1,WordGapPos(S, P, True)); {this, by itself, returns '' if it finds '  .'}
	S := Copy(S,P,length(S));               {chop out spaces}
	W := Copy(S,1,WordGapPos(S, 1, True));  {locate end of word}
	S := Copy(S,length(W)+1,length(S));
	while (length(S)>0) and (pos(S[1], PunctChars)>0) do begin
		W := W + S[1];
		S := Copy(S,2,length(S));
	end;
	UpToEndFirstWord := space(P-1)+W;
end;



function NumWords(const S : string) : byte;
var P : byte;
		Mode, OnWord : boolean; {mark whether over word}
		Num : byte;
begin
	if S = '' then begin
		NumWords := 0;
		exit;
	end;

	P := 0; Mode := False; Num := 0;
	repeat
		inc(P);
		OnWord := pos(S[P], WordBreakChars)=0;
		if Mode<>OnWord then begin
			if OnWord then inc(Num);
			Mode := OnWord;
		end;
	until P=length(S);

	NumWords := Num;
end;


{extracts word number "num" from string}
function WordNo(S : string; const Num : byte) : string;
var N : byte;
begin
	for N := 1 to Num do
		WordNo := SplitbyWord(S); {splits off each word}
end;

function LastWord(S : string) : string; {split after last space}
begin
	S := DelspaceR(S);
	LastWord := copy(S,WordGapPos(S, length(S), False), 256);
end;

{Gets word (ie split by space, stop or comma) around the position P}
function WordAbout(const S :string; const P : integer) : string;
begin
	WordAbout := LastWord(copy(S,1,P))+FirstWord(copy(S,P+1,length(S)));
end;


function NumLines(const S : string) : byte;
begin
	NumLines := Count(#13, S)+1;
end;

{Gets line given by LineNo in S, using CR as line separator}
function GetLine;
var	LineCOunt : byte;
		P : byte;
begin
	LineCount := 0; GetLine := '';
	while (LineCount<LineNo) and (length(S)>0) do begin
		P := pos(#13,S+#13);
		GetLine := Copy(S,1,P-1); 				{extract first line}
		delete(S,1,P); 									{delete first line}
		if S[1]=#10 then delete(S,1,1); 	{delete Line feed if present}
		inc(LineCount);
	end;
	if LineCount<LineNo then GetLine := '';
end;




{------------ Split first "word" by given character ---------}
{eg can split off first word out of a sentence by passing space
as breaking character.  If breaking character not found, "word" is taken
to be rest of sentence, sentence is := ''}
function SplitBy(var Sentence : string; const Chars : string) : string;
var P : byte;
begin
	{find position}
	P := 1;
	while {(P>0) and{} (P<=length(Sentence)) and	(pos(Sentence[P], Chars)=0) do inc(P);

	SplitBy := SplitAt(Sentence, P); {chop out word}

	{and remove excess chars from start of sentence}
	while (Sentence[0]>#0) and (pos(Sentence[1], Chars)<>0) do delete(Sentence,1,1);
end;

function SplitByWord(var Sentence : string) : string;
begin
	SplitByWord := SplitAt(Sentence, WordGapPos(Sentence, 1, True)+1);

	{get rid of superfluous chars at start of sentence}
	while (length(Sentence)>0) and (pos(Sentence[1], WordBreakChars)>0) do
		Sentence := Copy(Sentence,2,length(Sentence));
end;


{NB - ASSUMES that the character at Pos is not wanted...}
function SplitAt(var Sentence : string; const Pos : integer) : string;
begin
	SplitAt := Copy(Sentence,1,Pos-1);
	Sentence := Copy(Sentence,Pos+1,length(Sentence));
end;

{------------- Word Break ------------------}
{Given string and test point (ie maximum length of line) will work back
to find where word break would go, ie last *space*}
{Returns position of SPACE}
function WordBreakPos(const S : string; const TestPoint : integer) : integer;
var P : byte;
begin
	if (pos(CRLF,S)<=TestPoint) and (pos(CRLF, S)>0) then
		{if CRLF found first, force break point there}
		WordBreakPos := pos(CRLF,S)-1
	else
		if TestPoint>length(S) then
			WordBreakPos := length(S)  {end of line}
		else begin
			P := WordGapPos(S, TestPoint, False); {search backwards to beginning of word}
			if P>1 then WordBreakPos := P-1 else WordBreakPos := TestPoint;
		end;
end;

{Extracts just one line, given word break test point and line number}
function WordBreakLine;
var WorkLine : byte;
begin
	WorkLine := 0;
	while WorkLine<Line do begin
		{First go through previously extracted lines and remove}
		S := DelSpaceL(Copy(S,WordBreakPos(S,TestPoint)+1,length(S)));
		if Copy(S,1,2)=CRLF then S := Copy(S, 3, length(S)); {Remove CRLF's if that caused the breakpoint}
		WorkLine := WorkLine +1;
	end;
	WordBreakLine := Copy(S, 1, WordBreakPos(S, TestPoint));
end;

{Inserts CRLF's in string at appropriate break points}
function WordBreakString;
var WorkString : string;
		BreakPos : byte;
begin
	WorkString := '';
	while length(S)>0 do begin
		BreakPos := WordBreakPos(S,TestPoint);
		WorkString := WorkString + copy(S,1,BreakPos) + #13#10 + space(Tab);
		S := Copy(S,BreakPos+1,length(S));
	end;
	if WorkString<>'' then WorkString := copy(WorkString,1,length(WorkString)-Tab-2);  {chop out last CRLF}
	WordBreakString := WorkString;
end;


{------------------ TAB OUT ---------------------}
{replaces #8 (Tab) with spaces to fit tab settings}
function TabOut(const S,Tabs : string; const Width : integer) : string;
var TabPos,TabNum,LineNum : integer;
		Line,Out,R : string;
begin
	Out := '';
	for LineNum := 1 to NumLines(S) do begin
		Line := GetLine(S,LineNum);
		TabNum := 1;
		TabPos := CharPos(Tab+SkipTab, Line); {minilib - gets first occurence of tab or skiptab}
		while (TabPos<>0) and (TabNum<=length(Tabs)) do begin

			if Line[TabPos]=SKipTab then
				{remove skiptab}
				Line := Copy(Line,1,TabPos-1)+Copy(Line,TabPos+1,255)
			else
				{Insert spaces for tab}
				Line := SetLength(Copy(Line,1,TabPos-1), ord(Tabs[TabNum]))
								+copy(Line,TabPos+1, 255);

			inc(TabNum);
			TabPos := CharPos(Tab+SkipTab, Line);
		end;

		{Check for rightset}
		TabPos := pos(RightSet, Line);
		if TabPos>0 then begin
			R := ' '+Copy(Line, TabPos+1, 255); {rightset bit, add space for clarity}
			Line := Copy(Line, 1, TabPos-1); {leftset bit}
			R := DelAllChar(R, RightSet); {remove all rightset markers from rightset part}
		end else
			R := '';{}

		{NB - IT IS V.V. IMPORTANT THAT NO LINE IS LONGER THAN TDRAWBUFFER, OR
		THE DRAWDISPLAYITEM WILL CRASH!}
		if Width>0 then
			Line := SetLength(Line, Width-Length(R)) + R
		else
			Line := Line + R;

		Out := Out + Line+CR;
	end;

	TabOut := Copy(Out,1,length(Out)-1); {w/o last CR}
end;

{pass Line as string (w/o CR's) to justify, width as width to be set in,
and Justify as -1 left set (ie no change?), +1, right set, 0 centralised}
procedure JustifyLine(var S : string; const Width,Justify : byte);
var	W,L, R : string;
		InitToggle : byte;
		Toggle : boolean;
begin
	if Width=0 then exit;

	case Justify of
		juLeft 	: S := SetLength(S, Width);
		juRight : S := PadSpaceL(Right(S, Width), Width);  {Right justify/set length}
		juCentre: begin
			S := delspace(S);
			if length(S)>Width then
				S := Copy(S, 1, Width)
			else
				S := SetLength(Space((Width-length(S)) div 2) + S, Width);
			end;
		juFull : begin
			S := delspaceR(S);
			while (NumWords(S)>1) and (Length(S)<Width) do begin
				{Does three passes, first inserts after full stops/commas}
				L := ''; R := delspaceR(S); {*shouldn't* need to delspaceR, but JIC}
				while (R<>'') and (length(R)+length(L)<Width) do begin
					W := UpToEndFirstWord(R);
					R := Copy(R,length(W)+1,length(R));
					if (pos(W[length(W)],PunctChars)>0) and (length(R)>0) then W := W + ' '; {but not last word}
					L := L + W;
				end;
				S := L+R;

				{Pass II/III after every other word (starting with second)/first{}
				for InitToggle := 0 to 1 do begin
					L := ''; R := S;
					Toggle := InitToggle=1;
					while (R<>'') and (length(R)+length(L)<Width) do begin
						W := UpToEndFirstWord(R);
						R := Copy(R,length(W)+1,length(R));
						if Toggle and (length(R)>0) then W := W+ ' ';  {add space to everyother one (not last one)}
						Toggle := not Toggle;
						L := L + W;
					end;
					S := L+R;
				end;
			end;
			if (length(S)<Width) then S := SetLength(S, Width);
		end;

	end;
end;

{************************************************
 *** NAME FORMATS                             ***
 ************************************************}
{SPECIFICATION:
	NaDisplay - Surname,Forname
	NaAddress - Title ForeName Surname
	NaFull    - Title Forename Surname
	NaSurFull - Surname, Title Forname
	NaInitials- Title Initials SurName
	NaFirstInit-Title First Initial Surname
	NaDear    - Dear name or Title Surname

	TITLES:   SIR/DAME  - Always have full forename
				 - If just surname was required, substitute just full forename
		LORD - Never have any forename/initials

 NB - Problem if Sir & l% specified, forename does not fit but initial does
 SHOULD be that surname is cancelled & full forename is left
}
function Initials(S : string) : string;
var I : integer;
		SS : string;
begin
	DelSpace(S);
	if length(S)>0 then SS := S[1] else SS := ''; {first initial, first word}
	I := 1;  {Start at pos 2}
	while I<length(S) do begin
		I := I +1;         {Start at pos 2}
		if (S[I] = ' ') or (S[I]='.') then begin
			while ((S[I] = ' ') or (S[I]='.')) and (I<=length(S)) do I := I +1; {skip all spaces & stops}
			if (I<=length(S)) and (S[I]<>'.') then SS := SS + ' ' + S[I];
		end;
	end;
	Initials := SS;
end;

function GetName(const SurName, ForName, Title, DearName : string; naType : byte; Maxlen : byte) : string;
var T,F,S,I,N,TType : string; {Title, Forname, Surname, Initials, Name}
		oldna : byte;

begin
	 S := DelSpaceR(Surname);
	 F := DelSpaceR(Forname);
	 T := DelSpaceR(Title);
	 I := initials(ForName);
	 if naType = naFirstInit then if length(I)>0 then I:=I[1]+I[2];  {First initial plus space}

	 {Special cases of titles}
	 TType := ucase(T);  {To make checks easier for lord, etc}
	 if (TType = 'SIR') or (TType = 'DAME') then begin
		 I := F;  {Always have full forename}
		 if (naType = naDear) or
				(naType = naReport) or
				(naType = naTitlSur) then S := F;  {Dear should have Sir Peter not Sir Pontifront}
	 end;
	 if TType = 'LORD' then begin
		 I := '';
		 F := '';
	 end;

	 if F<>'' then F:=F+' ';
	 if T<>'' then T:=T+' ';
	 if I<>'' then I:=I+' ';

	 case naType of
		 naRef : begin N := DearName; if N = '' then N := FirstWord(S); end; {first word of surname}
		 naDisplay : begin N := S; if F<>'' then N := N + ',' + F; end;
		 naAddress : if pos('ESQ',ucase(S))>0 then {esquire - initials plus surname}
										N := I+S
								 else
										if T = '' then N := F+S else N := T+F+S;

		 naFull    : N := T+F+S;
		 naReport : begin N := S; if T+F<>'' then N := N +', '+T+F; end;  {Surname first, but full}
		 naInitials : N := T+I+S;
		 naFirstInit: N := T+I+S;
		 naDear    : begin
									if DearName=space(length(DearName)) then begin
										{automatic dear}
										N := T+S;
										if delspace(N)='' then N := 'Sir/Madam';
										if (T = '') and (ucase(Right(delspace(S),3))='ESQ') then N := 'Mr '+S; {esquire}
									end	else
										if ucase(DearName)='BLANK' then N := ''	else N := DearName;
								 end;
		 naSurname : N := S;
		 naTitlSur : N := T+S;
		 naFullInformal : N := F+S;
	 else
		 N := S;  {Just in case missing wossname}
	 end;

	 {Doesn't fit, so attempt to squeeze}
	 while (length(N)>Maxlen) and (Maxlen<>0) and (naType<>naSurname) and (naType<>oldna) do begin
			 oldna := naType; {To prevent looping}
			 case naType of
				 naAddress : naType := naInitials;
				 naFull    : naType := naInitials;
				 naReport : naType := naDisplay;
				 naInitials: naType := naFirstInit;
				 naFirstInit : naType := naTitlSur;
				 naTitlSur : naType := naSurname;
			 end;
			 N := GetName(SurName, ForName, Title, DearName, naType, 0);
	 end;

	 if (length(N)>Maxlen) and (Maxlen<>0) then N := Copy(N,1,Maxlen);

	 GetName := N;
end;




{********************************************
 ***        NUMBER/STRING CONVERSIONS     ***
 ********************************************}

{for fast numeric conversions}
function Units(const W : word) : char;
begin Units := char(W mod 10 + 48); end;

function Tens(const W : word) : char;
begin Tens := char((W div 10) mod 10 + 48); end;


{extracts just numbers from string}
function GetNumbers;
var N : string;
		I : byte;
begin
	N := '';
	for I := 1 to length(S) do
		if (S[I]>='0') and (S[I]<='9') then
			N := N + S[I];
	GetNumbers := N;
end;





{---------- Add ordinator ----------}
function AddOrdinator;
var S : string;
begin
	S := N2Str(No);

	if S<>'' then begin
		if S[length(S)-1]<>'1' then  {If it's not 11,12,13 etc which are all th}
			case S[length(S)] of
				'1' : S := S + 'st';
				'2' : S := S + 'nd';
				'3' : S := S + 'rd';
			else
				S := S + 'th';
			end
		else
			S := S + 'th';
	end;

	AddOrdinator := S;
end;


{==== NEW VAL() PROCEDURE - doesn't get upset over spaces ========}
procedure EValR(s: string; var Value : real; var ErrCode : integer);
begin
	S := DelSpace(S);
	while ((S[length(S)]>=#58) or (S[length(S)]<=#47)) and (length(S)>0) do S := copy(S,1,length(S)-1);  {Remove letters at end}
	If S ='' then S:='0';
	Val(S, value, ErrCode);
end;

{==== For long integers ========}
procedure EVal(s: string; var Value : longint; var ErrCode : integer);
var R : real;
begin
{	S := DelSpace(S);
	while ((S[length(S)]>=#58) or (S[length(S)]<#45)) and (length(S)>0) do S := copy(S,1,length(S)-1);  {Remove letters at end}
{	If S ='' then S:='0'; {}
	R := Value;	EValR(S, R, ErrCode); Value := round(R);
end;



{------- Num to string -------}
{provides an easier route to the Str() procedure, returning a string
as a function.  Two functions, one for real and one longint to cover
byte, word, integer, etc}
function N2Str(L : longint) : string;
var S : string;
begin Str(L,S); N2Str := S; end;

function L2Str(L : longint) : string;
begin L2Str := N2Str(L); end; {compatibility with old system with its word, byte, etc funcs}

{------- Real to String ----}
{Does conversion with complete number, avoiding the 2.5E+0001 format.  This
is done by specifying the number of decimal places, maximum accuracy 9 through
this routine}
function R2Str(const R : real; const DecType : word; maxlen : word) : string;
var S : string;
		dcType : word;
		ExpPos, DecPos, nodecs : byte;


begin
	dcType := (DecType and $FF00);
	NoDecs := (DecType and $00FF);

	S := '';

	if NoDecs<>0 then
		Str(R : maxlen : NoDecs, S)
	else
		if dcType = dcNone then
			{no dec places}
			Str(R : maxlen : 0, S)
		else
			{auto/all decimal points}
			Str(R : maxlen : 9, S);

	if ((dcType and dcBlankZero)>0) and (S2Real(S)=0) then begin
		R2Str := space(Maxlen);
		exit;
	end;

	if Maxlen>0 then S := Copy(S,1,Maxlen); {doesn't always seem to work above}


	if ((dcType and dcFixed)=0) then begin
		{remove trailing zeros}
		while (S[Length(S)]='0') and (length(S)>0) do dec(S[0]);
		if (length(S)>0) and (S[length(S)]='.') then dec(S[0]);
	end;

	R2Str := S;
end;

{---- String to Number ----}
function S2Num(const S : string) : longint;
var L : longint;
begin EVal(S,L,ValErr); S2Num := L; end;


{---- String to Real No ----}
function S2Real(S : string) : real;
var R : real;
		C : byte;

begin
	{chop out spaces}
	S := DelSpace(S);
	{make sure that a blank does not return an error}
	If S ='' then begin
		S2Real := 0;
		ValErr := 0;
	end else begin
		{extract only initial numbers (so "3 boxes" or "5x10" converts to 3 or 5}
		C := 1;
		while (ord(S[C])<=58) and (ord(S[C])>=45) and (C<=length(S)) do inc(C);

		Val(Copy(S,1,C-1), R, ValErr);
		S2Real := R;
	end;
end;

{************************************
 ***         NUMBER STUFF         ***
 ************************************}
{returns the maximum of two numbers.  Amazing how often
a simple function like this can simplify code...}
function MaxOf(const V1, V2 : longint) : longint;
begin
	if V1>V2 then MaxOF := V1 else MaxOf := V2;
end;

function MinOf(const V1, V2 : longint) : longint;
begin
	if V1<V2 then MinOf := V1 else MinOf := V2;
end;


{Round up}
function RoundUp;
begin
	if Round(R) = R then
		RoundUp := round(R)
	else
		RoundUp := trunc(R + 1);
end;

{Check for real number in longint range}
function inLongintRange;
begin
	inLongintRange := (R>-2147483647) and (R<2147483647);
end;

{======== 2 to the power of ================}
function Exp2(x : byte) : longint;
var L : longint;
begin
	L := 1;  {force type for calc}
	Exp2 := L shl x;
end;

{======== 10 to the power of ================}
function Exp10(x : byte) : longint;
var W : longint;
		B : byte;
begin
	W := 1;
	for B := 1 to x do W := W *10;
	Exp10 := W;
end;

{======= Unsign an integer ==================}
function Unsign(const L : longint) : longint;
begin
	if L<0 then Unsign := -L else Unsign := L;
end;


{=== GENERAL POWER FUNCTION ============}
{ Generalized power function by Prof. Timo Salmi, Garbo.fi}
function PowerFn(number, exponent : real) : real;
begin
	if exponent = 0 then
		PowerFn := 1
	else
		if number = 0 then
			PowerFn := 0
		else
			if abs(exponent*Ln(abs(number))) > 87.498 then
				begin writeln ('PowerFn Overflow(',Number,',',Exponent,')'); halt; end
			else
				if number > 0 then
					{positive number}
					PowerFn := Exp(exponent*Ln(number))
				else

					if (number < 0.0) and (Frac(exponent) = 0.0) then
							if Odd(Round(exponent)) then
								PowerFn := -PowerFn(-number, exponent)
							else
								PowerFn :=  PowerFn(-number, exponent)
						else
							begin writeln ('PowerFn Invalid(',Number,',',Exponent,')'); halt; end;
end;

type TBCD = array [0..7] of char;

procedure StrToBCD (s : string; var b : TBCD);
var i, p : byte;
begin
	FillChar(b, SizeOf(b), '0');
	p := Length (s);
	if p > 8 then exit;
	for i := p downto 1 do b[p-i] := s[i];
end;  (* strtobcd *)

function BCDtoDec (b : TBCD; var ok : boolean) : longint;
const Digit : array [0..9] of char = '0123456789';
var i, k : byte;
		y, d : longint;
begin
	y := 0;
	d := 1;
	ok := false;
	for i := 0 to 7 do begin
		k := Pos (b[i], Digit);
		if k = 0 then exit;
		y := y + (k-1) * d;
		if i < 7 then d := 16 * d;
	end; { for }
	ok := true;
	BCDtoDec := y;
end;  (* bcdtodec *)

function LHEXFN (decimal : longint) : string;
const hexDigit : array [0..15] of char = '0123456789ABCDEF';
var i : byte;
		s : string;
begin
	FillChar (s, SizeOf(s), ' ');
	s[0] := chr(8);
	for i := 0 to 7 do
		s[8-i] := HexDigit[(decimal shr (4*i)) and $0F];
	lhexfn := s;
end;  (* lhexfn *)
	{}

function DecToBCD (x : longint; var ok : boolean) : longint;
 const Digit : array [0..9] of char = '0123456789';
 var hexStr : string;
 var i, k : byte;
		 y, d : longint;
 begin
	 hexStr := LHEXFN(x);
	 y := 0;
	 d := 1;
	 ok := false;
	 for i := 7 downto 0 do begin
		 k := Pos (hexStr[i+1], Digit);
		 if k = 0 then exit;
		 y := y + (k-1) * d;
		 if i > 0 then d := 10 * d;
	 end; { for }
	 ok := true;
	 DecToBCD := y;
end;  (* dectobcd *)


{*************************************************
 ***        PCHAR ROUTINES                     ***
 *************************************************}
function StrFromPS(const PStr: string) : PChar;
var P : Pchar;
begin
	GetMem(P, length(PStr)+1); {reserve space + space for #0}
	StrPCopy(P, PStr);
	StrFromPS := P;
end;

{!! no range checking! 0 is first char}
procedure StrDel(var S : PChar; const Start, Count : word);
var NewS : PChar;
		NewLen : word;
begin
	if Count>=StrLen(S) then begin
		StrDispose(S);
		S := nil;
	end else begin
		NewLen :=StrLen(S)-Count;
		GetMem(NewS, NewLen+1); {+1 for null terminator}
		Move(S[0], 						NewS[0], 			Start); {copy up to startpoint}
		Move(S[Start+Count], 	NewS[Start], 	NewLen-Start); {copy from past start+count}
		NewS[NewLen] := #0; 			{set last character to null}
		StrDispose(S);
		S := NewS;
	end;
end;

procedure StrAppPS(var S : PChar; const PStr : string);
var NewS : PChar;
		AppendStr : PChar;
begin
	if S=nil then
		S := StrFromPS(PStr)
	else begin
		GetMem(NewS, StrLen(S)+length(PStr)+1); {reserve space for both (incl 1 byte for #0)}
		StrCopy(NewS, S); {copy in existing pchar string}
		AppendStr := StrEnd(NewS); {find end of that string}
		StrPCopy(AppendStr, PStr); {copy in pascal string type}
		StrDispose(S);
	end;
	S := NewS;
end;

procedure StrPrefixPS(var S : PChar; const PStr : string);
var NewS : PChar;
		AppendStr : PChar;
begin
	if S=nil then
		S := StrFromPS(PStr)
	else begin
		GetMem(NewS, StrLen(S)+length(PStr)+1); {reserve space for both (incl 1 byte for #0)}
		StrPCopy(NewS, PStr); {copy in pascal type string}
		StrCat(NewS, S); 			{copy in pchar string}
		StrDispose(S);
	end;
	S := NewS;
end;

function StrGetFirstLine(const PC : PChar) : string;
var S : string;
		C : word;
begin
	C := 0;
	S := '';

	while (PC[C]<>#13) and (C<StrLen(PC)) do begin S := S + PC[C]; inc(C); end;

	StrGetFirstLine := S;
end;


{**************************************************
 ***           MISCELLANEOUS                    ***
 **************************************************}

function Loc(x : pointer) : string;
type PPointer = ^TPointer;
			TPointer = array[1..4] of byte;
var
	xAddress : PPointer;
	HS, HO : string;

begin
	{Can't deref pointer as it might be illegal, so}
	{First find location of pointer, then return memory at that point}

	xAddress := PPointer(Addr(x));

	HS := hex(xAddress^[3] + xAddress^[4]*256);
	HO := hex(xAddress^[1] + xAddress^[2]*256);

	Loc := HS+':'+HO;
end;

{======= HEAP LEFT =========}
function HeapLeft : string;
{var T : longint; S : string;{}

begin
{	T := MemAvail;{}
	HeapLeft := hex(MemAvail);
{	HeapLeft := S;{}
end;

{======= STACK SIZE/LEFT =======}
function StackLeft : string;
begin
	StackLeft := {hex(SSeg)+':'+}N2Str(SPtr);
end;

{****************************************************
 ***               BINARY STUFF                   ***
 ****************************************************}
function NumBits(x : longint) : byte;
var N : byte;
begin
	N := 0;
	while x<>0 do begin
		if x and $01 >0 then inc(N);
		x := x shr 1;
	end;
	NumBits := N;
end;



{---------------- HEX ----------------------}
const
	HexChars: array [0..$F] of Char = '0123456789ABCDEF';

{returns hex char of nybble}
function HexNybble(B : byte) : char;
begin
	HexNybble := HexChars[B and $F];
end;


{Decimal to hex}
function Hex(x : longint) : string;
var
	S : string;

begin
	S := '';
	repeat
		S := HexChars[x and $F] + S; {not very efficient string processing...}
		X := X shr 4; {shift right four bits, ie /16}
	until x = 0;
	Hex := S;
end;

{Hexadecimal to decimal}
function Hex2Dec(H : string) : longint;
var L,P : longint;
		C : byte;

begin
	L := 0; P := 1; C := length(H);

	{work from RHS to LHS, using P as power of 16 to multiply by digit and add to L}
	while C>0 do begin
		L := L + (pos(H[C], HexChars)-1)*P;
		dec(C);
		P := P * 16; {increase power}
	end;

	Hex2Dec := L;
end;

{--------- BINARY -------------------}
function Binary;
var S : string;
begin
	S := '';
	repeat
		if (x and $1)=1 then S:='1'+S else S := '0'+S;
		x := x shr 1;
	until x = 0;
	Binary := S;
end;

{--- Convert fraction string to numerator/denominator -----}
procedure Frac2Num(const S : string; var Numer, Denom : word);
begin
	{get numerator}
	Numer := S2Num(Copy(S, 1, pos('/',S+'/')-1));

	if pos('/',S)>0 then
		DeNom := S2Num(Copy(S, pos('/',S)+1, 256))
	else
		DeNom := 1; {no denominator given --> xx = xx/1}
end;

function Frac2Real(const S : string) : real;
var Numer, DeNom : word;
begin
	Frac2Num(S, Numer, Denom); {split}

	Frac2Real := Numer/Denom;
end;


{simplify fraction given as numbers}
procedure SimplifyFrac(var Numer, Denom : word);
var Factor : word; {common factor}
begin
	if (Numer>0) and (Denom>0) then begin

		{find highest common factor & divide}
		Factor := NUmer;
		while ((Numer mod Factor)<>0) or ((Denom mod Factor)<>0) do dec(Factor);
		{it *will* find a common factor, even if it's only 1...}
		if Factor<>1 then begin
			Numer := Numer div Factor;
			Denom := Denom div Factor;
			SimplifyFrac(Numer, Denom);
		end;
	end;
end;

function SimplifyFracStr(const S : String) : string;
var Numer,Denom : word;

begin
	Frac2Num(S, Numer, Denom);

	if Numer = 0 then
		SimplifyFracStr := '0'
	else
		if Numer = Denom then
			SimplifyFracStr := '1'
		else begin
			SimplifyFrac(Numer, Denom);
			SimplifyFracStr := N2Str(Numer)+'/'+N2Str(Denom);
		end;
end;


function MakeBar(const Len : byte) : string;
begin
	MakeBar := Chars(len div 2, #219) + chars(len mod 2,#221);
end;

function PakLint(const L : longint) : string;
var S : String[4];
begin
	S := space(4);
	Move(L, S[1], 4);
	PakLint := S;
end;

function UnPakLint(const S : string) : longint;
var L : longint;
begin
	Move(S[1], L, 4);
	UnPakLint := L;
end;

{for sorting purposes, we need to reverse pak, ie hi byte first}
function RPakLint(L : longint) : string;
var S : String[4];
		B : byte;
begin
	S[0] := #4;
	for B := 4 downto 1 do begin
		S[B] := char(L and $FF);
		L := L shr 8;
	end;
	RPakLint := S;
end;




{$IFDEF Fixit}
begin
 writeln('Unit minilib...'); {$ENDIF}

end. {unit}

