Извините, ничего не найдено.

abcdef · 27.08.2009, 17:47

Давайте складывать сюда свои оптимизированные алгоритмы и примеры для создания графических интерфейсов, меню, и т.д.
___
Вот моя реализация собственного шрифта с минимальными потребностями в памяти и без использования png-картинок.

//Raster font 8x8 form PC BIOS.
//programming by arT (c). e-mail: [email protected]
//
//Пример создания и работы с собственным растровым шрифтом в MidletPascal
//каждый символ занимает 64 bit (два числах типа integer).
//в примере заготовлены две кодовые таблицы: оригинальная CP866 (dos) и конвертированная в CP1251 (win).
//Исходный шрифт взят из знакогенератора BIOS.
//
//Используемые подпрограммы:
//procedure text(x,y : integer; s : string); - вывод текста "s" в позиции "x,y"
//function win2utf(s : string) : string; - конвертироание из win в utf8 кодировку
//function utf2win(s : string) : string; - конвертироание из utf8 в win кодировку

var
  f : array[0..511] of integer; //битовый образ шрифта 0..255,8x8
  s : string;
  c : char;
  i,j,k,h,w : integer;
  bool : boolean;

procedure text(x,y : integer; s : string);
// вывод шрифта 8x8 из битового образа f[0..511]
var
  c,i,j,p,len : integer;
begin
  len:=length(s)-1;
  for i:=0 to len do
  begin
    p:=(ord(getChar(s,i)) and 255)*2;
    for j:=0 to 1 do 
    begin
      c:=f[p+j];
      if ((c and 2147483648)<>0) or (c<0) then plot(x,y);
      if ((c and 1073741824)<>0) then plot(x+1,y);
      if ((c and 536870912)<>0)  then plot(x+2,y);
      if ((c and 268435456)<>0)  then plot(x+3,y);
      if ((c and 134217728)<>0)  then plot(x+4,y);
      if ((c and 67108864)<>0)   then plot(x+5,y);
      if ((c and 33554432)<>0)   then plot(x+6,y);
      if ((c and 16777216)<>0)   then plot(x+7,y);
      y:=y+1;
      if ((c and 8388608)<>0)    then plot(x,y);
      if ((c and 4194304)<>0)    then plot(x+1,y);
      if ((c and 2097152)<>0)    then plot(x+2,y);
      if ((c and 1048576)<>0)    then plot(x+3,y);
      if ((c and 524288)<>0)     then plot(x+4,y);
      if ((c and 262144)<>0)     then plot(x+5,y);
      if ((c and 131072)<>0)     then plot(x+6,y);
      if ((c and 65536)<>0)      then plot(x+7,y);
      y:=y+1;
      if ((c and 32768)<>0)      then plot(x,y);
      if ((c and 16384)<>0)      then plot(x+1,y);
      if ((c and 8192)<>0)       then plot(x+2,y);
      if ((c and 4096)<>0)       then plot(x+3,y);
      if ((c and 2048)<>0)       then plot(x+4,y);
      if ((c and 1024)<>0)       then plot(x+5,y);
      if ((c and 512)<>0)        then plot(x+6,y);
      if ((c and 256)<>0)        then plot(x+7,y);
      y:=y+1;
      if ((c and 128)<>0)        then plot(x,y);
      if ((c and 64)<>0)         then plot(x+1,y);
      if ((c and 32)<>0)         then plot(x+2,y);
      if ((c and 16)<>0)         then plot(x+3,y);
      if ((c and 8)<>0)          then plot(x+4,y);
      if ((c and 4)<>0)          then plot(x+5,y);
      if ((c and 2)<>0)          then plot(x+6,y);
      if ((c and 1)<>0)          then plot(x+7,y);
      y:=y+1;
    end;
    y:=y-8;  
    x:=x+8;
  end;
end;

function win2utf(s : string) : string;
var  {rus_ansi to unicode}
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i)) and 255;
    if (c>=192) then  s:=setChar(s,chr(c+848),i);
    if (c=168)  then  s:=setChar(s,chr($0401),i); {Ё}
    if (c=184)  then  s:=setChar(s,chr($0451),i); {ё}
  end;
  win2utf := s;
end;


function utf2win(s : string) : string;
var
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i));
    if (c>255)   then  s:=setChar(s,chr(c-848),i);
    if (c=$0401) then  s:=setChar(s,chr(168),i); {Ё}
    if (c=$0451) then  s:=setChar(s,chr(184),i); {ё}
  end;
  utf2win := s;
end;

begin
  //{CP866} s:='0,0,2122425729,-1114013314,2130697215,-1008205954,1828650750,2084048896,272137470,2084048896,947665150,-19525576,272137470,-25423816,272137470,-25423816,272137470,-25423816,3958338,1113996288,3958338,1113996288,252120957,-858993544,1013343846,1008238104,1013343846,1008238104,2137227107,1667753664,417021159,-415442152,-2132739842,-119504896,34488062,1041105408,406617624,410926104,1717986918,1711302144,2145115003,454761216,1046559846,1715242620,0,2122219008,406617624,2117867775,406617624,404232192,404232216,2117867520,1576190,202899456,3170558,1613758464,49344,-1057095680,2385663,1713635328,1588350,-65536,16777086,1008205824,0,0,406600728,402659328,1717969920,0,1819082348,-26448896,406741052,108795904,13028376,812041728,946616438,-590580224,404238336,0,202911792,806882304,806882316,202911744,6700287,1013317632,1579134,404226048,0,1579056,126,0,0,1579008,101455920,1623228416,2093403862,-423199744,406329368,404258304,2093352476,812056064,2093352508,113671168,473722060,-32760320,-20922116,113671168,945864956,-960070656,-20575208,808464384,2093401724,-960070656,2093401726,101480448,1579008,1579008,1579008,1579056,101455920,403441152,32256,8257536,1613764620,405823488,2093354008,402659328,2093407966,-557811712,946652926,-960051712,-60397956,1718025216,1013366976,-1067041792,-127113626,1718417408,-27105160,1751318016,-27105160,1751183360,1013366976,-832161280,-960051458,-960051712,1008211992,404241408,504105996,-859015168,-429495176,1818682880,-262119328,1650916864,-957415682,-691616256,-957942050,-825833984,2093401798,-960070656,-60397956,1616965632,2093401798,-959546354,-60397956,1818682880,2093375544,214334464,2122209816,404241408,-960051514,-960070656,-960051514,-965986304,-960051498,-687969280,-960074696,1824966144,1717986876,404241408,-20542440,845610496,1009791024,808467456,-1067438056,201720320,1007422476,202128384,272133318,0,0,255,806882304,0,30732,2093774336,-530547610,1718017024,31942,-1060733952,470580428,-859015680,31942,-20939776,1013342456,1616965632,30412,-864285448,-530551690,1718019584,402667544,404241408,100664838,107374140,-530553236,2020402688,941103128,404241408,60670,-690563584,56422,1717986816,31942,-960070656,56422,1719427312,30412,-864285666,56438,1616965632,32448,2080832512,808516656,808852480,52428,-859015680,50886,-965986304,50902,-687969280,50796,946652672,50886,-964819204,32332,405962240,236460144,404229632,404232216,404232192,1880627214,404254720,1994129408,0,1063020,-960037376,1046922950,-20527616,-26845060,1718025216,-60397956,1718025216,-26845088,1616965632,506881638,1718026179,-27105160,1751318016,-690586568,2094454272,2093352508,113671168,-960049442,-152648192,952553182,-152648192,-429495176,1818682880,506881638,1718011392,-957415682,-691616256,-960051458,-960051712,2093401798,-960070656,-20527418,-960051712,-60397978,2086727680,2093400256,-1060733952,2119833624,404241408,-960051586,113671168,2094454486,2081437696,-960074696,1824966144,-858993460,-858980858,-960051586,101058048,-690563370,-690553344,-690563370,-690553085,-252661700,909523968,-960051466,-555813376,-262119300,1717992448,2022442558,109869056,-589900042,-690562048,2126956230,2120664576,30732,2093774336,108839036,-960070656,64614,2087123968,65126,1616965632,15468,1819082438,31942,-20939776,54908,947705344,31942,482769920,50894,-554244608,3720910,-554244608,58988,2020402688,15974,1718019584,50942,-19479040,50886,-20527616,31942,-960070656,65222,-960051712,289673540,289673540,1437226410,1437226410,-579347081,-579347081,404232216,404232216,404232440,404232216,418912504,404232216,909522678,909522486,254,909522486,16259320,404232216,922093302,909522486,909522486,909522486,16647926,909522486,922093310,0,909522686,0,418912504,0,248,404232216,404232223,0,404232447,0,255,404232216,404232223,404232216,255,0,404232447,404232216,404690975,404232216,909522487,909522486,909586495,0,4141111,909522486,922157311,0,16711927,909522486,909586487,909522486,16711935,0,922157303,909522486,419365119,0,909522687,0,16711935,404232216,255,909522486,909522495,0,404690975,0,2037791,404232216,63,909522486,909522687,909522486,419371263,404232216,404232440,0,31,404232216,-1,-1,255,-1,-252645136,-252645136,252645135,252645135,-256,0,64614,1719427312,31942,-1060733952,32346,404241408,50886,-964819332,31958,-696512456,50796,946652672,52428,-858980858,50886,2114323968,54998,-690553344,54998,-690553085,61616,1010187264,50886,-153160192,61536,2087123968,31942,516324352,56534,-153691136,32454,2120664576,1828610680,1617100288,1811971270,-20939776,1013367032,-1067041792,15971,2019769856,1215836208,808482816,-872402896,808482816,952551038,113671168,1815660230,-964819332,946629688,0,24,402653184,0,402653184,235670540,1815878656,-1882329092,-590558208,13008070,-964901376,15420,1010565120,0,0,';
  {CP1251} s:='0,0,2122425729,-1114013314,2130697215,-1008205954,1828650750,2084048896,272137470,2084048896,947665150,-19525576,272137470,-25423816,272137470,-25423816,272137470,-25423816,3958338,1113996288,3958338,1113996288,252120957,-858993544,1013343846,1008238104,1013343846,1008238104,2137227107,1667753664,417021159,-415442152,-2132739842,-119504896,34488062,1041105408,406617624,410926104,1717986918,1711302144,2145115003,454761216,1046559846,1715242620,0,2122219008,406617624,2117867775,406617624,404232192,404232216,2117867520,1576190,202899456,3170558,1613758464,49344,-1057095680,2385663,1713635328,1588350,-65536,16777086,1008205824,0,0,406600728,402659328,1717969920,0,1819082348,-26448896,406741052,108795904,13028376,812041728,946616438,-590580224,404238336,0,202911792,806882304,806882316,202911744,6700287,1013317632,1579134,404226048,0,1579056,126,0,0,1579008,101455920,1623228416,2093403862,-423199744,406329368,404258304,2093352476,812056064,2093352508,113671168,473722060,-32760320,-20922116,113671168,945864956,-960070656,-20575208,808464384,2093401724,-960070656,2093401726,101480448,1579008,1579008,1579008,1579056,101455920,403441152,32256,8257536,1613764620,405823488,2093354008,402659328,2093407966,-557811712,946652926,-960051712,-60397956,1718025216,1013366976,-1067041792,-127113626,1718417408,-27105160,1751318016,-27105160,1751183360,1013366976,-832161280,-960051458,-960051712,1008211992,404241408,504105996,-859015168,-429495176,1818682880,-262119328,1650916864,-957415682,-691616256,-957942050,-825833984,2093401798,-960070656,-60397956,1616965632,2093401798,-959546354,-60397956,1818682880,2093375544,214334464,2122209816,404241408,-960051514,-960070656,-960051514,-965986304,-960051498,-687969280,-960074696,1824966144,1717986876,404241408,-20542440,845610496,1009791024,808467456,-1067438056,201720320,1007422476,202128384,272133318,0,0,255,806882304,0,30732,2093774336,-530547610,1718017024,31942,-1060733952,470580428,-859015680,31942,-20939776,1013342456,1616965632,30412,-864285448,-530551690,1718019584,402667544,404241408,100664838,107374140,-530553236,2020402688,941103128,404241408,60670,-690563584,56422,1717986816,31942,-960070656,56422,1719427312,30412,-864285666,56438,1616965632,32448,2080832512,808516656,808852480,52428,-859015680,50886,-965986304,50902,-687969280,50796,946652672,50886,-964819204,32332,405962240,236460144,404229632,404232216,404232192,1880627214,404254720,1994129408,0,1063020,-960037376,1046922950,-20527616,-26845060,1718025216,-60397956,1718025216,-26845088,1616965632,506881638,1718026179,-27105160,1751318016,-690586568,2094454272,2093352508,113671168,-960049442,-152648192,952553182,-152648192,-429495176,1818682880,506881638,1718011392,-957415682,-691616256,-960051458,-960051712,2093401798,-960070656,-20527418,-960051712,-60397978,2086727680,2093400256,-1060733952,2119833624,404241408,-960051586,113671168,2094454486,2081437696,-960074696,1824966144,-858993460,-858980858,-960051586,101058048,-690563370,-690553344,-690563370,-690553085,-252661700,909523968,-960051466,-555813376,-262119300,1717992448,2022442558,109869056,-589900042,-690562048,2126956230,2120664576,30732,2093774336,108839036,-960070656,64614,2087123968,65126,1616965632,15468,1819082438,31942,-20939776,54908,947705344,31942,482769920,1828610680,1617100288,3720910,-554244608,58988,2020402688,15974,1718019584,50942,-19479040,50886,-20527616,31942,-960070656,65222,-960051712,289673540,289673540,1437226410,1437226410,-579347081,-579347081,404232216,404232216,404232440,404232216,418912504,404232216,909522678,909522486,254,909522486,1811971270,-20939776,922093302,909522486,909522486,909522486,16647926,909522486,922093310,0,909522686,0,418912504,0,248,404232216,1046922950,-20527616,-26845060,1718025216,-60397956,1718025216,-26845088,1616965632,506881638,1718026179,-27105160,1751318016,-690586568,2094454272,2093352508,113671168,-960049442,-152648192,952553182,-152648192,-429495176,1818682880,506881638,1718011392,-957415682,-691616256,-960051458,-960051712,2093401798,-960070656,-20527418,-960051712,-60397978,2086727680,2093400256,-1060733952,2119833624,404241408,-960051586,113671168,2094454486,2081437696,-960074696,1824966144,-858993460,-858980858,-960051586,101058048,-690563370,-690553344,-690563370,-690553085,-252661700,909523968,-960051466,-555813376,-262119300,1717992448,2022442558,109869056,-589900042,-690562048,2126956230,2120664576,30732,2093774336,108839036,-960070656,64614,2087123968,65126,1616965632,15468,1819082438,31942,-20939776,54908,947705344,31942,482769920,50894,-554244608,3720910,-554244608,58988,2020402688,15974,1718019584,50942,-19479040,50886,-20527616,31942,-960070656,65222,-960051712,64614,1719427312,31942,-1060733952,32346,404241408,50886,-964819332,31958,-696512456,50796,946652672,52428,-858980858,50886,2114323968,54998,-690553344,54998,-690553085,61616,1010187264,50886,-153160192,61536,2087123968,31942,516324352,56534,-153691136,32454,2120664576,';
  j:=0;
  for i:=0 to 511 do
  begin
    bool:=false;
    repeat
      c:=getChar(s,j);
      if (c='-') then bool:=true;
      j:=j+1;
    until (c>='0') and (c<='9');
    k:=0;
    repeat
      k:=k*10+(ord(c)-ord('0'));
      c:=getChar(s,j);
      j:=j+1;
    until (c<'0') or (c>'9');
    if bool=true then k:=-k;
    f[i]:=k;
  end;
  w:=getWidth;
  h:=getHeight;
  setColor(0,0,0);
  fillRect(0,0,w,h);
  setColor(0,255,0);
  //{test} drawText(win2utf(utf2win('АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэюя')),0,20);
  text(0,0,utf2win('PC BIOS code page'));
  setColor(0,255,255);
  text(0,8,utf2win('Привет мир!'));
  repaint;	
  repeat delay(1000); until false;
end.

abcdef · 31.08.2009, 12:50

Аналогичный алгоритм собственного шрифта размер 5x6 (русификация моя), занимающий массив integer (32 bit) всего из 256 элементов.

Образы шрифтов загружены с http://www.ticalc.org/archives/files...260/26014.html и где-то отсюда: http://www.menuetos.net/

В архиве найденные шрифты в текстовом формате и моя программа для конвертирования в массив longInt (32 bit) на TurboPascal7.1

p.s.: выкладывайте если улучшите отображение символов, заранее спасибо!

//Raster font 5x6.
//programming by arT (c). e-mail: [email protected]
//
//Пример создания и работы с собственным растровым шрифтом в MidletPascal
//каждый символ занимает 30 bit (число типа integer). Оставшиеся 2 bit'а  (0011 bin = 04 dec) + 1
//можно использовать под ширину символа, если делать не моноширинный шрифт
//
//Используемые подпрограммы:
//procedure text(x,y : integer; s : string); - вывод текста "s" в позиции "x,y"
//function win2utf(s : string) : string; - конвертироание из win в utf8 кодировку
//function utf2win(s : string) : string; - конвертироание из utf8 в win кодировку
var
  f : array[0..255] of integer; //битовый образ шрифта 0..255,5x6
  s : string;
  c : char;
  i,j,k,h,w : integer;
  bool : boolean;


procedure text(x,y : integer; s : string);
// вывод шрифта 5x6 из битового образа f[0..255]
var
  c,i,len : integer;
begin
  len:=length(s)-1;
  for i:=0 to len do
  begin
    c:=f[ord(getChar(s,i)) and 255];
    if ((c and 536870912)<>0)  then plot(x,y);
    if ((c and 268435456)<>0)  then plot(x+1,y);
    if ((c and 134217728)<>0)  then plot(x+2,y);
    if ((c and 67108864)<>0)   then plot(x+3,y);
    if ((c and 33554432)<>0)   then plot(x+4,y);
    y:=y+1;
    if ((c and 16777216)<>0)   then plot(x,y);
    if ((c and 8388608)<>0)    then plot(x+1,y);
    if ((c and 4194304)<>0)    then plot(x+2,y);
    if ((c and 2097152)<>0)    then plot(x+3,y);
    if ((c and 1048576)<>0)    then plot(x+4,y);
    y:=y+1;
    if ((c and 524288)<>0)     then plot(x,y);
    if ((c and 262144)<>0)     then plot(x+1,y);
    if ((c and 131072)<>0)     then plot(x+2,y);
    if ((c and 65536)<>0)      then plot(x+3,y);
    if ((c and 32768)<>0)      then plot(x+4,y);
    y:=y+1;
    if ((c and 16384)<>0)      then plot(x,y);
    if ((c and 8192)<>0)       then plot(x+1,y);
    if ((c and 4096)<>0)       then plot(x+2,y);
    if ((c and 2048)<>0)       then plot(x+3,y);
    if ((c and 1024)<>0)       then plot(x+4,y);
    y:=y+1;
    if ((c and 512)<>0)        then plot(x,y);
    if ((c and 256)<>0)        then plot(x+1,y);
    if ((c and 128)<>0)        then plot(x+2,y);
    if ((c and 64)<>0)         then plot(x+3,y);
    if ((c and 32)<>0)         then plot(x+4,y);
    y:=y+1;
    if ((c and 16)<>0)         then plot(x,y);
    if ((c and 8)<>0)          then plot(x+1,y);
    if ((c and 4)<>0)          then plot(x+2,y);
    if ((c and 2)<>0)          then plot(x+3,y);
    if ((c and 1)<>0)          then plot(x+4,y);
    y:=y-5;
    x:=x+5;
  end;
end;


function win2utf(s : string) : string;
var  {rus_ansi to unicode}
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i)) and 255;
    if (c>=192) then  s:=setChar(s,chr(c+848),i);
    if (c=168)  then  s:=setChar(s,chr($0401),i); {Ё}
    if (c=184)  then  s:=setChar(s,chr($0451),i); {ё}
  end;
  win2utf := s;
end;


function utf2win(s : string) : string;
var
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i));
    if (c>255)   then  s:=setChar(s,chr(c-848),i);
    if (c=$0401) then  s:=setChar(s,chr(168),i); {Ё}
    if (c=$0451) then  s:=setChar(s,chr(184),i); {ё}
  end;
  utf2win := s;
end;


begin
  s:='0,33408703,33226623,29342148,4685252,15579278,15710350,473088,33081343,0,0,4477576,9053064,0,12921670,22506965,8796552,2308290,4657604,10823690,32319818,4665796,1023,4657631,4657284,4329924,97344,294144,556032,359744,146400,1030272,0,8658952,10813440,21976020,149297604,10625344,14825920,8650752,4464900,8523912,10627072,145536,132,458752,128,2232584,4532548,12718212,12652814,12652620,10827842,14954572,4469060,14749832,6623564,4528204,4100,131204,2236546,14694400,8521864,12652548,13195790,6633802,12923212,6562054,12921164,12857612,12857608,6564166,10828106,14815374,14832268,10826058,8659214,32467538,19749458,13191756,12923144,4532614,12923210,6557772,14815364,10824006,10823812,19491806,10817866,10817668,14749966,12853516,17309828,12718220,270976,14,8519680,414348,17584776,139524,4608652,291340,4469000,13250712,17584788,4198532,4198536,17457812,4329604,555986,807572,283272,25842448,13259140,401672,401548,8790276,676492,676104,617436,664212,21635344,397580,4481284,4329604,17051920,14016,0,0,0,136,12874000,660,672,9314568,9315208,9043968,27930967,281551000,16896,15358606,4539716,15400622,11191620,149935246,17301504,17301504,21626880,21626880,25344,448,992,448512,12582912,403054732,16896,351887,70424,9064724,20992648,0,16794128,4673988,6582558,17967249,21898120,17302032,428484812,350499086,15259182,13250560,21120,900,24576,15259182,29360128,9052160,9315200,8937472,25452544,8912896,21648272,15558986,16384,2585100,17301504,9052188,21120,19542358,19542358,28193238,8397324,6633802,14954828,12923212,14950664,15018993,14954766,22723253,12660812,19487570,153705298,10826058,6629722,30370386,10828106,13191756,15018314,12923144,6562054,14815364,10817672,15390148,10817866,10824130,10827842,22730720,22730721,25442638,18413245,8665422,29440092,24835767,6625610,414348,942748,17592984,467208,207313,487948,703157,464972,613202,4807506,680596,207194,555986,676756,283272,938644,938896,139524,462980,676112,4675012,664212,676740,684164,710624,710625,801102,587453,276814,931932,784055,207050,';
  j:=0;
  for i:=0 to 255 do
  begin
    bool:=false;
    repeat
      c:=getChar(s,j);
      if (c='-') then bool:=true;
      j:=j+1;
    until (c>='0') and (c<='9');
    k:=0;
    repeat
      k:=k*10+(ord(c)-ord('0'));
      c:=getChar(s,j);
      j:=j+1;
    until (c<'0') or (c>'9');
    if bool=true then k:=-k;
    f[i]:=k;
  end;
  w:=getWidth;
  h:=getHeight;
  setColor(0,0,0);
  fillRect(0,0,w,h);
  setColor(0,255,0);
  text(0,0,utf2win('Small font 5x6 by arT(c)'));
  text(0,7,utf2win('e-mail: [email protected]'));
  setColor(0,255,255);
  text(0,13,utf2win('Привет мир!'));
  repaint;
  repeat delay(1000); until false;
end.

Phantom · 31.08.2009, 12:58

А можно пример рабочего приложение с отображением текста на полный экран таким шрифтом? А то МП не установлен, но тема интересна. Я как-то проводил тесты по отрисовке отдельных точек на канвасе и результаты были удручающими =(

abcdef · 31.08.2009, 15:31

средняя скорость трех замеров печати 10000 символов на motorola V3i
стандартный метод drawText: 11256 ms.
собственная подпрограмма text: 20840 ms.

  time:=getRelativeTimeMs;
  for i:=0 to 9999 do
  begin
    setColor(random(255),random(255),random(255));
    //drawText(chr(random(255)),random(w-7),20+random(h-25));
    text(random(w-7),20+random(h-25),chr(random(255)));
  end;
  setColor(255,255,255);
  text(0,0,utf2win(''+(getRelativeTimeMs-time)));
  repaint;

исполняемый jar файл выложил в прошлом сообщении

abcdef · 22.09.2009, 18:00

Пример эмулятор консольного вывода стандартным шрифтом телефона в граф. режиме (реализован перенос и прокрутка)

//console demo. arT(c).  e-mail: [email protected]
var
  tx,ty : integer;  //положение курсора и максимальная высота букв
  tw,th : integer;  //размеры области вывода
  tb,tc : integer;  //цвет фона и букв
  sleep : integer;  //скорость прокрутки
procedure print(s : string);
//консольный вывод, управляющие символы: chr(10)-курсор на новую строку, chr(13)-курсор в начало строки
var
  c,i,len,xx : integer;
begin
  setColor(((tc div $10000) and $FF),((tc div $100) and $FF),(tc and $FF));
  c:=getStringHeight(s);
  if c>ty then ty:=c;
  len:=length(s)-1;
  for i:=0 to len do
  begin
    c:=ord(getChar(s,i));
    if (c>=32) then xx:=tx+getStringWidth(chr(c))+1
    else if (c=10) then xx:=tw
    else if (c=13) then tx:=0;
    if (xx>=tw) then  //scroll screen
    begin
      drawImage(imageFromCanvas(0,ty,tw,th-ty),0,0);
      setColor(((tb div $10000) and $FF),((tb div $100) and $FF),(tb and $FF)); //back color
      fillRect(0,th-ty,tw,ty);
      setColor(((tc div $10000) and $FF),((tc div $100) and $FF),(tc and $FF)); //text color
      repaint;
      delay(sleep);
      ty:=getStringHeight(s);
      xx:=xx-tx;
      tx:=0;
    end;
    if (c>=32) then begin drawText(chr(c),tx,th-ty); tx:=xx; end;
  end;
  repaint;
end;


procedure init;
begin
  tw:=getWidth;
  th:=96; //getHeight;
  tx:=0;
  sleep:=200;
  tb:=0*$10000+0*$100+20;     //backRGB
  tc:=230*$10000+230*$100+120; //textRGB
  setColor(((tb div $10000) and $FF),((tb div $100) and $FF),(tb and $FF));
  fillRect(0,0,tw,th);
end;


var
  i : integer;
begin
  init;
  print('console output demo'+chr(10));
  for i:=0 to 18 do
  begin
    tc:=$10000*i*40+$100*i*40+i*40;
    print('text'+chr(13));
    delay(150);
  end;
  print(chr(10));
  print('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'+chr(10));
  print('1'+chr(10));
  print('2'+chr(10));
  print('END');
  repeat delay(100); until false;
end.

abcdef · 19.11.2009, 15:25

Эмуляция некоторых функций модуля CRT для TurboPascal.
Реализованы функции вывода текста, управление EGA цветом символов и цветом заднего фона, установка курсора и получение его координат, получение кода нажатой клавиши, ввод строк и чисел.
__
getkey предлагает набор стандартных скан-кодов клавиш, также при вызове этой подпрограммы может осуществляться прокрутка экрана по клавишим влево-вправо. При отсутствии нажатых клавиш возвращает chr(0)

________
iodos.mpsrc

//DOS - IO emulation.
//programming by arT (c). e-mail: [email protected]

unit iodos;
interface
var
  textAttr : integer;                        //установить текущий DOS-цвет
  lenLine  : integer;                        //length of line of symbols
procedure clrscr;                            //очистка экрана текущим цветом и установка курсора в начало
procedure update(p1,p2 : integer);          //обновить участок экрана c позиции p1 по p2
function  wherex : integer;                 //текущая позиция по X
function  wherey : integer;                 //текущая позиция по Y
procedure gotoxy(x,y : integer);            //установить курсор в позицию X,Y
function  getkey : char;                    //получить код клавиши, а также прокрутка экрана, иначе chr(0)
function  readlnstr : string;               //получить введенную строку
function  readlnnum : integer;              //получить введенный номер
procedure textOut(x,y : integer; s : string); //прямой вывод текста в координаты [0..w,0..h]
procedure write(s : string);                //вывод текста с текущей позиции, символы меньше chr(14) не отображаются, кроме chr(10)
procedure writeln(s : string);
function  win2utf(s : string) : string;    //конвертирование русских символов из WIN в UTF
function  utf2win(s : string) : string;    //конвертирование русских символов из UTF в WIN
function  utf2dos(s : string) : string;    //конвертирование русских символов из UTF в DOS


implementation
var
  f            : array[0..511] of integer;  //битовый образ шрифта 0..255,8x8
  r,g,b        : array[0..15] of integer;   //EGA - palette
  data         : string;                     //DOS - data text
  pos,yscroll  : integer;                    //cursor
  w,h          : integer;                    //screen size
  fill         : char;                       //clrScr default color


////////////////////////////////////////////
procedure init;
var
  s : string;
  c : char;
  i,j,k : integer;
  bool : boolean;
begin
  // standard EGA - palette
  r[0] := 0;    g[0] := 0;    b[0] := 0;
  r[1] := 0;    g[1] := 0;    b[1] := 168;
  r[2] := 0;    g[2] := 168;  b[2] := 0;
  r[3] := 84;   g[3] := 252;  b[3] := 252;
  r[4] := 168;  g[4] := 0;    b[4] := 0;
  r[5] := 168;  g[5] := 0;    b[5] := 168;
  r[6] := 168;  g[6] := 168;  b[6] := 0;
  r[7] := 168;  g[7] := 168;  b[7] := 168;
  r[8] := 84;   g[8] := 84;   b[8] := 84;
  r[9] := 84;   g[9] := 84;   b[9] := 252;
  r[10] := 84;  g[10] := 252; b[10] := 84;
  r[11] := 0;   g[11] := 168; b[11] := 168;
  r[12] := 252; g[12] := 84;  b[12] := 84;
  r[13] := 252; g[13] := 84;  b[13] := 252;
  r[14] := 252; g[14] := 252; b[14] := 84;
  r[15] := 252; g[15] := 252; b[15] := 252;
  //BIOS font 8x8
  {CP866} s:='0,0,2122425729,-1114013314,2130697215,-1008205954,1828650750,2084048896,272137470,2084048896,947665150,-19525576,272137470,-25423816,272137470,-25423816,272137470,-25423816,3958338,1113996288,3958338,1113996288,252120957,-858993544,1013343846,1008238104,1013343846,1008238104,2137227107,1667753664,417021159,-415442152,-2132739842,-119504896,34488062,1041105408,406617624,410926104,1717986918,1711302144,2145115003,454761216,1046559846,1715242620,0,2122219008,406617624,2117867775,406617624,404232192,404232216,2117867520,1576190,202899456,3170558,1613758464,49344,-1057095680,2385663,1713635328,1588350,-65536,16777086,1008205824,0,0,406600728,402659328,1717969920,0,1819082348,-26448896,406741052,108795904,13028376,812041728,946616438,-590580224,404238336,0,202911792,806882304,806882316,202911744,6700287,1013317632,1579134,404226048,0,1579056,126,0,0,1579008,101455920,1623228416,2093403862,-423199744,406329368,404258304,2093352476,812056064,2093352508,113671168,473722060,-32760320,-20922116,113671168,945864956,-960070656,-20575208,808464384,2093401724,-960070656,2093401726,101480448,1579008,1579008,1579008,1579056,101455920,403441152,32256,8257536,1613764620,405823488,2093354008,402659328,2093407966,-557811712,946652926,-960051712,-60397956,1718025216,1013366976,-1067041792,-127113626,1718417408,-27105160,1751318016,-27105160,1751183360,1013366976,-832161280,-960051458,-960051712,1008211992,404241408,504105996,-859015168,-429495176,1818682880,-262119328,1650916864,-957415682,-691616256,-957942050,-825833984,2093401798,-960070656,-60397956,1616965632,2093401798,-959546354,-60397956,1818682880,2093375544,214334464,2122209816,404241408,-960051514,-960070656,-960051514,-965986304,-960051498,-687969280,-960074696,1824966144,1717986876,404241408,-20542440,845610496,1009791024,808467456,-1067438056,201720320,1007422476,202128384,272133318,0,0,255,806882304,0,30732,2093774336,-530547610,1718017024,31942,-1060733952,470580428,-859015680,31942,-20939776,1013342456,1616965632,30412,-864285448,-530551690,1718019584,402667544,404241408,100664838,107374140,-530553236,2020402688,941103128,404241408,60670,-690563584,56422,1717986816,31942,-960070656,56422,1719427312,30412,-864285666,56438,1616965632,32448,2080832512,808516656,808852480,52428,-859015680,50886,-965986304,50902,-687969280,50796,946652672,50886,-964819204,32332,405962240,236460144,404229632,404232216,404232192,1880627214,404254720,1994129408,0,1063020,-960037376,1046922950,-20527616,-26845060,1718025216,-60397956,1718025216,-26845088,1616965632,506881638,1718026179,-27105160,1751318016,-690586568,2094454272,2093352508,113671168,-960049442,-152648192,952553182,-152648192,-429495176,1818682880,506881638,1718011392,-957415682,-691616256,-960051458,-960051712,2093401798,-960070656,-20527418,-960051712,-60397978,2086727680,2093400256,-1060733952,2119833624,404241408,-960051586,113671168,2094454486,2081437696,-960074696,1824966144,-858993460,-858980858,-960051586,101058048,-690563370,-690553344,-690563370,-690553085,-252661700,909523968,-960051466,-555813376,-262119300,1717992448,2022442558,109869056,-589900042,-690562048,2126956230,2120664576,30732,2093774336,108839036,-960070656,64614,2087123968,65126,1616965632,15468,1819082438,31942,-20939776,54908,947705344,31942,482769920,50894,-554244608,3720910,-554244608,58988,2020402688,15974,1718019584,50942,-19479040,50886,-20527616,31942,-960070656,65222,-960051712,289673540,289673540,1437226410,1437226410,-579347081,-579347081,404232216,404232216,404232440,404232216,418912504,404232216,909522678,909522486,254,909522486,16259320,404232216,922093302,909522486,909522486,909522486,16647926,909522486,922093310,0,909522686,0,418912504,0,248,404232216,404232223,0,404232447,0,255,404232216,404232223,404232216,255,0,404232447,404232216,404690975,404232216,909522487,909522486,909586495,0,4141111,909522486,922157311,0,16711927,909522486,909586487,909522486,16711935,0,922157303,909522486,419365119,0,909522687,0,16711935,404232216,255,909522486,909522495,0,404690975,0,2037791,404232216,63,909522486,909522687,909522486,419371263,404232216,404232440,0,31,404232216,-1,-1,255,-1,-252645136,-252645136,252645135,252645135,-256,0,64614,1719427312,31942,-1060733952,32346,404241408,50886,-964819332,31958,-696512456,50796,946652672,52428,-858980858,50886,2114323968,54998,-690553344,54998,-690553085,61616,1010187264,50886,-153160192,61536,2087123968,31942,516324352,56534,-153691136,32454,2120664576,1828610680,1617100288,1811971270,-20939776,1013367032,-1067041792,15971,2019769856,1215836208,808482816,-872402896,808482816,952551038,113671168,1815660230,-964819332,946629688,0,24,402653184,0,402653184,235670540,1815878656,-1882329092,-590558208,13008070,-964901376,15420,1010565120,0,0,';
  //{CP1251} s:='0,0,2122425729,-1114013314,2130697215,-1008205954,1828650750,2084048896,272137470,2084048896,947665150,-19525576,272137470,-25423816,272137470,-25423816,272137470,-25423816,3958338,1113996288,3958338,1113996288,252120957,-858993544,1013343846,1008238104,1013343846,1008238104,2137227107,1667753664,417021159,-415442152,-2132739842,-119504896,34488062,1041105408,406617624,410926104,1717986918,1711302144,2145115003,454761216,1046559846,1715242620,0,2122219008,406617624,2117867775,406617624,404232192,404232216,2117867520,1576190,202899456,3170558,1613758464,49344,-1057095680,2385663,1713635328,1588350,-65536,16777086,1008205824,0,0,406600728,402659328,1717969920,0,1819082348,-26448896,406741052,108795904,13028376,812041728,946616438,-590580224,404238336,0,202911792,806882304,806882316,202911744,6700287,1013317632,1579134,404226048,0,1579056,126,0,0,1579008,101455920,1623228416,2093403862,-423199744,406329368,404258304,2093352476,812056064,2093352508,113671168,473722060,-32760320,-20922116,113671168,945864956,-960070656,-20575208,808464384,2093401724,-960070656,2093401726,101480448,1579008,1579008,1579008,1579056,101455920,403441152,32256,8257536,1613764620,405823488,2093354008,402659328,2093407966,-557811712,946652926,-960051712,-60397956,1718025216,1013366976,-1067041792,-127113626,1718417408,-27105160,1751318016,-27105160,1751183360,1013366976,-832161280,-960051458,-960051712,1008211992,404241408,504105996,-859015168,-429495176,1818682880,-262119328,1650916864,-957415682,-691616256,-957942050,-825833984,2093401798,-960070656,-60397956,1616965632,2093401798,-959546354,-60397956,1818682880,2093375544,214334464,2122209816,404241408,-960051514,-960070656,-960051514,-965986304,-960051498,-687969280,-960074696,1824966144,1717986876,404241408,-20542440,845610496,1009791024,808467456,-1067438056,201720320,1007422476,202128384,272133318,0,0,255,806882304,0,30732,2093774336,-530547610,1718017024,31942,-1060733952,470580428,-859015680,31942,-20939776,1013342456,1616965632,30412,-864285448,-530551690,1718019584,402667544,404241408,100664838,107374140,-530553236,2020402688,941103128,404241408,60670,-690563584,56422,1717986816,31942,-960070656,56422,1719427312,30412,-864285666,56438,1616965632,32448,2080832512,808516656,808852480,52428,-859015680,50886,-965986304,50902,-687969280,50796,946652672,50886,-964819204,32332,405962240,236460144,404229632,404232216,404232192,1880627214,404254720,1994129408,0,1063020,-960037376,1046922950,-20527616,-26845060,1718025216,-60397956,1718025216,-26845088,1616965632,506881638,1718026179,-27105160,1751318016,-690586568,2094454272,2093352508,113671168,-960049442,-152648192,952553182,-152648192,-429495176,1818682880,506881638,1718011392,-957415682,-691616256,-960051458,-960051712,2093401798,-960070656,-20527418,-960051712,-60397978,2086727680,2093400256,-1060733952,2119833624,404241408,-960051586,113671168,2094454486,2081437696,-960074696,1824966144,-858993460,-858980858,-960051586,101058048,-690563370,-690553344,-690563370,-690553085,-252661700,909523968,-960051466,-555813376,-262119300,1717992448,2022442558,109869056,-589900042,-690562048,2126956230,2120664576,30732,2093774336,108839036,-960070656,64614,2087123968,65126,1616965632,15468,1819082438,31942,-20939776,54908,947705344,31942,482769920,1828610680,1617100288,3720910,-554244608,58988,2020402688,15974,1718019584,50942,-19479040,50886,-20527616,31942,-960070656,65222,-960051712,289673540,289673540,1437226410,1437226410,-579347081,-579347081,404232216,404232216,404232440,404232216,418912504,404232216,909522678,909522486,254,909522486,1811971270,-20939776,922093302,909522486,909522486,909522486,16647926,909522486,922093310,0,909522686,0,418912504,0,248,404232216,1046922950,-20527616,-26845060,1718025216,-60397956,1718025216,-26845088,1616965632,506881638,1718026179,-27105160,1751318016,-690586568,2094454272,2093352508,113671168,-960049442,-152648192,952553182,-152648192,-429495176,1818682880,506881638,1718011392,-957415682,-691616256,-960051458,-960051712,2093401798,-960070656,-20527418,-960051712,-60397978,2086727680,2093400256,-1060733952,2119833624,404241408,-960051586,113671168,2094454486,2081437696,-960074696,1824966144,-858993460,-858980858,-960051586,101058048,-690563370,-690553344,-690563370,-690553085,-252661700,909523968,-960051466,-555813376,-262119300,1717992448,2022442558,109869056,-589900042,-690562048,2126956230,2120664576,30732,2093774336,108839036,-960070656,64614,2087123968,65126,1616965632,15468,1819082438,31942,-20939776,54908,947705344,31942,482769920,50894,-554244608,3720910,-554244608,58988,2020402688,15974,1718019584,50942,-19479040,50886,-20527616,31942,-960070656,65222,-960051712,64614,1719427312,31942,-1060733952,32346,404241408,50886,-964819332,31958,-696512456,50796,946652672,52428,-858980858,50886,2114323968,54998,-690553344,54998,-690553085,61616,1010187264,50886,-153160192,61536,2087123968,31942,516324352,56534,-153691136,32454,2120664576,';
  j:=0;
  for i:=0 to 511 do
  begin
    bool:=false;
    repeat
      c:=getChar(s,j);
      if (c='-') then bool:=true;
      j:=j+1;
    until (c>='0') and (c<='9');
    k:=0;
    repeat
      k:=k*10+(ord(c)-ord('0'));
      c:=getChar(s,j);
      j:=j+1;
    until (c<'0') or (c>'9');
    if bool=true then k:=-k;
    f[i]:=k;
  end;
end;


procedure textOut(x,y : integer; s : string);
// вывод шрифта 8x8 из битового образа f[0..511]
var
  c,i,j,p,len : integer;
begin
  len:=length(s)-1;
  for i:=0 to len do
  begin
    p:=(ord(getChar(s,i)) and 255)*2;
    for j:=0 to 1 do 
    begin
      c:=f[p+j];
      if ((c and 2147483648)<>0) or (c<0) then plot(x,y);
      if ((c and 1073741824)<>0) then plot(x+1,y);
      if ((c and 536870912)<>0)  then plot(x+2,y);
      if ((c and 268435456)<>0)  then plot(x+3,y);
      if ((c and 134217728)<>0)  then plot(x+4,y);
      if ((c and 67108864)<>0)   then plot(x+5,y);
      if ((c and 33554432)<>0)   then plot(x+6,y);
      if ((c and 16777216)<>0)   then plot(x+7,y);
      y:=y+1;
      if ((c and 8388608)<>0)    then plot(x,y);
      if ((c and 4194304)<>0)    then plot(x+1,y);
      if ((c and 2097152)<>0)    then plot(x+2,y);
      if ((c and 1048576)<>0)    then plot(x+3,y);
      if ((c and 524288)<>0)     then plot(x+4,y);
      if ((c and 262144)<>0)     then plot(x+5,y);
      if ((c and 131072)<>0)     then plot(x+6,y);
      if ((c and 65536)<>0)      then plot(x+7,y);
      y:=y+1;
      if ((c and 32768)<>0)      then plot(x,y);
      if ((c and 16384)<>0)      then plot(x+1,y);
      if ((c and 8192)<>0)       then plot(x+2,y);
      if ((c and 4096)<>0)       then plot(x+3,y);
      if ((c and 2048)<>0)       then plot(x+4,y);
      if ((c and 1024)<>0)       then plot(x+5,y);
      if ((c and 512)<>0)        then plot(x+6,y);
      if ((c and 256)<>0)        then plot(x+7,y);
      y:=y+1;
      if ((c and 128)<>0)        then plot(x,y);
      if ((c and 64)<>0)         then plot(x+1,y);
      if ((c and 32)<>0)         then plot(x+2,y);
      if ((c and 16)<>0)         then plot(x+3,y);
      if ((c and 8)<>0)          then plot(x+4,y);
      if ((c and 4)<>0)          then plot(x+5,y);
      if ((c and 2)<>0)          then plot(x+6,y);
      if ((c and 1)<>0)          then plot(x+7,y);
      y:=y+1;
    end;
    y:=y-8;  
    x:=x+8;
  end;
end;


procedure update(p1,p2 : integer);
//обновить участок экрана c позиции p1 по p2
var
  x,y,b0,b1,b2,old,c1,c2 : integer;
begin
  x:=(p1 mod lenLine)*8;
  y:=((p1 div lenLine)-yscroll)*8;
  while (p1<p2) do
  begin
    if (y>=0) and (y+8<=h) then
    begin
      b0:=ord(getChar(data,p1));
      b1:=(b0 and $00FF);
      b2:=(b0 and $FF00);
      if (b2<>old) then
      begin
        c1:=(b2 div $0100) and $0F;
        c2:=(b2 div $1000) and $0F;
        old:=b2;
      end;
      setColor(r[c2],g[c2],b[c2]);
      fillRect(x,y,8,8);
      setColor(r[c1],g[c1],b[c1]);
      textOut(x,y,chr(b1));
    end;
    x:=x+8;
    if (x+8>w) then
    begin
      x:=0;
      y:=y+8;
    end;
    p1:=p1+1;
  end;
  //очистить остаток экрана
  c2:=((ord(fill) and $FF00) div $1000) and $0F;
  setColor(r[c2],g[c2],b[c2]);
  b0:=length(data);
  x:=(b0 mod lenLine)*8;
  y:=((b0 div lenLine)-yscroll)*8;  
  fillRect(x,y,w-x,8);
  fillRect(0,y+8,w,h);
  repaint;
end;


procedure write(s : string);
//вывод текста с текущей позиции, символы меньше chr(14) не отображаются, кроме chr(10)
var
  pos2,i,len,b : integer;
  c : char;
begin
  pos2:=pos;
  if length(data)<pos then
  begin
    pos:=length(data);
    while (length(data)<pos2) do data:=data+fill;
  end;
  len:=length(s)-1;
  for i:=0 to len do
  begin
    b:=ord(getChar(s,i));
    if (b>13) then
    begin
      c:=chr((textAttr*$100) + (b and $FF));
      if pos2>=length(data) then data:=data+c;
        else data:=setChar(data,c,pos2);
      pos2:=pos2+1;
    end
    else if (b=10) then
    begin
      //c:=chr((textAttr*$100) + 32);
      repeat
        if pos2>=length(data) then data:=data+fill;
        {  else data:=setChar(data,c,pos2);}
        pos2:=pos2+1;
      until (pos2 mod lenLine=0);
    end;
  end;
  update(pos,pos2);
  pos:=pos2;
end;


procedure writeln(s : string);
begin
  write(s+chr(10));
end;


function win2utf(s : string) : string;
var  {rus_ansi to unicode}
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i)) and 255;
    if (c>=192) then  s:=setChar(s,chr(c+848),i);
    if (c=168)  then  s:=setChar(s,chr($0401),i); {Ё}
    if (c=184)  then  s:=setChar(s,chr($0451),i); {ё}
  end;
  win2utf := s;
end;


function utf2win(s : string) : string;
var
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i));
    if (c>255)   then  s:=setChar(s,chr(c-848),i);
    if (c=$0401) then  s:=setChar(s,chr(168),i); {Ё}
    if (c=$0451) then  s:=setChar(s,chr(184),i); {ё}
  end;
  utf2win := s;
end;

function utf2dos(s : string) : string;
var
  i,c : integer;
begin
  for i:=length(s)-1 downto 0 do
  begin
    c:=ord(getChar(s,i));
    if c>255 then
    begin
      if c=$0401 then s:=setChar(s,chr(240),i)
      else if c=$0451 then s:=setChar(s,chr(184),i)
      else
      begin
        c:=c-848;
        if (c>=192) then
        begin
          if (c>=224) then
          begin
            if (c>=240) then s:=setChar(s,chr(c-16),i);
              else s:=setChar(s,chr(c-64),i);
          end
            else s:=setChar(s,chr(c-64),i);
        end;
      end;
    end;
  end;
  utf2dos := s;
end;


function win2dos(c : char) : char;
begin   {перекодировка из ANSI в ASCII кодировку}
  if (c>=chr(192)) then
  begin
    if (c>=chr(224)) then
    begin
      if (c>=chr(240)) then win2dos:=chr(ord(c)-240+224)
        else win2dos:=chr(ord(c)-224+160)
    end
      else win2dos:=chr(ord(c)-192+128)
  end
  else if c=chr(168) then win2dos:=chr(240)
  else if c=chr(184) then win2dos:=chr(241)
  else win2dos:=c;
end;



////////////////////////////////////////////
function getkey : char;
//получить код клавиши, а также прокрутка экрана, иначе chr(0)
var
  k,k2,keyn,keyp,lasttime : integer;
  s : string;
  c : char;
begin
  c:=chr(0);
  s:=' ';
  keyn:=KE_NONE;
  lasttime:=getRelativeTimeMs;
  repeat
    k:=getKeyPressed;
    if k<>KE_NONE then
    begin
      if (k<>keyn) then
      begin
        if (k=KE_KEY1)       then s:='1,.:;"''!?+-*/\|^=<>(){}[]_`@#$%&~'     //Chars...
        else if (k=KE_KEY2)  then s:='2abcабвгABCАБВГ'                       //Key2...
        else if (k=KE_KEY3)  then s:='3defдежзDEFДЕЖЗ'                       //Key3...
        else if (k=KE_KEY4)  then s:='4ghiийклGHIИЙКЛ'                       //Key4...
        else if (k=KE_KEY5)  then s:='5jklмнопJKLМНОП'                       //Key5...
        else if (k=KE_KEY6)  then s:='6mnoрстуMNOРСТУ'                       //Key6...
        else if (k=KE_KEY7)  then s:='7pqrsфхцчPQRSФХЦЧ'                     //Key7...
        else if (k=KE_KEY8)  then s:='8tuvшщыьъTUVШЩЫЬЪ'                     //Key8...
        else if (k=KE_KEY9)  then s:='9wxyzэюяWXYZЭЮЯ'                       //Key9...
        else if (k=KE_KEY0)  then s:='0 '                                    //Key0 / Space
        else if (k=KE_STAR)  then s:='*'+chr(72)+chr(80)+chr(77)+chr(75)     //Cursor
        else if (k=KE_POUND) then s:='#'+chr(8)+chr(13)+chr(27);             //BackSpace / Enter / Esc
        else
        begin  //иначе допольнительные клавиши, но не цифровые
          k2:=keyToAction(k);
          if k2=GA_UP    then begin s:=chr(72); end;
          if k2=GA_DOWN  then begin s:=chr(80); end;
          if k2=GA_LEFT  then begin s:=chr(75); if yscroll>0 then begin yscroll:=yscroll-(h div 8)+1; update(0,length(data)); end; end;
          if k2=GA_RIGHT then begin s:=chr(77); if yscroll<length(data) div lenLine then begin yscroll:=yscroll+(h div 8)-1; update(0,length(data)); end; end;
          if k2=GA_FIRE  then begin s:=chr(13); end;
          if k2=GA_GAMEA then begin end;
          if k2=GA_GAMEB then begin end;
          if k2=GA_GAMEC then begin end;
          if k2=GA_GAMED then begin end;
        end;
        s:=utf2dos(s);
        keyp:=-1;
        keyn:=k;
      end;
      keyp:=keyp+1;
      if (keyp>=length(s)) then keyp:=0;
      c:=getChar(copy(s,keyp,keyp+1),0);
      setColor(0,0,0);
      fillRect(w-8,h-8,8,8);
      setColor(255,255,255);
      textOut(w-8,h-8,c);        //отобразим где-нить текущий выбранный код клавиши
      repaint;
      lasttime:=getRelativeTimeMs;
      repeat until (getKeyPressed=KE_NONE) or (((getRelativeTimeMs-lasttime)>300) or (getRelativeTimeMs<lasttime));
      delay(20);
    end;
  until ((getRelativeTimeMs-lasttime)>400) or (getRelativeTimeMs<lasttime) or (keyn=KE_NONE);
  getkey:=c;
end;


function getstr(start_,end_ : char) : string;
//ввод диапазона символов с chr(start_) по chr(end_). Enter - завершить ввод
var
  l : integer;
  s : string;
  c : char;
begin
  l:=0;
  s:='';
  write('>');
  repeat c:=getkey; until c=chr(0);
  repeat
    if (c<>chr(0)) then
    begin
      if (c>=start_) and (c<=end_) then
      begin
        l:=l+1;
        s:=s+c;
        pos:=pos-1;    //back 1 char
        write(c+'>');  //rewrite screen
      end
      else if (c=chr(8)) and (l>0) then
      begin
        l:=l-1;
        s:=copy(s,0,l);
        pos:=pos-2;    //back 2 chars
        write('> ');   //rewrite screen
        pos:=pos-1;
      end;
    end;
    c:=getkey;
  until (c=chr(13));
  getStr:=s;
end;


function readlnstr : string;
//получить введенную строку
begin
  readlnstr:=getStr(chr(32),chr(255));
end;


function readlnnum : integer;
//получить введенный номер
begin
  readlnnum:=stringToInteger(getStr('0','9'));
end;


////////////////////////////////////////////
procedure clrscr;
//очистка экрана текущим цветом и установка курсора в начало
var
  i : integer;
begin
  pos:=0;
  yscroll:=0;
  data:='';
  fill:=chr((textAttr*$100) + 32);
  i:=(textAttr div $10) and $0F;
  setColor(r[i],g[i],b[i]);
  fillRect(0,0,w,h);
  repaint;
end;


function wherex : integer;
//текущая позиция по X
begin
  wherex:=(pos mod lenLine)+1;
end;


function wherey : integer;
//текущая позиция по Y
begin
  wherey:=(pos div lenLine)+1;
end;


procedure gotoxy(xx,yy : integer);
//установить курсор в позицию X,Y
begin
  pos:=((yy-1)*lenLine)+(xx-1);
end;


initialization
  init;
  w:=getWidth;
  h:=getHeight;
  lenLine:=w div 8;
  textAttr:=$07;
  clrScr;
end.

___________
demo.mpsrc

uses IOdos;
var
  n : integer;
  key : char;
  s : string;
begin
  for n:=0 to 24 do write('ironwoodcutter_bk.ru '+n+' ');
  writeln('ironwoodcutter_bk.ru 25');
  writeln('ironwoodcutter_bk.ru 26');
  writeln('ironwoodcutter_bk.ru 27');
  writeln('ironwoodcutter_bk.ru 28');
  writeln('ironwoodcutter_bk.ru 29');
  writeln('ironwoodcutter_bk.ru 30');
  gotoxy(1,100);
  writeln('--------');
  gotoxy(1,1);
  repeat
    textAttr:=random(8)*16+(random(8)+8);
    key:=getkey;
    write(key);
    delay(100);
  until key=chr(13);
  textAttr:=$1E;
  clrScr;
  write('*');
  gotoxy(2,4);
  writeln('cursor:'+wherex+','+wherey);
  s:=readlnstr;
  write('['+s+']'+chr(10)+chr(10));
  textAttr:=$1F;
  n:=readlnnum;
  write('['+n+']'+chr(10)+'END.');
  delay(2000);
end.

cherepets · 20.11.2009, 18:28

abcdef, круто!
доделать бы срт и граф сделать, так этой штуке цены б не было)))

abcdef · 24.11.2009, 16:17

Доработал кода функций модуля CRT,
а вот адаптация pascal программ работы с файлами (только для чтения)

type
  text = record
    f : resource;
    eof : boolean;
  end;
var
  IOres : integer;

procedure assign(f : text;  name : string);
begin
  f.f:=openResource('/'+name);
  f.eof:=false;
end;

procedure reset(f : text);
begin
  if (resourceAvailable(f.f)) then IOres:=0
    else IOres:=1;
end;

procedure close(f : text);
begin
  closeResource(f.f);
end;

function IOresult : integer;
begin
  IOresult:=IOres;
  IOres:=0;
end;

function eof(r : text) : boolean;
begin
  eof:=r.eof;
end;

function system_read(f : text) : char;
var
  b : integer;
begin
  b:=readByte(f.f) and 255;
  if b=0 then f.eof:=true;
  system_read:=chr(b);
end;

{========}
var
  f : text;
  c : char;
begin
  assign(f,fname);
  reset(f);
  if IOresult=0 then
  begin
    while not eof(f) do
    begin
      c:=system_read(f);
      write(c);
      ...
    end;
    close(f);
  end;
end;