home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / HTMIX20.ZIP / FE.ZIP / FE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-14  |  27.5 KB  |  806 lines
  1. program FontEditor;
  2. {┌──────────────────────────────── INFO ────────────────────────────────────┐}
  3. {│ File    : FE.PAS                                                         │}
  4. {│ Author  : Harald Thunem                                                  │}
  5. {│ Purpose : Edit fonts in text mode VGA.                                   │}
  6. {│ Updated : July 10 1992                                                   │}
  7. {└──────────────────────────────────────────────────────────────────────────┘}
  8.  
  9. {────────────────────────── Compiler directives ─────────────────────────────}
  10. {$A+   Word align data                                                       }
  11. {$B-   Short-circuit Boolean expression evaluation                           }
  12. {$E-   Disable linking with 8087-emulating run-time library                  }
  13. {$G+   Enable 80286 code generation                                          }
  14. {$R-   Disable generation of range-checking code                             }
  15. {$S-   Disable generation of stack-overflow checking code                    }
  16. {$V-   String variable checking                                              }
  17. {$X-   Disable Turbo Pascal's extended syntax                                }
  18. {$N+   80x87 code generation                                                 }
  19. {$D-   Disable generation of debug information                               }
  20. {────────────────────────────────────────────────────────────────────────────}
  21. uses  Dos,
  22.       Screen,
  23.       FEUnit,
  24.       Strings,
  25.       Keyboard;
  26.  
  27. const PowerList   : array[1..8] of byte = (128,64,32,16,8,4,2,1);
  28.       MainBAttr   = White+BlueBG;
  29.       TopAttr     = White+CyanBG;
  30.       BottomAttr1 = Yellow+CyanBG;
  31.       BottomAttr2 = White+CyanBG;
  32.  
  33.       CharRow     = 5;                   { Char box Row (upper left)     }
  34.       CharCol     = 4;                   { Char box Column               }
  35.       CharRows    = 18;                  { Char box Row number           }
  36.       CharCols    = 35;                  { Char box Column number        }
  37.       CharAttrBo  = White+LightGrayBG;   { Char box Border attr          }
  38.       CharAttrBoH = Red+LightWhiteBG;    { Char box Border attr          }
  39.       CharAttrNo  = White+CyanBG;        { Char box Normal attr          }
  40.       CharAttrHiNo= White+RedBG;         { Char box Highlighted normal   }
  41.       CharAttrHiSe= White+LightRedBG;    { Char box Highlighted selected }
  42.       CharAttrSe  = White+LightWhiteBG;  { Char box Selected attr        }
  43.  
  44.       ChartRow    = 5;                   { Chart box Row (upper left) }
  45.       ChartCol    = 43;                  { Chart box Column           }
  46.       ChartRows   = 10;                  { Chart box Row number       }
  47.       ChartCols   = 34;                  { Chart box Column number    }
  48.       ChartAttrBo = White+LightGrayBG;   { Chart box Border attr      }
  49.       ChartAttrBoH= Red+LightWhiteBG;    { Chart box Highlight Border }
  50.       ChartAttrNo = White+CyanBG;        { Chart box Normal attr      }
  51.       ChartAttrHi = Yellow+LightRedBG;   { Chart box Highlighted attr }
  52.       ChartAttrSe = White+RedBG;         { Chart box Selected attr    }
  53.  
  54.  
  55. var   Filename    : string;
  56.       CurrentPath : string;
  57.  
  58. procedure SaveFontFile(FontFileName: string);
  59. begin
  60.   Assign(FontFile,FontFileName);
  61.   ReWrite(FontFile);
  62.   Write(FontFile,Font);
  63.   Close(FontFile);
  64. end;
  65.  
  66.  
  67. function HexStr(b: byte): string;
  68. var bl: array[1..2] of byte;
  69.     i: byte;
  70.     s: string;
  71. begin
  72.   s := '$';
  73.   bl[1] := b shr 4;    { High 4 bits }
  74.   bl[2] := b and $0F;  { Low 4 bits  }
  75.   for i := 1 to 2 do
  76.   if bl[i]<10 then
  77.     s := s + Chr(bl[i]+48)
  78.   else s := s + Chr(bl[i]+65-10);
  79.   HexStr := s;
  80. end;
  81.  
  82.  
  83. procedure Savefile(var Filename: string);
  84. const SaveAttr = White+GreenBG;
  85.       TopAttr  = Green+LightWhiteBG;
  86.       FileAttr = Yellow+BlackBG;
  87. var   L        : byte;
  88.       Size     : integer;
  89.       Scr      : pointer;
  90. begin
  91.   L := 30;
  92.   Size := 2*5*L;
  93.   GetMem(Scr,Size);
  94.   StoreToMem(11,25,5,L,Scr^);
  95.   Box(11,25,4,L-2,SaveAttr,NoBorder,' ');
  96.   AddShadow(11,25,4,L-2);
  97.   Fill(11,25,1,L-2,TopAttr,' ');
  98.   WriteStr(11,33,TopAttr,'Save file');
  99.   WriteStr(13,27,SaveAttr,'Save to : ');
  100.   InputString(Filename,13,37,12,FileAttr,[Escape,Return]);
  101.   StoreToScr(11,25,5,L,Scr^);
  102.   FreeMem(Scr,Size);
  103.   if Key=Return then
  104.     SaveFontFile(CurrentPath+Filename);
  105.   Key := NullKey;
  106. end;
  107.  
  108.  
  109. procedure Help;
  110. const HelpAttr = White+GreenBG;
  111.       TopAttr  = Green+LightWhiteBG;
  112.       CommAttr = LightCyan+GreenBG;
  113.       HRow     = 3;
  114.       HCol     = 17;
  115.       HRows    = 21;
  116.       HCols    = 48;
  117. var
  118.       Size     : integer;
  119.       Scr      : pointer;
  120. begin
  121.   Size := 2*HRows*HCols;
  122.   GetMem(Scr,Size);
  123.   StoreToMem(HRow,HCol,HRows,HCols,Scr^);
  124.   Box(HRow,HCol,HRows-1,HCols-2,HelpAttr,NoBorder,' ');
  125.   AddShadow(HRow,HCol,HRows-1,HCols-2);
  126.   Fill(HRow,HCol,1,HCols-2,TopAttr,' ');
  127.   WriteC(HRow,HCol+(HCols div 2)-1,TopAttr,'Help');
  128.   Fill(HRow,HCol,HRows-1,1,HelpAttr,'█');
  129.   Fill(HRow,HCol+HCols-3,HRows-1,1,HelpAttr,'█');
  130.   Fill(HRow+HRows-2,HCol+1,1,HCols-4,HelpAttr,'▄');
  131.   WriteStr(HRow+2,HCol+2,CommAttr,'Commands');
  132.   WriteStr(HRow+3,HCol+4,CommAttr,'F1   ');
  133.   WriteEos(HelpAttr,'- This help screen');
  134.   WriteStr(HRow+4,HCol+4,CommAttr,'F2   ');
  135.   WriteEos(HelpAttr,'- Save current font to file');
  136.   WriteStr(HRow+5,HCol+4,CommAttr,'F3   ');
  137.   WriteEos(HelpAttr,'- Load a new font from file');
  138.   WriteStr(HRow+6,HCol+4,CommAttr,'Space');
  139.   WriteEos(HelpAttr,'- Toggle character bit');
  140.   WriteStr(HRow+7,HCol+4,CommAttr,'Tab  ');
  141.   WriteEos(HelpAttr,'- Switch between character editing');
  142.   WriteStr(HRow+8,HCol+4,HelpAttr,'       and character selection');
  143.   WriteStr(HRow+9,HCol+4,CommAttr,'AltF ');
  144.   WriteEos(HelpAttr,'- Fill with movement');
  145.   WriteStr(HRow+10,HCol+4,CommAttr,'AltE ');
  146.   WriteEos(HelpAttr,'- Erase with movement');
  147.   WriteStr(HRow+11,HCol+4,CommAttr,'AltN ');
  148.   WriteEos(HelpAttr,'- Normal movement');
  149.   WriteStr(HRow+12,HCol+4,CommAttr,'Esc  ');
  150.   WriteEos(HelpAttr,'- Quit');
  151.   WriteStr(HRow+14,HCol+4,HelpAttr,'  Read the FE.DOC file for a more');
  152.   WriteStr(HRow+15,HCol+4,HelpAttr,'detailed description of the available');
  153.   WriteStr(HRow+16,HCol+4,HelpAttr,'commands.');
  154.   WriteStr(HRow+17,HCol+20,Blue+LightWhiteBG,#16+' OK '+#17);
  155.   WriteStr(HRow+17,HCol+26,HelpAttr and $F0,'▄');
  156.   WriteStr(HRow+18,HCol+21,HelpAttr and $F0,'▀▀▀▀▀▀');
  157.   repeat
  158.     InKey(Ch,Key);
  159.   until Key in [Escape,Return];
  160.   StoreToScr(HRow,HCol,HRows,HCols,Scr^);
  161.   FreeMem(Scr,Size);
  162.   Key := NullKey;
  163. end;
  164.  
  165.  
  166. procedure About;
  167. const ARow  = 7;
  168.       ACol  = 13;
  169.       ARows = 10;
  170.       ACols = 54;
  171. var A,i,j: byte;
  172. begin
  173.   Fill(1,1,25,80,White+BlueBG,'▒');
  174.   Fill(ARow,ACol,ARows,ACols,White+LightBlackBG,' ');
  175.   AddShadow(ARow,ACol,ARows,ACols);
  176.   Fill(ARow,ACol,1,ACols,Green+LightWhiteBG,' ');
  177.   WriteC(ARow,ACol+(ACols div 2),SameAttr,'About');
  178.   { Blue }
  179.   Fill(ARow+1,ACol,ARows-1,3,White+LightBlueBG,' ');
  180.   Fill(ARow+1,ACol+ACols-3,ARows-1,3,White+LightBlueBG,' ');
  181.   { Green }
  182.   Fill(ARow+1,ACol+3,ARows-1,3,White+LightGreenBG,' ');
  183.   Fill(ARow+1,ACol+ACols-6,ARows-1,3,White+LightGreenBG,' ');
  184.   { Cyan }
  185.   Fill(ARow+1,ACol+6,ARows-1,3,White+LightCyanBG,' ');
  186.   Fill(ARow+1,ACol+ACols-9,ARows-1,3,White+LightCyanBG,' ');
  187.   { Red }
  188.   Fill(ARow+1,ACol+9,ARows-1,3,White+LightRedBG,' ');
  189.   Fill(ARow+1,ACol+ACols-12,ARows-1,3,White+LightRedBG,' ');
  190.   { Magenta }
  191.   Fill(ARow+1,ACol+12,ARows-1,3,White+LightMagentaBG,' ');
  192.   Fill(ARow+1,ACol+ACols-15,ARows-1,3,White+LightMagentaBG,' ');
  193.   { Change middle attribute }
  194.   for i := (ARow+4) to (ARow+6) do
  195.   for j := ACol to (ACol+ACols-1) do
  196.   begin
  197.     A := ReadAttr(i,j);
  198.     A := A and $7F;
  199.     Attr(i,j,1,1,A);
  200.   end;
  201.   { Text }
  202.   WriteC(ARow+4,ACol+(ACols div 2),SameAttr,'Font Editor  2.0');
  203.   WriteC(ARow+5,ACol+(ACols div 2),SameAttr,'by');
  204.   WriteC(ARow+6,ACol+(ACols div 2),SameAttr,'Harald  Thunem');
  205.   Inkey(Ch,Key);
  206.   Key := NullKey;
  207. end;
  208.  
  209.  
  210. function Confirm(Msg: string; Select: boolean): boolean;
  211. const MessageAttr = White+RedBG;
  212.       TopAttr     = Green+LightWhiteBG;
  213. var   L           : byte;
  214.       Size        : integer;
  215.       Scr         : pointer;
  216. begin
  217.   if Pos('?',Msg)<=0 then Msg := Msg + ' ?';
  218.   L := 4+(Length(Msg) div 2);
  219.   Size := 2*7*(2*L+2);
  220.   GetMem(Scr,Size);
  221.   StoreToMem(11,8,7,60,Scr^);
  222.   Box(11,40-L,6,2*L,MessageAttr,NoBorder,' ');
  223.   AddShadow(11,40-L,6,2*L);
  224.   Fill(11,40-L,1,2*L,TopAttr,' ');
  225.   WriteC(11,40,TopAttr,'Confirm');
  226.   WriteC(13,40,MessageAttr,Msg);
  227.   if Select then
  228.     WriteStr(15,30,Blue+LightWhiteBG,#16+' Yes '+#17)
  229.   else WriteStr(15,30,Blue+LightGrayBG,'  Yes  ');
  230.   WriteStr(16,31,Black+RedBG,'▀▀▀▀▀▀▀');
  231.   WriteStr(15,37,Black+RedBG,'▄');
  232.   if Select then
  233.     WriteStr(15,43,Blue+LightGrayBG,'  No   ')
  234.   else WriteStr(15,43,Blue+LightWhiteBG,#16+' No  '+#17);
  235.   WriteStr(16,44,Black+RedBG,'▀▀▀▀▀▀▀');
  236.   WriteStr(15,50,Black+RedBG,'▄');
  237.   repeat
  238.     InKey(Ch,Key);
  239.     Ch := Upcase(Ch);
  240.     WriteStr(15,30,Blue+LightGrayBG,'  Yes  ');
  241.     WriteStr(15,43,Blue+LightGrayBG,'  No   ');
  242.     if Key in [LeftArrow,RightArrow] then
  243.       Select := not Select;
  244.     if Select then
  245.       WriteStr(15,30,Blue+LightWhiteBG,#16+' Yes '+#17)
  246.     else WriteStr(15,43,Blue+LightWhiteBG,#16+' No  '+#17);
  247.   until (Ch in ['Y','N']) or (Key in [Return,Escape]);
  248.   if (Ch='Y') then Select := true;
  249.   if (Ch='N') then Select := false;
  250.   if Key=Escape then Select := false;
  251.   Confirm := Select;
  252.   StoreToScr(11,8,7,60,Scr^);
  253.   Freemem(Scr,Size);
  254.   Key := NullKey;
  255. end;
  256.  
  257.  
  258. procedure OpenFile(var CurrentPath,Filename: string);
  259. const OpenAttr = White+LightGrayBG;
  260.       OpenAttr2= White+CyanBG;
  261.       DirAttr  = LightCyan+LightGrayBG;
  262.       TopAttr  = Green+LightWhiteBG;
  263.       SlideAttr= White+GreenBG;
  264.       HighAttr = Yellow+MagentaBG;
  265.       OpenRow  = 5;
  266.       OpenCol  = 20;
  267.       MaxFiles = 1000;
  268.  
  269. type  FileType = record
  270.                    Attr : Byte;
  271.                    Time : Longint;
  272.                    Size : Longint;
  273.                    Name : string[12];
  274.                  end;
  275.       PFile    = ^FileType;
  276.  
  277. var   FileList : array[1..MaxFiles] of PFile;
  278.       NumFiles : integer;
  279.       ImSize,
  280.       Size: integer;
  281.       SearchPath: string;
  282.       Scr : pointer;
  283.  
  284.   procedure ScanForFiles(CurrentPath,SearchPath: string);
  285.   var S: SearchRec;
  286.   begin
  287.     NumFiles := 0;
  288.     FindFirst(CurrentPath+'*.*',AnyFile,S);
  289.     while DosError=0 do
  290.     begin
  291.       if (S.Name<>'.') and (S.Attr=Directory) then
  292.       begin
  293.         Inc(NumFiles);
  294.         GetMem(FileList[NumFiles],Size);
  295.         FileList[NumFiles]^.Attr := S.Attr;
  296.         FileList[NumFiles]^.Time := S.Time;
  297.         FileList[NumFiles]^.Size := S.Size;
  298.         FileList[NumFiles]^.Name := S.Name;
  299.       end;
  300.       FindNext(S);
  301.     end;
  302.     FindFirst(CurrentPath+SearchPath,ReadOnly+Archive+Hidden,S);
  303.     while DosError=0 do
  304.     begin
  305.       Inc(NumFiles);
  306.       GetMem(FileList[NumFiles],Size);
  307.       FileList[NumFiles]^.Attr := S.Attr;
  308.       FileList[NumFiles]^.Time := S.Time;
  309.       FileList[NumFiles]^.Size := S.Size;
  310.       FileList[NumFiles]^.Name := S.Name;
  311.       FindNext(S);
  312.     end;
  313.   end;
  314.  
  315.   procedure SortFileList;
  316.   var i: integer;
  317.       b: boolean;
  318.       t: PFile;
  319.   begin
  320.     repeat
  321.       b := true;
  322.       for i := 1 to NumFiles-1 do
  323.       if FileList[i]^.Name > FileList[i+1]^.Name then
  324.       begin
  325.         t:=FileList[i]; FileList[i]:=FileList[i+1]; FileList[i+1]:=t; b:=False;
  326.       end;
  327.     until b;
  328.     repeat
  329.       b := true;
  330.       for i := 1 to NumFiles-1 do
  331.       if (FileList[i]^.Attr and Directory<>Directory) and (FileList[i+1]^.Attr and Directory=Directory) then
  332.       begin
  333.         t:=FileList[i]; FileList[i]:=FileList[i+1]; FileList[i+1]:=t; b:=False;
  334.       end;
  335.     until b;
  336.   end;
  337.  
  338.   procedure EraseFileList;
  339.   var i: integer;
  340.   begin
  341.     for i := 1 to NumFiles do
  342.       FreeMem(FileList[i],Size);
  343.   end;
  344.  
  345.   procedure ClearOpen;
  346.   var i: integer;
  347.   begin
  348.     Fill(OpenRow,OpenCol,10,42,OpenAttr,' ');
  349.     for i := 1 to 10 do
  350.     begin
  351.       WriteStr(OpenRow+i-1,OpenCol+13,OpenAttr,'│');
  352.       WriteStr(OpenRow+i-1,OpenCol+27,OpenAttr,'│');
  353.     end;
  354.   end;
  355.  
  356.   procedure DrawBackground;
  357.   begin
  358.     Box(OpenRow-1,OpenCol-1,18,44,OpenAttr,NoBorder,' ');
  359.     AddShadow(OpenRow-1,OpenCol-1,18,44);
  360.     Box(OpenRow+10,OpenCol-1,7,44,OpenAttr2,NoBorder,' ');
  361.     Fill(OpenRow-1,OpenCol-1,1,44,TopAttr,' ');
  362.     WriteC(OpenRow-1,OpenCol+20,TopAttr,'Open File');
  363.     WriteStr(OpenRow+10,OpenCol-1,TopAttr,' ');
  364.     WriteStr(OpenRow+10,OpenCol+42,TopAttr,' ');
  365.     Fill(OpenRow+10,OpenCol+1,1,40,SlideAttr,'▒');
  366.     WriteStr(OpenRow+10,OpenCol,SlideAttr,#17);
  367.     WriteStr(OpenRow+10,OpenCol+41,SlideAttr,#16);
  368.     ClearOpen;
  369.   end;
  370.  
  371.   procedure WriteFileList(StartNum: integer);
  372.   var i,j: integer;
  373.   begin
  374.     ClearOpen;
  375.     i := StartNum-1;
  376.     repeat
  377.       Inc(i);
  378.       j := i-StartNum;
  379.       if FileList[i]^.Attr=Directory then
  380.         WriteStr(OpenRow+(j mod 10),OpenCol+1+14*(j div 10),DirAttr,FileList[i]^.Name)
  381.       else WriteStr(OpenRow+(j mod 10),OpenCol+1+14*(j div 10),OpenAttr,FileList[i]^.Name);
  382.     until (i-StartNum >= 29) or (i=NumFiles);
  383.   end;
  384.  
  385.   procedure LightName(StartNum,i: integer;  b: boolean);
  386.   var j: integer;
  387.       a: byte;
  388.       s: string[13];
  389.   begin
  390.     if b then a:=HighAttr
  391.     else if FileList[i]^.Attr = Directory then a:=DirAttr
  392.     else a := OpenAttr;
  393.     j := i-StartNum;
  394.     s := ' '+FileList[i]^.Name+'            ';
  395.     WriteStr(OpenRow+(j mod 10),OpenCol+14*(j div 10),a,s);
  396.   end;
  397.  
  398.   procedure WriteInfo(i: integer);
  399.   const DateStr : array[1..12] of string[3] = ('Jan','Feb','Mar','Apr','May','Jun',
  400.                                                'Jul','Aug','Sep','Oct','Nov','Dec');
  401.   var DT: DateTime;
  402.       s,s1: string;
  403.       a: byte;
  404.   begin
  405.     Fill(OpenRow+10,OpenCol+1,1,40,SlideAttr,'▒');
  406.     if NumFiles>1 then
  407.       a := 1+Trunc(39*(i-1)/(NumFiles-1))
  408.     else a:=1;
  409.     WriteStr(OpenRow+10,OpenCol+a,SlideAttr,'■');
  410.     WriteStr(OpenRow+12,OpenCol+1,OpenAttr2,'File :');
  411.     WriteStr(OpenRow+13,OpenCol+1,OpenAttr2,'Size :');
  412.     WriteStr(OpenRow+14,OpenCol+1,OpenAttr2,'Attr :');
  413.     WriteStr(OpenRow+15,OpenCol+1,OpenAttr2,'Path :');
  414.     WriteStr(OpenRow+12,OpenCol+22,OpenAttr2,'Time :');
  415.     WriteStr(OpenRow+13,OpenCol+22,OpenAttr2,'Date :');
  416.     s := Copy(FileList[i]^.Name+'            ',1,12);
  417.     WriteStr(OpenRow+12,OpenCol+8,OpenAttr2,s);
  418.     Str(FileList[i]^.Size:1,s);
  419.     s := Copy(s+'            ',1,12);
  420.     WriteStr(OpenRow+13,OpenCol+8,OpenAttr2,s);
  421.     a := FileList[i]^.Attr;
  422.     if (a and Directory)=Directory then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2,   'Directory')
  423.     else if (a and Archive)=Archive then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2,  'Archive  ')
  424.     else if (a and ReadOnly)=ReadOnly then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2,'ReadOnly ')
  425.     else if (a and Hidden)=Hidden then WriteStr(OpenRow+14,OpenCol+8,OpenAttr2,    'Hidden   ');
  426.     s := SearchPath;
  427.     if Length(s)>34 then
  428.       s := Copy(s,1,34);
  429.     WriteStr(OpenRow+15,OpenCol+8,OpenAttr2,'                                  ');
  430.     WriteStr(OpenRow+15,OpenCol+8,OpenAttr2,s);
  431.  
  432.     UnpackTime(FileList[i]^.Time,DT);
  433.     s := '';
  434.     Str(DT.Hour:1,s);
  435.     if DT.Hour<10 then s := '0'+s;
  436.     Str(DT.Min:1,s1);
  437.     if DT.Min<10 then s1 := '0'+s1;
  438.     s := s+':'+s1;
  439.     Str(DT.Sec:1,s1);
  440.     if DT.Sec<10 then s1 := '0'+s1;
  441.     s := s+':'+s1;
  442.     WriteStr(OpenRow+12,OpenCol+29,OpenAttr2,s);
  443.     s := DateStr[DT.Month];
  444.     Str(DT.Day:1,s1);
  445.     if DT.Day<10 then s1 := '0'+s1;
  446.     s := s+'.'+s1;
  447.     Str(DT.Year:1,s1);
  448.     s := s+' '+s1;
  449.     WriteStr(OpenRow+13,OpenCol+29,OpenAttr2,s);
  450.   end;
  451.  
  452.   procedure NewSearchPath;
  453.   const NewAttr = White+RedBG;
  454.         EditAttr= LightCyan+LightGrayBG;
  455.   var s: string;
  456.   begin
  457.     Box(OpenRow+6,OpenCol+11,1,19,NewAttr,NoBorder,' ');
  458.     AddShadow(OpenRow+6,OpenCol+11,1,19);
  459.     WriteStr(OpenRow+6,OpenCol+12,NewAttr,'Path ');
  460.     s := SearchPath;
  461.     InputString(s,OpenRow+6,OpenCol+17,12,EditAttr,[Escape,Return]);
  462.     if Key=Return then
  463.       SearchPath := s;
  464.     Key := NullKey;
  465.   end;
  466.  
  467.   procedure SelectFile;
  468.   var i,j,StartNum,OldStartNum: integer;
  469.   begin
  470.     StartNum := 1;
  471.     OldStartNum := 1;
  472.     i := 1;
  473.     WriteFileList(StartNum);
  474.     LightName(StartNum,i,true);
  475.     WriteInfo(i);
  476.     repeat
  477.       InKey(Ch,Key);
  478.       LightName(StartNum,i,false);
  479.       case Key of
  480.         UpArrow   : if i > 1 then Dec(i);
  481.         DownArrow : if i < NumFiles then Inc(i);
  482.         LeftArrow : if i > 10 then Dec(i,10) else i := 1;
  483.         RightArrow: if i < NumFiles-10 then Inc(i,10) else i := NumFiles;
  484.         F3        : begin
  485.                       NewSearchPath;
  486.                       EraseFileList;
  487.                       ScanForFiles(CurrentPath,SearchPath);
  488.                       SortFileList;
  489.                       StartNum := 1;
  490.                       OldStartNum := 1;
  491.                       i := 1;
  492.                       WriteFileList(StartNum);
  493.                       LightName(StartNum,i,true);
  494.                       WriteInfo(i);
  495.                     end;
  496.         Return    : if FileList[i]^.Attr = Directory then
  497.                     begin
  498.                       if FileList[i]^.Name = '..' then
  499.                       begin
  500.                         j := Length(CurrentPath);
  501.                         repeat
  502.                           Dec(j);
  503.                         until CurrentPath[j]='\';
  504.                         CurrentPath := Copy(CurrentPath,1,j);
  505.                       end
  506.                       else
  507.                         CurrentPath := CurrentPath + FileList[i]^.Name+'\';
  508.                       EraseFileList;
  509.                       ScanForFiles(CurrentPath,SearchPath);
  510.                       SortFileList;
  511.                       StartNum := 1;
  512.                       OldStartNum := 1;
  513.                       i := 1;
  514.                       WriteFileList(StartNum);
  515.                       LightName(StartNum,i,true);
  516.                       WriteInfo(i);
  517.                       Key := NullKey;
  518.                     end;
  519.       end;
  520.       if (i-StartNum < 0) and (StartNum>10) then Dec(StartNum,10);
  521.       if (i-StartNum >= 30) then Inc(StartNum,10);
  522.       if StartNum<>OldStartNum then
  523.       begin
  524.         WriteFileList(StartNum);
  525.         OldStartNum := StartNum;
  526.       end;
  527.       LightName(StartNum,i,true);
  528.       WriteInfo(i);
  529.     until Key in [Escape,Return];
  530.     if Key=Return then Filename := FileList[i]^.Name;
  531.   end;
  532.  
  533. begin
  534.   ImSize := 2*19*46;
  535.   GetMem(Scr,ImSize);
  536.   StoreToMem(OpenRow-1,OpenCol-1,19,46,Scr^);
  537.   SearchPath := '*.FNT';
  538.   Size := SizeOf(FileType);
  539.   ScanForFiles(CurrentPath,SearchPath);
  540.   SortFileList;
  541.   DrawBackground;
  542.   SelectFile;
  543.   EraseFileList;
  544.   StoreToScr(OpenRow-1,OpenCol-1,19,46,Scr^);
  545.   FreeMem(Scr,ImSize);
  546. end;
  547.  
  548.  
  549. procedure AddSmallShadow(Row,Col,Rows,Cols: byte);
  550. var i,Attr: byte;
  551. begin
  552.   for i := 1 to Cols do
  553.   begin
  554.     Attr := ReadAttr(Row+Rows,Col+i) and $F0;
  555.     WriteStr(Row+Rows,Col+i,Attr,'▀');
  556.   end;
  557.   for i := 1 to Rows-1 do
  558.   begin
  559.     Attr := ReadAttr(Row+i,Col+Cols) and $F0;
  560.     WriteStr(Row+i,Col+Cols,Attr,'█');
  561.   end;
  562.   Attr := ReadAttr(Row,Col+Cols) and $F0;
  563.   WriteStr(Row,Col+Cols,Attr,'▄');
  564. end;
  565.  
  566.  
  567. procedure StatusLine(Filename: string);
  568. begin
  569.   Fill(25,1,1,80,BottomAttr2,' ');
  570.   WriteStr(25,2,BottomAttr1,'F1');
  571.   WriteEos(BottomAttr2,'-Help');
  572.   WriteStr(25,2,BottomAttr1,'F1');
  573.   WriteEos(BottomAttr2,'-Help  ');
  574.   WriteEos(BottomAttr1,'F2');
  575.   WriteEos(BottomAttr2,'-Save  ');
  576.   WriteEos(BottomAttr1,'F3');
  577.   WriteEos(BottomAttr2,'-Load  ');
  578.   WriteEos(BottomAttr1,'Tab');
  579.   WriteEos(BottomAttr2,'-Select Char  ');
  580.   Filename := UpcaseStr(Filename);
  581.   WriteStr(25,73-Length(Filename),BottomAttr1,'File : ');
  582.   WriteEos(BottomAttr2,Filename);
  583. end;
  584.  
  585.  
  586. procedure MainBackground(Filename: string);
  587. begin
  588.   Fill(1,1,25,80,MainBAttr,' ');
  589.   Fill(2,4,1,73,TopAttr,' ');
  590.   AddSmallShadow(2,4,1,73);
  591.   WriteC(2,40,TopAttr,'Font Editor 2.0');
  592.   StatusLine(Filename);
  593. end;
  594.  
  595.  
  596. procedure CharBackground;
  597. var i: byte;
  598. begin
  599.   Fill(CharRow,CharCol,CharRows,CharCols,CharAttrBo,' ');
  600.   AddSmallShadow(CharRow,CharCol,CharRows,CharCols);
  601.   Fill(CharRow+1,CharCol+4,CharRows-2,CharCols-11,CharAttrNo,' ');
  602.   WriteStr(CharRow,CharCol+4,CharAttrBoH,' 8  7  6  5  4  3  2  1 ');
  603.   WriteEos(CharAttrBo,' Value');
  604.   WriteStr(CharRow+CharRows-1,CharCol+4,CharAttrBo,' 8  7  6  5  4  3  2  1');
  605.   for i := 1 to 16 do
  606.     WriteStr(CharRow+i,CharCol+1,CharAttrBo,StrLF(i,2));
  607.   Fill(CharRow+CharRows-7,CharCol+CharCols,7,38,CharAttrBo,' ');
  608.   AddSmallShadow(CharRow+CharRows-7,CharCol+CharCols,7,38);
  609.  
  610.   WriteStr(CharRow+12,CharCol+CharCols+2,CharAttrBo,'Normal    Character Bit   Current');
  611.   WriteC(CharRow+14,CharCol+CharCols+18,CharAttrBo,'---- 0 ----');
  612.   WriteC(CharRow+16,CharCol+CharCols+18,CharAttrBo,'---- 1 ----');
  613.   WriteStr(CharRow+14,CharCol+CharCols+4,CharAttrSe,'   ');
  614.   AddSmallShadow(CharRow+14,CharCol+CharCols+4,1,3);
  615.   WriteStr(CharRow+16,CharCol+CharCols+4,CharAttrNo,'   ');
  616.   AddSmallShadow(CharRow+16,CharCol+CharCols+4,1,3);
  617.   WriteStr(CharRow+14,CharCol+CharCols+29,CharAttrHiNo,'   ');
  618.   AddSmallShadow(CharRow+14,CharCol+CharCols+29,1,3);
  619.   WriteStr(CharRow+16,CharCol+CharCols+29,CharAttrHiSe,'   ');
  620.   AddSmallShadow(CharRow+16,CharCol+CharCols+29,1,3);
  621. end;
  622.  
  623.  
  624. procedure ChartBackground;
  625. var i: byte;
  626. begin
  627.   Fill(ChartRow,ChartCol,ChartRows,ChartCols,ChartAttrBo,' ');
  628.   AddSmallShadow(ChartRow,ChartCol,ChartRows,ChartCols);
  629.   Fill(ChartRow+1,ChartCol+1,ChartRows-2,ChartCols-2,ChartAttrNo,' ');
  630.   for i := 0 to $FF do
  631.     WriteStr(ChartRow+1+(i div 32),ChartCol+1+(i mod 32),ChartAttrNo,Chr(i));
  632.   WriteC(ChartRow,ChartCol+(ChartCols div 2),ChartAttrBo,'ASCII Chart');
  633. end;
  634.  
  635.  
  636. procedure ShowChar(CharNumber: byte);
  637. var i,j: byte;
  638.     s: string;
  639. begin
  640.   for i := 1 to 16 do
  641.   begin
  642.     for j := 8 downto 1 do
  643.     begin
  644.       if Font[CharNumber,i] and PowerList[j] = PowerList[j] then
  645.         WriteStr(CharRow+i,CharCol+4+3*(j-1),CharAttrSe,'   ')
  646.       else WriteStr(CharRow+i,CharCol+4+3*(j-1),CharAttrNo,'   ');
  647.     end;
  648.     WriteStr(CharRow+i,CharCol+CharCols-5,CharAttrBo,HexStr(Font[CharNumber,i]));
  649.   end;
  650.   s := 'Character #    '+HexStr(CharNumber)+'  =  '+StrLF(CharNumber,3);
  651.   WriteC(ChartRow+ChartRows-1,ChartCol+(ChartCols div 2),ChartAttrBo,s);
  652. end;
  653.  
  654.  
  655. procedure SelectCharNumber(var CharNumber: byte);
  656. var CN: byte;
  657. begin
  658.   CN := CharNumber;
  659.   WriteStr(CharRow,CharCol+4,CharAttrBo,' 8  7  6  5  4  3  2  1 ');
  660.   WriteC(ChartRow,ChartCol+(ChartCols div 2),ChartAttrBoH,'ASCII Chart');
  661.   WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrHi,Chr(CN));
  662.   repeat
  663.     InKey(Ch,Key);
  664.     WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrNo,Chr(CN));
  665.     case Key of
  666.       UpArrow   : Dec(CN,32);
  667.       DownArrow : Inc(CN,32);
  668.       LeftArrow : Dec(CN);
  669.       RightArrow: Inc(CN);
  670.     end;
  671.     WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrHi,Chr(CN));
  672.     ShowChar(CN);
  673.   until Key in [TabKey,Return,Escape];
  674.   if Key<>Escape then
  675.     CharNumber := CN;
  676.   WriteStr(ChartRow+1+(CN div 32),ChartCol+1+(CN mod 32),ChartAttrNo,Chr(CN));
  677.   WriteStr(ChartRow+1+(CharNumber div 32),ChartCol+1+(CharNumber mod 32),ChartAttrSe,Chr(CharNumber));
  678.   WriteC(ChartRow,ChartCol+(ChartCols div 2),ChartAttrBo,'ASCII Chart');
  679.   WriteStr(CharRow,CharCol+4,CharAttrBoH,' 8  7  6  5  4  3  2  1 ');
  680.   ShowChar(CharNumber);
  681.   Key := NullKey;
  682.   Ch := ' ';
  683. end;
  684.  
  685.  
  686. procedure EditCharacter;
  687. var Row,Col,CharNumber: byte;
  688.     OldCurrentPath,
  689.     OldFilename: string;
  690.     Filled: boolean;
  691.     DrawMode: (FillAll,EraseAll,Normal);
  692. begin
  693.   CharNumber := 65;
  694.   ShowChar(CharNumber);
  695.   Row := 1;
  696.   Col := 1;
  697.   DrawMode := Normal;
  698.   Filled := (Font[CharNumber,Row] and PowerList[Col]) = PowerList[Col];
  699.   if Filled then
  700.     WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiSe,'   ')
  701.   else WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiNo,'   ');
  702.   WriteStr(ChartRow+1+(CharNumber div 32),ChartCol+1+(CharNumber mod 32),ChartAttrSe,Chr(CharNumber));
  703.   repeat
  704.     InKey(Ch,Key);
  705.  
  706.     if Filled then
  707.       WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrSe,'   ')
  708.     else WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrNo,'   ');
  709.  
  710.     case Key of
  711.       TabKey    : SelectCharNumber(CharNumber);
  712.       UpArrow   : Dec(Row);
  713.       DownArrow : Inc(Row);
  714.       LeftArrow : Dec(Col);
  715.       RightArrow: Inc(Col);
  716.       PgUp      : begin Dec(Row); Inc(Col); end;
  717.       PgDn      : begin Inc(Row); Inc(Col); end;
  718.       HomeKey   : begin Dec(Row); Dec(Col); end;
  719.       EndKey    : begin Inc(Row); Dec(Col); end;
  720.       AltF      : DrawMode := FillAll;
  721.       AltE      : DrawMode := EraseAll;
  722.       AltN      : DrawMode := Normal;
  723.       F1        : Help;
  724.       F2        : SaveFile(Filename);
  725.       F3        : begin
  726.                     OldCurrentPath := CurrentPath;
  727.                     OldFilename := Filename;
  728.                     OpenFile(CurrentPath,Filename);
  729.                     if (Key<>Escape) and ReadFontFile(CurrentPath+Filename) then
  730.                     begin
  731.                       LoadUserFont;
  732.                       ShowChar(CharNumber);
  733.                     end
  734.                     else begin
  735.                       Filename := OldFilename;
  736.                       CurrentPath := OldCurrentPath;
  737.                     end;
  738.                     StatusLine(Filename);
  739.                     Key := NullKey;
  740.                   end;
  741.       Space     : if DrawMode = Normal then
  742.                   begin
  743.                     Font[CharNumber,Row] := Font[CharNumber,Row] xor PowerList[Col];
  744.                     LoadOneChar(CharNumber,Font[CharNumber]);
  745.                     WriteStr(CharRow+Row,CharCol+CharCols-5,CharAttrBo,HexStr(Font[CharNumber,Row]));
  746.                   end;
  747.     end;
  748.  
  749.     if Row>BytesPerChar then Row:=1;
  750.     if Row<1 then Row:=BytesPerChar;
  751.     if Col>8 then Col:=1;
  752.     if Col<1 then Col:=8;
  753.  
  754.     if DrawMode<>Normal then
  755.     begin
  756.       if DrawMode=FillAll then
  757.         Font[CharNumber,Row] := Font[CharNumber,Row] or PowerList[Col]
  758.       else Font[CharNumber,Row] := Font[CharNumber,Row] and (not PowerList[Col]);
  759.       LoadOneChar(CharNumber,Font[CharNumber]);
  760.       WriteStr(CharRow+Row,CharCol+CharCols-5,CharAttrBo,HexStr(Font[CharNumber,Row]));
  761.     end;
  762.     Filled := (Font[CharNumber,Row] and PowerList[Col]) = PowerList[Col];
  763.     if Filled then
  764.       WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiSe,'   ')
  765.     else WriteStr(CharRow+Row,CharCol+4+3*(Col-1),CharAttrHiNo,'   ');
  766.   until Key = Escape;
  767.   if Confirm('Save file before quitting',true) then SaveFile(Filename);
  768. end;
  769.  
  770.  
  771. begin
  772.   WriteLn('Font Editor 2.0                                              Written by H.Thunem');
  773.   GetDir(0,CurrentPath);
  774.   if Length(CurrentPath)>3 then
  775.     CurrentPath := CurrentPath + '\';
  776.   Filename := 'STANDARD.FNT';
  777.   if ParamCount=1 then
  778.     Filename := UpcaseStr(ParamStr(1));
  779.   if Pos('.',Filename)=0 then
  780.     Filename := Filename + '.FNT';
  781.   if ReadFontFile(Filename) then LoadUserFont
  782.   else begin
  783.     if Filename<>'STANDARD.FNT' then
  784.       WriteLn('Couldn''t find ',Filename,'. Using STANDARD.FNT instead !');
  785.     Filename := 'STANDARD.FNT';
  786.     if ReadFontFile(Filename) then LoadUserFont
  787.     else
  788.     begin
  789.       WriteLn('Couldn''t find ',Filename,'. Quitting program !!');
  790.       Halt(1);
  791.     end;
  792.   end;
  793.  
  794.   SetIntens;
  795.   SetCursor(CursorOff);
  796.   About;
  797.   MainBackground(Filename);
  798.   CharBackground;
  799.   ChartBackground;
  800.   EditCharacter;
  801.   SetBlink;
  802.   SetCursor(CursorUnderline);
  803.   ClrScr;
  804.   Fill(1,1,1,80,White+BlueBG,' ');
  805.   WriteStr(1,1,SameAttr,' Welcome back to...           The Font Editor                       by H.Thunem');
  806. end.