home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / answcode / index.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-10-27  |  8.6 KB  |  344 lines
  1. {$M 65500,16384,655360} {Turbo 3 default stack and heap}
  2. {$R-,S-,D-,T-,F+,V-,N-,I-,B-}
  3. Program Index;
  4.  
  5. { ANSWERS ! Version 4.0 May 10, 1988}
  6. { Copyright 1988, Brian Corll }
  7. { All Rights Reserved }
  8.  
  9. {$U LSort}
  10. Uses Crt,Dos,Turbo3,LSort,Sort,Qwik,Wndw,Wndwvars,Library,NewPoint;
  11.  
  12. const
  13.      TextSize = 4500;
  14.      MaxWndws = 30;
  15. Type
  16.   String80 = String[80];
  17.   ShortString = String[30];
  18.   AnyString = String[255];
  19.   String6 = String[6];
  20.   String8  = String[8];
  21.   StringOne = String[1];
  22.   PtrArray = Array[0..255] of Integer;
  23.   WdString = String[20];
  24.   LineSize = String[12];
  25.   TextData = record
  26.            TextLine : String80;
  27.            end;
  28.   UnSorted = Record
  29.             KeyWord : String[12];
  30.             end;
  31.  
  32.   Sorted = Record
  33.             KeyWord : String[12];
  34.             end;
  35.  
  36.   TextArrayType = array[1..TextSize] of LineSize;
  37.   ParseType = String[80];
  38.   RootString = String[8];
  39. var
  40.     Message : string;
  41.     Num : String[5];
  42.    Times : Integer;
  43.    Initial,YesNo : Char;
  44.    Line,LineCount,Position,Width,J,EndWord,PointNum,Ptr,Per,K,M,I,IntValue : Integer;
  45.    SourceStr : ParseType;
  46.    Found : Boolean;
  47.    InFile,OutFile : Text;
  48.    LineOut,OutFileName,DtaTxtFileName,InWord,NewWord,LineIn,InFileName : String[12];
  49.    OneLine : String[80];
  50.    FirstCh : String[1];
  51.    TextDataFile : File of TextData;
  52.    TextDataRec : TextData;
  53.    InStr : WdString;
  54.    Root : String8;
  55.    WrtLine : String[20];
  56.    TextArray : TextArrayType;
  57.    CRTCols,Row,Col,Result : Integer;
  58.    UnSortFile : File of UnSorted;
  59.     SortFile : File of Sorted;
  60.     UnSorts : UnSorted;
  61.     Sorts : Sorted;
  62.     Buffer : Array[1..2048] of Char;
  63.    KeyLine : String[12];
  64.    LongI : LongInt;
  65.    Beginning,LSortResult,SortResult : Integer;
  66.  
  67.  
  68. Procedure ProcessString(InString : String80);
  69.  
  70. var
  71. I : Integer;
  72. OutWord : String80;
  73. g,f,m,z : Integer;
  74. Posit : Integer;
  75. Marker : Integer;
  76. ProcWord : String80;
  77. Ch,Character : Char;
  78. OneByte,Code : Byte;
  79. begin
  80. I := 1;
  81. z := Words(InString);
  82. for I := 1 to Z do
  83.       begin
  84.       ProcWord := OneWord(InString,I);
  85.       ProcWord := copy(procWord,1,6);
  86.       Marker := Length(triml(trimr(ProcWord)));
  87.       Posit := 1;
  88.       OutWord := '';
  89.               For Posit := 1 to Marker do
  90.                   begin
  91.                   Character := ProcWord[Posit];
  92.                   If UpCase(Character) in ['A'..'Z'] then
  93.                      begin
  94.                      OutWord := OutWord + Character;
  95.                      end;
  96.                   If Character in ['0'..'9'] then
  97.                      begin
  98.                      OutWord := OutWord + Character;
  99.                      end;
  100.                      end;
  101.                 If Length(TrimL(TrimR(OutWord)))>0 then
  102.           begin
  103.               LongI := LongI + 1;
  104.               Num := '';
  105.           with UnSorts do
  106.           begin
  107.           Str(Line:5,Num);
  108.           KeyWord := PadR(UpperCase(OutWord)+','+TrimL(Num),12);
  109.           write(UnSortFile,UnSorts);
  110.           end;
  111.           end;
  112.                   ProcWord := '';
  113.                   end;
  114. end;
  115.  
  116. {$F+}
  117.  
  118. Procedure Beep;
  119. Begin
  120.   Sound(1500); Delay(50);
  121.   Sound(1000); Delay(50);
  122.   NoSound;
  123. End;
  124.  
  125. Procedure InpRecs;
  126. Begin
  127.     Repeat
  128.         Read(UnSortFile,UnSorts);
  129.         SortRelease(UnSorts);
  130.    Until eof(UnSortFile);
  131. end;
  132.  
  133. Function LessRec(var x,y : UnSorted) : Boolean;
  134.  
  135. begin
  136.     LessRec := x.KeyWord<y.KeyWord;
  137. end;
  138.  
  139. Procedure OutpRecs;
  140.  
  141. begin
  142. Assign(SortFile,Root+'.srt');
  143. Rewrite(SortFile);
  144.     Repeat
  145.         SortReturn(UnSorts);
  146.       with UnSorts do
  147.         begin
  148.             KeyLine := PadR(KeyWord,12);
  149.             with Sorts do
  150.             begin
  151.                 KeyWord := KeyLine;
  152.             end;
  153.             end;
  154.     Write(SortFile,Sorts);
  155.    Until SortEos;
  156.    Close(UnSortFile);
  157.     Close(SortFile);
  158. end;
  159.  
  160. Procedure LLInpRecs;
  161. Begin
  162.     Repeat
  163.         Read(UnSortFile,UnSorts);
  164.         LSortRelease(UnSorts);
  165.    Until eof(UnSortFile);
  166. end;
  167.  
  168. Function LLessRec(var x,y : UnSorted) : Boolean;
  169.  
  170. begin
  171.     LLessRec := x.KeyWord<y.KeyWord;
  172. end;
  173.  
  174. Procedure LLOutpRecs;
  175.  
  176. begin
  177. Assign(SortFile,Root+'.srt');
  178. Rewrite(SortFile);
  179.     Repeat
  180.         LSortReturn(UnSorts);
  181.       with UnSorts do
  182.         begin
  183.             KeyLine := PadR(KeyWord,12);
  184.             with Sorts do
  185.             begin
  186.                 KeyWord := KeyLine;
  187.             end;
  188.             end;
  189.    write(SortFile,Sorts);
  190.    Until LSortEos;
  191.     Close(UnSortFile);
  192.     Close(SortFile);
  193. end;
  194.  
  195. begin
  196.      InitWindow(0,True);
  197.      SetWindowModes(ZoomMode);
  198.      Line := 0;
  199.      ClrScr;
  200.      If ParamCount=0 then
  201.      begin
  202.       Beep;
  203.       ClrScr;
  204.       MakeWindow(9,20,5,40,Red+LightGrayBG,Red+LightGrayBG,DoubleBrdr,aWindow);
  205.       QWriteC(11,1,80,Red+LightGrayBG,'Syntax : INDEX filename.ext');
  206.       Halt(1);
  207.      end
  208.      else
  209.      InFileName := ParamStr(1);
  210.      Off;
  211.      Per := Pos('.',InFileName);
  212.      Root := Copy(InFileName,1,Per-1);
  213.      Root := UpperCase(Root);
  214.      Assign(InFile,InFileName);
  215.      SetTextBuf(InFile,Buffer);
  216.      Reset(InFile);
  217.      If (IoResult<>0) then
  218.      begin
  219.      Beep;
  220.      InitWindow(0,True);
  221.       MakeWindow(11,20,3,44,White+RedBG,White+RedBG,DoubleBrdr,Window23);
  222.       Message := 'File '+UpperCase(ParamStr(1))+' does not exist !';
  223.      TitleWindow(Top,Center,Message);
  224.       gotoxy(12,2);
  225.       write('          Aborting Program. Sorry !');
  226.      Halt;
  227.      end;
  228.      ClrScr;
  229.      MakeWindow(17,1,8,80,White+RedBG,White+RedBG,DoubleBrdr,Window30);
  230.      gotoxy(2,2);
  231.      gotoxy(2,3);
  232.      write('                             ANSWERS ! Version 4.0');
  233.      gotoxy(2,4);
  234.      write('                           Copyright 1988 Brian Corll');
  235.      gotoxy(2,5);
  236.      write('                               All Rights Reserved');
  237.      MakeWindow(1,9,3,64,White+BlackBG,White+BlackBG,DoubleBrdr,Window10);
  238.      gotoxy(16,2);
  239.      TextColor(White);
  240.      write('         Creating ',Root+'.DAT',' data file from text file.');
  241.      assign(TextDataFile,Root+'.dat');
  242.      rewrite(TextDataFile);
  243.      MakeWindow(5,14,3,55,Black+LightGrayBG,Black+LightGrayBG,DoubleBrdr,Window11);
  244.      I := 1;
  245.      while not eof(InFile) do
  246.      begin
  247.      readln(InFile,OneLine);
  248.      if Pos(chr(12),OneLine)>0 then
  249.      OneLine := Copy(OneLine,Pos(chr(12),OneLine)+1,80-Pos(chr(12),OneLine));
  250.      gotoxy(2,1);
  251.      write('              Writing Record Number ',I);
  252.      with TextdataRec do
  253.      begin
  254.      TextLine := OneLine;
  255.      write(TextDataFile,TextDataRec);
  256.      end;
  257.      I := I +1;
  258.      end;
  259.      close(TextDataFile);
  260.       Close(InFile);
  261.      SetTextBuf(InFile,Buffer);
  262.      reset(InFile);
  263.      Assign(UnSortFile,Root+'.uns');
  264.      Rewrite(UnSortFile);
  265.      MakeWindow(9,12,3,59,Black+LightGrayBG,Black+LightGrayBG,DoubleBrdr,Window11);
  266.       LongI := 0;
  267.      while not eof(InFile) do
  268.      begin
  269.      Line := Line+1;
  270.      gotoxy(2,1);
  271.      write('          Parsing ',UpperCase(InFileName),' Line Number ',Line);
  272.      Readln(InFile,OneLine);
  273.      if length(triml(trimr(OneLine)))>0 then
  274.      ProcessString(OneLine);
  275.      end;{while}
  276.       Close(UnSortFile);
  277.      Reset(UnSortFile);
  278.       If LongI>=32767 then
  279.       begin
  280.      MakeWindow(13, 17, 3, 52, White+BlackBG,White+BlackBG, DoubleBrdr,Window1);
  281.       Write('               LongSorting ', UpperCase(Root),'.UNS');
  282.       LSortResult := LTurboSort(SizeOf(UnSorted),@LLInpRecs,@LLessRec,@LLOutpRecs);
  283.       if LSortResult = 0 then
  284.       begin
  285.          ClrScr;
  286.          write('                 Sorting Complete !')
  287.       end
  288.       else
  289.       begin
  290.          ClrScr;
  291.          For Times := 1 to 5 do
  292.          Beep;
  293.          writeln(^G,'                  Sort Error # ',LSortResult);
  294.       end;
  295.       end
  296.       else
  297.       begin
  298.      MakeWindow(13, 17, 3, 52, White+BlackBG,White+BlackBG, DoubleBrdr,Window1);
  299.      Write('             ShortSorting ', UpperCase(Root),'.UNS');
  300.      SortResult := TurboSort(SizeOf(UnSorted),@InpRecs,@LessRec,@OutpRecs);
  301.       if SortResult = 0 then
  302.          begin
  303.          ClrScr;
  304.        write('                 Sorting Complete !')
  305.          end
  306.       else
  307.          begin
  308.          ClrScr;
  309.          For Times := 1 to 5 do
  310.          Beep;
  311.          write(^G,'                  Sort Error # ',SortResult);
  312.          end
  313.       end;
  314.      Erase(UnSortFile);
  315.       MakePointers;
  316.       Erase(SortFile);
  317.      InitWindow(0,True);
  318.       SetWindowModes(ZoomMode);
  319.      MakeWindow(10,11,4,62,White+BlueBG,White+BlueBG,DoubleBrdr,Window7);
  320.      gotoxy(2,1);
  321.      write('                   Processing is Complete.');
  322.       gotoxy(2,2);
  323.       write('                  Press Any Key to Continue.');
  324.      Repeat until KeyPressed;
  325.       RemoveWindow;
  326.       MakeWindow(1,1,25,80,White+BlueBG,White+BlueBG,SolidBrdr,aWindow);
  327.      MakeWindow(9,11,5,62,White+RedBG,White+RedBG,DoubleBrdr,Window8);
  328.      gotoxy(18,2);
  329.      write('Copyright 1988 Brian Corll');
  330.      gotoxy(22,3);
  331.      write('All Rights Reserved');
  332.      Delay(3000);
  333.      for i:=1 to 5000 do
  334.      begin
  335.      Row:=random(25)+1;
  336.      Col:=random(CRTcols)+1;
  337.      Qfill (row,col, 1, 1,Black,' ');
  338.      end;
  339.       On;
  340.       InitWindow(0,True);
  341. end.
  342.  
  343.  
  344.