Die ASC Mega 2/ASC-Mega2-CD-ROM.iso/SPIELE/KAISER/FONTEDIT.PAS

Pascal/Delphi Source File | 1990-11-09 | 34.8 KB | 1,167 lines

program fontedit;
(* Oliver Redner, 12.08.
                  15.08.1990 *)
{$A-,B-,D+,E-,F-,I-,L+,N-,O-,R-,S-,V-}
{$M 16384,0,655360}

uses  crt,dos,screen;

const titelzeile         = ' FONTEDIT  *  (C) Copyright 1990  *  Oliver Redner ';
      wildcard           = '*.FNT';

type  palette_typ        = array[1..16] of byte;
      string2            = string[2];
      filename           = string[12];
      maxstring          = string[80];
      byte_array         = array[0..$8000] of byte;
      byte_array_ptr     = ^byte_array;

const normal             = 7;      (* Bildschirm-Attribute für monochrom *)
      hell               = 15;
      invers             = 7*16;

      mono_palette:        palette_typ =
                             (normal,invers,
                              invers,normal,invers,
                              invers,invers,
                              normal,normal,hell,invers,
                              invers,invers,
                              normal,hell,
                              0);
      farb_palette:        palette_typ =
                             (lightgray,blue*16+lightgray,
                              blue*16+white,lightgray,lightgray*16,
                              blue*16+yellow,blue*16+lightred,
                              red*16+yellow,red*16+lightgray,
                              red*16+white,red+lightgray*16,
                              cyan*16+yellow,cyan*16+white,
                              lightgray,blue*16+white,
                              green*16+white);
      page_value:          array[0..3] of byte = (1,2,4,8);
      max_zeile:           byte = 24;

var   att_titelzeile,
      att_backgr,
      att_feld,att_leer,
      att_voll,att_menue_l,
      att_menue_r,
      att_fsb_rahmen,
      att_fsb_normal,
      att_fsb_hell,
      att_fsb_cursor,
      att_eing_rahmen,
      att_eing_schrift,
      att_zeig,att_ja,
      att_farb,
      hoehe,breite,farben:  byte;
      datei,pfad:           pathstr;
      std_cursor:           word;
      save_screen:          crt_screen_type;
      font:                 byte_array_ptr;


{$I kextrn}

{$F+}
{$I kgraph} {$L kgraph}
{$F-}

{$F+}
procedure ega_mono;
var regs: registers;
begin
  with regs do begin
    ax:=$F; intr($10,regs);
  end;
end;   (* ega_mono *)


procedure ega_mono_hor (von_x,bis_x,y: word);
var x: word;
begin
  for x:=(von_x shr 3) to ((bis_x+7) shr 3) do
    mem[$A000:y*80+x]:=$FF;
end;   (* ega_mono_hor *)


procedure dummy_proc (a,b,c: word);
begin
end;


procedure ega_big_plot (x: byte; y: word; zeichen: byte);
var x2,i,y2: byte;
begin
  for y2:=0 to 31 do for i:=0 to 1 do
    mem[$A000:(y+y2)*80+x+i]:=font^[zeichen*64+y2*2+i];
end;   (* ega_big_plot *)
{$F-}


procedure initialisieren;
var regs: registers;
begin
  checkbreak:=false; setcbreak(false);
  if crt_mode=7 then move(mono_palette,att_titelzeile,sizeof(palette_typ))
                else begin
                  move(farb_palette,att_titelzeile,sizeof(palette_typ));
                  palette:=@palette1; ega_palette;
                end;
  pfad:=''; datei:='';
  with regs do begin
    ah:=3; bh:=0; intr($10,regs);
    std_cursor:=cx;
  end;
end;   (* initialisieren *)


procedure schreibe_titelzeile;
begin
  textattr:=att_titelzeile;
  clrscr; writeln; writeln;
  wrm(0,40,att_titelzeile,titelzeile);
end;   (* schreibe_titelzeile *)


procedure parameter_auswerten;
const unbekannt       = 'Unbekannter Parameter: ';
      falsche_groesse = 'Unbekannte Zeichengröße: ';
      falsche_farben  = 'Unbekannte Farbenzahl: ';
var   lauf,i:           byte;
      s:                maxstring;

procedure hilfe (text: maxstring);
begin
  schreibe_titelzeile;
  writeln(text); writeln;
  writeln('Aufruf: FONTEDIT [<Parameter>]'); writeln;
  writeln('          <Parameter>: /H       Diese Hilfe erscheint.'); writeln;
  writeln('                       /G8X8    Zeichensätze  8x 8 Punkte');
  writeln('                       /G16X16  Zeichensätze 16x16 Punkte');
  writeln('                       /G16X32  Zeichensätze 16x32 Punkte');
  writeln('                       /F2      Zwei Farben');
  writeln('                       /F16     16 Farben (nur EGA/VGA)');
  writeln; halt;
end;   (* hilfe *)

begin  (* parameter_auswerten *)
  hoehe:=16; breite:=16; farben:=2;
  if paramcount>0 then for lauf:=1 to paramcount do begin
    s:=paramstr(lauf); for i:=1 to length(s) do s[i]:=upcase(s[i]);
    if s[1] in ['/','-']
      then case s[2] of
        'H': hilfe ('Hilfe:');
        'G': if s='/G8X8'
               then begin breite:=8; hoehe:=8; end
               else if s='/G16X16'
                      then begin breite:=16; hoehe:=16; end
                      else if s='/G16X32'
                             then begin breite:=16; hoehe:=32; end
                             else hilfe (falsche_groesse+s);
        'F': if s='/F2'
               then farben:=2
               else if s='/F16' then farben:=16
                                else hilfe (falsche_farben+s);
        else hilfe (unbekannt+s);
      end;
  end;
end;   (* parameter_auswerten *)


procedure editieren;
const menue_l_max                      = 7;
      menue_l_lng:                       byte = menue_l_max;
      menue_r_lng                      = 9;
      menue_l:                           array[1..menue_l_max] of string[28] =
                                         (#24','#25','#26','#27'   Cursor bewegen',
                                          'Leertaste Setz/Lösch Punkt',
                                          'F1..F4    Rollen',
                                          'H,V       Hor./Vert. Spiegel',
                                          'W         Farbwahl',
                                          'F         Füllen mit Farbe',
                                          '+,-       Zeichen Drehen');
      menue_l_inv                      =  'I         Invertieren';
      menue_r:                           array[1..menue_r_lng] of string[28] =
                                         ('L      Zeichensatz laden    ',
                                          'S      Zeichensatz speichern',
                                          'U      Speichern unter ...  ',
                                          'K      Zeichen kopieren     ',
                                          'Z      Zeichen löschen      ',
                                          'A      Alles löschen        ',
                                          'RETURN Anderes Zeichen      ',
                                          'ESC    Ungeschehen          ',
                                          'Q      Quit / Beenden       ');
      max_anz                          = $100;
type  word_array                       = array[0..$4000] of word;
      word_array_ptr                   = ^word_array;
      word_ptr                         = ^word;
      control_typ                      = (li,re,auf,ab,bauf,bab,pos1,end_,key,ext);
var   feld_x,feld_y,pages,z_lng,zeichen: byte;
      z_farbe,cs_x,cs_y:                 shortint;
      font_groesse,anzahl:               word;
      aufbauen,ende,quit,saved,dummy:    boolean;
      feld:                              array[0..15,0..31] of byte;
      control:                           control_typ;
      taste:                             char;

procedure zeige_farbe;
var col: byte;
    s:   string[8];
begin
 if pages=1
   then begin
     if z_farbe=0 then s:='Löschen '
                  else s:=' Setzen ';
     wrm(max_zeile-2,40,att_backgr,s);
   end else begin
     box(hor_single_box,38,max_zeile-3,2,1,att_backgr,0);
     wr(max_zeile-2,39,z_farbe,'██');
   end;
end;   (* zeige_farbe *)


function strr (zahl: longint; stellen: byte): maxstring;
var s: maxstring;
begin
  str(zahl,s); while length(s)<stellen do s:='0'+s;
  strr:=s;
end;  (* strr *)


function hex (zahl: byte): string2;
const hexchars: array[0..$F] of char = '0123456789ABCDEF';
begin
  hex:=hexchars[(zahl and $F0) shr 4]+hexchars[zahl and $F];
end;  (* hex *)


procedure bildschirm;
const zeich_breite = 16;
      zeich_x      = (80-zeich_breite) div 2;
      zeich_y      = 2;
var   lauf:          byte;
begin  (* bildschirm *)
  if hoehe=32 then textmode(co80+font8x8);
  box(all_double_box,0,0,78,pred(max_zeile),att_backgr,att_backgr);
  wrm(0,40,att_backgr,titelzeile);
  box(all_single_box,pred(zeich_x),pred(zeich_y),zeich_breite,1,
      att_feld,att_feld);
  wr(zeich_y,zeich_x,att_feld,'Zeichen: '+strr(zeichen,3)+'/$'+hex(zeichen));
  box(all_single_box,pred(feld_x),pred(feld_y),breite,hoehe,att_feld,att_leer);
  if breite=16 then begin
    wr(pred(feld_y),39,att_feld,'┬┬'); wr(feld_y+hoehe,39,att_feld,'┴┴');
  end;
  if hoehe=16 then begin
    wr(10,pred(feld_x),att_feld,'├'); wr(11,pred(feld_x),att_feld,'├');
    wr(10,feld_x+breite,att_feld,'┤'); wr(11,feld_x+breite,att_feld,'┤');
    wr(pred(feld_y),pred(feld_x),att_feld,'├');
    wr(pred(feld_y),feld_x+breite,att_feld,'┤');
  end;
  if hoehe=32 then begin
    wr(feld_y+15,pred(feld_x),att_feld,'├'); wr(feld_y+15,feld_x+breite,att_feld,'┤');
    wr(feld_y+16,pred(feld_x),att_feld,'├'); wr(feld_y+16,feld_x+breite,att_feld,'┤');
  end;
  for lauf:=1 to menue_l_lng do wr(5+lauf,2,att_menue_l,menue_l[lauf]);
  for lauf:=1 to menue_r_lng do wrr(5+lauf,77,att_menue_r,menue_r[lauf]);
  zeige_farbe;
  aufbauen:=false;
end;   (* bildschirm *)


procedure zeig_punkt (x,y: byte);
var col: byte;
begin
  col:=feld[x,y];
  if pages=1 then if col=0 then wr(feld_y+y,feld_x+x,att_leer,'∙')
                           else wr(feld_y+y,feld_x+x,att_voll,'∙')
             else if col=0 then wr(feld_y+y,feld_x+x,white,' ')
                           else wr(feld_y+y,feld_x+x,col,'▓');
end;   (* zeig_punkt *)


procedure setz_punkt (x,y,col: byte);
begin
  feld[x,y]:=col; zeig_punkt (x,y);
end;   (* setz_punkt *)

procedure darstellen;
var   pw:           word_array_ptr;
      pb:           byte_array_ptr;
      x,y,lauf,col: byte;
      werte:        array[0..3] of longint;
      mask:         word;
begin
  pw:=ptr(seg(font^),ofs(font^)+zeichen*z_lng); pb:=byte_array_ptr(pw);
  for y:=0 to pred(hoehe) do begin
    if breite=16
      then for lauf:=0 to pred(pages) do
        werte[lauf]:=pw^[y*pages+lauf]
      else for lauf:=0 to pred(pages) do
        werte[lauf]:=pb^[y*pages+lauf];
    mask:=$80;
    for x:=0 to pred(breite) do begin
      col:=0;
      for lauf:=0 to pred(pages) do
        if (werte[lauf] and mask)>0 then inc(col,page_value[lauf]);
      if pages=1 then if col=0 then setz_punkt(x,y,0)
                               else setz_punkt(x,y,1)
                 else setz_punkt (x,y,col);
      mask:=mask shr 1; if mask=0 then mask:=$8000;
    end;
  end;
end;   (* darstellen *)


procedure font_loeschen;
begin
  fillchar(font^,font_groesse,0); zeichen:=0; saved:=true;
end;   (* font_loeschen *)


procedure lies (var control: control_typ; var taste: char; num_pad: boolean);
begin
  taste:=readkey;
  if taste=#0
    then begin
      taste:=readkey;
      case ord(taste) of
        72:  control:=auf;
        80:  control:=ab;
        75:  control:=li;
        77:  control:=re;
        73:  control:=bauf;
        81:  control:=bab;
        71:  control:=pos1;
        79:  control:=end_;
        else control:=ext;
      end;
    end else
      if num_pad
        then case taste of
               '8': control:=auf;
               '2': control:=ab;
               '4': control:=li;
               '6': control:=re;
               '9': control:=bauf;
               '3': control:=bab;
               '7': control:=pos1;
               '1': control:=end_;
               else control:=key;
             end
        else control:=key;
end;   (* lies *)


procedure cursor (sichtbar: boolean);
var regs: registers;
begin
  with regs do begin
    ah:=1;
    if sichtbar then cx:=std_cursor
                else cx:=$1000;
    intr($10,regs);
  end;
end;   (* cursor *)


function ja (text: maxstring): boolean;
var control: control_typ;
    taste:   char;
begin
  save_screen:=crt_screen^;
  wrm(max_zeile,40,att_ja,text);
  cursor (false);
  repeat
    lies (control,taste,false); taste:=upcase(taste);
  until (control=key) and (taste in ['J','N',#27]);
  cursor (true);
  ja:=taste='J';
  crt_screen^:=save_screen;
end;  (* ja *)


function gesichert: boolean;
begin
  if saved then gesichert:=true
           else gesichert:=ja(' Bearbeiteten Zeichensatz verwerfen (J/N) ? ');
end;  (* gesichert *)


procedure min(var zahl1: shortint; zahl2: shortint);
begin
  if zahl1<zahl2 then zahl1:=zahl2;
end;   (* min *)


procedure max(var zahl1: shortint; zahl2: shortint);
begin
  if zahl1>zahl2 then zahl1:=zahl2;
end;   (* max *)


procedure invertieren;
var x,y: byte;
begin
  for y:=0 to pred(hoehe) do
    for x:=0 to pred(breite) do setz_punkt (x,y,1-feld[x,y]);
end;   (* invertieren *)


procedure vertikal;
var x,y,carry: byte;
begin
  for x:=0 to pred(breite div 2) do
    for y:=0 to pred(hoehe) do begin
      carry:=feld[x,y]; feld[x,y]:=feld[pred(breite)-x,y];
      feld[pred(breite)-x,y]:=carry;
      zeig_punkt (x,y); zeig_punkt (pred(breite)-x,y);
    end;
  saved:=false;
end;   (* vertikal *)


procedure horizontal;
var x,y,carry: byte;
begin
  for y:=0 to pred(hoehe div 2) do
    for x:=0 to pred(breite) do begin
      carry:=feld[x,y]; feld[x,y]:=feld[x,pred(hoehe)-y];
      feld[x,pred(hoehe)-y]:=carry;
      zeig_punkt (x,y); zeig_punkt (x,pred(hoehe)-y);
    end;
  saved:=false;
end;   (* horizontal *)


procedure roll_li;
var x,y,carry: byte;
begin
  for y:=0 to pred(hoehe) do begin
    carry:=feld[0,y];
    for x:=0 to breite-2 do setz_punkt (x,y,feld[x+1,y]);
    setz_punkt (pred(breite),y,carry);
  end;
  saved:=false;
end;   (* roll_li *)


procedure roll_re;
var x,y,carry: byte;
begin
  for y:=0 to pred(hoehe) do begin
    carry:=feld[pred(breite),y];
    for x:=pred(breite) downto 1 do setz_punkt (x,y,feld[x-1,y]);
    setz_punkt (0,y,carry);
  end;
  saved:=false;
end;   (* roll_re *)


procedure roll_auf;
var x,y,carry: byte;
begin
  for x:=0 to pred(breite) do begin
    carry:=feld[x,0];
    for y:=0 to hoehe-2 do setz_punkt (x,y,feld[x,y+1]);
    setz_punkt (x,pred(hoehe),carry);
  end;
  saved:=false;
end;   (* roll_auf *)


procedure roll_ab;
var x,y,carry: byte;
begin
  for x:=0 to pred(breite) do begin
    carry:=feld[x,pred(hoehe)];
    for y:=pred(hoehe) downto 1 do setz_punkt (x,y,feld[x,y-1]);
    setz_punkt (x,0,carry);
  end;
  saved:=false;
end;   (* roll_ab *)


procedure drehen (richtg: boolean);
var x,xx,y,yy,carry: byte;

procedure tausch;
var xalt,yalt: byte;
begin
  xalt:=x; yalt:=y;
  if richtg then begin
    x:=yalt; y:=breite-xalt-1;
  end else begin
    x:=hoehe-yalt-1; y:=xalt;
  end;
  setz_punkt (xalt,yalt,feld[x,y]);
end;   (* tausch *)

begin  (* drehen *)
  for xx:=0 to pred(breite div 2) do
    for yy:=0 to pred(hoehe div 2) do begin
      x:=xx; y:=yy;
      carry:=feld[x,y];
      tausch; tausch; tausch;
      setz_punkt (x,y,carry);
    end;
  saved:=false;
end;   (* drehen *)


procedure zurueck;
var   pw:           word_array_ptr;
      pb:           byte_array_ptr;
      x,y,lauf,col: byte;
      werte:        array[0..3] of word;
      mask:         word;
begin
  pw:=ptr(seg(font^),ofs(font^)+zeichen*z_lng); pb:=byte_array_ptr(pw);
  for y:=0 to pred(hoehe) do begin
    for lauf:=0 to pred(pages) do werte[lauf]:=0;
    mask:=$80;
    for x:=0 to pred(breite) do begin
      for lauf:=0 to pred(pages) do
        inc(werte[lauf],ord((feld[x,y] and page_value[lauf])>0)*mask);
      mask:=mask shr 1; if mask=0 then mask:=$8000;
    end;
    if breite=16
      then for lauf:=0 to pred(pages) do
        pw^[y*pages+lauf]:=werte[lauf]
      else for lauf:=0 to pred(pages) do
        pb^[y*pages+lauf]:=werte[lauf];
  end;
end;   (* zurueck *)


procedure laden;
var f:    file;
    size: longint;

function fileselect(wildcard: filename; var path: dirstr): pathstr;
type  eintragzeiger = ^eintragrec;
      eintragrec    = record
                        name:       filename;
                        nachfolger: eintragzeiger
                      end;
const fsb_x         = 10;
      fsb_y         = 8;
      fsb_pro_zeile = 4;
      fsb_zeilen    = 10;
      fsb_eintr     = fsb_pro_zeile*fsb_zeilen;
var startzeiger:      eintragzeiger;
    fertig,abbruch,
    eintraege_vorh:   boolean;
    eintraege:        integer;

procedure eintraege_lesen;
var eintrag: searchrec;

procedure zur_liste(was: filename);
var zeiger,hilfszeiger: eintragzeiger;
begin
  if startzeiger=nil then begin
    new(startzeiger);
    zeiger:=startzeiger;
    zeiger^.nachfolger:=nil
  end
  else begin
    zeiger:=startzeiger;
    while (zeiger^.nachfolger<>nil) and (zeiger^.name<was) do
      zeiger:=zeiger^.nachfolger;
    if zeiger^.nachfolger=nil then begin
      new(zeiger^.nachfolger);
      zeiger:=zeiger^.nachfolger;
      zeiger^.nachfolger:=nil
    end
    else begin
      hilfszeiger:=zeiger^.nachfolger;
      new(zeiger^.nachfolger);
      zeiger:=zeiger^.nachfolger;
      zeiger^.nachfolger:=hilfszeiger
    end;
  end;
  zeiger^.name:=was;
  inc(eintraege);
end;   (* zur_liste *)

begin  (* eintraege_lesen *)
  eintraege:=0;
  findfirst(path+wildcard,archive,eintrag);
  while doserror=0 do begin
    zur_liste(eintrag.name);
    findnext(eintrag)
  end;
  findfirst(path+'*.*',archive+directory,eintrag);
  while doserror=0 do begin
    if ((eintrag.attr and directory)>0) and (eintrag.name<>'.') then
      zur_liste('['+eintrag.name+']');
    findnext(eintrag)
  end;
  eintraege_vorh:=startzeiger<>nil;
  if not eintraege_vorh then
    wrm(fsb_y+1,40,att_fsb_hell,'Keine Einträge vorhanden!');
end;   (* eintraege_lesen *)

procedure auswaehlen;
var wahl,oben:      integer;
    taste:          char;
    changed,cursor: boolean;
    control:        control_typ;
    x,y:            byte;

function eintrag(nr: integer): eintragzeiger;
var zeiger: eintragzeiger;
begin
  zeiger:=startzeiger;
  while nr>0 do begin
    zeiger:=zeiger^.nachfolger;
    dec(nr);
  end;
  eintrag:=zeiger
end;  (* eintrag *)

procedure ausschnitt;

procedure darstellen;
var nr:     integer;
    zeiger: eintragzeiger;
    lauf:   byte;
begin  (* darstellen *)
  for lauf:=fsb_y to fsb_y+fsb_zeilen-1 do
    wischen (lauf,fsb_x,fsb_pro_zeile*15,att_fsb_normal);
  zeiger:=eintrag(oben);
  nr:=0;
  while (nr<fsb_eintr) and (zeiger<>nil) do begin
    wr(fsb_y+(nr div fsb_pro_zeile),fsb_x+(nr mod fsb_pro_zeile)*15,
       att_fsb_normal,zeiger^.name);
    zeiger:=zeiger^.nachfolger;
    inc(nr);
  end;
end;   (* darstellen *)

begin  (* ausschnitt *)
  if (wahl<oben) then begin
    oben:=(wahl div fsb_pro_zeile)*fsb_pro_zeile;
    darstellen;
  end else
    if (wahl>=oben+fsb_eintr) then begin
      oben:=((wahl div fsb_pro_zeile)*fsb_pro_zeile)-fsb_eintr+fsb_pro_zeile;
      darstellen;
    end;
  x:=fsb_x+(wahl mod fsb_pro_zeile)*15;
  y:=fsb_y+((wahl-oben) div fsb_pro_zeile);
  setattr(y,x,14,att_fsb_cursor);
end;   (* ausschnitt *)

procedure suchen(wonach: string2);
var zeiger: eintragzeiger;
    alt:    integer;
begin
  if startzeiger=nil then exit;
  alt:=wahl;
  zeiger:=eintrag(wahl);
  repeat
    inc(wahl);
    zeiger:=zeiger^.nachfolger;
    if zeiger=nil then begin
      zeiger:=startzeiger;
      wahl:=0
    end;
  until (wahl=alt) or
        (copy(zeiger^.name,1,length(wonach))=wonach)
end;   (* suchen *)

procedure laufwerk;
begin
  if diskfree(ord(taste))<>-1 then begin
    path:=chr(ord(taste)+64)+':';
    changed:=true
  end;
end;   (* laufwerk *)

procedure gewaehlt;
var zeiger: eintragzeiger;
begin
  zeiger:=eintrag(wahl);
  if zeiger^.name[1]='[' then
    path:=path+copy(zeiger^.name,2,length(zeiger^.name)-2)+'\'
  else begin
    fileselect:=fexpand(path+zeiger^.name);
    fertig:=true
  end;
end;   (* gewaehlt *)

begin  (* auswaehlen *)
  changed:=false;
  wahl:=0;
  oben:=1;
  repeat
    if eintraege_vorh then ausschnitt;
    lies (control,taste,true);
    if eintraege_vorh then setattr(y,x,14,att_fsb_normal);
    case control of
      auf:  dec(wahl,fsb_pro_zeile);
      ab:   inc(wahl,fsb_pro_zeile);
      li:   dec(wahl);
      re:   inc(wahl);
      pos1: wahl:=0;
      end_: wahl:=eintraege;
      key:  case taste of
              'a'..'z': suchen(chr(ord(taste)-32));
              'A'..'Z': suchen('['+taste);
              '.',':':  suchen('[.');
              #1..#10:  laufwerk;
            end;
    end;
    if wahl<0 then wahl:=0;
    if wahl>=eintraege then wahl:=eintraege-1;
  until changed or (taste in [#27,#13]);
  if taste=#27 then abbruch:=true
               else if not changed then gewaehlt
end;   (* auswaehlen *)

procedure liste_loeschen;
var zeiger: eintragzeiger;
begin
  zeiger:=startzeiger;
  while zeiger<>nil do begin
    dispose(zeiger); zeiger:=zeiger^.nachfolger;
  end;
  startzeiger:=nil;
end;   (* liste_loeschen *)

begin (* fileselect *)
  fileselect:=''; fertig:=false; abbruch:=false; cursor (false);
  repeat
    path:=fexpand(path); startzeiger:=nil;
    box(all_single_box,fsb_x-2,fsb_y-4,succ(fsb_pro_zeile*15),fsb_zeilen+3,
        att_fsb_rahmen,att_fsb_normal);
    box(all_single_box,fsb_x-2,fsb_y-4,succ(fsb_pro_zeile*15),2,
        att_fsb_rahmen,att_fsb_normal);
    wr(fsb_y-1,fsb_x-2,att_fsb_rahmen,'├');
    wr(fsb_y-1,fsb_x+fsb_pro_zeile*15,att_fsb_rahmen,'┤');
    wr(fsb_y-3,fsb_x,att_fsb_normal,'Pfad: '+path+wildcard);
    wrm(fsb_y-2,fsb_x+((fsb_pro_zeile*15) div 2),att_fsb_normal,
                               'CTRL + Laufwerksbuchstabe: Laufwerk ändern');
    eintraege_lesen;
    auswaehlen;
    liste_loeschen;
  until fertig or abbruch;
  aufbauen:=true; cursor (true);
end;  (* fileselect *)


begin  (* laden *)
  zurueck;
  if not gesichert then exit;
  datei:=fileselect (wildcard,pfad);
  if (datei<>'') then begin
    assign(f,datei); reset(f,1);
    if ioresult=0 then begin
      font_loeschen; size:=filesize(f);
      if size>longint(font_groesse) then size:=font_groesse;
      blockread(f,font^,size);
      close(f);
      inoutres:=0;
    end;
  end;
end;   (* laden *)


procedure taste_druecken;
var taste: char;
begin
  taste:=readkey;
end;   (* taste_druecken *)


procedure speichern;
var anzahl,lauf: byte;
    f:           file;

function empty (z: byte): boolean;
var lauf: byte;
    p:    byte_array_ptr;
begin
  p:=ptr(seg(font^),ofs(font^)+z*z_lng);
  lauf:=0;
  while (lauf<z_lng) and (p^[lauf]=0) do inc(lauf);
  empty:=lauf=z_lng;
end;  (* empty *)

function error: boolean;
begin
  if ioresult=0
    then error:=false
    else begin
      save_screen:=crt_screen^;
      wrm(24,40,att_backgr,' Fehler beim Schreiben von '+datei+' ');
      taste_druecken;
      crt_screen^:=save_screen;
    end;
end;  (* error *)

begin  (* speichern *)
  zurueck;
  anzahl:=pred(max_anz);
  while (anzahl>0) and empty (anzahl) do dec(anzahl);
  if not empty (anzahl) then inc(anzahl);
  if anzahl>0 then begin
    lauf:=0;
    while (lauf<anzahl) and (not empty (lauf)) do inc(lauf);
    if lauf>=anzahl then inc(anzahl);
    assign(f,datei); rewrite(f,1);
    if not error then begin
      blockwrite(f,font^,anzahl*z_lng);
      close(f);
      if not error then saved:=true;
    end;
  end;
end;   (* speichern *)


procedure string_eingabe (text: maxstring; laenge: byte;
                          var buffer: maxstring; var abbruch: boolean);
const eing_y           = 12;
var   s,s2:              maxstring;
      eing_x,alt_lng,cs: byte;
      control:           control_typ;
      taste:             char;
begin
  save_screen:=crt_screen^;
  eing_x:=(78-laenge) div 2;
  box(hor_double_box,pred(eing_x),pred(eing_y),laenge,1,
      att_eing_rahmen,att_eing_schrift);
  wrm(pred(eing_y),40,att_eing_rahmen,' '+text+' ');
  s:=buffer; alt_lng:=0; cs:=length(s);
  repeat
    if length(s)<alt_lng then wischen (eing_y,eing_x,laenge,att_eing_schrift);
    wr(eing_y,eing_x,att_eing_schrift,s); gotoxy(succ(eing_x+cs),succ(eing_y));
    alt_lng:=length(s);
    lies (control,taste,false);
    case control of
      li:   if cs>0 then dec(cs);
      re:   if cs<alt_lng then inc(cs);
      pos1: cs:=0;
      end_: cs:=alt_lng;
      key:  case taste of
              #8:      if (cs>0) and (alt_lng>0) then begin
                         delete(s,cs,1); dec(cs);
                       end;
              #13,#27: ;
              else     if length(s)<laenge then begin
                         s2:=''; if cs>0 then s2:=copy(s,1,cs);
                         s2:=s2+taste;
                         if cs<alt_lng then s2:=s2+copy(s,succ(cs),alt_lng-cs);
                         s:=s2; inc(cs);
                       end;
            end;
      ext:  case ord(taste) of
              83: if (alt_lng>0) and (cs<alt_lng) then delete(s,succ(cs),1);
            end;
    end;
  until taste in [#13,#27];
  abbruch:=taste=#27; if not abbruch then buffer:=s;
  crt_screen^:=save_screen;
end;   (* string_eingabe *)


procedure speichern_unter;
var abbruch: boolean;
    dir:     dirstr;
    name:    namestr;
    ext:     extstr;
begin
  zurueck;
  string_eingabe ('Dateiname',40,datei,abbruch);
  if not abbruch then begin
    datei:=fexpand(datei); fsplit (datei,dir,name,ext);
    if ext='' then ext:='.FNT';
    datei:=dir+name+ext;
    speichern;
  end;
end;   (* speichern unter *)


function zeichen_wahl (var abbruch: boolean): byte;
var z,x,y,x_lng,y_lng,x_fak: byte;
    x_rand,y_rand:           word;
    control:                 control_typ;
    taste:                   char;
    plot:                    procedure (x: byte; y: word; zeichen: byte);
    open,shut:               procedure;
    hor:                     procedure (x1,x2,y: word);
    ver:                     procedure (x,y1,y2: word);

procedure cursor_lines;
begin
  hor (x_rand+(x*x_fak) shl 3,x_rand+pred((succ(x)*x_fak) shl 3),y_rand+y*(hoehe+2));
  hor (x_rand+(x*x_fak) shl 3,x_rand+pred((succ(x)*x_fak) shl 3),y_rand+succ(y*(hoehe+2)+hoehe));
end;   (* cursor_lines *)

begin (* zeichen_wahl *)
  if (breite=16) and (hoehe=32) and (pages=1)
    then begin
      open:=ega_mono; shut:=ega_textmode;
      hor:=ega_mono_hor; ver:=dummy_proc;
      plot:=ega_big_plot;
      x_fak:=2; x_lng:=32; x_rand:=64;
      y_lng:=8; y_rand:=39;
    end else
      if (pages=1)
        then begin
          open:=hgc_graphmode; shut:=hgc_textmode;
          hor:=hgc_horline; ver:=hgc_verline; xorput:=false; x_rand:=104;
          if (hoehe=16) and (breite=16)
            then begin
              plot:=hgc_mal; graf_satz:=pointer(font);
              x_lng:=32; y_lng:=8; x_fak:=2; y_rand:=102;
            end else
              if (hoehe=8) and (breite=8) then begin
                if crt_screen=ptr($B800,0)
                  then begin
                    open:=ega_graphmode; shut:=ega_textmode;
                    hor:=ega_horline; ver:=ega_verline;
                    plot:=ega_char; x_rand:=64; y_rand:=155;
                  end else begin
                    plot:=hgc_char; y_rand:=154;
                  end;
                text_satz:=pointer(font);
                x_lng:=64; y_lng:=4; x_fak:=1;
              end else exit;
        end else begin
          open:=ega_graphmode; shut:=ega_textmode;
          hor:=ega_horline; ver:=ega_verline; xorput:=true;
          if (hoehe=16) and (breite=16)
            then begin
              plot:=ega_mal; graf_satz:=pointer(font);
              x_lng:=32; y_lng:=8; x_fak:=2; x_rand:=64; y_rand:=103;
            end else exit;
        end;
  z:=zeichen; farbe:=15;
  open;
  for y:=0 to pred(y_lng) do
    for x:=0 to pred(x_lng) do
      plot ((x_rand shr 3)+x*x_fak,y_rand+succ(y*(hoehe+2)),x+(y*x_lng));
  ver (x_rand-2,y_rand-2,y_rand+(hoehe+2)*y_lng+1);
  ver (x_rand+breite*x_lng+1,y_rand-2,y_rand+(hoehe+2)*y_lng+1);
  hor (x_rand-2,x_rand+breite*x_lng+1,y_rand-2);
  hor (x_rand-2,x_rand+breite*x_lng+1,y_rand+(hoehe+2)*y_lng+1);
  repeat
    x:=(z mod x_lng); y:=(z div x_lng); farbe:=1;
    repeat
      cursor_lines; inc(farbe); if farbe>15 then farbe:=1;
    until keypressed;
    lies (control,taste,true);
    farbe:=0; cursor_lines;
    case control of
      li:   dec(z);
      re:   inc(z);
      auf:  dec(z,x_lng);
      ab:   inc(z,x_lng);
      pos1: z:=z-(z mod x_lng);
      end_: z:=z-(z mod x_lng)+pred(x_lng);
      bauf: z:=z mod x_lng;
      bab:  z:=(z mod x_lng)+(max_anz-x_lng);
    end;
  until taste in [#13,#27];
  shut;
  aufbauen:=true; abbruch:=taste=#27; cursor (true);
  if not abbruch then zeichen_wahl:=z
                 else zeichen_wahl:=zeichen;
end;  (* zeichen_wahl *)


procedure kopieren;
var abbruch:            boolean;
    von,bis,nach,carry: integer;
    alt:                byte;

function zeig: boolean;
const zeig_y  = 22;
      zeig_x1 = 2;
      zeig_x2 = 16;
      zeig_x3 = 50;
var   taste:    char;
      s:        maxstring;

procedure schreib (x: byte; text: maxstring; zahl: integer);
begin
  wr(zeig_y,x,att_backgr,text+'   /   ');
  if zahl=-1
    then begin
      setattr(zeig_y,x+5,3,att_zeig); setattr(zeig_y,x+9,3,att_zeig);
    end else begin
      wr(zeig_y,x+5,att_zeig,strr(zahl,3));
      wr(zeig_y,x+9,att_zeig,'$'+hex(zahl));
    end;
end;   (* schreib *)

begin (* zeig *)
  s:=' Taste drücken, um das Zeichen zu bestimmen oder ESC zum Abbrechen ';
  if aufbauen then bildschirm;
  schreib (zeig_x1,'von: ',von);
  if von<>-1 then begin
    schreib (zeig_x2,'bis: ',bis);
    if bis<>-1 then begin
      schreib (zeig_x3,'nach:',nach);
      if nach<>-1 then
        s:=' Taste drücken, um die Zeichen zu kopieren oder ESC zum Abbrechen ';
    end;
  end;
  wrm(24,40,att_backgr,s);
  taste:=readkey;
  zeig:=taste<>#27;
end;  (* zeig *)

begin  (* kopieren *)
  von:=-1; bis:=-1; nach:=-1; alt:=zeichen;
  if zeig then begin
    von:=zeichen_wahl (abbruch);
    if not abbruch then begin
      if zeig then begin
        zeichen:=von; bis:=zeichen_wahl (abbruch);
        if not abbruch then begin
          if bis<von then begin
            carry:=von; von:=bis; bis:=carry;
          end;
          if zeig then begin
            zeichen:=alt; nach:=zeichen_wahl (abbruch);
            if (not abbruch) and (zeig) then begin
              move(font^[von*z_lng],font^[nach*z_lng],succ(bis-von)*z_lng);
              saved:=false;
            end;
          end;
        end;
      end;
    end;
  end;
  zeichen:=alt; aufbauen:=true;
end;   (* kopieren *)


procedure fuellen (farbe: byte);
var x,y: byte;
begin
  if ja(' Sind Sie sicher (J/N) ? ')
    then for x:=0 to pred(breite) do for y:=0 to pred(hoehe) do
      setz_punkt (x,y,farbe);
end;   (* fuellen *)


procedure farbwahl;
const farb_breite = 32;
      farb_x      = (80-farb_breite) div 2;
      farb_hoehe  = 8;
      farb_y      = (24-farb_hoehe) div 2;
var   lauf,x,y:      byte;
      c:            char;
begin
  if farben=2
    then z_farbe:=1-z_farbe
    else begin
      save_screen:=crt_screen^; cursor (false);
      box(all_double_box,pred(farb_x),pred(farb_y),farb_breite,farb_hoehe,
          att_farb,att_farb);
      wrm(pred(farb_y),40,att_farb,' Farbauswahl ');
      wrm(farb_y+farb_hoehe,40,att_farb,
          ' Cursor: '#24','#25','#26','#27',Pos1,Ende ');
      repeat
        for lauf:=0 to 15 do begin
          if lauf=z_farbe then c:='▓' else c:='█';
          for y:=farb_y+(lauf div 8)*4 to farb_y+3+(lauf div 8)*4 do
            for x:=farb_x+(lauf mod 8)*4 to farb_x+3+(lauf mod 8)*4 do begin
              crt_screen^[y,x,0]:=c; crt_screen^[y,x,1]:=chr(lauf);
            end;
        end;
        lies (control,taste,true);
        case control of
          li:   dec(z_farbe);
          re:   inc(z_farbe);
          auf:  dec(z_farbe,8);
          ab:   inc(z_farbe,8);
          pos1: z_farbe:=z_farbe and 8;
          end_: z_farbe:=z_farbe or 7;
        end;
        if z_farbe<0 then inc(z_farbe,farben);
        if z_farbe>=farben then dec(z_farbe,farben);
      until taste in [#27,#13];
      crt_screen^:=save_screen; cursor (true);
    end;
  zeige_farbe;
end;   (* farbwahl *)


begin  (* editieren *)
  if hoehe=32 then begin
    textmode(co80+font8x8); max_zeile:=mem[0:$484];
  end;
  feld_x:=(80-breite) div 2; feld_y:=(max_zeile-hoehe) div 2;
  if farben=2
    then begin
      pages:=1; menue_l[6]:=menue_l_inv;
    end else pages:=4;
  if breite<>hoehe then dec(menue_l_lng);
  z_lng:=(breite shr 3)*hoehe*pages; font_groesse:=max_anz*z_lng;
  getmem(font,font_groesse); aufbauen:=true;
  font_loeschen; cs_x:=0; cs_y:=0; quit:=false; z_farbe:=1;
  repeat
    if aufbauen then bildschirm;
    darstellen;
    repeat
      ende:=false;
      gotoxy(succ(feld_x)+cs_x,succ(feld_y)+cs_y);
      lies (control,taste,true); taste:=upcase(taste);
      case control of
        li:   dec(cs_x);
        re:   inc(cs_x);
        auf:  dec(cs_y);
        ab:   inc(cs_y);
        pos1: begin cs_x:=0; cs_y:=0; end;
        end_: begin cs_x:=0; cs_y:=pred(hoehe); end;
        bauf: begin cs_x:=pred(breite); cs_y:=0; end;
        bab:  begin cs_x:=pred(breite); cs_y:=pred(hoehe); end;
        key:  case taste of
                #13: begin zurueck; zeichen:=zeichen_wahl (dummy); end;
                #27: ende:=true;
                ' ': begin
                       if feld[cs_x,cs_y]=z_farbe
                         then setz_punkt(cs_x,cs_y,0)
                         else setz_punkt(cs_x,cs_y,z_farbe);
                       saved:=false;
                     end;
                'A': if gesichert then font_loeschen;
                '+': if breite=hoehe then drehen (true);
                '-': if breite=hoehe then drehen (false);
                'F': fuellen (z_farbe);
                'H': horizontal;
                'I': if pages=1 then invertieren;
                'K': kopieren;
                'L': laden;
                'Q': if gesichert then quit:=true;
                'S': if datei='' then speichern_unter
                                 else speichern;
                'U': speichern_unter;
                'V': vertikal;
                'W': farbwahl;
                'Z': fuellen (0);
              end;
        ext:  case ord(taste) of
                59: roll_li;
                60: roll_re;
                61: roll_auf;
                62: roll_ab;
              end;
      end;
      min(cs_x,0); min(cs_y,0); max(cs_x,pred(breite)); max(cs_y,pred(hoehe));
    until ende or aufbauen or quit;
  until quit;
end;   (* editieren *)


begin (* fontedit *)
  initialisieren;
  parameter_auswerten;
  editieren;
  schreibe_titelzeile;
end.