Program for make new char in ASCII table, pascal source

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: Source in Pascal
dascii.pngProgram: Dascii.pas
File exe: Dascii.exe
need: Dascii.dat

An excellent program which enables you to design completely newcharacters in ASCII set. Your work results can be stored in Dascii.dat file and returned to whenever you need. One of its most interesting functions is that which can read the character from RAM memory (give it a look, some stuff from the source code can be found useful even today).
{ 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.