*/
Got something to write about? Check out our Article Builder.
*/

View \VISCHAT.PAS

Full Source Code To Vision Bbs System

Submitted By: WEBMASTER
Rating: (Not rated) (Rate It)


{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }

unit chatstuf;        (* Chat Mode and F2 Keys *)

procedure verticalchat; (gotospecial:boolean);
var k:char;
    StartedTime:Word;
    cnt,displaywid:integer;
    quit,carrierloss,fromkbd:boolean;
    baudstr,commstr:mstr;
    c1,c2,c3,c4,c5,c6,c7,c8,backup:integer;


    xsys     :byte;
    ysys     :byte;
    xusr     :byte;
    yusr     :byte;
    curcolor :byte;
    ec       :byte;
    initi    :boolean;
    linebufs :string[80];
    linebufu :string[80];

procedure init;
begin
  xsys     :=1;
  ysys     :=14;
  xusr     :=1;
  yusr     :=4;
  curcolor :=1;
  ec       :=1;
  initi    :=true;
  linebufs :='';
  linebufu :='';
  inuse:=2;
end;


procedure sendxy (x,y:byte);
begin
 write(#27+'[',y,';',x,'H');

end;


Procedure clearscre;
 var i:byte;
 begin
 for I:=4 to 22 do
  begin
   sendxy(1,i);
   write(#27'[K');
   end;
 end;


Procedure setc;
begin
   if fromkbd then ec:=urec.statcolor else ec:=urec.inputcolor;
   if curcolor<>ec then begin
   curcolor:=ec;
  end;
end;

 procedure midline;
 var i:byte;
 begin
   sendxy(2,13);
   write('?????????????????????????????????????????????????????????????????????????????');
   sendxy(trunc((21-length(configset.sysopnam))/2),1);
   write (^R'? '^S+configset.sysopnam+^R' ?');
   sendxy(trunc((24-length(urec.handle))/2)+52,1);
   write (^R'? '^S+urec.handle+^R' ?');
   For i:=4 to 25 Do Begin
   Sendxy(i,40);
   Write('?');
 end;

Procedure cle (malig:byte);
var i,x    :byte;

begin
if malig=0 then
begin
  for i:=1 to 39 do Begin
   for x:=4 to 25 do
 begin
        sendxy(i,x);
        write(' ');
 end;
 sendxy(1,4);
 malig:=0;
end;

if malig=1 then
begin
 for i:=41 to 79 do begin
  for x:=4 to 25 do
 begin
  sendxy(i,x);
  write(#27,' ');
 end;
 sendxy(41,4);
 malig:=0;
end;



end;

  procedure wordwrapit(yeanea:byte);
  var cnt       :byte;
      wl        :integer;
      ww        :lstr;
      cutarea   :byte;
      done      :boolean;
  begin
   done:=false;
   cutarea:=0;
   ww:='';
   cnt:=39;
   if yeanea=0 then
     begin
      If Pos(' ',LineBufs)<=0 then Begin
        Writeln;
        LineBufs:='';
        Xsys:=1;
        Inc(Ysys);
        Exit;
      End;
    repeat
      if not done and (copy(linebufs,cnt,1)=' ') then cutarea:=cnt;
      if (cutarea>0) and not done then
        begin
        ww:=copy(linebufs,cnt+1,255);
         ansicolor(urec.statcolor);
         sendxy(cutarea,ysys);
         write(#27'[K');
         inc(ysys);
         xsys:=1;
         sendxy(xsys,ysys);
         write(copy(linebufs,cutarea+1,80-cutarea));
         xsys:=length(copy(linebufs,cutarea+1,80-cutarea))+1;
         sendxy(xsys,ysys);
         dec(ysys);
         done:=true
        end;
      dec(cnt);
     until cnt=1;
    linebufs:=ww;
   end;

   if yeanea=1 then
   begin
    If Pos(' ',LineBufu)<=0 then Begin
       Writeln;
       Inc(Yusr);
       Xusr:=0;
       LineBufu:='';
       Exit;
    End;
   done:=false;
   cutarea:=0;
   ww:='';
   cnt:=39;
    repeat
      if not done and (copy(linebufu,cnt,1)=' ') then cutarea:=cnt;
      if (cutarea>0) and not done then
        begin
        ww:=copy(linebufu,cnt+1,255);
         ansicolor(urec.inputcolor);
         sendxy(cutarea,yusr);
         write(#27'[K');
         inc(yusr);
         xusr:=1;
         sendxy(xusr,yusr);
         write(copy(linebufu,cutarea+1,39-cutarea));
         xusr:=length(copy(linebufu,cutarea+1,39-cutarea))+1;
         sendxy(xusr,yusr);
         dec(yusr);
         done:=true
        end;
      dec(cnt);
     until cnt=1;
    linebufu:=ww;
   end;

end;


 Procedure locate;
 begin
   if fromkbd then
 begin

         if (xsys=40) and (ysys<24) then
        begin
         wordwrapit(0);
         inc(ysys);
        end;
        if ((ysys=24) and (xsys=40)) or (ysys>24) then
        begin
        cle(0);
        ysys:=4;
        xsys:=1;
        sendxy(xsys,ysys);
        ansicolor(urec.statcolor);
        write(linebufs);
        sendxy(80-length(linebufs)+1,ysys);
        wordwrapit(0);
        inc(ysys);
        sendxy(xsys,ysys);
 end;

  sendxy(xsys,ysys);
  inc(xsys);
 end;
   if not fromkbd then
 begin
   if (xusr=80) and (yusr<24) then
  begin
   wordwrapit(1);
   inc(yusr);
  end;
if ((yusr=24) and (xusr=80)) or (yusr>24) then
 begin
   cle(1);
   yusr:=4;
   xusr:=41;
   sendxy(xusr,yusr);
   ansicolor(urec.inputcolor);
   write(linebufu);
   sendxy(80-length(linebufu)+1,yusr);
   wordwrapit(1);
   inc(yusr);
   sendxy(xusr,yusr);
 end;

   sendxy(xusr,yusr);
   inc(xusr);
 end;
end;

  procedure instruct;
  var i:integer;
  begin
    initi:=false;
    sendxy(1,4);
  end;

  Procedure ChangeVars;
      Begin
       backup:=c1;
       c1:=c2; c2:=c3; c3:=c4; c4:=c5; c5:=c6; c6:=c7; c7:=c8; c8:=backup;
       ansicolor(c1);
      End;

    Procedure GetCrazyVars;
      Begin
       If CrazyChat Then Begin
       c1:=configset.kkk1; c2:=configset.kkk2; c3:=configset.kkk3;
       c4:=configset.kkk4; c5:=configset.kkk5; c6:=configset.kkk6;
       c7:=configset.kkk7; c8:=configset.kkk8;
      End Else Begin
       c1:=urec.inputcolor;
       End;
      End;


procedure typedchar (k:char);

   begin
   ChangeVars;
   locate;
   begin;
   if fromkbd then begin If Crazychat then ansicolor(c1) else ansicolor(urec.promptcolor); linebufs:=linebufs+K;
   end;
   if not fromkbd then begin If Crazychat then ansicolor(c1) else ansicolor(urec.inputcolor); linebufu:=linebufu+K;
   end;
    write(k)
   end;
  end;


begin
  carrierloss:=false;
  chatmode:=false;
  writeln (^B^M);
  if wanted in urec.config then begin
    specialmsg ('(No longer wanted)');
    urec.config:=urec.config-[wanted];
    writeurec;
  end;
  if eightycols in urec.config then displaywid:=80 else displaywid:=40;
  if gotospecial then begin
    specialseries;
    exit
  end;
  clearbreak;
  nobreak:=true;
  writeln (^M^M,configset.entercha,^M^R);
  StartedTime:=TimeLeft;
  instruct;
  if not initi then
begin
   whatkindofchat;
   if crazychat then GetCrazyVars;
   init;
   clearscre;
   midline;
end;

  quit:=false;

  repeat
    linecount:=0;
    if (not carrierloss) and (not carrier) then begin
      carrierloss:=true;
      gotoxy(1,4);
      writeln (^M'Warning: There is no carrier present.'^M)

    end;
    repeat until keyhit or (carrier and (numchars>0));
    fromkbd:=keyhit;
    ingetstr:=true;

    read (directin,k);
    if k=#127 then k:=#8;
    if requestchat
      then if requestcom
        then
          begin
            quit:=specialcommand;
            if not quit then instruct;
            clearbreak;
            nobreak:=true;
          end
        else
          begin
            unsplit;
            writeln (^M^M,configset.exitcha,^M^R);
            SetTimeLeft(StartedTime);
            bottomline;
            clearscre;
            quit:=true
          end;
    case ord(k) of
      8:begin
      if (xsys>1) and fromkbd then
       begin
          modeminlock:=true;
          if xsys>1 then dec(xsys);
          sendxy(xsys,ysys);
          write (' ');
          sendxy(xsys,ysys);
          if length(linebufs)>0 then linebufs:=copy(linebufs,1,length(linebufs)-1);
          modeminlock:=false;
        end;
      if (xusr>1) and not fromkbd then
       begin
          modeminlock:=true;
          if xusr>1 then dec(xusr);
          sendxy(xusr+40,yusr);
          write (' ');
          sendxy(xsys,ysys);
          if length(linebufu)>0 then linebufu:=copy(linebufu,1,length(linebufu)-1);
          modeminlock:=false;
        end;
     end;
      0:;
      13:begin
           writeln;
           bottomline;
          if fromkbd then begin
           xsys:=1;
           inc(ysys);
           if (ysys>=24) then
           begin
           cle(0);
           ysys:=4;
           xsys:=1;
           sendxy(xsys,ysys);
           ansicolor(urec.statcolor);
           write(linebufs);
           ysys:=15;
           xsys:=1;
           end;
           sendxy(xsys,ysys);
           linebufs:='';
           end;

          if not fromkbd then begin
           xusr:=1;
           inc(yusr);
           if (yusr=24) then
              begin
                 cle(1);
                  yusr:=4;
                  xusr:=41;
                   ansicolor(urec.inputcolor);
                  sendxy(xusr,yusr);
                  write(linebufu);
                  yusr:=5;
                  sendxy(xusr,yusr);
              end;
            sendxy(xusr,yusr);
          linebufu:='';
          end;
         end;
      32..255:typedchar (k);
      1..31:if fromkbd and carrier then sendchar(k);
    end
  until quit;
  clearbreak
end;

begin
end.

corner
© 1996-2008 CommunityHeaven LLC. All rights reserved. Reproduction in whole or in part, in any form or medium without express written permission is prohibited.
Violators of this policy may be subject to legal action. Please read our Terms Of Use and Privacy Statement for more information.
North American business development: Nicolai Wadstrom. Publisher: Lars Hagelin.