home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PAS_0493.ZIP / LET2QTXT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-04-15  |  6.4 KB  |  270 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 250 of 298
  3. From : David Solly                         1:163/215.0          12 Apr 93  11:20
  4. To   : Moshe Harel
  5. Subj : Letrix to Q-Text file 1/
  6. ────────────────────────────────────────────────────────────────────────────────
  7. Moshe...
  8.  
  9.    Please find below the Turbo Pascal source code for the conversion
  10. program for making Letrix Hebrew files into Q-Text 2.10 files.  I could
  11. not find a way to make this conversion program convert embedded Roman
  12. text without making it into a monster.  If you have any suggestions, I
  13. would be thankful to the input.
  14.  
  15. ========================= Cut Here ========================  }
  16.  
  17.  
  18. Program LetrixQText;
  19.  
  20. {$D-}
  21.  
  22. Uses CRT, DOS;
  23.  
  24.  
  25.  
  26. VAR
  27.  
  28.   Infile, Transfile : Text;
  29.   Infilenm, Transfilenm : PathStr;
  30.   Letter, Ans : Char;
  31.   Printable, HiASCII : Set of Char;
  32.  
  33.  
  34.  
  35. {
  36.    "UpItsCase" is a function that takes a sting of any length and
  37.    sets all of the characters in the string to upper case.  It is handy
  38.    for comparing strings.
  39. }
  40.  
  41. function UpItsCase (SourceStr : PathStr): PathStr;
  42. var
  43.   i  : integer;
  44.  
  45. begin
  46.   for i := 1 to length(SourceStr) do
  47.     SourceStr[i] := UpCase(SourceStr[i]);
  48.   UpItsCase := SourceStr
  49. end; {function UpItsCase}
  50.  
  51.  
  52. Function Exist(fname : PathStr) : Boolean;
  53.  
  54. Var f : File;
  55.  
  56. BEGIN
  57.  
  58. {$F-,I-}
  59.   Assign(f, fname);
  60.   Reset(f);
  61.   Close(f);
  62. {$I+}
  63.  
  64. Exist := (IOResult = 0) AND (fname <> '')
  65.  
  66. END; {Function exist}
  67.  
  68. Procedure Help;
  69.  
  70. Begin
  71.   Writeln;
  72.   Writeln ('LTQT (Version 1.0)');
  73.   Writeln ('Hebrew Text File Conversion');
  74.   Writeln ('Letrix(R) 3.6 file to Q-Text 2.10 file');
  75.   Writeln;
  76.   Writeln;
  77.   Writeln ('LTQT converts Letrix Hebrew format files to  Q-Text format files.');
  78.   Writeln;
  79.   Writeln ('LTQT expects two parameters on the command line.');
  80.   Writeln ('The first parameter is the name of the file to convert,');
  81.   Writeln ('the second is the name of the new file.');
  82.   Writeln;
  83.   Writeln ('Example:  LTQT  HKVTL.TXT HKVTL.HEB');
  84.   Writeln;
  85.   Writeln ('If no parameters are found, LTQT will display this message.');
  86.   Writeln;
  87.   Halt;
  88.  
  89. End; {Procedure Help}
  90.  
  91.  
  92. {
  93.   "ParseCommandLine" is a procedure that checks if any data was input
  94.   at the DOS command line.  If no data is there, then the "Help"
  95.   procedure is executed and the program is halted.  Otherwise, the
  96.   Mode strig variable is set equal to the text on the command line.
  97. }
  98.  
  99.  
  100. procedure ParseCommandLine;
  101. begin
  102.   if (ParamCount = 0) or (ParamCount <> 2)
  103.     then Help
  104.     else
  105.       begin
  106.         Infilenm := ParamStr(1);
  107.         Infilenm := UpItsCase(Infilenm);
  108.         Transfilenm := ParamStr(2);
  109.         Transfilenm := UpItsCase(Transfilenm);
  110.       end;
  111. end; {procedure ParseCommandLine}
  112.  
  113. Procedure OpenFiles;
  114.  
  115. BEGIN
  116.  
  117.   {Open input/output files}
  118.  
  119.   If not exist(Infilenm) then
  120.     Begin
  121.       Writeln;
  122.       Writeln (Infilenm, ' not found');
  123.       Halt;
  124.     End
  125.     Else
  126.       Begin
  127.         Assign (Infile, Infilenm);
  128.         Reset (Infile);
  129.       End;
  130.  
  131.   If exist (Transfilenm) then
  132.     Begin
  133.       Writeln;
  134.       Writeln (Transfilenm, ' already exists!');
  135.       Write ('Overwrite it?  (Y/N) > ');
  136.       Repeat
  137.         Ans := Readkey;
  138.         Ans := Upcase(Ans);
  139.         If Ans = 'N' then Halt;
  140.       Until Ans = 'Y';
  141.     End;
  142.  
  143.   Assign (Transfile, Transfilenm);
  144.   Rewrite (Transfile);
  145.   Writeln;
  146.  
  147. End; {Procedure OpenFiles}
  148.  
  149.  
  150.  
  151. Procedure LT_Table (VAR Letter : Char);
  152.  
  153.   {
  154.     This section reviews each Letrix letter and matches it with a
  155.     Q-Text equivalent where possible
  156.   }
  157.  
  158. BEGIN
  159.  
  160.   CASE Letter of
  161.  
  162.     'a' : Write (Transfile, #128);
  163.     'b', 'B','v' : Write (Transfile, #129);  {Vet, Bet}
  164.     'g' : Write (Transfile, #130);
  165.     'd' : Write (Transfile, #131);
  166.     'h' : Write (Transfile, #132);
  167.     'V', 'o', 'u', 'w' : Write (Transfile, #133); {Vav, Holem male, Shuruq}
  168.     'z' : Write (Transfile, #134);
  169.     'H' : Write (Transfile, #135);
  170.     'T' : Write (Transfile, #136);
  171.     'y', 'e' : Write (Transfile, #137); {Yod}
  172.     'C', 'Q', 'W' : Write (Transfile, #138); {Khaf-Sofit}
  173.     'c', 'K' : Write (Transfile, #139); {Khaf, Kaf}
  174.     'l' : Write (Transfile, #140);
  175.     'M' : Write (Transfile, #141);
  176.     'm' : Write (Transfile, #142);
  177.     'N' : Write (Transfile, #143);
  178.     'n' : Write (Transfile, #144);
  179.     'S' : Write (Transfile, #145);
  180.     'i' : Write (Transfile, #146);
  181.     'F' : Write (Transfile, #147);
  182.     'p', 'P', 'f' : Write (Transfile, #148); {Fe, Pe}
  183.     'X' : Write (Transfile, #149);
  184.     'x' : Write (Transfile, #150);
  185.     'k' : Write (Transfile, #151);
  186.     'r' : Write (Transfile, #152);
  187.     's' : Write (Transfile, #153);
  188.     't' : Write (Transfile, #154);
  189.     'A' : Write (Transfile, '-');
  190.  
  191.     {Niqudim and unused letters}
  192.  
  193.     'D','E', 'G', 'I', 'J', 'j', 'O', 'q', 'R', 'U', 'Y', 'Z' :
  194.        Write(Transfile, '');
  195.   else
  196.     Write(Transfile, Letter);
  197.  
  198.   End; {Case of}
  199.  
  200. End; {Procedure LT_Table}
  201.  
  202.  
  203. Procedure DoIt;
  204.  
  205.  
  206. BEGIN
  207.  
  208.  
  209.   {Transcription loop}
  210.  
  211.   While not eof(Infile) do
  212.  
  213.     Begin
  214.       Read(Infile, Letter);
  215.  
  216.  
  217.       If (Letter in Printable) then
  218.         LT_Table(Letter);
  219.  
  220.       If (Letter in HiASCII) then
  221.         Write(Transfile, Letter);
  222.  
  223.  
  224.   End; {while}
  225.  
  226. {Close files}
  227.  
  228. Close (Transfile);
  229. Close (Infile);
  230.  
  231. {Final message}
  232.  
  233. Writeln;
  234. Writeln;
  235. Writeln('LTQT Version 1.0');
  236. Writeln('Hebrew Text File Conversion');
  237. Writeln('Letrix(R) 3.6 file to Q-Text 2.10 file');
  238. Writeln;
  239. Writeln;
  240. Writeln ('Letrix Hebrew file to Q-Text file conversion complete.');
  241. Writeln;
  242. Writeln('Special Note:');
  243. Writeln;
  244. Writeln ('Q-Text does not support either dagesh or niqudim (vowels).');
  245. Writeln ('Letters containing a dagesh-qol are reduced to their simple form.');
  246. Writeln ('Holam male and shuruq are transcribed as vav.  Roman letters used');
  247. Writeln ('to represent niqudim are ignored.  All other symbols are transcribed');
  248. Writeln ('without change.');
  249. Writeln;
  250. Writeln ('There is no foreign language check -- Anything that can be transcribed');
  251. Writeln ('into Hebrew characters will be.');
  252. Writeln;
  253. Writeln ('LTQT was written and released to the public domain by David Solly');
  254. Writeln ('Bibliotheca Sagittarii, Ottawa, Canada (8 December 1992).');
  255. Writeln;
  256.  
  257. End; {Procedure DoIt}
  258.  
  259.  
  260. BEGIN
  261.  
  262.   {Initialize Variables}
  263.   Printable := [#10,#12,#13,#32..#127];
  264.   HiASCII   := [#128..#154];
  265.  
  266. ParseCommandLine;
  267. OpenFiles;
  268. DoIt;
  269.  
  270. End.