program message_program;{v3.3}
{$M 8192,0,0}

{should be working version. with only 1 message per 15secs receive message}

{
display different text colour for each user
delete the temp files on exit
when disconnected, you cant tell if its connected. the program acts as normal
display how many users are connected in the main menu
maybe a help page in the room
}

uses
   crt,dos;

const
   ID_LEN    = 13;
   MSG_LEN   = 50;
   MAX_USERS = 10;
   MSG_MAX   = {150}100;
   PATH      = 'c:\windows\temp\message';

   quit     : boolean = false;
   connect1 : boolean = true;
   change   : boolean = false;
   savemin  : integer = -1;
   cursor_col : byte = 14;

   ftp      : string = ''; {these two are for choosing operating system}
   comspec  : string = '';

   ESC = #27;
   CR  = #13;
   SP  = #32;
   TAB = #9;
   BS  = #8;
   SPC = ' ';


type
   listRec =
   RECORD
      txtcol   : byte;
      sentence : string[MSG_LEN+ID_LEN+2];
   END;

   nameRec =
   RECORD
      id : string[ID_LEN];
   END;

   nametype    = file of nameRec;
   listType    = array[1..MSG_MAX] of listRec;
   FnameType   = file of nameRec;
   idArrayType = array[1..MAX_USERS] of string[ID_LEN];


procedure writeto
(
    txt1   : string;
    x,y    : byte;
    colour : byte
);

begin
   textcolor(colour);
   gotoxy(x,y);
   write(txt1);
end;


procedure writexy
(
    txt1   : string;
    row    : byte;
    colour : byte
);

begin
   writeto(txt1,(80 - length(txt1) + 1) div 2,row,colour);
end;


function conv
(
    number : longint
): string;

var
   tmpstr : string[10];

begin
   str(number,tmpstr);
   conv := tmpstr;
end;


procedure clear;

begin
   textcolor(black);
   clrscr;
end;


procedure pause
(
var ch : char
);

begin
   ch := readkey;

   if keypressed then
      ch := readkey;
end;


procedure press_space
(
   row : byte
);

var
   key : char;

begin
   writexy('Press SPACE to continue',row,13);
   repeat
      pause(key);
   until key = SP;
end;


function LeadingZero(w : Word) : String;
var
  s : String;
begin
  Str(w:0,s);
  if Length(s) = 1 then
    s := '0' + s;
  LeadingZero := s;
end;


function uppercase
(
    txt1 : string
) : string;

var
   a : byte;

begin
   for a := 1 to length(txt1) do
      txt1[a] := upcase(txt1[a]);
   uppercase := txt1;
end;


procedure errTest
(
    type1 : boolean
);

begin
   if IOresult <> 0 then
   begin
      if type1 then
      begin
         writeto('              ',17,24,0);
         writeto('Error',17,24,15);
      end;
   end;
end;


procedure check_keys
(
    choices : string;
var key : char
);

var
   i  : byte;
   ok : boolean;

begin
   ok := false;
   repeat
      pause(key);
      key := upcase(key);

      for i := 1 to length(choices) do
         if choices[i] = key then
            ok := true;
   until ok;
end;


function choice : boolean;

var
   hold : char;

begin
   check_keys('CR',hold);

   case upcase(hold) of
      'C' : choice := false;
      'R' : choice := true;
   end;
end;


procedure run
(
    comspec,cmdline : string
);

{  when using xcopy instead of cmd, you can't use > nul and > tmp.
   Only use COMSPEC when exec a command from windows 95/98 and also the
   Xcopy command without > nul }

begin
   gotoxy(30,17);

   swapvectors;
   exec(comspec,cmdline);
   swapvectors;

{   if DosExitCode <> 0) or (doserror <> 0) then
      error := true;}
end;


procedure readto
(
var txt1    : string;
    x,y     : byte;
    col,max : byte
);

var
   count : byte;
   ch    : char;
   done  : boolean;

begin
   done := false;
   txt1 := '';
   count := 1;
   repeat
      pause(ch);
      case ch of
         BS :
         if count > 1 then
         begin
            textcolor(cursor_col);
            write(BS,SPC,BS);
            dec(count);
            delete(txt1,count,1);
         end;
         SP..#127,#156 :
         if count <= max then
         begin
            writeto(ch,x+count-1,y,col);
            inc(count);
            txt1 := txt1 + ch;
         end;
         ESC :
         begin
            quit := true;
            exit;
         end;
         TAB :
         begin
            count := 1;
            gotoxy(x,y);
            textcolor(cursor_col);
            clreol;
            txt1 := '';
         end;
         CR : done := true;
      end;
      if (txt1 = '') and done then {prevents return on its own}
         done := false;
   until done;
end;


function file_exists(filename : string) : boolean;

var
   F : file;

begin
   file_exists := false;

   assign(F,filename);
   {$I-} reset(F); {$I+}

   if IOResult = 0 then
   begin
      file_exists := true;
      close(F);
   end;
end;


procedure del_msg_script;

var
   F : text;

begin
   assign(F,PATH+'\script.txt');
   {$I-} rewrite(F); {$I+}
   errTest(false);

   writeln(F,'verbose');
   writeln(F,'user fraserking computer');
   writeln(F,'del message1.txt');
   writeln(F,'del message2.txt');
   writeln(F,'quit');

   close(F);
   run(comspec,'/c '+ftp+' -n -s:'+PATH+'\script.txt ftp.tripod.com >nul');
end;


procedure send_names_script;

var
   F : text;

begin
   assign(F,PATH+'\script.txt');
   {$I-} rewrite(F); {$I+}
   errTest(false);

   writeln(F,'verbose');
   writeln(F,'user fraserking computer');
   writeln(F,'send '+PATH+'\name.dat name.dat');
   writeln(F,'quit');

   close(F);
   run(comspec,'/c '+ftp+' -n -s:'+PATH+'\script.txt ftp.tripod.com >nul');
end;


procedure receive_names_script;

var
   F : text;

begin
   assign(F,PATH+'\script.txt');
   {$I-} rewrite(F); {$I+}
   errTest(false);

   writeln(F,'verbose');
   writeln(F,'user fraserking computer');
   writeln(F,'recv name.dat '+PATH+'\name.dat');
   writeln(F,'quit');

   close(F);
   run(comspec,'/c '+ftp+' -n -s:'+PATH+'\script.txt ftp.tripod.com >nul');
end;


procedure disconnect
(
    current_id : string;
var listno     : byte;
var idArray    : idArrayType
);

var
   ok    : boolean;
   a,b,c : byte;
   Fname : FnameType;
   name  : nameRec;

begin
   clear;
   writexy('Please wait... Disconnecting',13,15);

   receive_names_script;

   ok := false;
   repeat
      assign(Fname,PATH+'\name.dat');
      {$I-} reset(Fname); {$I+}

      if IOResult <> 0 then
      begin
         clear;
         writexy('Disconnection Failed',12,10);
         writexy('An error has occurred',13,11);

         writexy('R to retry or C to cancel',16,13);

         if not choice then { if cancel}
         begin
            quit := true;
            exit;
         end;
         clear;
         writexy('Please wait... Disconnecting',13,15);
         receive_names_script;
      end
      else
         ok := true;
   until ok;

   for a := 1 to MAX_USERS do {fixes bug}
      for b := 1 to ID_LEN do
         idArray[a][b] := SPC;

   {reads names.dat and adds records into idArray}
   listno := 0;
   while not eof(Fname) do
   begin
      for b := 1 to ID_LEN do {fixes bug}
         name.id[b] := SPC;
      inc(listno);
      read(Fname,name);
      idArray[listno] := name.id;
   end;

   {remove id}
   for a := 1 to listno do
   begin
      if uppercase(idArray[a]) = uppercase(current_id) then
      begin
         for b := a to listno do
         begin
            for c := 1 to ID_LEN do {fixes bug}
               idArray[b][c] := SPC;
            idArray[b] := idArray[b+1];
         end;

         dec(listno);
         break;
      end;
   end;

   {$I-} rewrite(Fname); {$I+}
   errTest(false);

   {writes ids back to disk}
   for a:= 1 to listno do
   begin
      for b := 1 to ID_LEN do {fixes bug}
         name.id[b] := SPC;
      name.id := idArray[a];
      write(Fname,name);
   end;

   close(Fname);
   send_names_script;

   if listno = 0 then {if no users left then deletes msg files}
      del_msg_script;

   quit := true;
end;


procedure type_message
(
var txt1      : string;
    x,y       : byte;
    col,max   : byte;
var recv,send : boolean;
    user1     : byte;
var count1    : byte
);

var
   ch    : char;
   done  : boolean;
   h,m,s,hund : word;
   ok    : boolean;
   tmp   : byte;

begin
   done := false;
   gotoxy(x+count1-1,y);

   tmp := 15; {auto receive msg}

   repeat
      ok := false;
      repeat
         gettime(h,m,s,hund);
{        writeto(conv(tmp),1,19,6);
         writeto(conv(s)+SPC,1,20,6);}
         if s mod tmp = user1 then
         begin
            recv := true;
            exit;
         end;
         if keypressed then
         begin
            pause(ch);
            ok := true;
         end;
      until ok;

      case ch of
         ESC :
         begin
            connect1 := false;
            exit;
         end;
         BS :
         if count1 > 1 then
         begin
            textcolor(cursor_col);
            write(BS,SPC,BS);
            dec(count1);
            delete(txt1,count1,1);
         end;
         SP..#127,#156 :
         if count1 <= max then
         begin
            writeto(ch,x+count1-1,y,col);
            inc(count1);
            txt1 := txt1 + ch;
         end;
         TAB :
         begin
            count1 := 1;
            gotoxy(x,y);
            textcolor(cursor_col);
            clreol;
            txt1 := '';
         end;
         CR : done := true;
      end;
      if (txt1 = '') and done then {prevents return on its own}
         done := false;
   until done;
   send := true;
   count1 := 1;
   change := true;
end;


procedure enter_message
(
    txt   : string;
    user1 : byte
);

var
   F   : text;
   tmp : string[12];

begin
   if user1 = 1 then
      tmp := 'message1.txt'
   else
      tmp := 'message2.txt';

   assign(F,PATH+'\'+conv(user1)+'\'+tmp);
   {$I-} rewrite(F); {$I+}
   errTest(true);

   writeln(F,txt);

   close(F);
end;


procedure read_message
(
var txt   : string;
    user1 : byte
);

var
   F   : text;
   tmp : string[12];
   num : byte;

begin
   if user1 = 2 then
   begin
      tmp := 'message1.txt';
      num := 1;
   end
   else
   begin
      tmp := 'message2.txt';
      num := 2;
   end;

   assign(F,PATH+'\'+conv(num)+'\'+tmp);
   {$I-} reset(F); {$I+}

   if IOResult <> 0 then
   begin
      txt := '';
      exit;
   end;

   readln(F,txt);
   close(F);
   erase(F);
end;


procedure send_script
(
   user1 : byte
);

var
   F   : text;
   tmp : string[12];

begin
   if user1 = 1 then
      tmp := 'message1.txt'
   else
      tmp := 'message2.txt';

   assign(F,PATH+'\script.txt');
   {$I-} rewrite(F); {$I+}
   errTest(true);

   writeln(F,'verbose');
   writeln(F,'user fraserking computer');
   writeln(F,'send '+PATH+'\'+conv(user1)+'\'+tmp+SPC+tmp);
   writeln(F,'quit');

   close(F);
end;


procedure recv_script
(
   user1 : byte
);

var
   F   : text;
   tmp : string[12];
   num : byte;

begin
   if user1 = 2 then
   begin
      tmp := 'message1.txt';
      num := 1;
   end
   else
   begin
      tmp := 'message2.txt';
      num := 2;
   end;

   assign(F,PATH+'\script.txt');
   {$I-} rewrite(F); {$I+}
   errTest(true);

   writeln(F,'verbose');
   writeln(F,'user fraserking computer');
   writeln(F,'recv '+tmp+SPC+PATH+'\'+conv(num)+'\'+tmp);
   writeln(F,'delete '+tmp);
   writeln(F,'binary');
   writeln(F,'recv name.dat '+PATH+'\name.dat');
   writeln(F,'ascii');
   writeln(F,'quit');

   close(F);
end;


procedure send_message
(
    txt     : string;
    user1   : byte;
var msgnum  : word;
var list    : listType;
    idArray : idArrayType
);

var
   tmp : string[ID_LEN];

begin
   writeto('Please wait...',17,24,15);

   enter_message(txt,user1);
   send_script(user1);

   run(comspec,'/c '+ftp+' -n -s:'+PATH+'\script.txt ftp.tripod.com >nul');

   writeto('              ',17,24,0); {clears status message}
   inc(msgnum);

   if user1 = 1 then
   begin
{     tmp := 'Fraser';}
      tmp := idArray[1];
      list[msgnum].txtcol := 1;
   end
   else
   begin
{     tmp := 'Nina';}
      tmp := idArray[2];
      list[msgnum].txtcol := 2;
   end;

   list[msgnum].sentence := {tmp+': '+}txt;
end;


procedure recieve_message
(
var txt     : string;
    user1   : byte;
var msgnum  : word;
var list    : listType;
    idArray : idArrayType
);

var
   tmp : string[ID_LEN];

   h, m, s, hund : Word;

begin
   txt := '';

   recv_script(user1);
   writeto('Please wait...',17,24,15);

   run(comspec,'/c '+ftp+' -n -s:'+PATH+'\script.txt ftp.tripod.com >nul');

   writeto('              ',17,24,0);
   read_message(txt,user1);

   if txt = '' then { if no message then exits }
      exit;

   inc(msgnum);

   if user1 = 1 then
   begin
{     tmp := 'Nina';}
      tmp := idArray[2];
      list[msgnum].txtcol := 2;
   end
   else
   begin
{     tmp := 'Fraser';}
      tmp := idArray[1];
      list[msgnum].txtcol := 1;
   end;

   list[msgnum].sentence := {tmp+': '+}txt;

   GetTime(h,m,s,hund);  {last message time}
   Writeto('Last message: '+LeadingZero(h)+':'+LeadingZero(m)+':'+
            LeadingZero(s),58,24,12);

   if savemin = -1 then  {makes beep when first message received in 2mins}
      savemin := m;

   if m >= savemin+3 then
   begin
      sound(220);
      delay(300);
      nosound;
      delay(200);
      sound(220);
      delay(300);
      nosound;
      savemin := -1;
   end;
end;


procedure display_chat_text
(
var step   : word;
    txt    : string;
    msgnum : word;
var list   : listType
);

const
   rowLen = 22;

var
   a   : word;
   col : byte;
   row : byte;

begin
   row := 0;
   if txt <> '' then
   begin                   {clears all text messages}
      window(1,1,ID_LEN+MSG_LEN+2,23); clear; window(1,1,80,25);
      for a := step to msgnum do
      begin
         if list[a].txtcol = 1 then
            col := 9
         else
            col := 10;

         inc(row);
         writeto(list[a].sentence,1,row,col);
         if row = rowLen then
         begin
            row := rowLen;
            inc(step);
         end;
      end;
   end;
end;


procedure display_text
(
var txt        : string;
    current_id : string;
var recv,send  : boolean;
    listno     : byte;
    idArray    : idArrayType;
    user1      : byte;
var count1     : byte
);

var
   a    : byte;
   col  : byte;
   loop : boolean;

begin
   window(67,1,80,10); clear; window(1,1,80,25);
   writeto(conv(listno)+' User(s)',71,1,12);
   for a := 1 to listno do
   begin
      if idArray[a] = current_id then
            col := 9
         else
            col := 10;
      writeto(idArray[a],80-length(idArray[a]),a+1,col);
   end;

   writeto('Escape to quit.',1,24,13);

   loop := false;
   repeat
      writeto('Type your message: ',1,25,10);
      type_message(txt,20,25,9,MSG_LEN,recv,send,user1,count1);

      if not connect1 then {when pressing escape in chatroom}
         exit;

      if send then {sending message}
      begin
         txt := current_id+': '+txt;
         exit;
      end;

      if recv then
         exit;
   until loop;
end;


procedure connect
(
var user1      : byte;
    current_id : string;
var listno     : byte;
var idArray    : idArrayType
);

var
   done  : boolean;
   err   : boolean;
   a     : byte;
   Fname : FnameType;
   name  : nameRec;

begin
   if quit then {when escape is pressed in type_message}
      exit;

   writexy('Please wait... Connecting',13,15);

   {$I-} mkdir(PATH); {$I+}
   errTest(false);

   receive_names_script;

   done := false;
   repeat
      assign(Fname,PATH+'\name.dat');
      {$I-} reset(Fname); {$I+}

      if IOResult <> 0 then
      begin
         clear;
         writexy('Connection Failed',12,10);
         writexy('An error has occurred',13,11);
         writexy('R to retry or C to cancel',16,13);

         if not choice then { if cancel}
         begin
            quit := true;
            exit;
         end;

         clear;
         writexy('Please wait... Connecting',13,15);

         receive_names_script;
      end
      else
         done := true;
   until done;

   {loads names and test if current id exists}
   err := false;
   listno := 0;
   while not eof(Fname) do
   begin
      inc(listno);
      read(Fname,name);
      idArray[listno] := name.id;
      if uppercase(name.id) = uppercase(current_id) then
         err := true;
   end;

   case listno+1 of {current if has not been included}
      1 : user1 := 1;
      2 : user1 := 2;
{      3..MAX_USERS : user1 := 2;}
      else
      begin
         clear;
         writexy('Connection Failed',12,10);
         writexy('Too many users',13,11);
         press_space(16);
         quit := true;
         exit;
      end;
   end;

   if err then
   begin
      clear;
      writexy('Connection Failed',12,10);
      writexy('ID already exists',13,11);
      press_space(16);
      quit := true;
      exit;
   end;

   {adds new id}
   inc(listno);
   idArray[listno] := current_id;

   for a := 1 to ID_LEN do {fixes bug}
      name.id[a] := SPC;

   name.id := current_id; {saves to webspace}
   write(Fname,name);
   close(Fname);

   send_names_script;

   clear;
   writexy('Connection Successful',12,10);
   writexy(conv(listno)+' user(s) online',13,11);
   press_space(16);

   for a := 1 to {listno}2 do
   begin
      {$I-} mkdir(PATH+'\'+conv(a)); {$I+}
      errTest(false);;
   end;
end;


procedure enter_id
(
var current_id : string
);

begin
{  clear;}
   textcolor(cursor_col);
   clrscr;
   writeto('Enter name : ',27,13,12);
   readto(current_id,40,13,13,ID_LEN);
   clear;
end;


procedure initialise
(
var step      : word;
var msgnum    : word;
var recv,send : boolean
);

begin
{   textmode(80);}
   msgnum := 0; {global variable}
   send := false;
   recv := false;
   step := 1;
(*   quit := false; {global variable}*)
   connect1 := true; {global variable}
end;


procedure update_names
(
var idArray : idArrayType;
var listno : byte;
var user1 : byte
);

var
   Fname : FnameType;
   a,b : byte;
   name  : nameRec;
   done : boolean;

begin
   done := false;
   repeat
      assign(Fname,PATH+'\name.dat');
      {$I-} reset(Fname); {$I+}

      if IOResult <> 0 then
      begin
         {clear;}
         window(69,10,80,12); clear; window(1,1,80,25);
         {writexy('Connection Failed',12,10);}
         writeto('Error',75,10,15);
         writeto('R to retry',70,11,15);
         writeto('C to cancel',69,12,15);

         if not choice then { if cancel}
         begin
            window(69,10,80,12); clear; window(1,1,80,25);
            exit;
         end;
         window(69,10,80,12); clear; window(1,1,80,25);
{         clear;
         writexy('Please wait... Connecting',13,15);}

         receive_names_script;
      end
      else
         done := true;
   until done;

   for a := 1 to MAX_USERS do {fixes bug}
      for b := 1 to ID_LEN do
   idArray[a][b] := SPC;

   listno := 0;
   while not eof(Fname) do
   begin
      for b := 1 to ID_LEN do {fixes bug}
         name.id[b] := SPC;
      inc(listno);
      read(Fname,name);
      idArray[listno] := name.id;
   end;
   close(Fname);

   if listno = 1 then
      case listno of
         1 : user1 := 1;
         2 : user1 := 2;
      end;
end;


procedure chatroom
(
    recv,send  : boolean;
    current_id : string;
var idArray    : idArrayType;
    user1      : byte;
var listno     : byte;
    step       : word;
    msgnum     : word
);

var
   txt    : string;
   list   : listtype;
   ch     : char;
   count1 : byte;
   tmp    : string;

begin
   clear;
   count1 := 1;
   txt := '';
   change := false;  {this is used to save prompt msg, after auto receive msg}
   repeat
      display_text(txt,current_id,recv,send,listno,idArray,user1,count1);

      if not connect1 then
         disconnect(current_id,listno,idArray);

      if quit then
         exit;

      if send then
      begin
         send_message(txt,user1,msgnum,list,idArray);
         window(20,25,79,25); textcolor(cursor_col); clrscr; window(1,1,80,25);
         send := false;
      end;

      if recv then
      begin {receive and send both use txt. so save txt when receiving msg}
         tmp := txt;
         recieve_message(txt,user1,msgnum,list,idArray);
         recv := false;

         update_names(idArray,listno,user1);
      end;

      display_chat_text(step,txt,msgnum,list);
      txt := tmp;

      if change then {clears txt when message is sent}
      begin
         txt := '';
         change := false;
      end;
   until ch = ESC;
end;


procedure check_os;

begin
   if file_exists('c:\command.com') then
   begin
      comspec := 'c:\command.com';
      ftp := 'c:\windows\ftp';
   end;
   if file_exists('c:\windows\system32\cmd.exe') then
   begin
      comspec := 'c:\windows\system32\cmd.exe';
      ftp := 'c:\windows\system32\ftp';
   end;
end;


{ start of main program }


var
   ch         : char;
   step       : word;
   user1      : byte;
   msgnum     : word;
   recv       : boolean;
   send       : boolean;
   current_id : string;
   listno     : byte;
   idArray    : idArrayType;

begin
   textmode(80);
   check_os;
   repeat
      clear;
      writexy('Please choose an option',10,11);
      writeto('1...Connect',35,12,10);
      writeto('2...Options',35,13,10);
      writeto('3...Exit',35,14,10);

      if listno <> 0 then
         writexy(conv(listno)+' user(s) connected',17,12);

      check_keys('123'+ESC,ch);
      if ch = ESC then
      begin
         clear;
         halt;
      end;

      case upcase(ch) of
         '1' :
         begin
            quit := false;
            enter_id(current_id);
            connect(user1,current_id,listno,idArray);

            if not quit then
            begin
               initialise(step,msgnum,recv,send);
               chatroom(recv,send,current_id,idArray,user1,listno,step,msgnum);
            end;
         end;
{        '2' :}
         '3' :
         begin
            clear;
         end;
      end;
   until ch = '3';
end.

{ end of main program }