home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPCASE.ZIP / TPCASE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  15.0 KB  |  394 lines
  1. PROGRAM Cases;
  2. {$D-,R-,V-}
  3.  
  4. uses DOS, Crt, Panes;
  5.  
  6. TYPE
  7.         ChFile = Text;
  8. CONST
  9.         UCaseChr : Set of Char = ['A'..'Z'];
  10. VAR
  11.      InFile, OutFile : ChFile;              { Text files                                     }
  12.      InFileName, OutFileName : String[65];
  13.      Switch   : String[1];                  { Holds the "u" or "l" params.}
  14.      ch       : String[255];                { Temporary string to process.}
  15.      TbufOut,                               { Used for dynamic allocation }
  16.      TbufIn        : Pointer;                    { of text file buffer.        }
  17.      NChars   : LongInt;                    { Number of chars processed.  }
  18.      LL,                                    { Number of lines processed.  }
  19.      TBufSize    : Word;                       { Max size of file buffer.    }
  20.      TermFlag : Boolean;                    { Flag for end of a sentence. }
  21.      I, Row,
  22.      Col          : Byte;
  23.  
  24.  
  25. PROCEDURE SetBuf;
  26. Begin
  27.     IF MaxAvail > ( 65535 * 2) THEN          { TP5.5 limits max size of a  }
  28.     Begin TBufSize := 65000; End             { heap variable to 65519 bytes}
  29.     ELSE Begin
  30.     TBufSize := MaxAvail div 3;              { Leave a margin                             }
  31.     End;
  32.     GetMem(TBufIn,TBufSize);
  33.     GetMem(TBufOut,TBufSize);
  34. End;
  35.  
  36. PROCEDURE RestoreCursor ( Row, Col : Integer);
  37. VAR TheRegs : Registers;
  38. BEGIN
  39.     TheRegs.AH := $2;        { function request code}
  40.     TheRegs.DH := Row;       { new row position         }
  41.     TheRegs.DL := Col;         { new column position     }
  42.     TheRegs.BH := 0;         { page 0                             }
  43.     Intr ( $10, TheRegs);       { BIOS interrupt             }
  44. END;  { RestoreCursor }
  45.  
  46. FUNCTION IntToStr(i: Longint): string;
  47. var
  48.     s: string[11];           { length of a LONGINT variable }
  49. begin
  50.     Str(i, s);
  51.     IntToStr := s;
  52. end;
  53.  
  54. PROCEDURE CenterString(TheString: String; Line: Byte);
  55. VAR
  56. Offset : Byte;             { this routine is window oriented }
  57. Begin
  58. Offset := ((Lo(WindMax) - Lo(WindMin))Div 2 +1 ) - (Length(TheString)DIV 2);
  59. GotoXY(Offset,line);
  60. Write(TheString);
  61. End;
  62.  
  63. PROCEDURE Chirp;
  64. Begin
  65.    Sound(900); Delay(25);
  66.    Sound(750); Delay(25);
  67.    NoSound;
  68. End;
  69.  
  70. PROCEDURE Buzz;
  71. Begin
  72.      Sound(100); Delay(250);
  73.      NoSound;
  74. End;
  75.  
  76. PROCEDURE WaitForUser(PromptStr: String);
  77. Var Ch : Char;
  78. Begin
  79.     CenterString(PromptStr, WhereY);
  80.     Ch := ReadKey;
  81.     Repeat
  82.     IF Ch <> #13 THEN
  83.         Begin
  84.         Buzz;
  85.         Ch := ReadKey;
  86.         End;
  87.     Until Ch = #13;
  88. End;
  89.  
  90.  
  91. PROCEDURE CloseUp;
  92. Begin
  93.     winclose;
  94.     FreeMem(TBufIn,TBufSize);               { deallocate the text buffer   }
  95.     FreeMem(TBufOut,TBufSize);
  96.     ShowCursor;
  97.     RestoreCursor(Row,Col);
  98.     WriteLn(' THANK YOU for using CASE...');
  99.     WriteLn(' A public domain program by Peter Gallagher');
  100.     WriteLn;
  101. End;
  102.  
  103. PROCEDURE Instructions;
  104. BEGIN
  105.     Buzz;
  106.     WinOpen(8,4,63,23,HWinAttr);Winborder(1,HBordAttr,' CASE Help ');
  107.     WriteLn('The command to start CASE must specify which process ');
  108.     WriteLn('   you wish to use: either <u>pper or <l>ower case.  ');
  109.     WriteLn('   Use only one of these commands each time you use  ');
  110.     WriteLn('   CASE.  There must be a space before and after the ');
  111.     WriteLn('   switch.  You must also name the file to process   ');
  112.     WriteLn('   and you may specify a name for the converted file.');
  113.     WriteLn('   If you do not name a file for output CASE will    ');
  114.     WriteLn('   create a new file using the name of the input file');
  115.     WriteLn('   but adding the extension "LOW" or "UP ".          ');
  116.     WriteLn;
  117.     WriteLn('You may specify input and output files in any disk   ');
  118.     WriteLn('   directory by including the full path name.        ');
  119.     WriteLn('   Like this...                                      ');
  120.     WriteLn('   [Disk Drive name]:\[directory]\..Filename.Ext     ');
  121.     WriteLn('   eg: Case u C:\Word\Docs\Uppercase.DOC             ');
  122.     WriteLn('      drive---^   ^----^--path  ^----File.Extension  ');
  123.     WriteLn;
  124.     WaitForUser('* Press ENTER when you are ready to restart *');
  125.     WinClose;
  126.     WinClose;
  127.     RestoreCursor(Row,Col);
  128.     WriteLn('Command Line format is: ');
  129.     WriteLn('Case <u> <l> [d:\path\]InputFile.ext [OutputFile.ext]');
  130.     WriteLn;
  131.     ShowCursor; Halt;
  132. END;
  133.  
  134. PROCEDURE Lower(Var STRG : String);     {using code created from Lower.asm}
  135. BEGIN
  136. Inline(
  137.   $C4/$BE/STRG/          {    LES DI,[BP]               ; TP SETUP}
  138.   $26/$8A/$0D/           {    MOV CL,ES [DI]            ;}
  139.   $FE/$C1/               {    INC CL                    ;}
  140.   $FE/$C9/               {L1: DEC CL                    ; Get a chr}
  141.   $74/$5E/               {    JZ  L3                    ; All gone, exit.}
  142.   $47/                   {    INC DI                    ;}
  143.   $26/$80/$3D/$2E/       {L2: ES: CMP BYTE PTR [DI],'.' ; Is this a sentence}
  144.   $74/$1E/               {    JZ  T1                    ; terminator?}
  145.   $26/$80/$3D/$3F/       {    ES: CMP BYTE PTR [DI],'?' ; Go to Term routine}
  146.   $74/$18/               {    JZ  T1                    ; at T1.}
  147.   $26/$80/$3D/$21/       {    ES: CMP BYTE PTR [DI],'!' ;}
  148.   $74/$12/               {    JZ  T1                    ;}
  149.   $26/$80/$3D/$41/       {    ES: CMP BYTE PTR [DI],'A' ; Or is it in the}
  150.   $72/$E3/               {    JB  L1                    ; range A..Z ?}
  151.   $26/$80/$3D/$5A/       {    ES: CMP BYTE PTR [DI],'Z' ;}
  152.   $77/$DD/               {    JA  L1                    ;}
  153.   $26/$80/$05/$20/       {    ES: ADD BYTE PTR [DI],32  ; Then add 32}
  154.   $EB/$D7/               {    JMP L1                    ; and loop for next.}
  155.   $FE/$C9/               {T1: DEC CL                    ; Sentence Terminator}
  156.   $74/$35/               {    JZ  L3                    ; detected, get next}
  157.   $47/                   {    INC DI                    ; chr.}
  158.   $26/$80/$3D/$20/       {    ES: CMP BYTE PTR [DI],$20 ; If a SP check}
  159.   $74/$0E/               {    JE  X1                    ; the next char.}
  160.   $26/$80/$3D/$21/       {    ES: CMP BYTE PTR [DI],'!' ; If a '!' or a '.'}
  161.   $74/$EF/               {    JE  T1                    ; restart the term}
  162.   $26/$80/$3D/$2E/       {    ES: CMP BYTE PTR [DI],'.' ; routine ie pass}
  163.   $74/$E9/               {    JZ  T1                    ; this one thru.}
  164.   $EB/$C3/               {    JMP L2                    ; Nope. So test it.}
  165.   $FE/$C9/               {X1: DEC CL                    ; A term and one SP}
  166.   $74/$1C/               {    JZ L3                     ; found, get}
  167.   $47/                   {    INC DI                    ; next chr.}
  168.   $26/$80/$3D/$20/       {    ES: CMP BYTE PTR [DI],$20 ; Is it a SP?}
  169.   $74/$02/               {    JZ X2                     ;}
  170.   $EB/$B6/               {    JMP L2                    ; No? False alarm.}
  171.   $FE/$C9/               {X2: DEC CL                    ; If here then we need}
  172.   $74/$0F/               {    JZ L3                     ; to find the next Ucase}
  173.   $47/                   {    INC DI                    ; chr and pass it thru}
  174.   $26/$80/$3D/$41/       {    ES: CMP BYTE PTR [DI],'A' ; without conversion}
  175.   $72/$F5/               {    JB  X2                    ; Below A, try again}
  176.   $26/$80/$3D/$5A/       {    ES: CMP BYTE PTR [DI],'Z' ;}
  177.   $77/$EF/               {    JA  X2                    ; Above Z, try again}
  178.   $EB/$9E);              {    JMP L1                    ; Found it, go back to top.}
  179.                          {L3:                           ; Exit}
  180. End; { lower }
  181.  
  182. PROCEDURE Upper(Var Strg : String);         { Using code in Upper.asm }
  183. Begin
  184. Inline(
  185.   $C4/$BE/STRG/          {    LES DI,[BP]               ; TP SETUP}
  186.   $26/$8A/$0D/           {    MOV CL,ES [DI]            ;}
  187.   $FE/$C1/               {    INC CL                    ;}
  188.   $FE/$C9/               {L1: DEC CL                    ; Get a chr.}
  189.   $74/$13/               {    JZ  L2                    ; All gone, exit.}
  190.   $47/                   {    INC DI                    ;}
  191.   $26/$80/$3D/$61/       {    ES: CMP BYTE PTR [DI],'a' ; Is it in range}
  192.   $72/$F5/               {    JB  L1                    ; a..z ?}
  193.   $26/$80/$3D/$7A/       {    ES: CMP BYTE PTR [DI],'z' ; Loop if not.}
  194.   $77/$EF/               {    JA  L1                    ; Else..}
  195.   $26/$80/$2D/$20/       {    ES: SUB BYTE PTR [DI],32  ; subtract 32}
  196.   $EB/$E9);              {    JMP L1                    ; and loop for next.}
  197.                          {L2:                           ; Exit}
  198. End; { upper }
  199.  
  200.  
  201. PROCEDURE ShowProgress(Val,Small,Large: Longint); { Do something on screen }
  202. CONST MarkerCh = #254;
  203. Begin
  204.     IF (Val MOD Small = (Small - 1)) THEN
  205.         Write(MarkerCh);
  206.     IF (Val MOD Large = (Large - 1)) THEN
  207.         Begin
  208.         Write (' ',LL,' lines processed');
  209.         WriteLn; End
  210. End;
  211.  
  212. PROCEDURE ReportError(ErrorRef : String; ErrorCode: Integer);
  213. { Each of these are treated as fatal and the program is halted }
  214. { after attempting to give the user a hint about what to do.   }
  215. Begin
  216. WinOpen(10,14,70,18,HWinAttr);Winborder(1,HBordAttr,'  OOPS!  ');
  217. Buzz;
  218. Case ErrorCode of
  219.             2 : writeln(' ',ErrorRef,' not found. Have you entered the name right ?');
  220.             3 : writeln(' Path ',ErrorRef,' not found (check the directory)');
  221.             4 : writeln(' Too many files open.  You may need to fix the Config.sys.');
  222.             5 : writeln(' Can`t open ',ErrorRef,'.  Check the file name.');
  223.         101 : writeln(' Can`t write to the disk ... it`s full.');
  224. 103,104 : writeln(' Can`t find a file with the name (or path) ',ErrorRef);
  225.         150 : writeln(' The disk you named is Write-Protected (check the tab)');
  226.         152 : writeln(' The drive isn`t ready.  Have you loaded a disk ?');
  227.         998 : writeln(' ',ErrorRef,' can`t be used for BOTH input and output.');
  228.         999 : writeln(' "',ErrorRef,'" isn`t a legal switch.  Use "u" or "l" only.');
  229.         Else  writeln(' Something screwy here !  Too many commands?  Try again.');
  230. end; {case}
  231. WaitForUser('* Press ENTER when ready *');
  232. WinClose;
  233. WinClose;
  234. RestoreCursor(Row,Col);
  235. WriteLn('Please try again.  The command format is: ');
  236. WriteLn('CASE <u> <l> [Drive:\path\]InputFile.ext [d:\path\][OutputFile.ext]');
  237. ShowCursor; Halt;
  238. End;
  239.  
  240. PROCEDURE MakeNames;                       { Set up names for                   }
  241. VAR I : Integer;                           { InFile and Outfile depending}
  242.         Ext, Sw : String;                      { on the first parameter.    }
  243. Begin
  244.     InFileName := ParamStr(2);
  245.     Sw := Copy(ParamStr(1),1,1);             { Allow for entry of full         }
  246.     Case Sw[1] of                            { word eg. "upper" but take  }
  247.     'l','L': Ext := 'LOW';                   { only first character in        }
  248.     'u','U': Ext := 'UP ';                   { upper or lower case.       }
  249.     Else ReportError(ParamStr(1), 999);
  250.     End;
  251.     I := pos('.',InFileName);
  252.     IF I = 0 THEN Begin
  253.         OutFileName := InFileName + '.' + Ext; End
  254.     ELSE Begin
  255.         OutFileName := copy(InFileName,1,I)+Ext; End;
  256. End;
  257.  
  258. FUNCTION CreateFile (Var TheFile : ChFile;  FName : STRING): Boolean;
  259. {Create a new File.  If not ok closes the file.}
  260. VAR
  261.     Result :  Integer;
  262. Begin
  263.     Assign( TheFile, FName);
  264.     SetTextBuf( TheFile, TBufOut^, TBufSize);
  265.     {$I-} Rewrite ( TheFile ); {$I+}
  266.     Result := IOResult;
  267.     IF Result <> 0 THEN ReportError(FName, Result);
  268.     CreateFile := IOResult = 0;
  269. End;
  270.  
  271. FUNCTION OpenFile ( VAR TheFile : ChFile; FName : STRING): Boolean;
  272. { opens an existing file }
  273. VAR
  274.     Result : Integer;
  275. Begin
  276.     Assign( TheFile, FName);
  277.     SetTextBuf(TheFile, TBufIn^, TBufSize);
  278.     {$I-} Reset ( TheFile ); {$I+}
  279.     Result := IOResult;
  280.   IF Result <> 0 THEN ReportError(FName, Result);
  281.     OpenFile := IOResult = 0;
  282. End;
  283.  
  284. PROCEDURE GetParams;
  285. VAR
  286.     P : Integer;
  287. BEGIN
  288.     P := ParamCount;
  289.     Begin
  290.         Case P of
  291.         0,1: Instructions;                       { No parameters so give help  }
  292.             2: MakeNames;
  293.             3: Begin InFileName := ParamStr(2); OutFileName := ParamStr(3);
  294.                              IF InFileName = OutFIleName THEN
  295.                              ReportError(OutFileName,998); End;
  296.         ELSE
  297.             ReportError('',000);                                   { ?? Garbage on command line. }
  298.         End; {select case}
  299.     End; {if}
  300.     IF NOT OpenFile(InFile, InFileName) THEN CloseUp; { unknown error.       }
  301.     IF NOT CreateFile(OutFile, OutFileName) THEN CloseUp;
  302. END;
  303.  
  304. PROCEDURE UCase;                              { Simple routine.            }
  305. Begin
  306. Ch := '';
  307.     While NOT EOF(InFile) Do
  308.     Begin
  309.         ReadLn(InFile,ch);
  310.         Inc(LL);
  311.         Upper(Ch);
  312.     WriteLn(OutFile,ch);
  313.         Inc(NChars,Length(ch));
  314.         ShowProgress(LL,4,90);
  315.     End; { while }
  316.     Write(' ',LL,' lines processed');
  317. End;
  318.  
  319. PROCEDURE LCase;                        { A more complex routine.    }
  320. Var                                     { Using ReadLn to get text   }
  321.   FirstCh : String[1];                  { means we need some means of}
  322.   Temp    : String[3];                  { flagging when one line ends}
  323. Begin                                   { in a terminator so that we }
  324. FirstCh := ''; Temp := '';              { can keep the first ucase   }
  325. TermFlag := True; Ch := '';             { char in the next line.     }
  326. While NOT EOF(InFile) DO
  327.     Begin
  328.         ReadLn(InFile,ch);
  329.         Inc(LL);
  330.         IF TermFlag AND (Length(Ch) > 1) THEN
  331.         Begin                               { Last line ended in a sentence }
  332.             I := 1;                           { terminator: "." or "!" or "?" }
  333.             FirstCh := Copy(ch,I,1);          { So find the first ucase char. }
  334.             While NOT (FirstCh[1] in UCaseChr) AND (I < Length(Ch)) DO Begin
  335.                 INC(I);
  336.                 FirstCh := Copy(ch, I ,1);
  337.             End; {While}
  338.             IF I = Length(Ch) THEN            { Got to end of line without      }
  339.                 Begin                           { finding an ucase character.   }
  340.                     I := 0; FirstCh := '';        { Wipe the index and FirstCh    }
  341.                 End                                                            { vars but leave TermFlag set.  }
  342.             ELSE Begin TermFlag := False; End;{ Here because found an UCase   }
  343.             End;                                                            { reset TermFlag but keep FirstCh }
  344.                                                                                 { and I for later.                            }
  345.         Lower(ch);                          { Lowercase the whole line.     }
  346.         Temp := Copy(ch,(Length(ch)-2),3);  { If thelast three chars contain}
  347.         IF (Pos('.', Temp) + Pos('!',Temp) + Pos('?',Temp)) <> 0 THEN
  348.             TermFlag := True;                 { a terminator, set the Flag.   }
  349.         IF FirstCh <> '' THEN Begin         { Have we got an unconverted    }
  350.             Delete(Ch,I,1);                   { ucase char to reinsert?       }
  351.             Insert(FirstCh,Ch,I);             { Replace the converted char    }
  352.             FirstCh := ''; End;               { at index and wipe the var.    }
  353.         WriteLn(OutFile,ch);                { Write the converted string to }
  354.         Inc(NChars,Length(ch));             { the output file and do        }
  355.         ShowProgress(LL,4,90);              { something on the screen.      }
  356.     End;
  357.     Write(' ',LL,' lines processed');     { End of the File, update accounts.}
  358. End;
  359.  
  360. PROCEDURE Initialise;
  361. Begin
  362.     NChars := 0; LL := 0;
  363.     Row := WhereY; Col := WhereX;
  364.     Switch := '';
  365.     SetBuf; HideCursor;
  366.     WinOpen(12,6,68,21,MainWinAttr);Winborder(2,BordAttr,' CASE ');
  367. End;
  368.  
  369. BEGIN                                                                             { Main                                             }
  370.     Initialise;
  371.     GetParams;
  372.     Window(13,18,67,20);
  373.     CenterString('Reading characters from: ', 1);
  374.     WriteLn;
  375.     CenterString(InFileName,2);
  376.     Window(13,7,67,16);
  377.     Switch := Copy(ParamStr(1),1,1);
  378.     Case Switch[1] of
  379.         'l','L': LCase;
  380.         'u','U': Ucase;
  381.     End;
  382.     Close(InFile); Close(OutFile);
  383.     Window(13,18,67,20);
  384.     Clrscr;
  385.     CenterString(IntToStr(Nchars) + ' characters written to',1);
  386.     CenterString(OutFileName,2);
  387.     WriteLn;
  388.     Chirp;
  389.     WaitForUser('* Press <ENTER> to end *');
  390.     CloseUp;
  391. END.
  392.  
  393.  
  394.