Версия для печати темы

{ 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.