home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
pascal
/
library
/
dos
/
answcode
/
index.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-10-27
|
9KB
|
344 lines
{$M 65500,16384,655360} {Turbo 3 default stack and heap}
{$R-,S-,D-,T-,F+,V-,N-,I-,B-}
Program Index;
{ ANSWERS ! Version 4.0 May 10, 1988}
{ Copyright 1988, Brian Corll }
{ All Rights Reserved }
{$U LSort}
Uses Crt,Dos,Turbo3,LSort,Sort,Qwik,Wndw,Wndwvars,Library,NewPoint;
const
TextSize = 4500;
MaxWndws = 30;
Type
String80 = String[80];
ShortString = String[30];
AnyString = String[255];
String6 = String[6];
String8 = String[8];
StringOne = String[1];
PtrArray = Array[0..255] of Integer;
WdString = String[20];
LineSize = String[12];
TextData = record
TextLine : String80;
end;
UnSorted = Record
KeyWord : String[12];
end;
Sorted = Record
KeyWord : String[12];
end;
TextArrayType = array[1..TextSize] of LineSize;
ParseType = String[80];
RootString = String[8];
var
Message : string;
Num : String[5];
Times : Integer;
Initial,YesNo : Char;
Line,LineCount,Position,Width,J,EndWord,PointNum,Ptr,Per,K,M,I,IntValue : Integer;
SourceStr : ParseType;
Found : Boolean;
InFile,OutFile : Text;
LineOut,OutFileName,DtaTxtFileName,InWord,NewWord,LineIn,InFileName : String[12];
OneLine : String[80];
FirstCh : String[1];
TextDataFile : File of TextData;
TextDataRec : TextData;
InStr : WdString;
Root : String8;
WrtLine : String[20];
TextArray : TextArrayType;
CRTCols,Row,Col,Result : Integer;
UnSortFile : File of UnSorted;
SortFile : File of Sorted;
UnSorts : UnSorted;
Sorts : Sorted;
Buffer : Array[1..2048] of Char;
KeyLine : String[12];
LongI : LongInt;
Beginning,LSortResult,SortResult : Integer;
Procedure ProcessString(InString : String80);
var
I : Integer;
OutWord : String80;
g,f,m,z : Integer;
Posit : Integer;
Marker : Integer;
ProcWord : String80;
Ch,Character : Char;
OneByte,Code : Byte;
begin
I := 1;
z := Words(InString);
for I := 1 to Z do
begin
ProcWord := OneWord(InString,I);
ProcWord := copy(procWord,1,6);
Marker := Length(triml(trimr(ProcWord)));
Posit := 1;
OutWord := '';
For Posit := 1 to Marker do
begin
Character := ProcWord[Posit];
If UpCase(Character) in ['A'..'Z'] then
begin
OutWord := OutWord + Character;
end;
If Character in ['0'..'9'] then
begin
OutWord := OutWord + Character;
end;
end;
If Length(TrimL(TrimR(OutWord)))>0 then
begin
LongI := LongI + 1;
Num := '';
with UnSorts do
begin
Str(Line:5,Num);
KeyWord := PadR(UpperCase(OutWord)+','+TrimL(Num),12);
write(UnSortFile,UnSorts);
end;
end;
ProcWord := '';
end;
end;
{$F+}
Procedure Beep;
Begin
Sound(1500); Delay(50);
Sound(1000); Delay(50);
NoSound;
End;
Procedure InpRecs;
Begin
Repeat
Read(UnSortFile,UnSorts);
SortRelease(UnSorts);
Until eof(UnSortFile);
end;
Function LessRec(var x,y : UnSorted) : Boolean;
begin
LessRec := x.KeyWord<y.KeyWord;
end;
Procedure OutpRecs;
begin
Assign(SortFile,Root+'.srt');
Rewrite(SortFile);
Repeat
SortReturn(UnSorts);
with UnSorts do
begin
KeyLine := PadR(KeyWord,12);
with Sorts do
begin
KeyWord := KeyLine;
end;
end;
Write(SortFile,Sorts);
Until SortEos;
Close(UnSortFile);
Close(SortFile);
end;
Procedure LLInpRecs;
Begin
Repeat
Read(UnSortFile,UnSorts);
LSortRelease(UnSorts);
Until eof(UnSortFile);
end;
Function LLessRec(var x,y : UnSorted) : Boolean;
begin
LLessRec := x.KeyWord<y.KeyWord;
end;
Procedure LLOutpRecs;
begin
Assign(SortFile,Root+'.srt');
Rewrite(SortFile);
Repeat
LSortReturn(UnSorts);
with UnSorts do
begin
KeyLine := PadR(KeyWord,12);
with Sorts do
begin
KeyWord := KeyLine;
end;
end;
write(SortFile,Sorts);
Until LSortEos;
Close(UnSortFile);
Close(SortFile);
end;
begin
InitWindow(0,True);
SetWindowModes(ZoomMode);
Line := 0;
ClrScr;
If ParamCount=0 then
begin
Beep;
ClrScr;
MakeWindow(9,20,5,40,Red+LightGrayBG,Red+LightGrayBG,DoubleBrdr,aWindow);
QWriteC(11,1,80,Red+LightGrayBG,'Syntax : INDEX filename.ext');
Halt(1);
end
else
InFileName := ParamStr(1);
Off;
Per := Pos('.',InFileName);
Root := Copy(InFileName,1,Per-1);
Root := UpperCase(Root);
Assign(InFile,InFileName);
SetTextBuf(InFile,Buffer);
Reset(InFile);
If (IoResult<>0) then
begin
Beep;
InitWindow(0,True);
MakeWindow(11,20,3,44,White+RedBG,White+RedBG,DoubleBrdr,Window23);
Message := 'File '+UpperCase(ParamStr(1))+' does not exist !';
TitleWindow(Top,Center,Message);
gotoxy(12,2);
write(' Aborting Program. Sorry !');
Halt;
end;
ClrScr;
MakeWindow(17,1,8,80,White+RedBG,White+RedBG,DoubleBrdr,Window30);
gotoxy(2,2);
gotoxy(2,3);
write(' ANSWERS ! Version 4.0');
gotoxy(2,4);
write(' Copyright 1988 Brian Corll');
gotoxy(2,5);
write(' All Rights Reserved');
MakeWindow(1,9,3,64,White+BlackBG,White+BlackBG,DoubleBrdr,Window10);
gotoxy(16,2);
TextColor(White);
write(' Creating ',Root+'.DAT',' data file from text file.');
assign(TextDataFile,Root+'.dat');
rewrite(TextDataFile);
MakeWindow(5,14,3,55,Black+LightGrayBG,Black+LightGrayBG,DoubleBrdr,Window11);
I := 1;
while not eof(InFile) do
begin
readln(InFile,OneLine);
if Pos(chr(12),OneLine)>0 then
OneLine := Copy(OneLine,Pos(chr(12),OneLine)+1,80-Pos(chr(12),OneLine));
gotoxy(2,1);
write(' Writing Record Number ',I);
with TextdataRec do
begin
TextLine := OneLine;
write(TextDataFile,TextDataRec);
end;
I := I +1;
end;
close(TextDataFile);
Close(InFile);
SetTextBuf(InFile,Buffer);
reset(InFile);
Assign(UnSortFile,Root+'.uns');
Rewrite(UnSortFile);
MakeWindow(9,12,3,59,Black+LightGrayBG,Black+LightGrayBG,DoubleBrdr,Window11);
LongI := 0;
while not eof(InFile) do
begin
Line := Line+1;
gotoxy(2,1);
write(' Parsing ',UpperCase(InFileName),' Line Number ',Line);
Readln(InFile,OneLine);
if length(triml(trimr(OneLine)))>0 then
ProcessString(OneLine);
end;{while}
Close(UnSortFile);
Reset(UnSortFile);
If LongI>=32767 then
begin
MakeWindow(13, 17, 3, 52, White+BlackBG,White+BlackBG, DoubleBrdr,Window1);
Write(' LongSorting ', UpperCase(Root),'.UNS');
LSortResult := LTurboSort(SizeOf(UnSorted),@LLInpRecs,@LLessRec,@LLOutpRecs);
if LSortResult = 0 then
begin
ClrScr;
write(' Sorting Complete !')
end
else
begin
ClrScr;
For Times := 1 to 5 do
Beep;
writeln(^G,' Sort Error # ',LSortResult);
end;
end
else
begin
MakeWindow(13, 17, 3, 52, White+BlackBG,White+BlackBG, DoubleBrdr,Window1);
Write(' ShortSorting ', UpperCase(Root),'.UNS');
SortResult := TurboSort(SizeOf(UnSorted),@InpRecs,@LessRec,@OutpRecs);
if SortResult = 0 then
begin
ClrScr;
write(' Sorting Complete !')
end
else
begin
ClrScr;
For Times := 1 to 5 do
Beep;
write(^G,' Sort Error # ',SortResult);
end
end;
Erase(UnSortFile);
MakePointers;
Erase(SortFile);
InitWindow(0,True);
SetWindowModes(ZoomMode);
MakeWindow(10,11,4,62,White+BlueBG,White+BlueBG,DoubleBrdr,Window7);
gotoxy(2,1);
write(' Processing is Complete.');
gotoxy(2,2);
write(' Press Any Key to Continue.');
Repeat until KeyPressed;
RemoveWindow;
MakeWindow(1,1,25,80,White+BlueBG,White+BlueBG,SolidBrdr,aWindow);
MakeWindow(9,11,5,62,White+RedBG,White+RedBG,DoubleBrdr,Window8);
gotoxy(18,2);
write('Copyright 1988 Brian Corll');
gotoxy(22,3);
write('All Rights Reserved');
Delay(3000);
for i:=1 to 5000 do
begin
Row:=random(25)+1;
Col:=random(CRTcols)+1;
Qfill (row,col, 1, 1,Black,' ');
end;
On;
InitWindow(0,True);
end.