unit SCREEN4;
INTERFACE
{$V-,R-,Q-}
uses crt,dos;

var SCRHDR: array[0..128,0..11] of byte;
    wsins:boolean;

procedure wcursoron(cpos:byte);
procedure wcursoroff;
function wreadkey:word;
procedure wgetevent(var event:word);
procedure wmovecursor(event:word);
function wgetpos:byte;
procedure wwrite(a:string; i,color,color2:byte);
function wgetcolor(i:word):byte;
procedure wread(var a:string;i,color,color2:byte;exitmode:boolean;
                var exitcode:word; var posio:byte);
function wstring(a:char;i:byte):string;
procedure bell;
procedure drawcursor(x,y,l,color:byte;var bcolor:byte);
procedure wsavescr;
procedure wloadscr;
procedure wscroll(direct:byte;how:byte; color:byte;x1,y1,x2,y2:byte);
                  { 0=Up }
procedure putbox(n:byte;tl:string);
procedure createmenu(x,y,x1,y1,first,color:byte;tl:string);
function _str(n:longint; cnt:word):string;

IMPLEMENTATION
uses desc;

type clip = array[0..3999] of byte;
     _pclip= ^_clip;
     _clip = record
       vol : clip;
       txm : byte;
       next: _pclip;
             end;

var cursorpos,bcolor,musor:byte;
              r:registers;
              musori:integer;
              scrn_sp:_pclip;
              clip0: clip absolute $b800:0;

{*****************************************}
{*   Процедуры доступа верхнего уровня   *}
{*****************************************}


function _str;
var io:string[16];
begin
 str(n:cnt,io);
 _str:=io;
end;


{*** Процедура генерации звонка ****}
{-----------------------------------}
procedure bell;
begin
 write(#7)
end;

{*** Рисование курсора длиной l цветом color; bcolor - текущ. цвет ***}
{---------------------------------------------------------------------}
procedure drawcursor;
var i,j:word;
begin
  i:=(x-1)*2+(y-1)*160+1;
  bcolor:=mem[$b800:i];
  for j:=0 to l-1 do mem[$b800:2*j+i]:=color;
end;

{*** Генерация строки указанных символов ***}
{-------------------------------------------}
function wstring;
var bf:string;
    j:byte;
begin
  bf:='';
  if i<255 then for j:=0 to i do bf:=bf+a;
  wstring:=bf;
end;

{*** Зажигание курсора в указанной позиции ***}
{---------------------------------------------}
procedure wcursoron;
begin
  cursorpos:=cpos;
  drawcursor(scrhdr[cpos,0],scrhdr[cpos,1],scrhdr[cpos,2],scrhdr[cpos,3],bcolor
);
end;

{*** Гашение курсора в текущей позиции ***}
{-----------------------------------------}
procedure wcursoroff;
begin
  drawcursor(scrhdr[cursorpos,0],scrhdr[cursorpos,1],scrhdr[cursorpos,2],bcolor
,musor);
end;

{*** Функция запроса кода нажатой клавиши ***}
{--------------------------------------------}
function wreadkey;
var c:char;
begin
  c:=readkey;
  if ord(c)=0 then wreadkey:=1000+ord(readkey)
              else wreadkey:=ord(c)
end;

{*** Процедура принудительного перемещения курсора ***}
{-----------------------------------------------------}
procedure wmovecursor;
begin
  wcursoroff;
  case event of
   1072 : musor:=scrhdr[cursorpos,4];
   1080 : musor:=scrhdr[cursorpos,5];
   1077 : musor:=scrhdr[cursorpos,6];
   1075 : musor:=scrhdr[cursorpos,7];
   1071 : musor:=scrhdr[cursorpos,8];
   1079 : musor:=scrhdr[cursorpos,9];
   1073 : musor:=scrhdr[cursorpos,10];
   1081 : musor:=scrhdr[cursorpos,11];
  else musor:=cursorpos;
  end;
  wcursoron(musor)
end;

{*** Процедура перемещения курсора ***}
{-------------------------------------}
procedure wgetevent;
begin
  event:=wreadkey;
  if event-1000 in [72,80,77,75,71,79,73,81]
  then wmovecursor(event);
end;

{*** Процедура запроса позиции курсора ***}
{-----------------------------------------}
function wgetpos;
begin
 wgetpos:=cursorpos
end;

{*** Процедура вывода сообщения ***}
{----------------------------------}
procedure wwrite;
begin
  if (i=cursorpos) and (color2>0) then bcolor:=color2;
  gotoxy(scrhdr[i,0],scrhdr[i,1]);
  textcolor((color mod 16)+(color and 128));
  textbackground((color and 127) div 16);
  if length(a)>scrhdr[i,2]
    then write(copy(a,1,scrhdr[i,2]))
    else write(a,wstring(' ',scrhdr[i,2]-length(a)-1))
end;

{*** Функция запроса цвета ***}
{-----------------------------}
function wgetcolor;
begin
 if i=256 then wgetcolor:=bcolor
         else wgetcolor:=mem[$b800:(scrhdr[i,0]-1)*2+(scrhdr[i,1]-1)*160+1]
end;

{*** Процедура ввода строки ***}
{------------------------------}
procedure wread;
var ff:boolean;
begin
  ff:=true;
  if length(a)+1>scrhdr[i,2] then begin exitcode:=0; exit end;
  wwrite(wstring(' ',scrhdr[i,2]),i,color,color2);
  r.ah:=1;
  r.cl:=7;
  if wsins then r.ch:=6 else r.ch:=4;
  intr($10,r);
  repeat
    wwrite(a+' ',i,color,color2);
    gotoxy(scrhdr[i,0]+posio-1,scrhdr[i,1]);
    exitcode:=wreadkey;
    if (exitcode>999) and (((exitcode<>1077)and(exitcode<>1075))or exitmode)
       and (exitcode<>1082) and (exitcode<>1083)
       and (exitcode<>1071) and (exitcode<>1079)
    then exit;
    if exitcode in [13,27] then exit;
    case exitcode of
    8      :if posio>1 then begin
              delete(a,posio-1,1);
              posio:=posio-1;
              ff:=false
            end else bell;
    1077:   if posio<=length(a) then begin
              posio:=posio+1;
              ff:=false;
            end else bell;
    1075:   if posio>1 then begin
              posio:=posio-1;
              ff:=false
            end else bell;
    1071:   begin
              posio:=1;
              ff:=false
            end;
    1079:   begin
              posio:=length(a)+1;
              ff:=false
            end;
    32..254:begin
              if ff and (posio=1) then begin
                a:='';
                ff:=false;
                posio:=1;
                wwrite(wstring(' ',scrhdr[i,2]),i,color,color2);
              end;
              if not wsins then delete(a,posio,1);
              if length(a)<scrhdr[i,2]-1 then begin
               insert(char(exitcode),a,posio);
               posio:=posio+1
              end
              else bell;
            end;
    1082:   begin
              wsins:=not wsins;
              r.ah:=1;
              r.cl:=7;
              if wsins then r.ch:=6 else r.ch:=4;
              intr($10,r);
            end;
    1083:   if posio<=length(a) then begin
              delete(a,posio,1);
              ff:=false;
             end else bell;
    end;
  until false
end;

{*** Дополнительная процедура записи окна ***}
{--------------------------------------------}
procedure wsavescr;
var pp:_pclip;
begin
  new(pp);
  pp^.vol:=clip0;
  pp^.txm:=textattr;
  pp^.next:=scrn_sp;
  scrn_sp:=pp;
end;

{*** Дополнительная процедура чтения окна ***}
{--------------------------------------------}
procedure wloadscr;
var pp:_pclip;
begin
  clip0:=scrn_sp^.vol;
  textattr:=scrn_sp^.txm;
  pp:=scrn_sp;
  scrn_sp:=scrn_sp^.next;
  dispose(pp);
end;

{*** Процедура скроллирования окна ***}
{-------------------------------------}
procedure wscroll;
begin
 with r do
 begin
   ah:=6+direct; al:=how;
   ch:=y1-1; cl:=x1-1;
   dh:=y2-1; dl:=x2-1;
   bh:=color;
   intr($10,r)
 end
end;

procedure putbox;
begin
 barwindow((scrhdr[n,0]-1),(scrhdr[n,1]-1),(scrhdr[n,0]+scrhdr[n,2]),
 (scrhdr[n,4]-n+1+scrhdr[n,1]),(textattr mod 16),(textattr div 16),
 4,1);
 topwin(tl);
end;

procedure createmenu;
var i,j,k,l:byte;
begin
 k:=y1-y-2;
 l:=first+k;
 for i:=first to l do
 begin
  scrhdr[i,0]:=x+1;
  scrhdr[i,1]:=y+(i-first)+1;
  scrhdr[i,2]:=(x1-x-1);
  scrhdr[i,3]:=color;
  scrhdr[i,4]:=i-1;
  scrhdr[i,5]:=i+1;
  for j:=6 to 11 do scrhdr[i,j]:=i;
 end;
 scrhdr[first,4]:=l;
 scrhdr[l,5]:=first;
 putbox(first,tl);
end;

{****************************************************************************}
{--------------------------I-N-I-T-I-A-L-I-Z-A-T-I-O-N-----------------------}
begin
 wsins:=true;
 scrn_sp:=nil;
end.
