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