Power-Programmierung/CD1.mdf/pascal/library/dos/answcode/answers.pas

Pascal/Delphi Source File | 1988-10-27 | 17.5 KB | 640 lines

{$R-,S-,I-,D+,T-,F+,V-,B+,N+,L+ }
{$M 65520,0,655360 }
Program Answers10; { Version 4.0 }

(*********************************************************)
(********** ANSWERS ! Version 4.0 October 27, 1988 *******)
(********** Copyright 1988, Brian Corll ******************)
(********** All Rights Reserved         ******************)
(*********************************************************)

(*************************************************************)
(* This is the original source code to ANSWERS ! Version     *)
(* 4.0, which I distributed last summer.  ANSWERS ! is a     *)
(* plain and simple text file indexing and retrieval sys-    *)
(* tem.  For more information, download the original file    *)
(* ANSWER40.arc.                                             *)
(* This program is now in the public domain.  If you make    *)
(* any improvements on it ( and many could be made; this     *)
(* is just the nucleus) please share them with me.           *)
(* Questions or comments may be left on these boards:        *)
(*      Cliffside Park  201-886-8041                         *)
(*      MicroSellar     201-239-1346                         *)
(*      Turbo Source Search  617-545-9131                    *)
(*                                                           *)
(*                    Brian Corll                            *)
(*                    102 West Locust Street                 *)
(*                    Mechanicsburg, PA 17055                *)
(*                    717-691-0286                           *)
(*                    October 27, 1988                       *)
(*************************************************************)
(* Compilation requires Jim LeMay's Qwik,Wndw, and Wndwvars; *)
(* Juan Vegarra's DER12.arc, and the Turbo Database Toolbox  *)
(*************************************************************)

Uses CRT,Dos,Turbo3,TAccess,TAHigh,Qwik,Wndw,Wndwvars,Der,Utils;

Const
 MaxWndw = 100;

Type
   String80 = String[80];
   IndexType = String[6];
   Pointers = Record
            IndexWord : IndexType;
            PtrArray : Array[1..200] of Integer;
            end;
   TextData = record
            TextLine : String80;
            end;

   Regs =
             Record Case Boolean of
             True : (al,ah,bl,bh,cl,ch,dl,dh : Byte);
             False : (ax, bx, cx, dx, bp,si,di,ds,es,Flags : Registers)
                     end;

    Config = Record
           Colors : Array[1..18] of Byte;
          end;
   String6 = String[6];
   Elements = Array[1..100] of Integer;
   Element = Integer;
   String20 = String[20];
MaxDataType = Pointers;
MaxKeyType = IndexType;

Var
  Color : Array[1..4] of Byte;
  ConfigFile : DataFile;
  ConfigRec : Config;
  TextDataFile : File of TextData;
  TextDataRec : TextData;
  PointerFile : DataSet;
  PointerRec : Pointers;
  Times : Byte;
  TheCowsComeHome : Boolean;
  FS : Integer;
  St : String[5];
  Quit : string[1];
  TC,GoAhead : Char;
  Ch : Char;
  Root : String[8];
  NewStr,TextKey,Line6 : String[6];
  H,TotLines,RecordNum,Lines,X,Z,G,P,M,A,Pntr,Stop,Number,Comma,LineCount,Position,Result,I,K : Integer;
  Row,Col,IndexSize,Spot,Head,Foot,RedLine,EndPoint,NumChars : Integer;
  Query : String[55];
  Message,ParseWord : String[80];
  ParseStr : String[6];
  WordIn : String20;
  Answers : Array[1..2,1..1000] of Integer;
  FinalWord : Elements;
  ChoiceIn : String[5];
  NumLines,Code : Integer;
  WhyNot,Choice : Byte;
  ChoiceNumbers : Array[1..24] of Integer;
  BC,ZZ,Q : Integer;
  Color1,Color2 : String[12];

Procedure Wait;
Var
   Ch : Char;
begin
     ModCursor(CursorOff);
     QWrite(WhereR,WhereC,White+RedBG,'Press any key to continue....');
     Read(kbd,Ch);
     gotoxy(1,WhereY);
     ClrEol;
     ModCursor(CursorOn);
end;

Procedure Block;
Var
   Reg : Registers;

begin
     with Reg do
     begin
     ch := 01;
     cl := 12;
     ah := 1;
     Intr($10,Reg)
     end
end;

Procedure Configuration;
   Var
      Finished : Byte;
      TC : Char;
   begin
          InitWindow(0,True);
        ModCursor(CursorOff);
        MakeWindow(7,10,7,60,White+BlackBG,White+BlackBG,DoubleBrdr,Window1);
        TitleWindow(Top,Center,'Color Selection');
        Repeat
        MakeFile(ConfigFile,'answers.cfg',SizeOf(ConfigRec));
          For Times := 1 to 18 do
                ConfigRec.Colors[Times] := 0;
        ClearWindow;
        QWrite(8,12,White+BlackBG,'Select a Color for each of the following:');
        QWrite(9,12,White+BlackBG,'Main Text Color: ');
        QWrite(10,12,White+BlackBG,'Error Message Color: ');
        QWrite(11,12,White+BlackBG,'HighLight Color: ');
        ConfigRec.Colors[1] := ColorSelect(9,30,1,1);
        QWrite(9,12,ConfigRec.Colors[1],'Main Text Color: ');
        ConfigRec.Colors[2] := ColorSelect(10,33,1,1);
        QWrite(10,12,ConfigRec.Colors[2],'Error Message Color: ');
        ConfigRec.Colors[3] := ColorSelect(11,30,1,1);
        QWrite(11,12,ConfigRec.Colors[3],'HighLight Color: ');
          PutRec(ConfigFile,1,ConfigRec);
        CloseFile(ConfigFile);
          Finished := 0;
        QWrite(12,12,White+BlackBg,'Are you satisfied with these colors ? (Y or N)');
        NormalAtt  := Attr(White,Blue);
        ReverseAtt := Attr(White,Blue);
        TC := SelectBoolean(Finished,'Y','N',62,12);
        Block;
        Until Finished = 1;
        ModCursor(CursorOff);
        RemoveWindow;
        QWriteC(12,1,80,White+RedBG,'Color Selections have been saved.');
end; (* Procedure Configuration *)

Procedure AnswerQuestion;
{ $B+}
     Function Clean(var Dirty : String6) : string;
     Var
    Ch : Char;
    OutStr : string[6];
    I : Integer;
     begin
    OutStr := '';
    For I := 1 to Length(TrimL(TrimR(Dirty))) do
    begin
         Ch := Dirty[I];
       If (UpCase(Ch) in ['A'..'Z']) or (Ch in ['0'..'9']) then
       OutStr := OutStr + Ch;
       end;
           Clean := PadR(TrimR(TrimL(OutStr)),6);
     end;
{ $B-}

     Procedure ScrollDown;Forward;
     Procedure ScrollUp;

     begin
          while (Ch = #72) or (ch = #27) do
          begin
          gotoxy(1,1);
          DelLine;
          Foot := Foot + 1;
          Head := Head + 1;
          If Foot>FS then
          begin
          while Foot>FS do
          begin
          Beep;
          QWrite(24,1,Color[2],'End of File.');
          Head := FS-(FS-Head-1);
          Read(kbd,Ch);
          If Ch = #27 then
          begin
          Read(kbd,Ch);
          if ch = #80 then ScrollDown;
          end;
          end;
          end
          else
          begin
          Seek(TextDataFile,Foot-1);
          Read(TextDataFile,TextDataRec);
          with TextDataRec do
          begin
          Message := TextLine;
          If Foot-1 = RedLine then
          begin
          QWrite(23,1,Color[3],PadR(Message,80));
          end
          else
          QWrite(23,1,Color[1],Message);
          Read(kbd,Ch);
          end;
          end;
          end
          end;

          Procedure ScrollDown;

          begin
          while (Ch = #80) or (Ch = #27) do
          begin
          gotoxy(1,1);
          InsLine;
          Head := Head - 1;
          Foot := Foot - 1;
          If Head<0 then
          begin
          WHILE Head<0 do
          begin
          Beep;
          QWrite(1,1,Color[2],'Beginning of File.');
          Read(kbd,Ch);
          If Ch = #27 then begin
          Read(kbd,Ch);
          If ch = #72 then ScrollUp;
          end;
          end;
          end
          else
          begin
          Seek(TextDataFile,Head);
          Read(TextDataFile,TextDataRec);
          with TextDataRec do
          begin
          Message := TextLine;
          If Head = RedLine then
          begin
          QWrite(1,1,Color[3],PadR(Message,80));
          end
          else
          QWrite(1,1,Color[1],Message);
          Read(kbd,Ch);
          end;
          end;
          end;
          end;

          Procedure SortInts(Var FinalWord : Elements; c : Integer);

          Var
             d,f,Foot,Head,Middle : Integer;
             Temp : Element;

             begin
                  for d := 2 to c do
                  begin
                  Temp := FinalWord[d];Foot := 1;Head := d-1;
                  while Foot<=Head do
                  begin
                  Middle := (Foot+Head) div 2;
                  If Temp<FinalWord[Middle]
                  Then Head := Middle -1
                  else Foot := Middle+1
                  end;
                  for f := d-1 downto Foot do
                  FinalWord[f+1] := FinalWord[f];
                  FinalWord[Foot] := Temp
                  end
             end;

begin
     InitWindow(Blue+BlueBG,True);
     Block;
     For I := 1 to 1000 do
     begin
     Answers[1,I] := 0;
     Answers[2,I] := 0;
     end;
     for I := 1 to 100 do
     FinalWord[I] := 0;
     A := 1;
     SetWindowModes($00);
     MakeWindow(4,12,16,60,White+BlueBG,White+BlueBG,DoubleBrdr,Window25);
     QWriteC(22,1,80,Black+GreenBG,'Copyright 1988 Brian Corll');
     gotoxy(3,6);
     write('What topic are you looking for ?');
     gotoxy(3,10);
     write('Press ESCape Key to End Program.');
     Message := '';
     For Q := 1 to 52 do
     begin
     Message := Message+chr(219);
     end;
     gotoxy(3,14);
     write('         ANSWERS !                 VERSION 4.0     ');
     SetWindowModes(ShadowRight);
     MakeWindow(3,28,3,27,Black+GreenBG,Black+GreenBG,HdoubleBrdr,Window9);
     QWriteC(4,28,55,Black+GreenBG,UpperCase(ParamStr(1)));
     TextColor(White);
     TextBackGround(Blue);
     NormalAtt  := Attr(White,Blue);
     ReverseAtt := Attr(White,Blue);
     Block;
     Query := '';
     TC := SelectString(Query,55,14,12);
     If TC = #27 then
     begin
      InitWindow(0,True);
      ModCursor(CursorOn);
     Close(TextDataFile);
     TAClose(PointerFile);
      Halt(1);
      end;
     ModCursor(CursorOff);
      RemoveWindow;
     MakeWindow(3,28,3,27,White+RedBG,White+RedBG,DoubleBrdr,Window11);
     gotoxy(3,2);
     write('      Searching... ');
     Query := UpperCase(TrimR(TrimL(Query)));
     K := 1;
     Number := Words(Query);
     while K<=Number do
      begin
      ParseStr := WordOne(Query,K);
      ParseStr := PadR(copy(Clean(ParseStr),1,6),6);
       TARead(PointerFile,PointerRec,ParseStr,PartialMatch);
     if not Ok then
        begin
        end
     else
     begin
     with PointerRec do
     begin
     Pntr := 1;
     while PtrArray[Pntr]>0 do
     begin
     Answers[1,A] := PtrArray[Pntr];
     Pntr := Pntr + 1;
     A := A + 1;
     end;
     end;
     end;
     K := K + 1;
     end;
     If Answers[1,1]>0 then
     begin
     for Z := 1 to A do
     begin
     G := Answers[1,Z];
     for P := 1 to A do
     begin
     if Answers[1,P] = G then Answers[2,Z] := Answers[2,Z]+1;
     end;
     end;
     G := Answers[2,1];
     for Z := 1 to A do
     begin
     If Answers[2,Z]>G then G := Answers[2,Z];
     end;
     end;
     X := 1;
     for Z := 1 to A do
     begin
     If Answers[2,Z] = G then
     begin
     P := Answers[1,Z];
     FinalWord[X] := P;
     X := X +1;
     end;
     end;
     SortInts(FinalWord,100);
     If FinalWord[100] = 0 then
     begin
     TextBackGround(White);
     ModCursor(CursorOff);
     For Times := 1 to 3 do
     Beep;
     MakeWindow(5,11,13,60,White+RedBG,White+RedBG,DoubleBrdr,Window12);
     gotoxy(12,3);
     QWriteC(8,11,71,White+RedBG,'No answers found to match');
     Message := '"'+UpperCase(Query)+'"';
     QWriteC(11,11,71,White+RedBG,Message);
     QWriteC(14,11,71,White+RedBG,'Press any key to continue.....');
     Read(kbd,Ch);
     RemoveWindow;
     RemoveWindow;
     ModCursor(CursorOn);
     end
     else
     begin
     RemoveWindow;
      InitWindow(0,True);
     GoAhead := 'Y';
     while GoAhead = 'Y' do
      begin
     M := 1;
     ClrScr;
     ModCursor(CursorOff);
     QWrite(1,1,LightCyan+BlackBG,'The following line(s) of text pertain to your question: ');
     H := 0;
     Spot := 2;
     for Z := 99-(x) to 100 do
     begin
     if FinalWord[Z]>0 then
     begin
     If FinalWord[Z]>H then
     begin
     ChoiceNumbers[M] := FinalWord[Z];
     Seek(TextDataFile,FinalWord[Z]-1);
     Read(TextDataFile,TextDataRec);
     with TextDataRec do
     begin
     Str(M,St);
     Message := St + ': '+ TrimL(TextLine);
     QWrite(Spot,1,LightCyan+BlackBG,Message);
     M := M + 1;
     Spot := Spot + 1;
     If (M mod 21) = 0 then
     begin
     gotoxy(1,Spot+1);
     Spot := 2;
     wait;
     ClrScr;
     QWrite(1,1,LightCyan+BlackBG,'These additional line(s) of text pertain to your question: ');
     end;
     end;
     H := FinalWord[Z];
     end;
     end;
     end;
     Choice := 0;
     QWrite(Spot+2,1,White+RedBg,'Enter line number to begin display >>> ');
     Block;
     TextColor(White);
     NormalAtt  := Attr(White,Blue);
     ReverseAtt := Attr(White,Blue);
     TC := SelectByte(Choice,0,M-1,3,42,Spot+2);
     If Choice = 0 then Exit;
     If Choice>0 then
     begin
        ClrScr;
        MakeWindow(1,1,25,80,Color[1],Color[1],NoBrdr,Window2);
         ModCursor(CursorOff);
         Lines :=1;
         RecordNum := ChoiceNumbers[Choice]-1;
         Head := RecordNum;
         RedLine := RecordNum;
             if RecordNum<0 then exit;
             If RecordNum+23>=FS then EndPoint := FS-RecordNum
             else EndPoint := 23;
         while Lines <=EndPoint do
             begin
             Seek(TextDataFile,RecordNum);
         Read(TextDataFile,TextDataRec);
                 with TextDataRec do
                 begin
                 If Lines = 1 then
                 begin
                 Message := TextLine;
                 QWrite(Lines,1,Color[3],PadR(Message,80));
                 end
                 else
            begin
                 Message := TextLine;
                 QWrite(Lines,1,Color[1],Message);
                 end;
             Lines := Lines + 1;
             RecordNum := RecordNum + 1;
         end;
        end;
     Foot := RecordNum;
     QWrite(24,1,Color[4],'     Press '+#24+' Key to Scroll Up , '+#25+' Key to Scroll Down , or Enter Key to Exit     ');
     Read(kbd,Ch);
         If Ch = #27 then
             begin
                Read(kbd,Ch);
             if (ch = #72) or (ch = #80) then
             begin
             gotoxy(1,24);
             ClrEol;
             while (Ch = #72) or (Ch = #80) do
             begin
             case Ch of
              #72 : ScrollUp;
               #80 : ScrollDown;
               end;
             end;
             end;
         end;
     MakeWindow(12,24,3,37,White+RedBG,White+RedBG,DoubleBrdr,Window20);
     Block;
     write(' Choose another line ? (Y or N) ');
      WhyNot := 0;
          NormalAtt  := Attr(White,Blue);
          ReverseAtt := Attr(White,Blue);
     TC := SelectBoolean(WhyNot,'Y','N',57,13);
      If WhyNot = 2 then Exit;
     RemoveWindow;
     RemoveWindow;
     ClrScr;
      end;
     end;
     ModCursor(CursorOn);
     RemoveWindow;
     RemoveWindow;
end;
end;

Procedure Initialize;

Procedure OpenFiles;
Var
   Times : Byte;

begin
     ModCursor(CursorOff);
     If UpperCase(ParamStr(1))='COLORS' then
     begin
     Configuration;
     Halt(1);
     end;
     TAOpen(PointerFile,ParamStr(1)+'.ptr',SizeOf(PointerRec),ParamStr(1)+'.ndx',SizeOf(IndexType)-1);
     If (not OK) then
     begin
     InitWindow(Black+BlackBG,True);
     MakeWindow(5,15,15,55,Black+LightGrayBG,Black+LightGrayBG,DoubleBrdr,Window30);
     For Times := 1 to 3 do
     Beep;
     gotoxy(2,4);
     write('No files with a root name of ',UpperCase(ParamStr(1)),' were found !');
     gotoxy(2,6);
     write('You will be returned to the DOS prompt in a moment.');
     gotoxy(3,8);
     write('Start the program again using a valid file name.');
     Delay(5000);
     RemoveWindow;
     InitWindow(0,True);
     Halt;
     end
     else
     begin
     Assign(TextDataFile,ParamStr(1)+'.dat');
     Reset(TextDataFile);
     FS := FileSize(TextDataFile);
     end;
end;

Procedure StartUp;
begin
     QInit;
     CRTCols := CrtColumns;
     CheckSnow := QSnow;
     TheCowsComeHome := False;
     CheckBreak := False;
end;

Procedure GetConfig;
Var
   H,Times : Byte;
begin
     If ParamCount = 0 then
     begin
     For Times := 1 to 3 do
     Beep;
     TextColor(White);
     writeln('Syntax: ANSWERS <filename>');
     Halt;
     end
      else
     If UpperCase(ParamStr(1)) = 'COLORS' then
     begin
     Configuration;
      Halt(1);
     end
      else
      begin
     ClrScr;
     For H := 1 to 4 do
     Color[H] := 0;
      OpenFile(ConfigFile,'answers.cfg',SizeOf(ConfigRec));
      GetRec(ConfigFile,1,ConfigRec);
     Color[1] := ConfigRec.Colors[1];
     Color[2] := ConfigRec.Colors[2];
     Color[3] := ConfigRec.Colors[3];
      Color[4] := Black+LightGrayBG;
     CloseFile(ConfigFile);
end;
end;

Procedure NoFiles;
Var
   Times : Byte;
    begin
     ModCursor(CursorOff);
     InitWindow(White+BlackBG,True);
     SetWindowModes(ShadowRight+ZoomMode);
     MakeWindow(10,17,5,50,White+BlackBG,White+BlackBG,DoubleBrdr,Window30);
     For Times:= 1 to 3 do
     Beep;
     QWrite(12,20,White+BlackBG,'NO FILES WERE SPECIFIED ON THE COMMAND LINE.');
     Delay(3000);
     RemoveWindow;
     InitWindow(Black+BlackBG,True);
     ModCursor(CursorOn);
     Halt;
end;

begin (* Initialize *)
     If ParamCount=0 then NoFiles;
     StartUp;
     GetConfig;
     OpenFiles;
end; (* Initialize *)

begin (* Main Program *)
     Initialize;
     Repeat
     AnswerQuestion
     Until TheCowsComeHome;
end. (* Main Program *)