{ this unit is for FreePascal .
  this unit is for all OS .
  you need only the Video unit .
  with TxtVideo, is easy work with Video unit .
  First position is X=0 and Y=0


  written by: Salvatore Licciardi
  WWW page  : web.tiscali.it/licciardi
  E-Mail    : turylicciardi@tiscali.it
  this file : web.tiscali.it/prog/txtvideo.pas
  version   : 1.1.0  2003/07/22

}

unit TxtVideo;
{$macro ON}

interface
uses Video,Math;

function  GetAbsoluteCursorPos:word;
function  GetAbsoluteCursorPosXY(x,y:word):word;
function  GetBlink:boolean;
function  GetBlinkXY(x,y:word):boolean;
function  GetTextColor:word;
function  GetTextColorXY(x,y:word):word;
function  GetBackColor:word;
function  GetBackColorXY(x,y:word):word;
function  GetChar:char;
function  GetCharXY(x,y:word):char;
function  GetString(n:word):string;
function  GetStringXY(x,y,n:word):string;
procedure ForceUpdateXY(x,y,n:word);
procedure ForceUpdate(n:word);
procedure WindowsForceUpdate(x1,y1,x2,y2:word);
procedure OutText(txt:string);
procedure OutText(txt:string; n:word);   //   blink_=0=Off ; blink_=1=On
procedure OutText(txt:string; blink_,backcolor_,textcolor_:word);
procedure OutText(txt:string; blink_,backcolor_,textcolor_,n:word);
procedure OutTextXY(x,y:word; txt:string);
procedure OutTextXY(x,y:word; txt:string; n:word);
procedure OutTextXY(x,y:word; txt:string; blink_,backcolor_,textcolor_:word);
procedure OutTextXY(x,y:word; txt:string; blink_,backcolor_,textcolor_,n:word);
procedure SetBlinkOn;
procedure SetBlinkOff;
procedure SetBlinkOnXY(x,y:word);
procedure SetBlinkOnXY(x,y,n:word);
procedure SetBlinkOffXY(x,y:word);
procedure SetBlinkOffXY(x,y,n:word);
procedure SetTextColor(color:word);
procedure SetTextColorXY(x,y,color:word);
procedure SetTextColorXY(x,y,color,n:word);
procedure SetBackColor(color:word);
procedure SetBackColorXY(x,y,color:word);
procedure SetBackColorXY(x,y,color,n:word);
procedure MoveCursor(position:integer);
procedure WindowsStr(x1,y1,x2,y2:word; str:string; blink_,backcolor_,textcolor_,n:word);
procedure WindowsStr(x1,y1,x2,y2:word; str:string; blink_,backcolor_,textcolor_:word);
procedure WindowsStr(x1,y1,x2,y2:word; str:string; n:word);
procedure WindowsStr(x1,y1,x2,y2:word; str:string);
procedure WindowsTextColor(x1,y1,x2,y2,textcolor_,n:word);
procedure WindowsTextColor(x1,y1,x2,y2,textcolor_:word);
procedure WindowsBackColor(x1,y1,x2,y2,backcolor_,n:word);
procedure WindowsBackColor(x1,y1,x2,y2,backcolor_:word);
procedure WindowsBlinkOff(x1,y1,x2,y2,n:word);
procedure WindowsBlinkOff(x1,y1,x2,y2:word);
procedure WindowsBlinkOn(x1,y1,x2,y2,n:word);
procedure WindowsBlinkOn(x1,y1,x2,y2:word);
procedure TxtBlink(color:word);             // new ver 1.10
procedure TxtBackground(color:word);        // new ver 1.10
procedure TxtColor(color:word);             // new ver 1.10
procedure TxtWrite(txt:string);             // new ver 1.10
procedure TxtClrScr;                        // new ver 1.10
procedure TxtClreol;                        // new ver 1.10

implementation

const  TxtBackGround_local:word=0;
       TxtColor_local:word=7;
       TxtBlink_local:word=0;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TxtBackground(color:word);   // ver 1.10
begin
TxtBackground_local:=color mod 16;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TxtColor(color:word);        // ver 1.10
begin
TxtColor_local:=color mod 16;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TxtBlink(color:word);        // ver 1.10
begin
TxtBlink_local:=color mod 2;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TxtWrite(txt:string);        // ver 1.10
begin
OutText(txt,TxtBlink_local,TxtBackGround_local,TxtColor_local);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{$define common:= begin
                  blink_:=min(255,blink_);
                  backcolor_:=min(255,backcolor_);
                  textcolor_:=min(255,textcolor_);
                  end}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function GetTextColorXY(x,y:word):word;
begin
Exit(hi(VideoBuf^[GetAbsoluteCursorPosXY(x,y)]) and 15);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function GetTextColor:word;
begin
Exit(hi(VideoBuf^[GetAbsoluteCursorPos]) and 15);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function GetChar:char;
begin
Exit(char(lo(VideoBuf^[GetAbsoluteCursorPos])));
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function GetCharXY(x,y:word):char;
begin
getcharXY:=char(lo(VideoBuf^[GetAbsoluteCursorPosXY(x,y)]));
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function  GetStringXY(x,y,n:word):string;      // ver 1.01
var i,here:word;
    s:string;
begin
if n=0 then Exit('');
s:='';
n:=min(n,255);
here:=GetAbsoluteCursorPosXY(x,y);
for i:=0 to n-1 do
                begin
                if here+i>=ScreenHeight*ScreenWidth then break;
                s:=s+char(lo(VideoBuf^[here+i]));
                end;
Exit(s);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutTextXY(x,y:word; txt:string);
begin
OutTextXY(x,y,txt,1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutTextXY(x,y:word; txt:string; n:word);
var pos,i,j:word;
begin
if txt='' then Exit;
if n=0 then Exit;
pos:=GetAbsoluteCursorPosXY(x,y);
for j:=1 to n do
    begin
    for i:=0 to length(txt)-1 do
        if pos+i>ScreenHeight*ScreenWidth then Exit
                                          else VideoBuf^[pos+i]:=(VideoBuf^[pos+i] and $FF00) + Ord(txt[i+1]);
    pos:=pos+length(txt);
    end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutText(txt:string);
begin
outtextXY(cursorx,cursory,txt);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutText(txt:string; n:word);
var pos,i,j:word;
begin
if txt='' then Exit;
if n=0 then Exit;
pos:=GetAbsoluteCursorPos;
for j:=1 to n do
    begin
    for i:=0 to length(txt)-1 do
        if pos+i>ScreenHeight*ScreenWidth then Exit
                                          else VideoBuf^[pos+i]:=(VideoBuf^[pos+i] and $FF00) + Ord(txt[i+1]);
    pos:=pos+length(txt);
    end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutText(txt:string; blink_,backcolor_,textcolor_:word);
begin
common;
outtext(txt);
case blink_ of
     0: setblinkoffXY(cursorx,cursory,length(txt));
     1: setblinkonXY(cursorx,cursory,length(txt));
     end;
if backcolor_ in [0..7]  then setbackcolorXY(cursorx,cursory,backcolor_,length(txt));
if textcolor_ in [0..15] then settextcolorXY(cursorx,cursory,textcolor_,length(txt));
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutText(txt:string; blink_,backcolor_,textcolor_,n:word);
begin
if txt='' then Exit;
if n=0 then Exit;
common;
OutTextXY(cursorx,cursory,txt,blink_,backcolor_,textcolor_,n);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutTextXY(x,y:word; txt:string; blink_,backcolor_,textcolor_:word);
begin
if txt='' then Exit;
common;
outtextXY(x,y,txt);
case blink_ of
     0: setblinkoffXY(x,y,length(txt));
     1: setblinkonXY(x,y,length(txt));
     end;
if backcolor_ in [0..7]  then setbackcolorXY(x,y,backcolor_,length(txt));
if textcolor_ in [0..15] then settextcolorXY(x,y,textcolor_,length(txt));
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure OutTextXY(x,y:word; txt:string; blink_,backcolor_,textcolor_,n:word);
var l:word;
begin
if txt='' then Exit;
if n=0 then Exit;
common;
l:=length(txt)*n;
case blink_ of
     0: setblinkoffXY(x,y,l);
     1: setblinkonXY(x,y,l);
     end;
if backcolor_ in [0..7]  then setbackcolorXY(x,y,backcolor_,l);
if textcolor_ in [0..15] then settextcolorXY(x,y,textcolor_,l);

OutTextXY(x,y,txt,n);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure MoveCursor(position:integer);
var pos:integer;
begin
pos:=GetAbsoluteCursorPos+position;
if pos<0 then
         begin
         cursorX:=0;
         cursorY:=0;
         end else
if pos>ScreenHeight*ScreenWidth then
         begin
         cursorX:=ScreenWidth-1;
         cursorY:=ScreenHeight-1;
         end
        else
         begin
         cursorY:=pos div ScreenWidth;
         cursorX:=pos mod ScreenWidth;
         end;
setcursorPos(cursorX,cursorY);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function  GetString(n:word):string;
begin
getstring:=GetStringXY(cursorX,cursorY,n);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetTextColorXY(x,y,color:word);
begin
SetTextColorXY(x,y,color,1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetTextColorXY(x,y,color,n:word);   // ver 1.01
var i,pos:word;
begin
if n=0 then Exit;
pos:=GetAbsoluteCursorPosXY(x,y);
for i:=0 to n-1 do
                begin
                if pos+i>=ScreenHeight*ScreenWidth then break;
                VideoBuf^[pos+i]:=((hi(VideoBuf^[pos+i]) and 240 + color)shl 8)+lo(VideoBuf^[pos+i]);
                end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function  GetBackColorXY(x,y:word):word;
begin
Exit((hi(VideoBuf^[GetAbsoluteCursorPosXY(x,y)]) shr 4) and 7);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function  GetBackColor:word;
begin
GetBackColor:=GetBackColorXY(cursorx,cursory);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBackColor(color:word);
begin
VideoBuf^[GetAbsoluteCursorPos]:=((hi(VideoBuf^[GetAbsoluteCursorPos]) and $8F or (color shl 4) ) shl 8)+lo(VideoBuf^[GetAbsoluteCursorPos]);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBackColorXY(x,y,color:word);
begin
SetBackColorXY(x,y,color,1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBackColorXY(x,y,color,n:word);          // ver 1.01
var i,pos:word;
begin
if n=0 then Exit;
pos:=GetAbsoluteCursorPosxy(x,y);
for i:=0 to n-1 do
                begin
                if pos+i>=ScreenHeight*ScreenWidth then Exit;
                VideoBuf^[pos+i]:=((hi(VideoBuf^[pos+i]) and $8F or (color shl 4) ) shl 8)+lo(VideoBuf^[pos+i]);
                end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetTextColor(color:word);
begin
SetTextColorXY(cursorx,cursory,color,1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBlinkOn;
begin
VideoBuf^[GetAbsoluteCursorPos]:=VideoBuf^[GetAbsoluteCursorPos]or(1 shl 15);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBlinkOnXY(x,y:word);
begin
SetBlinkOnXY(x,y,1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBlinkOnXY(x,y,n:word);             // ver 1.01
var i,pos:word;
begin
if n=0 then Exit;
pos:=GetAbsoluteCursorPosxy(x,y);
for i:=0 to n-1 do
                begin
                if pos+i>=ScreenHeight*ScreenWidth then Exit;
                VideoBuf^[pos+i]:=VideoBuf^[pos+i]or(1 shl 15);
                end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBlinkOff;
begin
VideoBuf^[GetAbsoluteCursorPos]:=VideoBuf^[GetAbsoluteCursorPos] and 32767;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBlinkOffXY(x,y:word);
begin
SetBlinkOffXY(x,y,1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure SetBlinkOffXY(x,y,n:word);               // ver 1.01
var pos,i:word;
begin
if n=0 then Exit;
pos:=GetAbsoluteCursorPosXY(x,y);
for i:=0 to n-1 do
                begin
                if pos+i>=ScreenHeight*ScreenWidth then Exit;
                VideoBuf^[pos+i]:=VideoBuf^[pos+i] and 32767;
                end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function  GetAbsoluteCursorPos:word;
begin
Exit(cursorX+cursorY*ScreenWidth);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function  GetAbsoluteCursorPosXY(x,y:word):word;
begin
Exit(X+Y*ScreenWidth);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function GetBlink:boolean;
begin
Exit(VideoBuf^[GetAbsoluteCursorPos] > 32767);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

function GetBlinkXY(x,y:word):boolean;
begin
if (x>=ScreenWidth)or(y>=ScreenHeight) then Exit(false);
GetBlinkXY:=VideoBuf^[GetAbsoluteCursorPosXY(x,y)] > 32767;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure ForceUpdateXY(x,y,n:word);                 // ver 1.01
var here,original,i:word;
begin
if n=0 then Exit;
n:=min(n,ScreenWidth*ScreenHeight);
here:=GetAbsoluteCursorPosXY(x,y);
for i:=0 to n-1 do
                begin
                if here+i>=ScreenHeight*ScreenWidth then Exit;
                original:=oldVideoBuf^[here+i];
                if original=65535 then original:=0
                                  else inc(original);
                oldVideoBuf^[here+i]:=original;
                end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure ForceUpdate(n:word);
begin
ForceUpdateXY(cursorx,cursory,n);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsForceUpdate(x1,y1,x2,y2:word);
begin
if (x1>x2) or (y1>y2) then Exit;
for y1:=y1 to y2 do ForceUpdateXY(x1,y1,x2-x1+1);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsStr(x1,y1,x2,y2:word; str:string; blink_,backcolor_,textcolor_:word);
begin
WindowsStr(x1,y1,x2,y2,str,blink_,backcolor_,textcolor_,65535);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsStr(x1,y1,x2,y2:word; str:string; n:word);
begin
WindowsStr(x1,y1,x2,y2,str,255,255,255,n);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsStr(x1,y1,x2,y2:word; str:string);
begin
WindowsStr(x1,y1,x2,y2,str,255,255,255,65535);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsStr(x1,y1,x2,y2:word; str:string; blink_,backcolor_,textcolor_,n:word);
var i,x,y:word;
begin
if x1>x2 then Exit;
if y1>y2 then Exit;
if str='' then Exit;
common;
x:=x1;
y:=y1;
for n:=n downto 1 do
    for i:=1 to length(str) do
        begin
        outtextxy(x,y,str[i],blink_,backcolor_,textcolor_);
        inc(x);
        if x>x2 then
                begin
                x:=x1;
                inc(y);
                if y>y2 then Exit;
                end;
        end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsTextColor(x1,y1,x2,y2,textcolor_,n:word);
var x,y:word;
begin
textcolor_:=min(textcolor_,255);
if x1>x2 then Exit;
if y1>y2 then Exit;
x:=x1;
y:=y1;
for n:=n downto 1 do
        begin
        settextcolorxy(x,y,textcolor_);
        inc(x);
        if x>x2 then
                begin
                x:=x1;
                inc(y);
                if y>y2 then Exit;
                end;
        end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsTextColor(x1,y1,x2,y2,textcolor_:word);
begin
WindowsTextColor(x1,y1,x2,y2,textcolor_,65535);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsBackColor(x1,y1,x2,y2,backcolor_,n:word);
var x,y:word;
begin
backcolor_:=min(backcolor_,255);
if x1>x2 then Exit;
if y1>y2 then Exit;
x:=x1;
y:=y1;
for n:=n downto 1 do
        begin
        setbackcolorxy(x,y,backcolor_);
        inc(x);
        if x>x2 then
                begin
                x:=x1;
                inc(y);
                if y>y2 then Exit;
                end;
        end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsBackColor(x1,y1,x2,y2,backcolor_:word);
begin
WindowsBackColor(x1,y1,x2,y2,backcolor_,65535);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsBlinkOff(x1,y1,x2,y2,n:word);
var x,y:word;
begin
if x1>x2 then Exit;
if y1>y2 then Exit;
x:=x1;
y:=y1;
for n:=n downto 1 do
        begin
        setBlinkOffxy(x,y);
        inc(x);
        if x>x2 then
                begin
                x:=x1;
                inc(y);
                if y>y2 then Exit;
                end;
        end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsBlinkOff(x1,y1,x2,y2:word);
begin
WindowsBlinkOff(x1,y1,x2,y2,65535);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsBlinkOn(x1,y1,x2,y2,n:word);
var x,y:word;
begin
if x1>x2 then Exit;
if y1>y2 then Exit;
x:=x1;
y:=y1;
for n:=n downto 1 do
        begin
        setBlinkOnxy(x,y);
        inc(x);
        if x>x2 then
                begin
                x:=x1;
                inc(y);
                if y>y2 then Exit;
                end;
        end;
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure WindowsBlinkOn(x1,y1,x2,y2:word);
begin
WindowsBlinkOn(x1,y1,x2,y2,65535);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TxtClreol;   // ver 1.10
begin
OutText(' ',TxtBlink_local,TxtBackGround_local,TxtColor_local,ScreenWidth-cursorX);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TxtClrScr;   // ver 1.10
begin
setcursorPos(0,0);
OutTextXY(0,0,' ',TxtBlink_local,TxtBackGround_local,TxtColor_local,ScreenHeight*ScreenWidth);
end;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

end.


Version:    Date:      Modify:

1.1.0     22/07/03     more functions/procedures
1.0.1     16/07/03     check range [0..ScreenHeight*ScreenWidth-1]
1.0.0     27/11/02     finished.