Обсуждение темы о псевдографике в FAQ Опции

[-TarasBer-]

Эта тема - обсуждение статьи в FAQ: Псевдографика. Рисование линий, рамок и таблиц.
- Lapp


Мне кажется, что выводить через процедуры модуля ЦРТ, храня вывод в буфере, не очень целесообразно. Намного проще было бы обратиться напрямую к видеопамяти. Преимущество будет в том, что можно будет не хранить буфер, а прямо читать из видеопамяти.

[IUnknown]

Если поправить модуль вот так, то под FPC он будет работать не только под Windows, но и под другими осями, причем обращаясь напрямую к видеопамяти (с буфером, ага, я только избавился от "любимого" CRT). При этом сохранится работоспособность программы под Турбо-Паскалем (хотя я не тестировал, просто негде, я удалил у себя ТП, но вроде все по правилам, причин не работать не вижу).

(модуль) (Показать/Скрыть)

{ drawing with pseudo-graphic characters in text mode
  by Lapp
  forum.pascalnet.ru, FAQ
  v.1.0 }
unit TxGraph;
interface
procedure TxHorLine(x1,x2,y,w: integer);
procedure TxVerLine(y1,y2,x,w: integer);
procedure TxRectangle(x1,y1,x2,y2,wr,wu,wl,wd: integer);
procedure TxDump;
implementation

{$ifdef fpc}
   uses video;
{$else}
   type
      VideoType =
      record
         ch : Char;
         attr : Byte;
      end;
   const
      ScreenWidth = 80;
      ScreenHeight = 25;
   var
      VideoBuf : array[1 .. ScreenHeight, 1 .. ScreenWidth] Of VideoType
      absolute $B800 : $0000;
{$endif}

const
  mx= 300;
  my= 200;
  TxGrEl: array [
    0..2,       {// r}
    0..2,       {// u}
    0..2,       {// l}
    0..2        {// d}
  ] of char = (
    (           {// r=0}
      (                {// u=0}
        (' ','│','║'),        {// l=0}
        ('─','┐','╖'),        {// l=1}
        ('═','╕','╗')         {// l=2}
      ),
      (                {// u=1}
        ('│','│','*'),        {// l=0}
        ('┘','┤','*'),        {// l=1}
        ('╛','╡','*')         {// l=2}
      ),
      (                {// u=2}
        ('║','*','║'),        {// l=0}
        ('╜','*','╢'),        {// l=1}
        ('╝','*','╣')         {// l=2}
      )
    ),
    (           {// r=1}
      (                {// u=0}
        ('─','┌','╓'),        {// l=0}
        ('─','┬','╥'),        {// l=1}
        ('*','*','*')         {// l=2}
      ),
      (                {// u=1}
        ('└','├','*'),        {// l=0}
        ('┴','┼','*'),        {// l=1}
        ('*','*','*')         {// l=2}
      ),
      (                {// u=2}
        ('╙','*','╟'),        {// l=0}
        ('╨','*','╫'),        {// l=1}
        ('*','*','*')         {// l=2}
      )
    ),
    (           {// r=2}
      (                {// u=0}
        ('═','╒','╔'),        {// l=0}
        ('*','*','*'),        {// l=1}
        ('═','╤','╦')         {// l=2}
      ),
      (                {// u=1}
        ('╘','╞','*'),        {// l=0}
        ('*','*','*'),        {// l=1}
        ('╧','╪','*')         {// l=2}
      ),
      (                {// u=2}
        ('╚','*','╠'),        {// l=0}
        ('*','*','*'),        {// l=1}
        ('╩','*','╬')         {// l=2}
      )
    )
  );
var
  TxGrA: array [0..mx,0..my] of byte;

procedure DrawChar(PosX, PosY : integer; Ch : Char);
begin
{$ifdef fpc}
  VideoBuf^[Pred(PosX) + Pred(PosY) * ScreenWidth] := $0700 + byte(Ch);
{$else}
  { Working with "Array ... absolute $B800:$0000;" }
  VideoBuf[PosY, PosX].Attr := 7;
  VideoBuf[PosY, PosX].Ch := Ch;
{$endif}
end;

procedure Order(var a,b: integer);
begin
  if a<=b then exit;
  a:= a xor b;
  b:= a xor b;
  a:= a xor b
end;
procedure TxHorLine(x1,x2,y,w: integer);
var
  i: integer;
begin
  Order(x1,x2);
  for i:=x1 to x2 do TxGrA[i,y]:= w;
  for i:=x1 to x2 do begin
    DrawChar(i, y, TxGrEl[TxGrA[i+1,y],TxGrA[i,y-1],TxGrA[i-1,y],TxGrA[i,y+1]]);
    {
    GoToXY(i,y);
    Write(TxGrEl[TxGrA[i+1,y],TxGrA[i,y-1],TxGrA[i-1,y],TxGrA[i,y+1]])
    }

  end
end;
procedure TxVerLine(y1,y2,x,w: integer);
var
  i: integer;
begin
  Order(y1,y2);
  for i:=y1 to y2 do TxGrA[x,i]:= w;
  for i:=y1 to y2 do begin
    DrawChar(x, i, TxGrEl[TxGrA[x+1,i],TxGrA[x,i-1],TxGrA[x-1,i],TxGrA[x,i+1]]);
    {
    GoToXY(x,i);
    Write(TxGrEl[TxGrA[x+1,i],TxGrA[x,i-1],TxGrA[x-1,i],TxGrA[x,i+1]])
    }
  end
end;
procedure TxDump;
begin
  FillChar(TxGrA,SizeOf(TxGrA),0);
  {$ifdef fpc}
  updatescreen(true);
  {$endif}
end;
procedure TxRectangle(x1,y1,x2,y2,wr,wu,wl,wd: integer);
begin
  Order(x1,x2);
  Order(y1,y2);
  TxVerLine(y1,y2,x2,wr);
  TxHorLine(x1,x2,y1,wu);
  TxVerLine(y1,y2,x1,wl);
  TxHorLine(x1,x2,y2,wd);
  {$ifdef fpc}
  updatescreen(true);
  {$endif}
end;

{$ifdef fpc}
initialization
   InitVideo;
finalization
   DoneVideo;
{$else}
begin
  TxDump
{$endif}
end.

Собственно, тестовая программа не меняется...

[Lapp]

Если поправить модуль вот так, то под FPC он будет работать не только под Windows, но и под другими осями, причем обращаясь напрямую к видеопамяти ...

Замечательно , спасибо, IUnknown. Я практически забыл о существовании юнита video, поскольку не нашел его так уж сильно полезным, когда смотрел, shame on me.. Ну и, конечно, условная компиляция rules. Добавляю этот код в FAQ.
IUnknown +1