Program na definovanie nových znakov v ASCII tabuľke, pascal

{ DASCII.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Editor znakovej sady ASCII pre textovy rezim. Dokaze editovat     }
{ aktualne znaky, ukladat do datoveho suboru a hlavne predefinovat. }
{ Posluzi ak chcete definovat vlastne znaky ASCII pre OS.           }
{                                                                   }
{ Datum:04.02.1994                             http://www.trsek.com }
 
program defascii;
uses crt,dos,trsek;
const kvad:array[1..8] of byte=
      (1,2,4,8,16,32,64,128);
      cpasw='kesrt  ';
type bj=array[0..255,1..16] of byte;
var x,y,i:integer;
    b,znak:byte;
    maska:array[1..8,1..16] of byte;
    bajt,baj:bj;
    fr:array[1..16] of byte;
    pasw:string;
    ch:char;
    z:word;
    pv:longint;
    f:file of bj;
    cis_okna:byte;      { uchovavam cislo okna }
 
procedure writexy(x,y:integer;ch:char);
begin
 gotoxy(37-x*3,y+4);
 write(ch,ch,ch);
 kurzorzap(false);
end;
 
procedure poloz(x,y:integer);
begin
 if maska[x,y]=1 then textbackground(cyan)
                 else textbackground(blue);
 writexy(x,y,' ');
 textbackground(red);
end;
 
procedure writec(fp,fd:integer;s:string;dlz:integer);
var i,y:integer;
begin
i:=0;y:=0;
repeat
 i:=i+1;y:=y+1;
 if s[i]='^' then begin
     textcolor(fp);i:=i+1;
     write(s[i]);end
    else begin
     textcolor(fd);
     write(s[i]);end;
until (i>=length(s));
textcolor(fd);
for i:=y to dlz do write(' ');
end;
 
procedure vykresli;
begin
 gotoxy(1,1);
 farba(lightgray,black);
 write('  X=',x:2,'  Y=',y:2,'    Znak : ',znak:4,'   Jeho ascii zatial : ',chr(znak),'                             ');
 for x:=1 to 8 do
  for y:=1 to 16 do maska[x,y]:=round((bajt[znak,y] and kvad[x])/kvad[x]);
 farba(blue,yellow);
 for x:=1 to 8 do
 for y:=1 to 16 do begin
  textbackground(blue);
  gotoxy(43,y+4);write(bajt[znak,y]:3);
  poloz(x,y);
  end;
 x:=8;y:=1;
end;
 
procedure vedla;
begin
 textbackground(blue);
 window(54,5,71,20);clrscr;window(1,1,80,25);
 for x:=0 to 15 do
  for y:=0 to 15 do begin
  if not((x+y*16) in [7,8,10,13]) then begin gotoxy(55+x,y+5);write(chr(x+y*16));end;
  end;
end;
 
function pasword:string;
begin
 farba(red,yellow);
 gotoxy(18,23);
 write(' Pre ascii mensie 128 chcem heslo :         ');
 pasword:=tread(54,23,7,'       ',#0,#0);
 gotoxy(18,23);farba(green,yellow);
 write('                                            ');
end;
 
procedure make(i:integer);
var reg:registers;
begin
 if ((pasw<>cpasw) and (i>=0) and (i<=127)) then begin
     pasw:=pasword;
     if pasw<>cpasw then exit;
     end;
 reg.es:=seg(bajt[i]);
 reg.bp:=ofs(bajt[i]);
 reg.ah:=$11;
 reg.al:=$10;
 reg.bl:=0;
 reg.bh:=$10;
 reg.cx:=1;
 reg.dx:=i;
 intr($10,reg);
end;
 
procedure help;
begin
 window(11,3,71,22);
 farba(blue,yellow);
 clrscr;
  writeln;
  writeln('  Toto je produkt na zmenu znakovej sady na VGA,SVGA');
  writeln;
  writeln('        F1 - Tento help');
  writeln('        F2 - Nahraje znak do suboru z menom dascii.dat');
  writeln('        F3 - Vyberie znak zo suboru z menom dascii.dat');
  writeln('        F5 - Predefinuje znak podla predlohy');
  writeln('        F6 - Vymaze predlohu, vyplni nulami');
  writeln('        F7 - Vlozi znak do virtualneho registra');
  writeln('        F8 - Vyberie znak z virtualneho registra');
  writeln('        F9 - Vyberie znak z ROM pamete');
  writeln('        F10- Ukoncenie prace s mojim produktom');
  writeln('  Shift F2 - Nahraje celu znakovu sadu ');
  writeln('  Shift F3 - Vyberie celu znakovu sadu zo suboru');
  writeln('  Shift F5 - Predefinuje celu znakovu sadu podla predlohy');
  writeln('  Shift F6 - Vymaze vsetky predlohy');
  writeln('  Shift F9 - Vyberie z ROM pamete vsetky znaky');
  writeln('  Prikazom dascii.exe /d - predefinuje ASCII sadu z DOSu');
  writeln;
  writeln('                                         Software by TRSEK.');
 repeat until (readkey in [#27,#13]);
 window(1,1,80,24);
 farba(green,white);
 lowvideo;
 clrscr;
 vykresli;vedla;
 x:=8;y:=1;
 farba(red,yellow);
 writexy(x,y,' ');
end;
 
procedure load(ak:boolean;znak:integer);
var x,y:integer;
begin
 assign(f,'dascii.dat');
 {$I-}
 reset(f);
 {$I+}
 if ioresult=0 then begin
    if znak=257 then read(f,bajt)
       else begin
        read(f,baj);
        for x:=1 to 16 do bajt[znak,x]:=baj[znak,x];
        end;
     close(f);
     end
 else begin
      gotoxy(20,23);
      if ak then begin write(' Subor dascii.dat neexistuje v adresari.');
            repeat until (readkey in [#27,#13,#32]);
            gotoxy(20,23);farba(green,yellow);
            write('                                       ');end;
      end;
end;
 
procedure save(znak:integer);
var x,y:integer;
begin
  assign(f,'ascii.dat');
  if znak=257 then begin
                rewrite(f);
                write(f,bajt);end
     else begin
          {$I-}
          reset(f);
          {$I+}
          if ioresult=0 then read(f,baj)
            else for x:=0 to 255 do for y:=1 to 16 do baj[x,y]:=0;
          rewrite(f);
          for x:=1 to 16 do baj[znak,x]:=bajt[znak,x];
          write(f,baj);
          end;
  close(f);
end;
 
procedure ukonc;
begin
 farba(black,white);
 clrscr;
 lowvideo;
end;
 
procedure napln(znak:integer);
var i:word;
    x1:word;
   reg:registers;
   adresa: ^byte;
begin
 reg.ah:=$11;
 reg.al:=$30;
 reg.bl:=$0;
 reg.bh:=$1;
 intr($10,reg);
 
 for i:=0 to 15 do begin
  adresa := Ptr(reg.es,reg.bp+znak*16+i);
  bajt[znak,i+1]:=adresa^;
 end;
end;
 
begin
 cis_okna:=get_window(1,1,80,25);
 farba(blue,white);
 clrscr;
 writeln('                ...........    Vies co, trochu pockaj.    .........');
 for i:=0 to 255 do
  for y:=1 to 16 do bajt[i,y]:=0;
 for i:=1 to 16 do fr[i]:=0;
 pasw:='';
 if paramcount>0 then
    if paramstr(1)='/d' then begin pasw:=cpasw;
                             load(false,257);
                             for i:=0 to 255 do make(i);
                             halt(0);end;
 for x:=1 to 8 do
  for y:=1 to 16 do maska[x,y]:=0;
 farba(green,white);
 lowvideo;
 clrscr;
 textbackground(lightgray);gotoxy(1,25);
 writec(red,black,'^F^1Help ^F^2Save ^F^3Load ^F^5Zmen ^F^6Cls ^F^7In ^F^8Out ^F^9ROM ^F^1^0Exit',78);
 gotoxy(62,25);write('Software by TRSEK.');
 znak:=97;
 vykresli;vedla;
 x:=8;y:=1;
 farba(red,yellow);
 writexy(x,y,' ');
 
 repeat
  ch:=readkey;
  if ch=#13 then begin
                  maska[x,y]:=abs(maska[x,y]-1);
                  bajt[znak,y]:=(maska[x,y]*kvad[x]) or (kvad[x] xor bajt[znak,y]);
                  farba(blue,yellow);
                  gotoxy(43,y+4);write(bajt[znak,y]:3);
                  textbackground(red);
                  end;
  if ch=#0  then ch:=readkey;
  case ch of
   #59:help;
   #60:save(znak);
   #61:begin load(true,znak);vykresli;end;
   #63:make(znak);
   #64:begin for i:=1 to 16 do bajt[znak,i]:=0;vykresli;end;
   #65:for i:=1 to 16 do fr[i]:=bajt[znak,i];
   #66:begin for i:=1 to 16 do bajt[znak,i]:=fr[i];
        vykresli;end;
   #67:begin napln(znak);vykresli;end;
 
   #85:save(257);
   #86:begin load(true,257);vykresli;end;
   #88:for i:=0 to 255 do make(i);
   #89:begin for i:=0 to 4096 do bajt[i div 16,(i mod 16)+1]:=0;
       vykresli;end;
   #92:begin
    for i:=0 to 255 do napln(i);vykresli;end;
   #68:ch:=#27;
   #72:begin poloz(x,y);y:=y-1;if y<1  then y:=1; end;
   #80:begin poloz(x,y);y:=y+1;if y>16 then y:=16;end;
   #77:begin poloz(x,y);x:=x-1;if x<1  then x:=1; end;
   #75:begin poloz(x,y);x:=x+1;if x>8  then x:=8; end;
   #73:begin if(znak>0) then znak:=znak-1; vykresli;end;
   #81:begin if(znak<255) then znak:=znak+1; vykresli;end;
   end;
  farba(red,yellow);
  writexy(x,y,' ');
  gotoxy(1,1);
  farba(lightgray,black);
  write('  X=',x:2,'  Y=',y:2,'    Znak : ',znak:4,'   Jeho ascii zatial : ',chr(znak),'                             ');
  until (ch=#27);
  ukonc;
  put_window(cis_okna,1,1,80,25);
end.