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 / FONTM.PAS < prev    next >
Pascal/Delphi Source File  |  1990-12-26  |  9KB  |  389 lines
  1. {$C-}
  2. program FontMaker;
  3. {version 1.8  copyright 1988 by Sam Bellotto Jr.  August 23, 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.         str14    =string[14];
  13.  
  14. var     fontfile :file of letrec;
  15.         recvar   :letrec;
  16.         n,runs,
  17.         wd       :integer;
  18.         fname    :str14;
  19.         sel,opt  :char;
  20.         nlq      :boolean;
  21.  
  22. procedure SetWidth(var wd :integer);
  23. begin
  24.    repeat
  25.       wd:=0;
  26.       gotoxy(1,4);clreol;
  27.       write('Charac width? ');
  28.       {$I-} read(wd); {$I+}
  29.       if (ioresult<>0) or not(wd in[1..32])
  30.       then write(^G)
  31.       until wd in[1..32]
  32.    end;
  33.  
  34. procedure SpaceData(var onerec:letrec);
  35. var i :integer;
  36. begin
  37.    with onerec do
  38.    begin
  39.       SetWidth(width);
  40.       gotoxy(27,1);write(width);
  41.       for i:=1 to width do
  42.       pass1[i]:=0;
  43.       gotoxy(36,1);
  44.       write(i);
  45.       for i:=1 to width do
  46.       pass2[i]:=0;
  47.       gotoxy(42,1);
  48.       write(i);
  49.       if runs>2 then
  50.       begin
  51.          for i:=1 to width do
  52.          pass3[i]:=0;
  53.          gotoxy(48,1);
  54.          write(i)
  55.          end;
  56.       if runs=4 then
  57.       begin
  58.          for i:=1 to width do
  59.          pass4[i]:=0;
  60.          gotoxy(54,1);
  61.          write(i)
  62.          end
  63.       end
  64.    end;
  65.  
  66. procedure GetData;
  67. var i,p,result,
  68.     result2     :integer;
  69.     line        :string[8];
  70.  
  71. procedure DoMath;
  72. begin
  73.    result:=0;
  74.    read(line);
  75.    if length(line)=0 then {null}
  76.    else begin
  77.       for p:=1 to length(line) do
  78.       begin
  79.          case line[p] of
  80.             '#':result:=255;
  81.             '1':result:=result+128;
  82.             '2':result:=result+64;
  83.             '3':result:=result+32;
  84.             '4':result:=result+16;
  85.             '5':result:=result+8;
  86.             '6':result:=result+4;
  87.             '7':result:=result+2;
  88.             '8':result:=result+1
  89.             else result:=result+0
  90.             end
  91.          end
  92.       end
  93.    end;
  94.  
  95. procedure DoNLQMath(r:integer);
  96. begin
  97.    result:=0;
  98.    result2:=0;
  99.    read(line);
  100.    if length(line)=0 then {null}
  101.    else begin
  102.       for p:=1 to length(line) do
  103.       begin
  104.          case line[p] of
  105.             '#':begin
  106.                    result:=result+(r*15);
  107.                    result2:=result2+(r*15);
  108.                    end;
  109.             '1':result:=result+(r*8);
  110.             '2':result2:=result2+(r*8);
  111.             '3':result:=result+(r*4);
  112.             '4':result2:=result2+(r*4);
  113.             '5':result:=result+(r*2);
  114.             '6':result2:=result2+(r*2);
  115.             '7':result:=result+r;
  116.             '8':result2:=result2+r;
  117.             else begin
  118.                result:=result+0;
  119.                result2:=result2+0
  120.                end
  121.             end
  122.          end
  123.       end
  124.    end;
  125.  
  126. begin
  127.    with recvar do
  128.    begin
  129.       if n=32 then SpaceData(recvar)
  130.       else begin
  131.          SetWidth(width);
  132.          gotoxy(27,1);write(width);
  133.          gotoxy(1,4);clreol;
  134.          write('  First pass? ');
  135.          for i:=1 to width do
  136.          begin
  137.             gotoxy(36,1);write(i);
  138.             gotoxy(15,4);clreol;
  139.             if nlq then
  140.             begin
  141.                DoNLQMath(16);
  142.                pass1[i]:=result;
  143.                pass2[i]:=result2
  144.             end else begin
  145.                DoMath;
  146.                pass1[i]:=result
  147.                end
  148.             end;
  149.          gotoxy(1,4);clreol;
  150.          write(' Second pass? ');
  151.          for i:=1 to width do
  152.          begin
  153.             gotoxy(42,1);write(i);
  154.             gotoxy(15,4);clreol;
  155.             if nlq then
  156.             begin
  157.                DoNLQMath(1);
  158.                pass1[i]:=pass1[i]+result;
  159.                pass2[i]:=pass2[i]+result2
  160.             end else begin
  161.                DoMath;
  162.                pass2[i]:=result
  163.                end
  164.             end;
  165.          if runs>2 then
  166.          begin
  167.             gotoxy(1,4);clreol;
  168.             write('  Third pass? ');
  169.             for i:=1 to width do
  170.             begin
  171.                gotoxy(48,1);write(i);
  172.                gotoxy(15,4);clreol;
  173.                DoMath;
  174.                pass3[i]:=result
  175.                end;
  176.             if runs=4 then
  177.             begin
  178.                gotoxy(1,4);clreol;
  179.                write(' Fourth pass? ');
  180.                for i:=1 to width do
  181.                begin
  182.                   gotoxy(54,1);write(i);
  183.                   gotoxy(15,4);clreol;
  184.                   DoMath;
  185.                   pass4[i]:=result
  186.                   end
  187.                end
  188.             end
  189.          end
  190.       end;
  191.    write(fontfile,recvar);
  192.    close(fontfile);
  193.    if opt in['E','e'] then
  194.    begin
  195.       gotoxy(65,1);
  196.       write('      ')
  197.       end
  198.    end;
  199.  
  200. procedure SetScreen;
  201. begin
  202.    gotoxy(27,1);write('  ');
  203.    gotoxy(36,1);write('  ');
  204.    gotoxy(42,1);write('  ');
  205.    if runs>2 then
  206.    begin
  207.       gotoxy(48,1);
  208.       write('  ');
  209.       if runs=4 then
  210.       begin
  211.          gotoxy(54,1);
  212.          write('  ')
  213.          end
  214.       end;
  215.    gotoxy(65,1);
  216.    if opt in['E','e'] then
  217.    n:=n+32;
  218.    case n of
  219.       32 :write('space ');
  220.       92 :write('u1 <\>');                       {\ backslash}
  221.       94 :write('fl <^>');                       {^ caret}
  222.       95 :write('u2 <_>');                       {_ underline}
  223.       96 :write('fi <`>');                       {` accent grave}
  224.       124:write('u3 <|>');                       {| vertical bar}
  225.       126:write('ji <~>')                        {~ tilde}
  226.       else write(' ',chr(n),'    ')
  227.       end
  228.    end;
  229.  
  230. procedure SignOn;
  231. begin
  232.    clrscr;
  233.    gotoxy(7,1);write(fname);
  234.    gotoxy(22,1);write('LWID');
  235.    gotoxy(33,1);write('P1');
  236.    gotoxy(39,1);write('P2');
  237.    if runs>2 then
  238.    begin
  239.       gotoxy(45,1);
  240.       write('P3');
  241.       if runs=4 then
  242.       begin
  243.          gotoxy(51,1);
  244.          write('P4')
  245.          end
  246.       end;
  247.    gotoxy(60,1);write('CHAR ')
  248.    end;
  249.  
  250. procedure InputRoutine;
  251. var ans :char;
  252. begin
  253.    SignOn;
  254.    repeat
  255.       SetScreen;
  256.       GetData;
  257.       n:=n+1;
  258.       if n=127 then
  259.       begin
  260.          gotoxy(1,4);clreol;
  261.          write(^G,'*** FONT COMPLETED ');
  262.          delay(3000)
  263.       end else begin
  264.          gotoxy(1,4);clreol;
  265.          write('<N>ext/<C>hange/<Q>uit? ');
  266.          read(kbd,ans);
  267.          if upcase(ans)='C' then n:=n-1;
  268.          if not (ans in['Q','q']) then
  269.          begin
  270.             reset(fontfile);
  271.             seek(fontfile,n-32)
  272.             end 
  273.          end
  274.       until (n=127) or (ans in['Q','q'])
  275.    end;
  276.  
  277. procedure EditChar;
  278. begin
  279.    write('Edit char? ');
  280.    read(kbd,sel);
  281.    if sel in[' '..'~'] then
  282.    begin
  283.       n:=ord(sel)-32;
  284.       {$I-} seek(fontfile,n); {$I+}
  285.       if ioresult<>0 then sel:=chr(13)
  286.       end
  287.    end;
  288.  
  289. procedure EditRoutine;
  290. begin
  291.    SignOn;
  292.    repeat
  293.       SetScreen;
  294.       GetData;
  295.       gotoxy(1,4);clreol;
  296.       reset(fontfile);
  297.       EditChar;
  298.       until not (sel in[' '..'~'])
  299.    end;
  300.  
  301. procedure NameFont;
  302. var ext   :str14;
  303.     c,pts :integer;
  304.  
  305. procedure StartInp;
  306. begin
  307.    {$I-} reset(fontfile); {$I+}
  308.    if ioresult<>0 then
  309.    rewrite(fontfile)
  310.    else begin
  311.       n:=filesize(fontfile);
  312.       if n=95 then
  313.       begin
  314.          writeln(^G);
  315.          writeln('*** Fontfile completed ');
  316.          halt
  317.          end;
  318.       seek(fontfile,n)
  319.       end;
  320.    n:=n+32
  321.    end;
  322.  
  323. procedure StartEd;
  324. begin
  325.    {$I-} reset(fontfile); {$I+}
  326.    if ioresult<>0 then
  327.    begin
  328.       writeln(^G);
  329.       writeln('+++ File does not exist +++');
  330.       halt
  331.    end else EditChar;
  332.    if not (sel in[' '..'~']) then halt
  333.    end;
  334.  
  335. procedure AllCaps(var afn:str14);
  336. var i:integer;
  337. begin
  338.    for i:=1 to length(afn) do
  339.    if afn[i] in['a'..'z']
  340.    then afn[i]:=upcase(afn[i])
  341.    end;
  342.  
  343. begin
  344.    writeln;
  345.    writeln('FONTMAKER    - version 1.80');
  346.    writeln('            (c) 1988 by Sam Bellotto Jr.');
  347.    writeln;writeln;
  348.    write('File name? ');
  349.    readln(fname);
  350.    if length(fname)=0 then halt;
  351.    AllCaps(fname);
  352.    ext:=copy(fname,length(fname)-1,2);
  353.    val(ext,pts,c);
  354.    case pts of
  355.       12:begin
  356.             runs:=2;
  357.             nlq:=true
  358.             end; 
  359.       16:runs:=2;
  360.       24:runs:=3;
  361.       32:runs:=4;
  362.       else begin
  363.          writeln(^G);
  364.          writeln('++ ILLEGAL FILE ++');
  365.          halt
  366.          end
  367.       end;
  368.    write('<I>nput <E>dit? ');
  369.    read(kbd,opt);
  370.    writeln;
  371.    if not (opt in ['I','i','E','e']) then
  372.    opt:='I';
  373.    assign(fontfile,fname);
  374.    if opt in['I','i'] then StartInp
  375.    else StartEd
  376.    end;
  377.  
  378. begin                                            {main}
  379.    bdos($0D);                                    {disk reset bdos call}
  380.    n:=0;
  381.    nlq:=false;
  382.    NameFont;
  383.    if opt in['I','i'] then
  384.    InputRoutine
  385.    else EditRoutine;
  386.    close(fontfile);
  387.    clrscr
  388.    end.
  389.