home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / BEEHIVE / UTILITYS / KWIKFONT.ARC / KWIKFONT.PAS < prev    next >
Pascal/Delphi Source File  |  1990-12-26  |  14KB  |  528 lines
  1. {$C-}
  2. program KwikFont;
  3. {version 1.80  copyright 1988 by Sam Bellotto Jr.  October 29, 1988}
  4.  
  5. type    letrec   =record
  6.                   width :integer;
  7.                   pass1 :array[1..32] of byte;
  8.                   pass2 :array[1..32] of byte;
  9.                   pass3 :array[1..32] of byte;
  10.                   pass4 :array[1..32] of byte;
  11.                   end;
  12.  
  13.         str80    =string[80];
  14.         str14    =string[14];
  15.  
  16. const   ht01     =#27#65#1;                      {line height to 01/72}
  17.         ht08     =#27#65#8;                      {line height to 08/72}
  18.         ht12     =#27#65#12;                     {line height to 12/72}
  19.         ht216    =#27#51#1;                      {line height to 01/216}
  20.         d60      =#27#42#0;                      {60 dots per inch}
  21.         d80      =#27#42#4;                      {80 dots per inch}
  22.         d90      =#27#42#6;                      {90 dots per inch}
  23.         dot      =#128;                          {one col bit-mapped dot}
  24.         spc      =#0;                            {one col bit-mapped space}
  25.         exp      =6;                             {6 dots per 10 pitch char}
  26.         nrm      =8;                             {8 dots per 10 pitch char}
  27.         con      =9;                             {9 dots per 10 pitch char}
  28.         lmpre    =#27#108;                       {left margin set prefix}
  29.         clesc    =#23;                           {clear to end of screen}
  30.         pset     =#27#64;                        {reset printer}
  31.  
  32. var     fontfile :file of letrec;
  33.         textfile :text;
  34.         recvar   :array[1..80] of letrec;
  35.         j,runs,
  36.         hits,dl,
  37.         cw       :integer;
  38.         skp      :real;
  39.         dum      :char;
  40.         prepln   :string[5];
  41.         dpi      :string[3];
  42.         filvar,
  43.         fname    :str14;
  44.         line     :array[1..23] of str80;
  45.         asc,fmf,
  46.         nlq,pbp  :boolean;
  47.  
  48. procedure AllCaps(var afn:str14);
  49. var i :integer;
  50. begin
  51.    for i:=1 to length(afn) do
  52.    if afn[i] in['a'..'z']
  53.    then afn[i]:=upcase(afn[i])
  54.    end;
  55.  
  56. procedure EstabRuns;
  57. var ext :str14;
  58.     c,p :integer;
  59. begin
  60.    nlq:=false;
  61.    ext:=copy(fname,length(fname)-1,2);
  62.    val(ext,p,c);
  63.    case p of
  64.       12:begin
  65.             runs:=2;
  66.             nlq:=true
  67.             end;
  68.       16:runs:=2;
  69.       24:runs:=3;
  70.       32:runs:=4;
  71.       else runs:=0
  72.       end
  73.    end;
  74.  
  75. procedure PrintOut;
  76. var f,i,p,r,
  77.     w,loop,
  78.     tab      :integer;
  79.     ctr,flr,
  80.     ind,uln  :boolean;
  81.  
  82. procedure CalcWidth(var oneln:str80);
  83. begin
  84.    w:=0;
  85.    dpi:=d80;
  86.    dl:=nrm*cw;
  87.    ctr:=false;
  88.    flr:=false;
  89.    ind:=false;
  90.    uln:=false;
  91.    repeat
  92.       if oneln[1]=';' then
  93.       begin
  94.          case oneln[2] of
  95.             'c','C':ctr:=true;                   {centered}
  96.             'r','R':flr:=true;                   {flush right}
  97.             'u','U':uln:=true;                   {underline}
  98.             't','T':begin                        {indented}
  99.                        ind:=true;
  100.                        delete(oneln,1,2);
  101.                        val(copy(oneln,1,2),i,p);
  102.                        if p<>0 then i:=0
  103.                        end;
  104.             'x','X':begin                        {expanded}
  105.                        dpi:=d60;
  106.                        dl:=exp*cw
  107.                        end;
  108.             'd','D':begin                        {condensed}
  109.                        dpi:=d90;
  110.                        dl:=con*cw
  111.                        end
  112.             end;
  113.          oneln:=copy(oneln,3,length(oneln)-2);
  114.          if length(oneln)=0 then oneln:=' '
  115.          end
  116.       until oneln[1]<>';';
  117.    for p:=1 to length(oneln) do
  118.    begin
  119.       w:=w+1;                                    {interletter space} 
  120.       r:=ord(oneln[p])-32;
  121.       {$I-} seek(fontfile,r); {$I+}
  122.       if ioresult<>0 then
  123.       begin
  124.          gotoxy(47,1);clreol;
  125.          write('** PROGRAM ABORTED **');
  126.          gotoxy(1,3);
  127.          writeln(^G,'++ ',filvar,' NOT ASCII ++');
  128.          halt
  129.          end; 
  130.       read(fontfile,recvar[p]);
  131.       with recvar[p] do w:=w+width
  132.       end;
  133.    if ind then tab:=(dl div cw)*i else
  134.    if ctr then tab:=(dl-w) div 2 else
  135.    if flr then tab:=dl-w else tab:=0;
  136.    w:=w+tab;
  137.    prepln:=dpi+chr(w mod 256)+chr(w div 256)
  138.    end;
  139.  
  140. procedure SetTab;
  141. var s :integer;
  142. begin
  143.    if tab>0 then
  144.    begin
  145.       for s:=1 to tab do
  146.       write(lst,spc)
  147.       end
  148.    end;
  149.  
  150. procedure ChangeFonts;
  151. var ok :boolean;
  152.  
  153. procedure CallErr(msg:str80);
  154. begin
  155.    gotoxy(47,1);write('**  ERROR ** ');
  156.    gotoxy(1,3);
  157.    writeln(^G,fname,msg);
  158.    write('Change to: ');
  159.    read(fname);
  160.    gotoxy(1,3);write(clesc);
  161.    gotoxy(47,1);write('Printing ... ')
  162.    end;
  163.  
  164. begin
  165.    fname:=copy(line[f],2,length(line[f])-1);
  166.    repeat
  167.       ok:=true;
  168.       AllCaps(fname);
  169.       if fname='PICA' then
  170.       begin
  171.          asc:=true;
  172.          writeln(lst);
  173.          write(lst,ht12)
  174.       end else begin
  175.          if asc then
  176.          begin
  177.             asc:=false;
  178.             write(lst,ht08)
  179.             end;
  180.          EstabRuns;
  181.          close(fontfile);
  182.          if runs=0 then
  183.          begin
  184.             ok:=false;
  185.             CallErr(' is illegal!')
  186.             end;
  187.          if ok then
  188.          begin
  189.             assign(fontfile,fname);
  190.             {$I-} reset(fontfile); {$I+}
  191.             if ioresult<>0 then
  192.             begin
  193.                ok:=false;
  194.                CallErr(' doesn''t exist!') 
  195.                end
  196.             end
  197.          end
  198.       until ok;
  199.    gotoxy(65,1);clreol;
  200.    write(fname)
  201.    end;
  202.  
  203. procedure RunOneLine;
  204. begin
  205.    CalcWidth(line[f]);
  206.    for loop:=1 to hits do
  207.    begin
  208.       write(lst,prepln);
  209.       SetTab;
  210.       for p:=1 to length(line[f]) do
  211.       begin
  212.          with recvar[p] do
  213.          begin
  214.             for i:=1 to width do
  215.             write(lst,chr(pass1[i]));
  216.             write(lst,spc)                       {interletter space}
  217.             end
  218.          end;
  219.       if hits>1 then write(lst,#13)
  220.       end;
  221.    if nlq then writeln(lst,ht216)                {down 1/216 inch space}
  222.    else begin
  223.       writeln(lst);
  224.       skp:=skp+1
  225.       end;
  226.    for loop:=1 to hits do
  227.    begin
  228.       write(lst,prepln);
  229.       SetTab;
  230.       for p:=1 to length(line[f]) do
  231.       begin
  232.          with recvar[p] do
  233.          begin
  234.             for i:=1 to width do
  235.             write(lst,chr(pass2[i]));
  236.             write(lst,spc)                       {interletter space}
  237.             end
  238.          end;
  239.       if hits>1 then write(lst,#13)
  240.       end;
  241.    if nlq then writeln(lst,ht12)
  242.    else writeln(lst,ht08);
  243.    skp:=skp+1;
  244.    if runs>2 then
  245.    begin
  246.       for loop:=1 to hits do
  247.       begin
  248.       write(lst,prepln);
  249.       SetTab;
  250.       for p:=1 to length(line[f]) do
  251.       begin
  252.          with recvar[p] do
  253.          begin
  254.             for i:=1 to width do
  255.             write(lst,chr(pass3[i]));
  256.             write(lst,spc)                       {interletter space}
  257.             end
  258.          end;
  259.       if hits>1 then write(lst,#13)
  260.       end;
  261.    writeln(lst);
  262.    skp:=skp+1;
  263.    if runs=4 then
  264.    begin
  265.       for loop:=1 to hits do
  266.       begin
  267.          write(lst,prepln);
  268.          SetTab;
  269.          for p:=1 to length(line[f]) do
  270.          begin
  271.             with recvar[p] do
  272.             begin
  273.                for i:=1 to width do
  274.                write(lst,chr(pass4[i]));
  275.                write(lst,spc)                    {interletter space}
  276.                end
  277.             end;
  278.          if hits>1 then write(lst,#13)
  279.          end;
  280.       writeln(lst);
  281.       skp:=skp+1
  282.       end
  283.    end;
  284.    if f<j then
  285.    begin
  286.       writeln(lst,ht01);                         {down 1/72 inch space}
  287.       if uln then
  288.       begin
  289.          write(lst,prepln);
  290.          SetTab;
  291.          for i:=1 to w do
  292.          write(lst,dot);
  293.          writeln(lst);
  294.          writeln(lst,ht01)
  295.          end; 
  296.       write(lst,ht08)                            {set line height}
  297.       end
  298.    end;
  299.  
  300. procedure PrintPica(var oneln:str80);
  301. var x,t :integer;
  302. begin
  303.    t:=0;
  304.    repeat
  305.       if oneln[1]=';' then
  306.       begin
  307.          case oneln[2] of
  308.             't','T':begin
  309.                        delete(oneln,1,2);
  310.                        val(copy(oneln,1,2),t,x);
  311.                        if x<>0 then t:=0 
  312.                        end; 
  313.             'c','C':t:=(cw-length(oneln)) div 2;
  314.             'r','R':t:=(cw-length(oneln));
  315.             end;
  316.          oneln:=copy(oneln,3,length(oneln)-2)
  317.          end
  318.       until oneln[1]<>';';
  319.    if t>0 then
  320.    for x:=1 to t do write(lst,' ');
  321.    writeln(lst,oneln);
  322.    skp:=skp+1.5
  323.    end;
  324.  
  325. procedure InsLine;
  326. begin
  327.    gotoxy(47,1);write(^G,'Waiting .... ');
  328.    gotoxy(1,3);
  329.    write('Insert: ');
  330.    read(line[f]);
  331.    if length(line[f])=0
  332.    then line[f]:=' ';                            {fill null line}
  333.    gotoxy(1,3);clreol;
  334.    gotoxy(47,1);write('Printing ... ')
  335.    end; 
  336.  
  337. begin
  338.    f:=0;
  339.    if not asc then write(lst,ht08);              {set line height}
  340.    repeat
  341.       repeat
  342.          f:=f+1;
  343.          if (line[f]=';p') or (line[f]=';P') then
  344.          begin
  345.             write(lst,#12);                      {forced page break}
  346.             skp:=0
  347.          end else begin
  348.             if (copy(line[f],1,2)=';M')
  349.             or (copy(line[f],1,2)=';m')
  350.             or (copy(line[f],1,2)=';W')
  351.             or (copy(line[f],1,2)=';w')
  352.             then begin
  353.                val(copy(line[f],3,2),i,p);
  354.                if p=0 then
  355.                begin
  356.                   if (copy(line[f],2,1))
  357.                   in['M','m'] then
  358.                   write(lst,lmpre,chr(i));       {set left margin}
  359.                   if (copy(line[f],2,1))
  360.                   in['W','w'] then cw:=i         {set page width}
  361.                   end
  362.             end else begin
  363.                if line[f][1]='.' then
  364.                ChangeFonts
  365.                else begin
  366.                   if (line[f]=';i') or (line[f]=';I') then
  367.                   InsLine;
  368.                   if asc then PrintPica(line[f])
  369.                   else RunOneLine
  370.                   end
  371.                end
  372.             end
  373.          until (skp>77) or (f=j);
  374.       if skp>77 then
  375.       begin
  376.          if pbp then
  377.          begin
  378.             gotoxy(47,1);write('Pausing .... ');
  379.             gotoxy(1,3);
  380.             write('Ready? ');
  381.             read(kbd,dum);
  382.             gotoxy(1,3);clreol;
  383.             gotoxy(47,1);write('Printing ... ')
  384.             end;
  385.          if fmf then write(lst,#12);             {conditional form feed}
  386.          skp:=0
  387.          end   
  388.       until f=j
  389.    end;
  390.  
  391. procedure OutPutJob;
  392. var h :char;
  393.     c :integer;
  394.  
  395. procedure FromTerminal;
  396. var y   :integer;
  397.     ans :char;
  398. begin
  399.    repeat
  400.       gotoxy(1,3);
  401.       write(clesc);
  402.       j:=0;y:=3;
  403.       repeat
  404.          j:=j+1;
  405.          gotoxy(1,y);
  406.          if y=21 then write(^G,'LAST LINE> ')
  407.          else write('> ');
  408.          read(line[j]);
  409.          y:=y+1;
  410.          until (length(line[j])=0) or (y=22);
  411.       if length(line[j])=0
  412.       then line[j]:=' ';                         {fill null line}
  413.       gotoxy(1,y+1);
  414.       write('OK to print? ');
  415.       read(kbd,ans)
  416.       until ans in['Y','y',#13];
  417.    gotoxy(1,3);
  418.    write(clesc);
  419.    gotoxy(47,1);
  420.    write('Printing ... ');
  421.    PrintOut
  422.    end;
  423.  
  424. procedure FromDisk;
  425. begin
  426.    assign(textfile,filvar);
  427.    {$I-} reset(textfile); {$I+}
  428.    if ioresult<>0 then FromTerminal
  429.    else begin
  430.       gotoxy(1,3);
  431.       write(clesc);
  432.       gotoxy(47,1);
  433.       write('Printing ... ');
  434.       while not eof(textfile) do
  435.       begin
  436.          j:=0;
  437.          repeat
  438.             j:=j+1;
  439.             readln(textfile,line[j]);
  440.             if length(line[j])=0
  441.             then line[j]:=' ';                   {fill null lines}
  442.             until (j=22) or eof(textfile);
  443.          PrintOut
  444.          end
  445.       end
  446.    end;
  447.  
  448. begin
  449.    cw:=80;
  450.    skp:=0;
  451.    gotoxy(1,1);write('KwikFont 1.80 (c) 1988 by Sam Bellotto Jr.');
  452.    gotoxy(65,1);write(fname);
  453.    gotoxy(1,3);
  454.    write('Strikes? ':21);
  455.    read(kbd,h);
  456.    val(h,hits,c);
  457.    if (c<>0) or not (hits in[1..6])
  458.    then hits:=1;
  459.    write(hits);
  460.    gotoxy(1,4);
  461.    write('Use form feeds? ':21);
  462.    read(kbd,dum);
  463.    if dum in['Y','y'] then fmf:=true
  464.    else begin
  465.       fmf:=false;
  466.       dum:='N'
  467.       end;
  468.    write(upcase(dum));
  469.    gotoxy(1,5);
  470.    write('Pause between pages? ':21);
  471.    read(kbd,dum);
  472.    if dum in ['Y','y'] then pbp:=true
  473.    else begin
  474.       pbp:=false;
  475.       dum:='N'
  476.       end;
  477.    write(upcase(dum));
  478.    gotoxy(1,6);
  479.    write('Disk file? ':21);
  480.    read(filvar);
  481.    if length(filvar)=0 then FromTerminal
  482.    else begin
  483.       AllCaps(filvar);
  484.       FromDisk
  485.       end
  486.    end;
  487.  
  488. procedure ErrMess(msg:str80);
  489. begin
  490.    writeln(^G);
  491.    writeln(msg);
  492.    halt
  493.    end;
  494.  
  495. procedure CallDos;
  496. var d:integer;
  497. begin
  498.    d:=bdos($19);
  499.    bdos($0E,d)
  500.    end;
  501.  
  502. begin                                            {main}
  503.    CallDos;
  504.    asc:=false;
  505.    if length(paramstr(1))=0 then
  506.    begin
  507.       fname:='PICA';
  508.       asc:=true;
  509.       write(lst,ht12)
  510.    end else begin
  511.       fname:=paramstr(1);
  512.       EstabRuns;
  513.       if runs=0 then
  514.       ErrMess('++ ILLEGAL FILE ++');
  515.       assign(fontfile,fname);
  516.       {$I-} reset(fontfile); {$I+}
  517.       if ioresult<>0 then
  518.       ErrMess('++ FILE DOES NOT EXIST ++')
  519.       end;
  520.    clrscr;
  521.    OutPutJob;
  522.    writeln(lst,pset);                            {reset printer}
  523.    gotoxy(47,1);
  524.    write(^G,'*** Finished ');
  525.    delay(3000);
  526.    clrscr
  527.    end.
  528.