addx hist string

adds` history: pascal string package (1990)

. this is a string package I built while programming at EWU (1990) ;
file handling utilities type conversions (string -to- { char, char array, text file, int } functions)
Format operations (tabs vs spaces )
String -to- String functions

functions that operate on a Word
-- a word being a textual unit deefined as:<
(1) any string of non-space non-tab chars;
(2) any quoted string.

string -to- index-finding functions
-- finding the beginning or end off the next occurrence
going forwards or backwards
depending on whether parameter"Start is positive or negative

-- we supposedly used pascal in college
only because object-oriented programming hadn.t been invented yet;
but when I was introduced to it after starting out on microsoft`basica,
I thought it was the most beautiful language I'd ever seen
. my current idea of what beautiful is
can be found in -- what else ? the language I designed myself -- adda

{ v.platform addx, links, home, pkg"string}

ADDX` history: pascal string package (1990)
1. types and subroutines specific to and shared among String modules
  1. {}{ " -- String functions that are dependent on string-heap's implementation. --" }
    1. {}{2} FUNCTION Rd( A, i:int ): char;
    2. {}{2} PROCEDURE Wr( A, i:int; ch:char );
    3. {}{2} FUNCTION Length(A:int ): int;
    4. {}{2} PROCEDURE SetLength( A, Length: int );
    5. {}{2} PROCEDURE OldStr( VAR C:int );
    6. {}{2} FUNCTION NewStr( VAR C:int ): boolean;
    7. {}{2} PROCEDURE InitStringHeap; VAR i: int;
  2. {}FUNCTION tabzone_index( length: int ): int;
  3. {}FUNCTION TabClass( length: int ): int;
  4. {}FUNCTION LenForLim( P1, P2 : int ): int;
  5. {} FUNCTION Range( VAR Start, Length: int; Limit: int ): boolean;
  6. {}FUNCTION RangeEO ( A : int ; VAR Start, Next, EO : int ): boolean ;
  7. {}PROCEDURE Mov ( Lay ,Start , SubLength , C , BedIndex : int );
    { v.platform addx, links, home, pkg"string}
2. file handling utilities
  1. {}PROCEDURE InitStrFile ;
  2. {}FUNCTION GetFileName ( A, Start, DefaultName, DefaultType, C: int ): int;
  3. {}PROCEDURE OpenFile ( VAR f : text ; Physical : int; Writing : boolean );
  4. {}PROCEDURE message( VAR Outs : text; VAR f: intfile; msg: int );
  5. {}FUNCTION FoundNameDate ( VAR f : text ; C : int ) : int ;
  6. {}PROCEDURE ReadFile ( VAR Outs , Ins : text );
3. String conversions (string -to- { char, char array, text file, int } functions)
  1. {}FUNCTION ReadStr( VAR f:text; C: int ): int; { -- Read to end of line. }
  2. {}PROCEDURE WriteStr( VAR f:text; A: int );
  3. {}FUNCTION Str32( A:String32; Length, C: int ): int;
  4. {}FUNCTION Str8( A:String8; Length, C: int ): int;
  5. {}FUNCTION IntStr( num, FieldSize, C: int ): int;
  6. {}FUNCTION CharStr( ch:char; C: int ): int;
  7. {}FUNCTION StrInt( A, Start : int ): int;
    { v.platform addx, links, home, pkg"string}
4. String Format operations (tabs vs spaces )
  1. {}FUNCTION LengthDeSpaced( A: int ): int;
  2. {}FUNCTION DeSpace( A, C: int ): int;
  3. {}FUNCTION DeTab( A, C: int ): int;
    1. {}{2}PROCEDURE PerformDeTab;
  4. {}FUNCTION EnTab( A, C: int ): int;
    1. {}{2}PROCEDURE PerformEntab; {---length(A) > 0 }
      { v.platform addx, links, home, pkg"string}
5. other String operations ( String -to- String functions)
  1. {}FUNCTION EmbedSubCopy ( Lay, Start, SubLength, Bed, BedIndex, C: int ): int;
    1. {} {2}PROCEDURE Perform;
  2. {}FUNCTION Embed( Lay, Bed, BedIndex, C: int ): int;
  3. {}FUNCTION EmbedMasking ( Lay, Start, SubLength, Bed, C: int ): int;
  4. {}FUNCTION SubCopy( A, Start, SubLength, C: int ): int;
  5. {}FUNCTION Copy( A,C:int ): int;
  6. {} FUNCTION Delete ( A, Start , Len, C : int ) : int ;
  7. {} FUNCTION Insert ( A, InsertPtr, B, Start , Len, C : int ) : int ;
    1. {} {2} PROCEDURE CopyB;
  8. {}FUNCTION Fillin( A: int; ch: char; Start, FiLength, C: int ): int;
    1. {} {2} PROCEDURE FillinSizeSpecified;
    2. {} {2} PROCEDURE FieldSizeSpecified;
  9. {} FUNCTION LeftJustified( A:int; ch:char; FieldSize, C: int ): int;
  10. {}FUNCTION Spaces( Length, C: int ): int;
  11. {} FUNCTION Indent( A, IndentSize, C: int ): int;
    { v.platform addx, links, home, pkg"string}
6. functions that operate on a Word
  1. {} FUNCTION WordLength ( Word : int ; Start : int ): int ;
  2. {}FUNCTION WordCopy( Word, Start, C: int ): int;
  3. {}FUNCTION ReadWord( VAR f:text; C: int ): int;
7. string -to- index-finding functions
  1. {}FUNCTION IndexNonSpace( A, Start: int ): int;
  2. {}FUNCTION IndexSpace( A, Start: int ): int;
  3. {} FUNCTION IndexStr( Target, Domain, Start: int ): int;
    1. {} {2}PROCEDURE ForwardIndex ;
  4. {}FUNCTION IndexKeyed ( Target, Domain: int ): int;
  5. {}FUNCTION IndexChar( ch: char; A, Start: int ): int;
  6. {}FUNCTION IndexNextWord ( A , Start : int ): int;
8. the test harness
  1. PROCEDURE Main;
    1. PROCEDURE pr( A: int );

{ v.platform addx, links, home, pkg"string}

types and subroutines specific to and shared among String modules

[ ENVIRONMENT ] (* NON-STD *)
{}{0} MODULE StrType ( input, output );
{


DOCUMENT NAME: StrType.PAS DATE: 1990.09.06 /08.24 /06.27

DESCRIPTION: Common types, and utility routines for all other Str Packages
InitStringHeap must be called by the application program before any other Str
routines are used. Temp and temp2 are available for temporary results.
OK is available to indicate fatal errors.

}
CONST
	TabSize = 8 ;
	StrNil = 0; Tab = ' '; Space = ' ' ; FormFeed = chr(12);
	{Heap string count}Max = 256;
TYPE
	int = integer;
	String8 = PACKED ARRAY [ 1..8 ] OF char;
	String32 = PACKED ARRAY [ 1..32 ] OF char;
	String = PACKED ARRAY [ 0..255 ] OF char;
	Str = ^String;
VAR
	Warning, OK: boolean;
	S : ARRAY[ 1..Max ] OF Str;
	P: int; { --gives function a parameter without arguments so in CALL can be used in debug
	--SET LANG PAS; DEP P:= 
CALL Len. }
	temp, temp2, { -- Spares to contain temporary results ( initing a local string is expensive ). }
	Av: int; { --Points at the next available place in StringHeap for a new string. }
{ v.platform addx, links, home, pkg"string}

{}{ " -- String functions that are dependent on string-heap's implementation. --" }

{}{2} FUNCTION Rd( A, i:int ): char;

BEGIN Rd := S[ A ]^[ i ] END;

{}{2} PROCEDURE Wr( A, i:int; ch:char );

BEGIN S[ A ]^[ i ] := ch END;

{}{2} FUNCTION Length(A:int ): int;

BEGIN Length := ord( S[ A ]^[ 0 ] ) END;

{}{2} PROCEDURE SetLength( A, Length: int );

BEGIN S[ A ]^[ 0 ] := chr( Length ) END;
{ v.platform addx, links, home, pkg"string}

{}{2} PROCEDURE OldStr( VAR C:int );

VAR temp: Str; BEGIN temp := S[ C ]; dispose( temp ); S[ C ]:= NIL; C:= StrNil END;

{}{2} FUNCTION NewStr( VAR C:int ): boolean;

LABEL Top;
VAR temp: Str; Maxed: boolean;
{--This heap expects StringHeap components to be NIL if available.
For each call to NewStr, successive components are allocated, until Av is Maxed,
apon which NewStr looks for components that OldStr may have set to NIL. }
BEGIN
Maxed:= ( Av > Max ); OK:= false;
IF NOT Maxed THEN
	OK := ( S[ Av ] = NIL );
Top:
IF NOT OK THEN BEGIN
	IF Maxed THEN Av:= 0;
	REPEAT Av:= Av+1;
	OK:= ( S[ Av ] = NIL ) 
	UNTIL NOT( Av < 256 ) OR OK END;
{--- NOT OK ==> searched from ( 1, or Av ) to Max and found no free heap space. }
IF NOT( OK OR Maxed ) THEN { --- NOT Maxed ==> it may not have started the check from the beginning, so...}
	BEGIN Maxed:= true; GOTO Top END;
{--- NOT OK ==> searched from 1 to Max and found no free heap space. }
IF OK THEN BEGIN
	new( temp ); S[ Av ]:= temp; C:= Av; SetLength( C, 0 );
	Av:= Av +1; NewStr := true END
ELSE BEGIN
	writeln( 'ERROR: string NewStr failed.' );
	NewStr := false END
END;

{}{2} PROCEDURE InitStringHeap; VAR i: int;

BEGIN Warning := true; Av := 1; FOR i:= 1 TO Max DO s[i] := NIL;
OK := NewStr ( temp ) AND NewStr ( temp2 ) END;
{ v.platform addx, links, home, pkg"string}

{}FUNCTION tabzone_index( length: int ): int;

BEGIN

tabzone_index:= length DIV TabSize END;

{}FUNCTION TabClass( length: int ): int;

BEGIN TabClass:= length MOD TabSize END;

{}FUNCTION LenForLim( P1, P2 : int ): int;

BEGIN LenForLim:= abs ( p1 - p2 ) +1 END;
{ v.platform addx, links, home, pkg"string}

{} FUNCTION Range( VAR Start, Length: int; Limit: int ): boolean;

{-- insures range doesn't exceed Limit, and that Length is positive with Start from left. }
VAR M

axindex, Trim: int;
BEGIN
Range:= NOT( Start = 0 );
IF Start < 0 THEN Start := -Start;
IF Length < 0 THEN BEGIN { -- Assume Start is indicating the right-most limit of the range. }
	Start := Start +1 +Length; { -- Now Start indicates the Left-most limit. }
	IF Start < 0 THEN Start := 1;
	Length:= -Length END;
IF Start > Limit THEN
	Length:= 0
ELSE BEGIN Maxindex:= Start -1 +Length; Trim:= Maxindex -Limit;
 IF Trim > 0 THEN BEGIN
	Length:= Length -Trim;
	IF Warning THEN writeln( 'WARNING StrType Range: Overflow truncation.' ) END
END 
END{ Range };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION RangeEO ( A : int ; VAR Start, Next, EO : int ): boolean ;

{
DESCRIPTION: the caller will use Start, Next, and EO like so:
i := Start ; WHILE NOT i = EO DO ( Body; i := i + Next )
}


VAR LenA : int ;
BEGIN{ RangeEO }
LenA := Length(A); RangeEO := true ;

IF ( Start = 0 ) THEN BEGIN
	RangeEO := false ; writeln( 'ERROR StrType RangeEO : start range. ' ) END
ELSE IF Start < 0 THEN BEGIN
	Start := - Start ; Next := -1; EO := 0 END
ELSE BEGIN
	Next := 1; EO := LenA +1
END{ if };
IF ( Start > LenA ) THEN BEGIN
	Start := EO; IF Warning THEN writeln( 'WARNING StrType RangeEO : start range. ' ) END
END;{ RangeEO }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE Mov ( Lay ,Start , SubLength , C , BedIndex : int );

{
DESCRIPTION: moves a string between 2 possibly overlapping areas.
Doesn't calculate length, but Start and BedIndex may equal zero.
Kernel routine -- no type-checking.
-- an expensive block move:
	FOR i:= Start TO Finish DO Wr( C, i+Cdif, Rd( A, i+Adif ));
	could be replaced by this efficient assembly language algorithm:
	PROCEDURE BlockMov( C, Cdif, A, Adif, Start, Finish: int );
	VAR i, Cstr, Astr: int;
	BEGIN
	Astr := VAX_ADDRESS( StringHeap[ A ]^[ 1 + Adif ] );
	Cstr := VAX_ADDRESS( StringHeap[ C ]^[ 1 + Cdif ] );
	FOR i:= Start TO Finish DO
	VAX_MOV( Astr+i, Cstr+i )
	END;
}

VAR LayEnd , Shift , i , d : int ;

BEGIN{ Mov }
LayEnd := Start -1 + SubLength; Shift:= BedIndex -Start;
IF Shift > 0 THEN BEGIN d:= Shift + LayEnd ;
	FOR i:= LayEnd DOWNTO Start DO BEGIN
	Wr( C, d, Rd( Lay, i )); d:= d-1 END END
ELSE IF( Shift < 0 ) OR NOT( Lay=C ) THEN BEGIN d := BedIndex ; { ==> S<0 or ( S=0 and FreshLay ) }
	FOR i:= Start TO LayEnd DO BEGIN
	Wr( C, d, Rd( Lay, i )); d:= d+1 END
END{ else Shift=0 and Lay = C so do nothing. }
END;{ Mov }

END.{ MODULE StrType }

{ v.platform addx, links, home, pkg"string}

file handling utilities

[ ENVIRONMENT , INHERIT ( 'StrType.PEN', 'StrCvt.PEN', 'StrFun.PEN', 'StrWord.PEN', 'StrIndex.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrFile ;
{

DOCUMENT NAME: StrFile.PAS DATE: 1990.09.04

DESCRIPTION:
 utilities for handling files. Needs initialization with InitStrFile.

}
TYPE
	intfile = FILE OF int;

VAR
{ CONSTANT STRINGS }
	NameQue, DateQue, { -- Keys "NAME:" and "DATE:" that identify corresponding strings. }

{ VARIABLE STRINGS }
	Name, Date: int ;{ -- The strings keyed by "NAME:" and "DATE:" found in user's file. }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE InitStrFile ;

BEGIN
NameQue:= Str8( 'NAME: ', 5, strNil ); DateQue:= Str8( 'DATE: ', 5, StrNil );
OK:= OK AND NewStr( Date ) AND NewStr( Name );
IF NOT OK THEN writeln( 'ERROR StrFile InitStrFile : mem. ')
END;{ InitStrFile }

{}FUNCTION GetFileName ( A, Start, DefaultName, DefaultType, C: int ): int;

{
GLOBAL: LOCAL Name ;
}
VAR LenC : int ; ch: char;
BEGIN
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
IF OK THEN C:= WordCopy ( A, Start, C );
IF NOT OK THEN
	writeln ( 'ERROR StrFile GetFileName : mem or range. ' )
ELSE BEGIN LenC := Length ( C ); GetFileName := C;
	IF LenC = 0 THEN
	C:= Copy ( DefaultName, C )
	ELSE IF IndexChar ( '.' , C , 1 ) = 0 THEN BEGIN
	Start := IndexChar ( ';' , C , 1 ); IF Start = 0 THEN Start := LenC +1 ;
	C := Insert ( C, Start, Append ( DefaultType , CharStr ( '.', Name), Name), 1, 255, C )
	END{ if }
END END;{ GetFileName }
	{ v.platform addx, links, home, pkg"string}

{}PROCEDURE OpenFile ( VAR f : text ; Physical : int; Writing : boolean );

VAR Name : String32 ; i , Len : int ;
BEGIN Len := Length( Physical ); FOR i := 1 TO 32 DO Name [i] := chr(0);
IF Len > 32 THEN
	writeln ( 'ERROR StrFile OpenFile : name truncation.' )
ELSE BEGIN FOR i := 1 TO Len DO Name [ i ] := Rd ( Physical , i );
	IF Writing THEN BEGIN OPEN ( f, Name, NEW ); rewrite( f ) END
	ELSE BEGIN OPEN ( f, Name, OLD ); reset( f ) END
END END;{ OpenFile }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE message( VAR Outs : text; VAR f: intfile; msg: int );

{
GLOBALS: OUT output , Outs ; WITH StrCvt USING WriteStr ;
DESCRIPTION: the file f contains indexes relevant to the string msg.
These indexes and the message are written out to both the output and Outs files. 
Rewrites the intfile.
}
CONST PageNumFieldSize = 5;
VAR z, Col: int;
BEGIN reset( f ); Col:= 0;
WriteStr( output, msg ); writeln;
WriteStr( Outs, msg ); writeln( Outs );
WHILE NOT eof( f ) DO BEGIN read( f, z );
	write( z: PageNumFieldSize ); write( Outs, z: PageNumFieldSize ); Col:= Col +PageNumFieldSize;
	IF Col > 80 THEN BEGIN writeln; writeln( Outs ); Col:= 0 END END;
writeln; writeln( Outs ); rewrite ( f )
END;{ message }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION FoundNameDate ( VAR f : text ; C : int ) : int ;

{
GLOBALS: NameQue , DateQue; OUT , output, Name , Date ;
WITH StrType IN temp, StrNil ; USING SetLength, ReadStr , NewStr ;
WITH StrIndex IN StrNil USING IndexKeyed, WordCopy
DESCRIPTION: Defines Name and Date with lines fed to it from file f.
If either Name or Date has already been found then FoundNameDate is
still looping for the other; it returns StrNil if neither is found.
If either string is found, then the returned string has the format:
( Name, 2 spaces, Date ). Expects file f to be reset and leaves the same.
}
VAR Named, Dated: int; {indices} Done: boolean;
BEGIN
Named:= 0; Dated:= 0; Done:= false; SetLength( Name , 0 ); SetLength( Date , 0 );
WHILE NOT Done AND NOT eof( f ) DO BEGIN temp:= ReadStr( f, temp );
	IF Named = 0 THEN BEGIN 
	Named := IndexKeyed ( NameQue , temp );
	IF NOT( Named =0 ) THEN Name := WordCopy( temp, Named , Name )
	END;{ if }
	IF Dated = 0 THEN BEGIN
	Dated := IndexKeyed ( DateQue, temp );
	IF NOT( Dated =0 ) THEN Date := WordCopy( temp, Dated , Date )
	END;{ if }
	Done:= NOT( Dated=0 ) AND NOT( Named=0 ) END;{while}
reset( f );
IF (Dated=0) AND (Named=0) THEN
	FoundNameDate := StrNil
ELSE BEGIN
	IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
	IF NOT OK THEN
	writeln( 'ERROR StrFile FoundNameDate : mem.' )
	ELSE
	FoundNameDate := Append ( RightJustified( Date, Space, Length(Date)+2, C ), Name, C )
END{ if }
END;{ FoundNameDate }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE ReadFile ( VAR Outs , Ins : text );

{
DESCRIPTION: Append file Ins to file Outs.
}
BEGIN
WHILE NOT eof( Ins ) DO BEGIN
	WHILE NOT eoln( Ins ) DO BEGIN
	Outs^ := Ins^ ; get( Ins ); put( Outs );
	END{ while };
	readln( Ins ); writeln( Outs );
END{ while }
END;{ ReadFile }

END.{ module StrFile }
{ v.platform addx, links, home, pkg"string}

String conversions (string -to- { char, char array, text file, int } functions)

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' ) ] (* NON-STD *)
{}{ 0 } MODULE StrCvt ;
{

DOCUMENT NAME: StrCvt.PAS DATE: 1990.08.22

DESCRIPTION: Convert between strings and other datatypes. See also StrWord, StrFile. 

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION ReadStr( VAR f:text; C: int ): int; { -- Read to end of line. }

LABEL Exit ;
VAR ch: char; i: int; 
BEGIN i:= 0;
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
IF OK THEN BEGIN
	WHILE NOT eoln( f ) OR eof( f ) DO BEGIN
	read( f, ch ); i:= i+1; Wr( C, i, ch );
	IF i = 255 THEN GOTO Exit END;
	Exit : IF eoln ( f ) AND NOT eof( f ) THEN readln( f );
	SetLength( C, i ); ReadStr:= C END
ELSE
	writeln( 'ERROR: string file-read failed.' );
END;{ ReadStr }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE WriteStr( VAR f:text; A: int );

VAR ALen, i: int;
BEGIN ALen:= Length(A);
IF ALen > 132 THEN BEGIN
	FOR i:= 1 TO 132 DO write( f, Rd( A, i ));
	writeln( f ); FOR i:= 133 TO ALen DO write( f, Rd( A, i ));
	IF Warning THEN writeln( 'WARNING string WriteStr: string longer than 132' ) END
ELSE
	FOR i:= 1 TO ALen DO write( f, Rd( A, i ))
END;{ WriteStr }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Str32( A:String32; Length, C: int ): int;

VAR i: int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= ( Length > 0 );
Str32:= C;
IF OK AND ( Length <= 32 ) THEN BEGIN
	FOR i:= 1 TO Length DO Wr( C, i, A[i] );
	SetLength( C, Length ) END
ELSE writeln( 'ERROR string Str32: mem or length arg.' );
END;{Str32}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Str8( A:String8; Length, C: int ): int;

VAR i: int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= ( Length > 0 );
Str8:= C;
IF OK AND ( Length <= 8 ) THEN BEGIN
	FOR i:= 1 TO Length DO Wr( C, i, A[i] );
	SetLength( C, Length ) END
ELSE writeln( 'ERROR string Str8: mem or Length arg.' );
END;{Str8}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IntStr( num, FieldSize, C: int ): int;

VAR temp: text;
BEGIN
open(temp); rewrite(temp); writeln( temp, num:FieldSize ); reset(temp); 
IntStr:= ReadStr( temp, C ); { --ReadStr sets OK. } close(temp );

IF NOT OK THEN writeln( 'ERROR string IntStr: mem.' )
END;{IntStr}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION CharStr( ch:char; C: int ): int;

BEGIN 
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= true;
CharStr:= C;
IF OK THEN BEGIN
	Wr( C, 1, ch );
	SetLength( C, 1 ) END
ELSE writeln( 'ERROR string CharStr: mem.' );
END;{CharStr}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION StrInt( A, Start : int ): int;

LABEL ExitLoop , Exit ;
VAR temp: text; i : int ; Found : boolean ; ch : char ;
BEGIN
open(temp); rewrite(temp); Found := false ;
FOR i := Start TO 256 DO BEGIN
	ch := Rd( A, i );
	IF ch IN ['0'..'9'] THEN BEGIN
	writeln( temp, ch ); Found := true END 
	ELSE IF Found THEN
	GOTO ExitLoop
	ELSE BEGIN
	writeln( 'ERROR StrCvt StrInt : number not found.' );
	StrInt := 0; GOTO Exit END
END{ for };
ExitLoop : reset(temp); read ( temp, i ); StrInt := i ;
Exit : END;{IntStr}

END.{ module StrCvt }
{ v.platform addx, links, home, pkg"string}

String Format operations (tabs vs spaces )

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' , 'StrIndex.PEN' , 'StrFun.PEN') ] (* NON-STD *)
{}{0}MODULE StrTab ;
{

DOCUMENT NAME:  StrTab.PAS			DATE: 1990.09.10

DESCRIPTION:	String  Format functions ( involving tabs or spaces ).

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION LengthDeSpaced( A: int ): int;

{
GLOBAL:  WITH StrIndex USING IndexNonSpace ;  WITH StrType IN  Space,Tab ;  USING Rd .
DESCRIPTION: counts Length when there are no spaces or tabs, except for one space between
words. A quoted string is considered one word,  and is assumed to contain no tabs. 
}
VAR Start, i, ALen, Len: int;  ch: char;   Run, Quoted: boolean;
BEGIN ALen:= Length( A );  Len:= 0;  Run:= false;  Quoted:= false;
IF ALen > 0 THEN BEGIN
    Start:= IndexNonSpace( A, 1 );
    FOR i:= Start TO ALen DO BEGIN
	ch:= Rd( A, i );
	IF ch = '"' THEN Quoted:= NOT Quoted;
	IF Quoted THEN BEGIN 
		Len:= Len+1;
		IF ch = Tab THEN writeln( 'ERROR string LengthDeSpaced: Tab in quoted string. ' ) END
	ELSE IF ch IN [Space,Tab] THEN BEGIN
		IF NOT Run THEN BEGIN { -- This is the first space in a run, so count it. }
			Run:= true; Len:= Len+1 END END
	ELSE BEGIN
		Run := false ;   Len:= Len+1 END
END{ for } END{ if };
IF Quoted THEN
	BEGIN IF Warning THEN writeln( 'ERROR string LengthDeSpaced: Closing quote missing. ' ) END
ELSE
	LengthDeSpaced:= Len
END;{LengthDeSpaced}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION DeSpace( A, C: int ): int;

{
GLOBAL:  WITH StrIndex USING IndexNonSpace ;
WITH StrType IN  StrNil,Space ;  OUT OK ;  USING NewStr, Length, Rd , Wr.
DESCRIPTION: returns a copy with no spaces or tabs, except for one space between
words. A quoted string is considered one word,  and is assumed to contain no tabs. 
}
VAR i,j,Start: int;  InSpaces: boolean;  ch: char;
BEGIN 
IF C = StrNIl THEN  OK := NewStr( C ) ELSE OK:= true;
DeSpace:= C;
IF OK THEN BEGIN
   InSpaces:= false; j:= 1; Start:= IndexNonSpace( A, 1 );
   FOR i:= Start TO Length(A) DO
	ch:= Rd( A, i );
	IF ch = Space THEN BEGIN
		IF NOT InSpaces THEN InSpaces:= true END
	ELSE BEGIN
		IF InSpaces THEN BEGIN InSpaces:= false; Wr( C, j, Space ); j:= j+1 END;
		Wr( C, j, ch ); j:= j+1 END;
   SetLength( C, j-1 ) END
ELSE writeln( 'ERROR string DeSpace' )
END{ DeSpace };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION DeTab( A, C: int ): int;

{
GLOBAL: WITH StrType IN  StrNIl,Space,Tab ;  OUT OK ; USING Rd, Length, Wr, TabClass,
SetLength, NewStr, OldStr ;   WITH StrFun USING Fillin, Copy 
DESCRIPTION: Chars are copied from A to C. When a tab occurs, not only is it adding multiple
spaces, but it's also shifting the remaining string into the zero tabclass; thus, beyond the
first tab, a char's tabclass won't necessarily correspond to its position in the unexpanded
string. If the result C is A then it must be copied to another structure. 
}
VAR	B: int;
{ v.platform addx, links, home, pkg"string}

{}{2}PROCEDURE PerformDeTab;

	VAR	ch: char;
		SpaceLength: int; { The number of spaces caused by a tab. }
		i: int { Index for A. };   j: int { Index for C. };
		iClass: int { ( range 0..TabSize -1 ) ---Tab class index for the i-th character of A. };
	BEGIN iClass:= 0; j:= 1;
	FOR i:= 1 TO Length(A) DO BEGIN
		ch:= Rd( A, i );
		IF ch = Tab THEN BEGIN
			SpaceLength := TabSize - iClass;
			C := Fillin( C, Space, j, SpaceLength, C );
			j:= j + SpaceLength;   iClass:= 0 END
		ELSE BEGIN
			Wr( C, j, ch );
			j:= j+1;  iClass:= TabClass( iClass+1 ) END
		END{for};
	SetLength( C, j-1 );  DeTab:= C
	END;{ PerformDeTab }
	{}{2}
BEGIN{ function DeTab }
{-- If A = C then C exists, but a new structure may be needed for destructive intermediate results,
--unless Length(A) = 0.  If A <> C and tthen if C = StrNil, then it needs a new structure. }
IF A = C THEN BEGIN 
	IF  Length( A ) = 0 THEN
		DeTab:= Copy( A, C )
	ELSE IF NewStr( B ) THEN BEGIN { Give the local ptr, A, the same data in a different structure. }
		A := Copy( A, B );
		PerformDeTab; OldStr(B) END
	ELSE	writeln( 'ERROR: string DeTab failed.' ) END
ELSE BEGIN OK:= true;
   IF C = StrNIl THEN  OK := NewStr( C );
   IF OK THEN 	PerformDeTab   ELSE writeln( 'ERROR: string DeTab failed.' )
END END;{ DeTab }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION EnTab( A, C: int ): int;

{
GLOBAL: WITH StrType IN  StrNIl,Space,Tab,TabSize ;  OUT OK ;
USING Rd, Wr, Length, SetLength, NewStr, TabClass, TabZone_index, Mov .
DESCRIPTION: If the string, A, has any tabs, run it through DeTab first. With no tabs, EnTab
will return a string that prints like A would, but uses less characters by replacing spaces
with tabs.  --Recall that a string is partitioned by Tab Zones:
zone 0 = ( 1 .. TabSize-1 ),   zone 1 = ( TabSize .. 2*TabSize-1 ), etc. 
If there are 2 or more spaces at the end of a Tab Zone, then one tab is copied in their place.
--Since this is always a sequential proccess that either preserves or shortens string-length,
it doesn't matter if ( A = C ). 
NOTE: Pascal is particular about fixed strs: Entab may change the length of strings. 
}
{ v.platform addx, links, home, pkg"string}

{}{2}PROCEDURE PerformEntab; {---length(A) > 0 }

	VAR	ch: char; Len, LastTabClass: int;
		SpaceLength: int; { The number of consecutive spaces found in one Tab Zone. }
		i: int { Index for A. };   j: int { Index for C. };
		WholeZones: int; { number of entire Tab Zones in string A. }
		iClass: int { ( range 0..TabSize -1 ) ---Tab class index for the i-th character of A. };
	BEGIN
	j:= 1;  i:= 1; LastTabClass:= TabSize - 1; Len:= Length(A);
	FOR WholeZones := 1 TO TabZone_index( Len ) DO BEGIN SpaceLength := 0;
		FOR iClass := 0 TO LastTabClass DO BEGIN
			ch:= Rd( A, i ); i:= i+1;
			Wr( C, j, ch ); j:=j+1;
			IF ch = Space THEN { --The length of the last run of spaces is counted. }
				SpaceLength := SpaceLength +1
			ELSE 	SpaceLength := 0
			END{ for classes };
		IF SpaceLength > 1 THEN BEGIN{ --the last spaces must be replaced with a tab. }
			j:= j- SpaceLength;
			Wr( C, j, Tab ); j:=j+1 END END{ for zones };
	{ -- FOR i:= i TO Len DO BEGIN Wr( C, j, Rd( A, i )); j:=j+1 END; SetLength( C, j-1 ); }
	Len := Len-i+1 ;   Mov ( A, i, Len, C, j ); SetLength( C, j+Len-1 );
	EnTab:= C END{ PerformEnTab };
	{}{2}
BEGIN{ function EnTab }
IF A = C THEN {-- C exists so no new structure is needed. }
	PerformEnTab
ELSE BEGIN OK:= true;
	IF C = StrNIl THEN  OK := NewStr( C );
	IF OK THEN PerformEnTab   ELSE writeln( 'ERROR: string EnTab failed.' )
END END;{ EnTab }

END. { module StrTab }
{ v.platform addx, links, home, pkg"string}

other String operations ( String -to- String functions)

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrFun ;
{

DOCUMENT NAME:  StrFun.PAS			DATE: 1990.08.27

DESCRIPTION:  string --> string functions 
CONVENTIONS: input strings have the names: [ A, B, Lay, Bed ], and the string to return is
named C. If ( C = StrNil ) then a new string is allocated. Input strings are never affected
unless C is one of the input strings. C is always the last parameter. A string Descriptor
refers to the info: ( Start , Length ) which specifies a substring within an input string. 

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION EmbedSubCopy ( Lay, Start, SubLength, Bed, BedIndex, C: int ): int;

{
GLOBAL: WITH StrType IN StrNil ; USING Mov , Length , Range , NewStr , SetLength .
DESCRIPTION: The descripted string in Lay is embedded into Bed starting at BedIndex.
Only string C is affected; a portion of C may remain undefined if ( BedIndex > Length(Bed) ) 
PROOF: Embed Now, the worst-case is when  B=C and A<>C and start<>1 ; example :
C( 1..3 ):= A( 1..3 );  ---here A has stepped on B values.
C( 2..4 ):= B => C( 1..3 ); ---here C(2):= C(1), and then C(3):= (stepped on) C(2).
(Start=1) and (Length(A) >= Length(B))   ==> trivial.
Others: A=B<>C, A<>B<>C ==> A, B are never written, so no precautions needed.
	B<>A=C	==> A is already written correctly alligned as C, and B is only read.
		(Length(B)=0  ==> trivial)
	A=B=C	==> B is shifted forward, and safe only with a backwards transfer.
		(Start=1 ==> trivial)
}
VAR	LayLen, LayEnd : int;   FreshBed: boolean;
{ v.platform addx, links, home, pkg"string}

{} {2}PROCEDURE Perform;

	VAR	AppendLen, BLen: int ;
	BEGIN
	Mov ( Lay , Start , SubLength ,  { to } C , BedIndex );
	FreshBed:= NOT(Bed=C);	 BedIndex := BedIndex -1;   AppendLen := BedIndex + SubLength; 
	IF NOT ( BedIndex = 0 )AND FreshBed  THEN  {--- Copy the intact first part of Lay into C. }
		Mov ( Bed, 1, BedIndex, { to }  C, 1 );
	BLen := Length( Bed );  
	IF  BLen > AppendLen  THEN BEGIN {--- LAY was properly contained within Bed, so unless Lay = C, }
		IF FreshBed THEN BEGIN {--- ..copy the last part of Bed, and Blen into C. }
			Mov ( Bed, AppendLen+1, BLen - AppendLen, { to }  C, AppendLen+1 );
			SetLength( C, Blen ) END END
	ELSE{ ---the new string is longer than A. }
		SetLength( C, AppendLen )
	END;{ EmbedSubCopy \Perform }
{} {2}
BEGIN{ EmbedSubCopy }   LayLen := Length( Lay );
IF C = StrNil THEN  OK := NewStr( C ) ELSE OK:= true;
OK := OK AND Range( Start, SubLength, LayLen ); {--This trims SubLength to fit within Lay. }
OK := OK AND Range( BedIndex, SubLength, 255 );
EmbedSubCopy := C;
IF OK THEN Perform ELSE writeln( 'ERROR: string Embed failed.' )
END;{ EmbedSubCopy }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Embed( Lay, Bed, BedIndex, C: int ): int;

{
GLOBAL: USING EmbedSubCopy ;  WITH StrType USING Length.
}
BEGIN Embed:= EmbedSubCopy( Lay, 1, Length(Lay),  Bed, BedIndex, C )
END;{ Embed }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION EmbedMasking ( Lay, Start, SubLength, Bed, C: int ): int;

{
GLOBAL: USING EmbedSubCopy .
DESCRIPTION: The embedded string starts at the same place in Bed as it does in Lay.
}
BEGIN EmbedMasking := EmbedSubCopy( Lay, Start, SubLength,   Bed, Start, C )
END;{ EmbedMasking }

{}FUNCTION Append( Lay, Bed, C: int ): int;
{
GLOBAL: USING EmbedSubCopy ;  WITH StrType USING Length .
DESCRIPTION: Lay is appended to Bed.
}
BEGIN Append:= EmbedSubCopy( Lay, 1, Length(Lay), Bed, Length(Bed)+1, C )
END;{ Append }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION SubCopy( A, Start, SubLength, C: int ): int;

{
GLOBAL: WITH StrType IN StrNil ;  USING Length , NewStr , Mov , SetLength , Range .
DESCRIPTION: And it accepts a reversed descriptor ( SubLength can be negative ).
}
BEGIN
IF (C = StrNil) THEN OK := NewStr( C ) ELSE OK := Range( Start, SubLength, Length(A) );
SubCopy:= C;
IF OK THEN BEGIN
	IF NOT(  (A=C) AND (Start=1)  ) THEN  Mov ( A, Start, SubLength, C, 1 );
	SetLength( C, SubLength ) END
ELSE writeln( 'ERROR: string SubCopy --bad arg( Start ) or no mem.' )
END;{ SubCopy }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Copy( A,C:int ): int;

{
GLOBAL: USING SubCopy ;  WITH StrType USING Length .
}
BEGIN Copy:= SubCopy( A, 1, Length(A), C )
END;{ Copy }
{ v.platform addx, links, home, pkg"string}

{} FUNCTION Delete ( A, Start , Len, C : int ) : int ;

{
GLOBAL: WITH StrType IN StrNil ;  USING Length , NewStr , Mov , SetLength , Range .
DESCRIPTION:  NOT the inverse of Insert: if the deletion is to be buffered,
then the user should calculate the substring descriptor first, and then
use this descriptor to first copy the deletion, and then delete it.
}
VAR	RemLen , StartnLen, LenA : int ;
BEGIN LenA := Length( A );
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK := Range( Start, Len, LenA );
Delete := C ;    SetLength ( C, LenA - Len );   StartnLen := Start + Len ;
RemLen := LenA - StartnLen +1;
IF  Len = 0 THEN BEGIN
	IF  NOT ( A=C ) THEN Mov ( A, 0, LenA+1, C, 1 ) END
ELSE BEGIN
	IF NOT ( A=C ) AND NOT ( Start = 1 ) THEN { -- truncation requested. }
		Mov ( A, 1, Start-1, C, 1 );
	IF NOT ( RemLen = 0 ) 	THEN
		Mov ( A, StartnLen, RemLen, C, Start );
END{ if }
END;{ Delete }

{ v.platform addx, links, home, pkg"string}

{} FUNCTION Insert ( A, InsertPtr, B, Start , Len, C : int ) : int ;

{
GLOBAL: WITH StrType IN StrNil ;  USING Length , NewStr , Mov , SetLength , Range .
DESCRIPTION:  Insert the descripted substring of B at the InsertPtr of A.
}
LABEL	Exit ;
VAR	PreLen , ShiftLen, LenA : int ;

{} {2} PROCEDURE CopyB;

	VAR	BCopy : String ;   i , d : int ;
	BEGIN d := Start ;
	FOR i := 1 TO Len DO BEGIN BCopy [ i ] := Rd ( B, d ); d:= d+1 END;
	Mov ( A, InsertPtr, LenA - PreLen, C, InsertPtr+Len );    d := InsertPtr ;
	FOR i := 1 TO Len DO BEGIN  Wr ( C, d, BCopy [ i ] ); d:= d+1 END
	END;{ Insert \ CopyB }
{} {2}
BEGIN LenA := Length( A );
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK := Range( Start, Len, Length( B ) );
PreLen := InsertPtr -1;   OK := OK AND ( PreLen + Len < 256 );   IF NOT OK THEN GOTO Exit ;
Insert := C ;   SetLength ( C, LenA + Len );    ShiftLen := LenA - PreLen ;
IF  ( ShiftLen < 0 ) AND Warning THEN
	writeln( 'WARNING StrFun Insert : Beyond EO leaves mid undefined.' );
IF A=C THEN
	IF (B=C) AND ( InsertPtr < Start ) THEN
		CopyB
	ELSE BEGIN
		Mov ( A, InsertPtr, LenA - PreLen, C, InsertPtr + Len ); { -- Shift A. }
		Mov ( B, Start, Len, C, InsertPtr ) { -- Embed B. }
	END { if }
ELSE BEGIN { -- A is safe but PreInsert needed. }
	Mov ( B, Start, Len, C, InsertPtr ); { -- Embed B first, since it isn't safe. }
	IF ShiftLen > 0 THEN Mov ( A, InsertPtr, ShiftLen, C, InsertPtr + Len ); { -- Shift A. }
	Mov ( A, 1, PreLen, C, 1 ) { -- Move A. }
END{ if };
Exit : END;{ Insert }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Fillin( A: int; ch: char; Start, FiLength, C: int ): int;

{
GLOBAL: WITH StrType IN StrNil ;  USING Length , NewStr , Mov , Wr, SetLength , Range .
DESCRIPTION:
	---Start and/or FiLength may be negative, and have the following affects:
	(- Start, - FiLength ): pad to the left of (C) until Length(C) = (| FiLength |);
	(- Start, + FiLength ): pad to the right of (C) until Length(C)= FiLength;
	(+ Start, - FiLength ): 	C.( Start -(| FiLength |)+1 ) .. Start ) := pad;
	---Doesn't warn if Start is beyond original length: mid-string may be undefined.
	( + Start, + FiLength ): 	C.(  Start .. ( Start +FiLength-1)  ) := pad;
}
VAR	i, ALen, IndexDiffs, AppendLen: int;   AFresh : boolean;

{} {2} PROCEDURE FillinSizeSpecified;

	BEGIN IF OK THEN BEGIN IndexDiffs := Start-1; { ---Diffs of beginnings of A, B. }
	AppendLen := IndexDiffs + FiLength;
	FOR i:= Start TO AppendLen DO  Wr( C, i, ch ); { ---Lay the fill. }
	AFresh:= NOT( A=C );
	IF AFresh THEN Mov ( A, 1, IndexDiffs, C, 1 );  { -- Copy the intact first part of A into C. }
	END{if OK } END;{ FillinSizeSpecified }    { -- Now what happens depends on the caller. }

{} {2} PROCEDURE FieldSizeSpecified;

	VAR	FieldSize: int ;   PadLeft : boolean ;
	BEGIN	PadLeft:= (FiLength < 0);  IF PadLeft THEN FiLength := -FiLength ;
	FieldSize := FiLength;
	FiLength := FieldSize - ALen; {---add padding until ( Length( C ) = | FiLength |). }
	SetLength( C, FieldSize);
	IF FiLength < 1 THEN BEGIN {--- truncate, if needed, to fit A within FieldSize. }
		IF NOT ( A = C ) THEN Mov( A, 1, FieldSize, C, 1 ) END
	ELSE BEGIN
		IF PadLeft THEN { -- ( Add padding on the left ). } BEGIN  Start:= 1;
			Mov ( A, 1, ALen, C, 1+FiLength ); { -- make room for padding. }
			A:= C { -- FillinSizeSpecified will fill but not copy. } END
		ELSE BEGIN{-- Add right padding. }
			Start:= ALen +1 { -- FillinSizeSpecified will copy and fill. }
		END{ if };
	   FillinSizeSpecified
	END{ if }END;{ FieldSizeSpecified }
	{} {2}
BEGIN{ Fillin }
IF C = StrNil THEN  OK := NewStr( C ) ELSE OK:= true;
Fillin:= C;  ALen := Length( A );
IF OK THEN
IF Start < 0 THEN
	FieldSizeSpecified
ELSE BEGIN OK:=  Range( Start, FiLength, 255 );
	FillinSizeSpecified ;
	IndexDiffs := ALen - AppendLen; {--- The length of A that remains to the right of the fill. }
	IF 0 < IndexDiffs THEN BEGIN{--- the fill was properly contained within A, so copy the last part of A. }
		IF AFresh THEN BEGIN AppendLen := AppendLen + 1;
			Mov ( A, AppendLen, IndexDiffs, C, AppendLen );  SetLength( C, ALen )
		END{ if } END
	ELSE{ ---the new string is longer than A. }
		SetLength( C, AppendLen )
END{ if };
IF NOT OK THEN {---checks for success of Embed  as well as NewStr. }
	writeln( 'ERROR: string Fillin.' )
END;{ Fillin }
{ v.platform addx, links, home, pkg"string}

{} FUNCTION LeftJustified( A:int; ch:char; FieldSize, C: int ): int;

{
GLOBAL: USING Fillin .
}
BEGIN LeftJustified := Fillin( A, ch, -1, FieldSize, C )
END{ LeftJustified };

{}FUNCTION RightJustified( A:int; ch:char; FieldSize, C: int ): int;
{
GLOBAL: USING Fillin .
}
BEGIN RightJustified:= Fillin( A, ch, -1, -FieldSize, C ) 
END{ RightJustified };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Spaces( Length, C: int ): int;

{
GLOBAL: 
WITH StrType IN Space, StrNil ; USING SetLength, Wr, NewStr ;  OUT OK
}
VAR i:int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= true;
Spaces := C;
IF OK THEN BEGIN
	FOR i:= 1 TO Length DO Wr( C, i, Space );
	SetLength( C, Length ) END
ELSE	writeln( 'ERROR string Spaces: mem.' )
END;{Spaces}
{ v.platform addx, links, home, pkg"string}

{} FUNCTION Indent( A, IndentSize, C: int ): int;

{
GLOBAL: USING Append, Spaces ;  WITH StrType IN StrNil ; USING NewStr ;  OUT OK .
DESCRIPTION: returns a copy of string A with ( IndentSize ) spaces prefixed.
}
VAR i:int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= true;
IF OK THEN Indent := Append( A, Spaces( IndentSize, C ), C )
ELSE writeln ( 'ERROR StrFun Indent : mem. ' )
END{ Indent };

END. { module StrFun }
{ v.platform addx, links, home, pkg"string}

functions that operate on a Word

[ ENVIRONMENT , INHERIT ( 'MathUtl.PEN' , 'StrType.PEN' , 'StrIndex.PEN' ) ] (* NON-STD *)

{}{0} MODULE StrWord ;
{

DOCUMENT NAME:  StrWord.PAS			DATE: 1990.08.31

DESCRIPTION: String Package functions that operate on a Word,
a textual unit defined as:
(1) any string of non-space non-tab chars;
(2) any quoted string.

}
{ v.platform addx, links, home, pkg"string}

{} FUNCTION WordLength ( Word : int ; Start : int ): int ;

{
GLOBAL: WITH MathUtl USING Absol ;  WITH StrType OUT OK ;  USING Rd ;
WITH StrIndex USING IndexChar , IndexSpace ;
DESCRIPTION: Returns a negative length if Start is negative, and gets word size.
Start represents the [ begin, end ] of the word when it is [ positive, negative ].
The size includes the quotes in the case of the quoted-phrase-word.
ALGORITHM: IndexSpace and IndexChar both react to a negative Start the same way WordLength
does. Absol sets Direction := [ 1, -1 ] depending on Starts sign, and this is convenient when
the case decides [ adding, subtraction ].
}
VAR	ch : char ;  AbStart , Lim, LenWord , Direction : int ;
BEGIN LenWord := Length ( Word );  AbStart := Absol ( Start, Direction );
IF LenWord = 0 THEN
	WordLength := 0
ELSE IF ( Start = 0 ) OR ( AbStart > LenWord ) THEN BEGIN
	OK := false ; writeln( 'ERROR StrType WordLength : start range. ' ) END
ELSE BEGIN
	ch := Rd( Word, AbStart );
	IF ch = '"' THEN BEGIN { -- Pick up a quoted phrase. }
		Lim := IndexChar( '"', Word, Start+1 );
		IF Lim = 0 THEN BEGIN
			OK := false ; writeln( 'ERROR StrType WordLength : missing quote.' ) END END
	ELSE BEGIN { -- Pick up a word. }
		Lim := IndexSpace ( Word, Start );
		IF Lim = 0 THEN
			IF Direction < 0 THEN Lim := 1 ELSE Lim := LenWord
		ELSE BEGIN 
			Lim := Lim - Direction
		END{ if }
	END{ if };
	WordLength := (Lim - AbStart) + Direction 
END{ if }
END;{ WordLength }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION WordCopy( Word, Start, C: int ): int;

{
GLOBAL: USING WordLength ;
WITH StrType IN StrNil ; OUT OK ;  USING Rd, Range, Length, Mov, SetLength NewStr .
DESCRIPTION: copy the word (Dequoted) from start and going [ forward , backward ]
from [ beginning, end ] of word, depending on whether Start is [ positive, negative ].
ALGORITHM: WordLength finds the length of the word, and it is negative if Start was.
When Range finds a negative Length, then it assumes  start is pointing at the end of the word,
and reverses this condition, so Start points at the beginning, and both Start and Length are
positive. Mov accomodates overlapping source and destination strings. 
}
LABEL	Exit ;
VAR	WordLen : int ;
BEGIN
IF C = StrNil THEN OK:= NewStr( C );
IF NOT OK THEN BEGIN writeln( 'ERROR StrFun WordCopy: mem. ' ); GOTO Exit END;
WordLen := WordLength( Word, Start );   WordCopy:= C;
IF WordLen = 0 THEN BEGIN Setlength( C, 0 ); GOTO Exit END;
OK := Range( Start, WordLen, Length( Word ));
IF NOT OK THEN BEGIN writeln( 'ERROR StrFun WordCopy: range.' ); GOTO Exit END;
IF Rd( Word, Start ) = '"' THEN BEGIN  Start := Start +1; WordLen := WordLen -2 END;
Mov ( Word, Start, WordLen,  C, 1 );  SetLength( C, WordLen );
Exit : END;{ WordCopy }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION ReadWord( VAR f:text; C: int ): int;

{
GLOBAL: WITH StrType IN StrNil,Tab,Space ; OUT OK ;  USING Wr, SetLength NewStr ;
DESCRIPTION: gets through spaces and picks up next word.
}
LABEL	ExitWhile, Loop , Exit ;
VAR	EOChar , ch: char;  i: int; 
BEGIN i:= 0;
IF C = StrNIl THEN  OK := NewStr( C ) ELSE OK:= true;
IF OK THEN BEGIN
	WHILE NOT eof( f ) DO
		IF ( f^ IN [Tab,Space] ) THEN get( f )
		ELSE IF eoln( f ) THEN readln( f )
		ELSE GOTO ExitWhile ;
	ExitWhile : IF eof( f ) THEN GOTO Exit ;
	IF f^ = '"' THEN read ( f, EOChar )  ELSE EOChar := Space ;

	Loop :	IF  eoln( f ) OR eof( f ) OR (f^ = EOChar) THEN
			GOTO Exit ;
		IF (i = 255) THEN BEGIN
			writeln( 'ERROR: StrWord ReadWord : Word truncation.' );
			GOTO Exit
		END{ if };
		read( f, ch );   i:= i+1;   Wr( C, i, ch );
	GOTO Loop { END while };

	Exit : IF eoln ( f ) AND NOT eof( f ) THEN readln( f );
	SetLength( C, i ); ReadWord := C  END
ELSE
	writeln( 'ERROR: StrWord ReadWord : mem.' )
END;{ ReadWord }

END.{ module StrWord }
{ v.platform addx, links, home, pkg"string}

string -to- index-finding functions

-- finding the beginning or end off the nextt occurrence
going forwards or backwards
depending on whether parameter"Start is positive or negative

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrIndex ;
{

DOCUMENT NAME:  StrIndex.PAS			DATE: 1990.08.31

DESCRIPTION:	String  index functions.
-- Any routine that uses a Start parametter finds the index of the [ beginning, end ]
of the next occurrence going [ forwards, backwards ] depending on whether start is
[ positive, negative ].
FUNCTION IndexCharSet( s, A: int ): int;	--not implemented.
--- (s) is a string of chars to look forr, consecutive duplicates signal a range;
--eg, AAZ means A..Z.

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexNonSpace( A, Start: int ): int;

{
GLOBAL: WITH StrType IN Tab, Space ; OUT OK ;  USING Rd, RangeEO .
}
LABEL Exit;
VAR i, Next, EO : int ;
BEGIN IndexNonSpace:= 0;  OK :=  RangeEO ( A , Start, Next, EO );
IF NOT OK THEN BEGIN  writeln( 'ERROR StrIndex IndexNonSpace : range ' ); GOTO Exit END;
i := Start ;
WHILE NOT ( i = EO ) DO BEGIN
	IF NOT( Rd( A, i ) IN [Tab,Space] ) THEN BEGIN IndexNonSpace := i; GOTO Exit END;
	i := i + Next
END;{ while }
Exit: END{ IndexNonSpace };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexSpace( A, Start: int ): int;

{
GLOBAL: WITH StrType IN Tab, Space ; OUT OK ;  USING Rd, RangeEO .
}
LABEL Exit;
VAR i, Next, EO : int ;
BEGIN IndexSpace:= 0;  OK :=  RangeEO ( A , Start, Next, EO );
IF NOT OK THEN BEGIN  writeln( 'ERROR StrIndex IndexSpace : range ' ); GOTO Exit END;
i := Start ;
WHILE NOT ( i = EO ) DO BEGIN
	IF Rd( A, i ) IN [Tab,Space] THEN BEGIN IndexSpace := i; GOTO Exit END;
	i := i + Next
END;{ while }
Exit: END{ IndexSpace };
{ v.platform addx, links, home, pkg"string}

{} FUNCTION IndexStr( Target, Domain, Start: int ): int;

{
GLOBAL: WITH StrType USING Length, Rd.
}
VAR	i, j: int;   Found: boolean;

{} {2}PROCEDURE ForwardIndex ;

	LABEL BadStart, GoodStart;
	BEGIN
		FOR i:= Start TO Length( Domain ) - Length( Target) +1 DO BEGIN Found:= true;
			FOR j:= 1 TO Length( Target ) DO
				IF Rd( Target, j ) <> Rd( Domain, i+(j-1) ) THEN BEGIN
					Found:= false;  GOTO BadStart END;
			IF Found THEN BEGIN IndexStr:= i;  GOTO GoodStart END;
		BadStart: END;{for i}
	GoodStart: END;{ ForwardIndex }

	{} {2}PROCEDURE ReverseIndex ;
	LABEL BadStart, GoodStart;
	BEGIN
		FOR i:= Start DOWNTO Length( Target) DO BEGIN Found:= true;
			FOR j:= Length( Target ) DOWNTO 1 DO
				IF Rd( Target, j ) <> Rd( Domain, i-(j-1) ) THEN BEGIN
					Found:= false;  GOTO BadStart END;
			IF Found THEN BEGIN IndexStr:= i;  GOTO GoodStart END;
		BadStart: END;{for i}
	GoodStart: END;{ ReverseIndex }
	{} {2}
BEGIN{IndexStr} IndexStr:= 0;
IF Start = 0 THEN writeln( 'ERROR StrIndex IndexStr : Start range. ' )
ELSE IF Start > 0 THEN 	ForwardIndex
ELSE	ReverseIndex
END;{IndexStr}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexKeyed ( Target, Domain: int ): int;

{
GLOBAL: USING IndexStr, IndexNonSpace ;  WITH StrType USING Length.
}
VAR TargetStart: int;
BEGIN
	TargetStart:= IndexStr( Target, Domain, 1 );
	IF TargetStart > 0 THEN
		IndexKeyed:= IndexNonSpace( Domain, TargetStart +Length( Target ))
	ELSE
		IndexKeyed:= 0
END;{ IndexKeyed }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexChar( ch: char; A, Start: int ): int;

{
GLOBAL: WITH StrType OUT OK ;  USING Rd, RangeEO .
}
LABEL Exit;
VAR i, Next, EO : int ;
BEGIN IndexChar:= 0;  OK :=  RangeEO ( A , Start, Next, EO );
IF NOT OK THEN BEGIN  writeln( 'ERROR StrIndex IndexChar : range. ' ); GOTO Exit END;
i := Start ;
WHILE NOT ( i = EO ) DO BEGIN
	IF Rd( A, i ) = ch THEN BEGIN IndexChar:= i; GOTO Exit END;
	i := i + Next
END;{ while }
Exit: END{ IndexChar };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexNextWord ( A , Start : int ): int;

{
GLOBAL: USING IndexChar , IndexSpace, IndexNonSpace ;
WITH StrType IN Tab, Space ; USING Rd .
DESCRIPTION: Assumes Start is index of current word, and gives index
of char of next word: beyond current word and then beyond spaces.
}
VAR	ch : char ;
BEGIN
ch := Rd ( A, Start );
CASE ch OF
	'"' 	: BEGIN Start := IndexChar( ch, A, Start+1 ); Start := Start +1 END;
	Tab, Space: ;
OTHERWISE	(* NON-STD *)
	Start := IndexSpace( A, Start )
END{ case };
IndexNextWord := IndexNonSpace( A, Start )
END;{ IndexNextWord }

END. { module StrIndex }
{ v.platform addx, links, home, pkg"string}

the test harness

[ ENVIRONMENT ] MODULE str( input, output );

PROCEDURE Main;

VAR B,A,line: int;

PROCEDURE pr( A: int );

BEGIN write( line:1,' Line="' );  Line:= Line+1;
WriteStr( output, A ); writeln( '"', Length(A):1) END;
BEGIN InitStrHeap; Line := 1;
REPEAT
writeln( 'string with/out tabs' );
A:= ReadStr( input, StrNil ); pr(A);
writeln( 'string with/out tabs' );
B:= ReadStr( input, StrNil ); pr(B);
pr( embed( A, B, 1, StrNil ));
pr( embed( A, B, Length(A), StrNil ));
pr( embed( A, B, 255, StrNil ));
pr( subcopy( A, 5, 2, B ));
pr( subcopy( A, -5, 2, B ));
pr( fillin( A, '*', 5, 2, StrNIl ));
pr( fillin( A, '*', 5, -2, StrNIl ));
pr( fillin( A, '*', -5, Length(A)+3, StrNIl ));
pr( fillin( A, '*', -5, -(Length(A)+3), StrNIl ));

writeln( 'string with/out tabs' );
A:= ReadStr( input, StrNil ); pr(A);
A:= Detab( A, A );  write( 'de tabbed:' ); pr( A);
A:= Entab( A, A ); write( 'tabbed:' ); pr(A)
UNTIL false END;

BEGIN MAIN

END.

{ v.platform addx, links, home, pkg"string}