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 / FONTM2A.ARC / FONTM2.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-27  |  13KB  |  553 lines
  1. program FontMaker2;
  2. {version 1.0 by Kalvis Duckmanton, 11th Feb., 1991}
  3.  
  4. const
  5.   z2=$f0f9;
  6.   max_menus = 3;
  7.   powers: array[0..7] of byte = (1,2,4,8,16,32,64,128);
  8.   menus: array[1..max_menus] of string[60] =('New|Open|Close|Quit',
  9.                                      'Copy|Paste|Clear',
  10.                                      'Set Width|Change character|Input new character');
  11.   mpos: array[1..max_menus] of integer = (1,7,13);
  12.   max_menu_items = 10;
  13.   credits = ' v1.0 by KRD 1991 ';
  14.   menu_bar = ' File  Edit  Font ';
  15.  
  16. type
  17.   letrec = record
  18.            width : integer;
  19.            pass1 : array[1..32] of byte;
  20.            pass2 : array[1..32] of byte;
  21.            pass3 : array[1..32] of byte;
  22.            pass4 : array[1..32] of byte;
  23.            end;
  24.   str14 = string[14];
  25.   str80 = string[80];
  26.  
  27. var
  28.   fontfile : file of letrec;
  29.   recvar,scratch : letrec;
  30.   runs,wd,scrn_x,scrn_y,screen_pointer : integer;
  31.   scrn_attr,scrn_color: byte;
  32.   nlq,use_pcg,colour,premium : boolean;
  33.   fontopen,newfont : boolean;
  34.   screen_data:array[1..8192] of byte;
  35.   fontname : str80;
  36.   opt,i : integer;
  37.   ch,edchar : char;
  38.  
  39. {$Iscrh.inc}
  40. {$Iwindows.inc}
  41. {$Imenu.inc}
  42.  
  43. procedure initpcg;
  44. var
  45.   iz:integer;
  46. begin
  47.   for iz:=$f810 to $f81f do mem[iz]:=$28;
  48.   for iz:=$f820 to $f82f do mem[iz]:=0;
  49.   mem [$f825]:=$08; mem[$f824]:=$14; mem[$f826]:=$14;
  50.   mem [$f823]:=$22; mem[$f827]:=$22;
  51.   for iz:=$f830 to $f83f do mem[iz]:=255-mem[iz-16];
  52.   for iz:=$f840 to $f84f do mem[iz]:=0; mem[$f844]:=$ff; mem[$f846]:=$ff;
  53. end;
  54.  
  55. function convert(y:integer):integer;
  56. var
  57.   y2:integer;
  58. begin
  59.   if nlq then
  60.   begin
  61.     y2:=(y div 2)+8*(y mod 2);
  62.   end
  63.   else y2:=y;
  64.   convert:=y2;
  65. end;
  66.  
  67. function Point(x,y:integer):boolean;
  68. var
  69.   i: byte;
  70.   j,k,iz: integer;
  71. begin
  72.   with recvar do
  73.   begin
  74.     if (x>width) or (y>runs*8) then Point:=false
  75.     else
  76.     begin
  77.       iz:=convert(y);
  78.       k:=iz div 8; j:= iz mod 8;
  79.       case k of
  80.       0: i:=pass1[x];
  81.       1: i:=pass2[x];
  82.       2: i:=pass3[x];
  83.       3: i:=pass4[x];
  84.       end;
  85.       Point:=((i and powers[7-j])>0);
  86.     end;
  87.   end;
  88. end;
  89.  
  90. procedure Setp(x,y:integer);
  91. var
  92.   iz,jz,kz: integer;
  93. begin
  94.   with recvar do
  95.   begin
  96.     if (x<width) and (y<runs*8) then
  97.     begin
  98.       x:=x+1;
  99.       iz:=convert(y);
  100.       kz:=iz div 8; jz:=iz mod 8;
  101.       case kz of
  102.       0: pass1[x]:=(pass1[x] or powers[7-jz]);
  103.       1: pass2[x]:=(pass2[x] or powers[7-jz]);
  104.       2: pass3[x]:=(pass3[x] or powers[7-jz]);
  105.       3: pass4[x]:=(pass4[x] or powers[7-jz]);
  106.       end;
  107.     end;
  108.   end;
  109. end;
  110.  
  111. procedure ReSetp(x,y:integer);
  112. var
  113.   iz,jz,kz: integer;
  114. begin
  115.   with recvar do
  116.   begin
  117.     if (x<width) and (y<runs*8) then
  118.     begin
  119.       x:=x+1;
  120.       iz:=convert(y);
  121.       kz:=iz div 8; jz:=iz mod 8;
  122.       case kz of
  123.       0: pass1[x]:=pass1[x] and 255-powers[7-jz];
  124.       1: pass2[x]:=pass2[x] and 255-powers[7-jz];
  125.       2: pass3[x]:=pass3[x] and 255-powers[7-jz];
  126.       3: pass4[x]:=pass4[x] and 255-powers[7-jz];
  127.       end;
  128.     end;
  129.   end;
  130. end;
  131.  
  132. procedure nukechar;
  133. var
  134.   i:integer;
  135. begin
  136.   with recvar do
  137.   begin
  138.     width:=1;
  139.     for i:=1 to 32 do
  140.     begin
  141.       pass1[i]:=0; pass2[i]:=0; pass3[i]:=0; pass4[i]:=0;
  142.     end;
  143.   end;
  144. end;
  145.  
  146. procedure setwidth;
  147. var
  148.   temp:str80;
  149.   iz:integer;
  150. begin
  151.   window(30,12,35,3,'character width',true);
  152.   setcolor(3); putat(32,13); print('Width of '+edchar+' is:');
  153.   setcolor(11); str(recvar.width,temp); edit(temp,false);
  154.   val(temp,iz,i); if (iz>0) and (iz<32) then recvar.width:=iz;
  155.   popwind;
  156. end;
  157.  
  158. procedure displaychar(start:integer);
  159. var
  160.   iz,jz,z,y:integer;
  161.   res:boolean;
  162. begin
  163.   setcolor(4);
  164.   for iz:=0 to 18 do
  165.   begin
  166.     z:=z2+iz*80;
  167.     setcolor(12); putchar(z,$81); setcolor(4);
  168.     for jz:=1 to 32 do
  169.     begin
  170.       res:=point(jz,iz+start);
  171.       if res then putchar(z+jz,$a0) else putchar(z+jz,$20);
  172.     end;
  173.     setcolor(12);
  174.     if iz+start=runs*8 then for jz:=1 to recvar.width do putchar(z+jz,$84);
  175.     putchar(z+recvar.width+1,$81); setcolor(4);
  176.   end;
  177. end;
  178.  
  179. function getmenu(iz:integer): integer;
  180. var
  181.   j: integer;
  182. begin
  183.   j:=menu(mpos[iz],2,menus[iz]);
  184.   if j=0 then getmenu:=0 else getmenu:=max_menu_items*(iz-1)+j;
  185. end;
  186.  
  187. function getfontchar: boolean;
  188. var
  189.   chtxt:char;
  190.   chnum:integer;
  191. begin
  192.   window(40,10,30,5,'Edit character',true);
  193.   putat(42,12); setcolor(3);
  194.   print ('Character to edit '); setcolor(11); setcursor(96); putcursor;
  195.   read (kbd,chtxt);
  196.   if (chtxt=^M) or (chtxt=^[) then getfontchar:=false
  197.   else
  198.   begin
  199.     print(chtxt); edchar:=chtxt; zapcursor;
  200.     chnum:=ord(chtxt)-32;
  201.     {$I-} seek(fontfile,chnum);
  202.      read(fontfile,recvar); {$i+}
  203.     if ioresult=0 then getfontchar:=true else getfontchar:=false;
  204.   end;
  205.   popwind;
  206. end;
  207.  
  208. procedure editchar;
  209. var
  210.   charst,xcurs,ycurs,z:integer;
  211.   opt:char;
  212.  
  213. procedure update;
  214. begin
  215.   use ('P'); setcolor(11); putat(68,2);
  216.   print (' Editing   ');
  217.   use('F'); putat (77,2); print (edchar); use('pf'); setcolor(3);
  218. end;
  219.  
  220. procedure putedcurs;
  221. begin
  222.   z:=z2+xcurs+1+80*(ycurs-charst);
  223.   if (z>=Z2) and (z<=z2+18*80+31) then
  224.   begin
  225.     if mem[z]=$a0 then mem[z]:=$83 else mem[z]:=$82;
  226.   end;
  227. end;
  228.  
  229. procedure zapedcurs;
  230. begin
  231.   z:=z2+xcurs+1+80*(ycurs-charst);
  232.   if (z>=Z2) and (z<=z2+18*80+31) then
  233.   begin
  234.     if mem[z]=$82 then mem[z]:=$20 else mem[z]:=$a0;
  235.   end;
  236. end;
  237.  
  238. begin
  239.   charst:=0; xcurs:=0; ycurs:=0;
  240.   update;
  241.   displaychar(charst);
  242.   putedcurs;
  243.   repeat
  244.   begin
  245.     read(kbd,opt);
  246.     if opt in['1'..chr(48+max_menus)] then
  247.     begin
  248.       case getmenu(ord(opt)-48) of
  249.       23: begin
  250.             if getfontchar then
  251.             begin
  252.               use('F'); putat(56,1); print (' Already assigned ');
  253.               repeat read(kbd,opt) until opt=^[;
  254.               use('f'); putat(56,1); print ('                  ');
  255.             end
  256.             else
  257.             begin
  258.               nukechar;
  259.               update;
  260.               displaychar(charst);
  261.               putedcurs;
  262.             end;
  263.           end;
  264.       22: if not(newfont) then
  265.           begin
  266.             if getfontchar then
  267.             begin
  268.               update;
  269.               displaychar(charst);
  270.               putedcurs;
  271.             end;
  272.           end;
  273.       21: begin
  274.             setwidth;
  275.             displaychar(charst);
  276.             putedcurs;
  277.           end;
  278.       11: scratch:=recvar;
  279.       12: begin
  280.             recvar:=scratch;
  281.             displaychar(charst);
  282.             putedcurs;
  283.           end;
  284.       13: begin
  285.             nukechar;
  286.             displaychar(charst);
  287.             putedcurs;
  288.           end;
  289.       end; {case}
  290.     end
  291.     else
  292.     begin
  293.       case opt of
  294.       ^R   : begin
  295.                if charst>0 then
  296.                begin
  297.                  charst:=charst-1; ycurs:=ycurs-1;
  298.                  displaychar(charst);
  299.                  putedcurs;
  300.                end;
  301.              end;
  302.       ^C   : begin
  303.                charst:=charst+1; ycurs:=ycurs+1;
  304.                displaychar(charst); putedcurs;
  305.              end;
  306.       ^A   : begin
  307.                if recvar.width>1 then recvar.width:=recvar.width-1;
  308.                displaychar(charst); putedcurs;
  309.              end;
  310.       ^F   : begin
  311.                if recvar.width<32 then recvar.width:=recvar.width+1;
  312.                displaychar(charst); putedcurs;
  313.              end;
  314.       ^E   : if ycurs>0 then
  315.              begin
  316.                zapedcurs;
  317.                ycurs:=ycurs-1;
  318.                putedcurs;
  319.              end;
  320.       ^X   : if ycurs<runs*8-1 then
  321.              begin
  322.                zapedcurs;
  323.                ycurs:=ycurs+1;
  324.                putedcurs;
  325.              end;
  326.       ^S   : if xcurs>0 then
  327.              begin
  328.                zapedcurs;
  329.                xcurs:=xcurs-1;
  330.                putedcurs;
  331.              end;
  332.       ^D   : if xcurs<recvar.width-1 then
  333.              begin
  334.                zapedcurs;
  335.                xcurs:=xcurs+1;
  336.                putedcurs;
  337.              end;
  338.       ^G   : begin
  339.                resetp(xcurs,ycurs);
  340.                displaychar(charst);
  341.                putedcurs;
  342.              end;
  343.       ' '  : begin
  344.                setp(xcurs,ycurs);
  345.                displaychar(charst);
  346.                putedcurs;
  347.              end;
  348.       ^T   : begin
  349.                if point(xcurs+1,ycurs) then
  350.                  resetp(xcurs,ycurs)
  351.                else
  352.                  setp(xcurs,ycurs);
  353.                displaychar(charst);
  354.                putedcurs;
  355.              end;
  356.       end; {case}
  357.     end; {if}
  358.   end {repeat}
  359.   until (opt=^M) or (opt=^[);
  360.   if opt=^M then
  361.   begin
  362.     seek(fontfile,ord(edchar)-32);
  363.     write(fontfile,recvar);
  364.   end;
  365.   use('P'); putat(68,2); print ('           '); use('p');
  366. end;
  367.  
  368. procedure updatename;
  369. var
  370.   iz:integer;
  371. begin
  372.   use('P'); putat(1,2); setcolor(3); for iz:=1 to 80 do print(' ');
  373.   setcolor(11); putat(39-(length(fontname) div 2),2);
  374.   print (' '+fontname+' '); setcolor(3); use('p');
  375. end;
  376.  
  377. procedure setruns;
  378. var
  379.   work:str14;
  380.   pts:integer;
  381. begin
  382.   nlq:=false;
  383.   work:=copy(fontname,length(fontname)-1,2);
  384.   val(work,pts,i);
  385.   case pts of
  386.   12: begin
  387.           runs:=2;
  388.           nlq:=true;
  389.         end;
  390.   16 : runs:=2;
  391.   24 : runs:=3;
  392.   32 : runs:=4;
  393.   end;
  394. end;
  395.  
  396. procedure allcaps(var work:str80);
  397. var
  398.   i:integer;
  399. begin
  400.   if length(work)>0 then for i:=1 to length(work) do work[i]:=upcase(work[i]);
  401. end;
  402.  
  403. procedure openfont;
  404. var
  405.   ok:boolean;
  406.   temp:str80;
  407.   ch:char;
  408.   n:integer;
  409. begin
  410.   window(20,6,40,5,'Open',true);
  411.   putat(22,8); setcolor(3); print ('Enter font name:');
  412.   repeat
  413.   begin
  414.     ok:=false;
  415.     setcolor(11); putat(39,8);
  416.     edit (fontname,false);
  417.     if fontname='' then ok:=true;
  418.     if not ok then
  419.     begin
  420.       {$i-} close(fontfile); {$i+}
  421.       allcaps(fontname);
  422.       fontopen:=false; newfont:=false;
  423.       assign(fontfile,fontname);
  424.       {$i-} reset (fontfile); {$i+}
  425.       if ioresult<>0 then write (^G) else
  426.       begin
  427.         ok:=true; fontopen:=true;
  428.         setruns;
  429.         updatename;
  430.         n:=filesize(fontfile);
  431.         if n<95 then
  432.         begin
  433.           putat(22,10); use('F');
  434.           str(n,temp);
  435.           insert(' '+fontname+' has only ',temp,1);
  436.           temp:=concat(temp,' records '); print (temp);
  437.           use('f'); read(kbd,ch);
  438.         end;
  439.       end;
  440.     end;
  441.   end
  442.   until ok;
  443.   popwind;
  444. end;
  445.  
  446. procedure inputseries;
  447. var
  448.   iz:integer;
  449.   ch: char;
  450. begin
  451.   use('F'); setcolor(13); putat(66,1); print (' Input Series ');
  452.   use('f'); setcolor(3);
  453.   for iz:=32 to 126 do
  454.   begin
  455.     edchar:=chr(iz);
  456.     nukechar;
  457.     repeat
  458.     begin
  459.       editchar;
  460.       if filesize(fontfile)<>iz-31 then
  461.       begin
  462.         putat(50,1); setcolor(13); use('F'); print (' No, again! ');
  463.         read (kbd,ch); putat(50,1); setcolor(3); use('f');
  464.         print('            ');
  465.       end;
  466.     end
  467.     until iz-31=filesize(fontfile);
  468.   end;
  469.   putat(66,1); print ('              ');
  470. end;
  471.  
  472. procedure makefont;
  473. var
  474.   ch: char;
  475. begin
  476.   window(20,6,50,5,'New',true);
  477.   putat(22,8); setcolor(3); print ('Enter name of new font : ');
  478.   setcolor(11); edit (fontname,false);
  479.   popwind;
  480.   if fontname<>'' then
  481.   begin
  482.     allcaps(fontname);
  483.     close(fontfile); fontopen:=false; newfont:=false;
  484.     assign(fontfile,fontname);
  485.     {$I-} reset(fontfile); {$I+}
  486.     if ioresult=0 then
  487.     begin
  488.       window (20,8,10,3,'',true);
  489.       putat (21,9); setcolor(11); use('PF');
  490.       print (' Error  '); use('fp'); setcolor(3);
  491.       read (kbd,ch);
  492.       popwind;
  493.     end
  494.     else
  495.     begin
  496.       rewrite(fontfile);
  497.       newfont:=true; fontopen:=true;
  498.       setruns;
  499.       updatename;
  500.       InputSeries;
  501.     end;
  502.   end;
  503. end;
  504.  
  505.  
  506. begin
  507.   determine;
  508.   initpcg;
  509.   fontopen:=false; newfont:=false;
  510.   fontname:=''; screen_pointer:=0;
  511.   setpcg(0); setcolor(3); use('fp'); cls;
  512.   window(1,2,80,23,fontname,false);
  513.   setcolor(11); putat(79-length(credits),24); print (credits);
  514.   putat(1,1); use('P'); print(menu_bar); use('p');
  515.   repeat
  516.   begin
  517.     repeat read(kbd,ch) until ch in['1'..chr(48+max_menus)];
  518.     i:=getmenu(ord(ch)-$30);
  519.     case i of
  520.     1: makefont;
  521.     2: openfont;
  522.     3: begin
  523.          if fontopen then close(fontfile);
  524.          fontopen:=false; newfont:=false; fontname:='';
  525.          updatename;
  526.        end;
  527.     22: begin
  528.          if (fontopen) and not(newfont) then
  529.          begin
  530.            if getfontchar then editchar;
  531.          end;
  532.        end;
  533.    23: if fontopen then
  534.        begin
  535.          if getfontchar then
  536.          begin
  537.            use('F'); putat(56,1); print (' Already assigned ');
  538.            repeat read(kbd,ch) until ch=^[;
  539.            use('f'); putat(56,1); print ('                  ');
  540.          end
  541.          else
  542.          begin
  543.            nukechar;
  544.            editchar;
  545.           end;
  546.         end;
  547.  
  548.     end;
  549.   end
  550.   until i=4;
  551.   if fontopen then close(fontfile);
  552.   setcolor(3); cls;
  553. end.