T P R O    N U M B E R    1

   The following is a set of procedures that we have been used in
various commercial programs. Feel free to use them for commercial
and noncomercial uses. We claim no responsibility to the outcome of
the use of these procedures. You are using them at your own risk.
Enough of the legalities. If you find these routines useful, we
would greatly appreciate any small donation.




                                Soft-Touch Computers
                                James Billmeyer
                                7716 Balboa Blvd, Unit D
                                Van Nuys, Ca  91406





(****************************************************************)
(*  The following set of procedures is a  include file that is  *)
(*  used to handle screen I/O very rapidly.  The screen_colors  *)
(*  procedure is used  to  set  the forground  and  background  *)
(*  colors for the fprint  and  bprint procedures.  The fprint  *)
(*  procedure writes directly  to  the graphics screen memory.  *)
(*  The fprint procedure is about 3 to 7 times faster then the  *)
(*  Turbo Pascal write/writeln routines.                        *)
(*                                                              *)
(*  The rest of the procedures  are  screen handling routines.  *)
(*  They are used to take a screen file from a  disk drive and  *)
(*  save  them  on  the  heap.  When  a  screen  is  need  for  *)
(*  displaying, the screen  is  retrieved from  the  heap  and  *)
(*  placed in  the image_buffer  by  the get_screen_from_stack  *)
(*  procedure.  Text can  then be added  to  the screen in the  *)
(*  image_buffer with  the  bprint procedure.  When the screen  *)
(*  is finish being modified in  the image_buffer,  if is then  *)
(*  transfered to the graphics display memory by the procedure  *)
(*  send_buffer_to_screen.                                      *)
(*                                                              *)
(*  An example of the program that is needed to create a screen *)
(*  files, and an example segment that  shows  the  routines in *)
(*  use is given after screen handling procedures.              *)
(*                                                              *)
(****************************************************************)

(************************************************)
(*  Begining Screen window  include procedures  *)
(************************************************)



type
   imagetype    = array[1..4096] of char;
   str80        = string[80];
   str12        = string[12];
   screenptr    = ^screenrecord;
   screenrecord = record
                     screen :  imagetype;
                     next   :  screenptr;
                  end;

var
   colorbuffer   :  imagetype absolute $b800:$0000;
   image_buffer  :  imagetype;
   i,row,col     :  integer;
   color,bgcolor :  byte;
   _screen       :  file;
   screens,top   :  screenptr;


procedure screen_colors(fcolor,bgcolor: byte; var color: byte);

begin
   if fcolor > 15  then
      begin
         fcolor := fcolor - 16;
         color  := fcolor + (bgcolor * 16) + 128 ;
      end
   else
      color := fcolor + (bgcolor * 16);
end;



procedure fprint(_string: str80; row,col: integer);

var
   i,j,
   first,
   offset,
   strlength :  integer;

begin
   offset := $8000 + ((row - 1) * 160) + ((col - 1) * 2);
   strlength := length(_string);
   if  strlength < 4  then
      first := strlength
   else
      first := strlength div 2;
   i := 1;
   while (i < first) or (i = 1) do
      if  (port[$3DA] and $8) > 0  then
         begin
            repeat
               memw[$B000:offset] := color shl 8 + ord(_string[i]);
               offset := offset + 2;
               i := i + 1;
            until  i > first;
         end;
   while (i < strlength) and (i > first) do
      if  (port[$3DA] and $8) > 0  then
         begin
            repeat
               memw[$B000:offset] := color shl 8 + ord(_string[i]);
               offset := offset + 2;
               i := i + 1;
            until  i > strlength;
         end;
end;



procedure bprint(var buffer: imagetype; _string: str80; row,col: integer);

var
   i,j,offset :  integer;

begin
   offset := ofs(buffer) + ((row - 1) * 160) + ((col - 1) * 2);
   i := 1;
   for  i := 1  to  length(_string)  do
      begin
         mem[seg(buffer):offset]     := ord(_string[i]);
         mem[seg(buffer):offset + 1] := color;
         offset := offset + 2;
      end;
end;





procedure load_screen_stack(    screen_file_name  :  str12;
                                number_of_screens :  integer;
                            var top               :  screenptr);

(**************************************************)
(*  The  load_screen_stack procedure  builds the  *)
(*  stack of screens used by this program.        *)
(**************************************************)

var
   next_screen :  screenptr;

begin
   assign(_screen,screen_file_name);
   reset(_screen);
   new(top);
   screens := top;
   blockread(_screen,screens^.screen,32);
   for  i := 1  to  number_of_screens - 1  do
      begin
         new(next_screen);
         screens^.next := next_screen;
         screens := next_screen;
         blockread(_screen,screens^.screen,32);
      end;
   screens^.next := nil;
   close(_screen);
end;


procedure get_screen_from_stack(    screen_number :  integer;
                                var image_buffer  :  imagetype;
                                    top           :  screenptr);

(**************************************************)
(*  The  get_screen_from_stack procedure get the  *)
(*  wanted screen off  of  the screen  stack and  *)
(*  places it in the screen buffer.               *)
(**************************************************)

var
   i    :  integer;
   next :  screenptr;

begin
   i := 1;
   screens := top;
   while  i < screen_number  do
      begin
         screens := screens^.next;
         i := i + 1;
      end;
   image_buffer := screens^.screen;
end;


procedure send_buffer_to_screen(image_buffer: imagetype);

(**************************************************)
(*  The  send_buffer_to_screen  procedure  takes  *)
(*  image_buffer  and  sends  it  to  the screen  *)
(*  buffer.                                       *)
(**************************************************)

var
   i :  integer;

begin
   i := 0;
   repeat
      if  (port[$3DA] and $8) > 0  then
         begin
            port[$3D8] := 33;
            colorbuffer := image_buffer;
            port[$3D8] := 41;
            i := i + 1;
         end;
   until  i > 0;
end;



(**************************************************)
(*  End of the Screen window  include procedures  *)
(**************************************************)



program mcisc(input,output);

(**************************)
(*  Screen saver program  *)
(**************************)

const
   number_of_screens = 3;

type
   imagetype    = array[1..4096] of char;
   str80        = string[80];
   str10        = string[10];

var
   colorbuffer   :  imagetype absolute $b800:$0000;
   image_buffer  :  imagetype;
   i,j           :  integer;
   save_screen   :  file;



Procedure print_mci_info_headers;

(**************************************************)
(*  The print_mci_info_headers  Procedure prints  *)
(*  information  titles  In column  form  on the  *)
(*  screen.                                       *)
(**************************************************)

Var
   line_205 :  String[28];
   line_196 :  String[51];

Begin
   fillchar(line_205,28,Chr(205));
   fillchar(line_196,51,Chr(196));
   textcolor(white);
   textbackground(lightgray);
   gotoxy(25,1);  Writeln(Chr(201),copy(line_205,1,27),Chr(187));
   gotoxy(25,2);  Writeln(Chr(186),'  MCI Dialing Information  ',Chr(186));
   gotoxy(14,3);  Writeln(Chr(218),copy(line_196,1,10),Chr(200),copy(line_205,1,27),Chr(188),copy(line_196,1,10),Chr(191));
   gotoxy(14,4);  Writeln(Chr(179),'                                                 ',Char(179));
   gotoxy(14,5);  Writeln(Chr(179),'   Name/Title:                                   ',Char(179));
   gotoxy(14,6);  Writeln(Chr(179),'                                                 ',Char(179));
   gotoxy(14,7);  Writeln(Chr(179),'    User Name:                                   ',Char(179));
   gotoxy(14,8);  Writeln(Chr(179),'                                                 ',Char(179));
   gotoxy(14,9);  Writeln(Chr(179),'     Password:                                   ',Char(179));
   gotoxy(14,10); Writeln(Chr(179),'                                                 ',Char(179));
   gotoxy(14,11); Writeln(Chr(179),'    Telephone:                                   ',Char(179));
   gotoxy(14,12); Writeln(Chr(179),'                                                 ',Char(179));
   gotoxy(14,13); Writeln(Chr(179),'      Local                                      ',Char(179));
   gotoxy(14,14); Writeln(Chr(179),'    Area Code:                                   ',Char(179));
   gotoxy(14,15); Writeln(Chr(179),'                                                 ',Char(179));
   gotoxy(14,16); Writeln(Chr(192),copy(line_196,1,49),Chr(217));
   textcolor(white);
   textbackground(lightgray);
   gotoxy(26,2);  Writeln('  MCI Dialing Information  ');
   textcolor(lightcyan);
   textbackground(black);
   gotoxy(15,4);  Writeln('                                                 ');
   gotoxy(15,5);  Writeln('   Name/Title:                                   ');
   gotoxy(15,6);  Writeln('                                                 ');
   gotoxy(15,7);  Writeln('    User Name:                                   ');
   gotoxy(15,8);  Writeln('                                                 ');
   gotoxy(15,9);  Writeln('     Password:                                   ');
   gotoxy(15,10); Writeln('                                                 ');
   gotoxy(15,11); Writeln('    Telephone:                                   ');
   gotoxy(15,12); Writeln('                                                 ');
   gotoxy(15,13); Writeln('      Local                                      ');
   gotoxy(15,14); Writeln('    Area Code:                                   ');
   gotoxy(15,15); Writeln('                                                 ');
   textcolor(black);
   textbackground(lightmagenta);
   gotoxy(8,25); Write('        ');
   gotoxy(17,25); Write(' date:            time:          ');
   gotoxy(51,25); Write('          ');
   gotoxy(62,25); Write('           ');
   textbackground(black);
   textcolor(lightgray)
End;



Procedure print_cust_menu;

(*******************************************************)
(*  The print_cust_menu Procedure prints the programs  *)
(*  menu.                                              *)
(*******************************************************)

Var
   line_196 : String[17];

Begin
   gotoxy(31,16); Write('              ');
   window(31,13,46,24);
   fillchar(line_196,17,196);
   textcolor(lightblue);
   textbackground(blue);
   gotoxy(31,13);
   gotoxy(1,11);
   Write(Char(218),copy(line_196,1,14),Char(191));
   Write( Char(179),'  - Press -   ',Char(179));
   Write(Char(195),copy(line_196,1,14),Char(180));
   Write( Char(179),' A..add       ',Char(179));
   Write( Char(179),' C..carry',Chr(26),'add ',Char(179));
   Write( Char(179),' E..edit      ',Char(179));
   Write( Char(179),' D..delete    ',Char(179));
   Write( Char(179),' F..forward   ',Char(179));
   Write( Char(179),' B..backward  ',Char(179));
   Write( Char(179),' X..Exit      ',Char(179));
   Write(Char(192),copy(line_196,1,14),Char(217));
   textcolor(white);
   gotoxy(2,2); Write('  - Press -   ');
   textcolor(yellow);
   textbackground(blue);
   gotoxy(2,4); Write(' A..add       ');
   gotoxy(2,5); Write(' C..carry',Chr(26),'add ');
   gotoxy(2,6); Write(' E..edit      ');
   gotoxy(2,7); Write(' D..delete    ');
   gotoxy(2,8); Write(' F..forward   ');
   gotoxy(2,9); Write(' B..backward  ');
   gotoxy(2,10); Write(' X..Exit      ');
   window(1,1,80,25);
   textcolor(white);
   textbackground(black);
   gotoxy(31,24); write('                      ');
End;



Procedure print_old_mci_rec_window;

(**************************************************)
(*  The display Record Procedure prints a Record  *)
(*  on the screen.                                *)
(**************************************************)

Const
   space = '                                ';

Var
   line_205,
   line_196 :  String[35];

Begin
   fillchar(line_205,35,Chr(205));
   fillchar(line_196,35,Chr(196));
   window(46,11,80,23);
   gotoxy(46,11);
   gotoxy(1,1);
   textcolor(lightgreen);
   textbackground(green);
   Write(Chr(201),copy(line_205,1,33),Chr(187));
   Write(Chr(186),' .Similar  MCI  account on file. ',Chr(186));
   Write(Chr(199),copy(line_196,1,33),Chr(182));
   Write(Chr(186),' Name/Title:                     ',Chr(186));
   Write(Chr(186),'  User Name:                     ',Chr(186));
   Write(Chr(186),'   Password:                     ',Chr(186));
   Write(Chr(186),'  Telephone:                     ',Chr(186));
   Write(Chr(186),'    Local                        ',Chr(186));
   Write(Chr(186),'  Area Code:                     ',Chr(186));
   Write(Chr(199),copy(line_196,1,33),Chr(182));
   Write(Chr(186),'                                 ',Chr(186));
   Write(Chr(200),copy(line_205,1,33),Chr(188));
   textcolor(white);
   textbackground(green);
   gotoxy(2,2); Write(' .Similar  MCI  account on file. ');
   textcolor(yellow);
   textbackground(black);
   gotoxy(2,4); Write(' Name/Title:                     ');
   gotoxy(2,5); Write('  User Name:                     ');
   gotoxy(2,6); Write('   Password:                     ');
   gotoxy(2,7); Write('  Telephone:                     ');
   gotoxy(2,8); Write('    Local                        ');
   gotoxy(2,9); Write('  Area Code:                     ');
   window(1,1,80,25);
End;



Procedure print_To_End_edit;

(**************************************************)
(*  The  print_To_End_edit Procedure  prints the  *)
(*  how To End edit reminder.                     *)
(**************************************************)

Var
   line_196  :  String[19];

Begin
   fillchar(line_196,19,Chr(196));
   window(60,10,79,13);
   gotoxy(60,10);
   gotoxy(1,1);
   textcolor(lightmagenta);
   textbackground(magenta);
   Writeln(Chr(218),copy(line_196,1,17),Chr(191));
   Writeln(Chr(179),' To EXIT press * ',Chr(179));
   Writeln(Chr(192),copy(line_196,1,17),Chr(217));
   textcolor(white);
   gotoxy(2,2); Writeln(' To EXIT press * ');
   textcolor(lightgray);
   textbackground(black);
   window(1,1,80,25);
End;



begin
   assign(save_screen,'MCI.SCR');
   rewrite(save_screen);
   clrscr;
   print_mci_info_headers;
   blockwrite(save_screen,colorbuffer,32);
   clrscr;
   print_mci_info_headers;
   print_to_end_edit;
   blockwrite(save_screen,colorbuffer,32);
   clrscr;
   print_mci_info_headers;
   print_old_mci_rec_window;
   print_cust_menu;
   blockwrite(save_screen,colorbuffer,32);
   clrscr;
   close(save_screen);
   assign(save_screen,'MCI.SCR');
   reset(save_screen);
   for  i := 1  to  number_of_screens  do
      begin
         blockread(save_screen,image_buffer,32);
         j := 0;
         repeat
            if  (port[$3DA] and $8) > 0  then
               begin
                  port[$3D8] := 33;
                  colorbuffer := image_buffer;
                  port[$3D8] := 41;
                  j := j + 1;
               end;
         until  j > 0;
         delay(2000);
      end;
end.


(*********************************************************)
(*  An example of the screen handling procedures in use  *)
(*********************************************************)



procedure makewindow(window_number,option: integer);

(**************************************************)
(*  the make_window procedure gets a screen from  *)
(*  the screen stack and fills in the nessessary  *)
(*  information.                                  *)
(**************************************************)

const
   space = '                   ';

begin
   screen_colors(white,black,color);
   get_screen_from_stack(window_number,image_buffer,top);
   case  option  of
      1,4 : begin   (* display_old_mci_rec *)
             clear_mci_info(mci_info);
             getrec(mci_data,recnumber,mci_info);
             with  mci_info  do
                begin
                   if  option = 4  then
                      begin
                         bprint(image_buffer,copy((mci_name),1,20),5,30);
                      end;
                   bprint(image_buffer,copy((mci_name + space),1,19),14,60);
                   bprint(image_buffer,copy((mci_user + space),1,19),15,60);
                   bprint(image_buffer,copy((mci_password + space),1,19),16,60);
                   bprint(image_buffer,copy((mci_telephone + space),1,19),17,60);
                   bprint(image_buffer,copy((mci_local_area + space),1,19),19,60);
               end;
          end;

      2,3 : begin   (* display_mci_rec *)
             if  option = 2  then
                begin
                   clear_mci_info(mci_info);
                   getrec(mci_data,recnumber,mci_info);
                 end;
             with  mci_info  do
                begin
                   bprint(image_buffer,copy((mci_name),1,20),5,30);
                   bprint(image_buffer,copy((mci_user),1,30),7,30);
                   bprint(image_buffer,copy((mci_password),1,30),9,30);
                   bprint(image_buffer,copy((mci_telephone),1,14),11,30);
                   bprint(image_buffer,copy((mci_local_area),1,5),14,30);
                end;
          end;

   end;
   screen_colors(black,magenta,color);
   bprint(image_buffer,'        ',25,8);
   bprint(image_buffer,' date:            time:          ',25,17);
   bprint(image_buffer,'          ',25,51);
   bprint(image_buffer,'           ',25,64);
   bprint(image_buffer,date,25,24);
   bprint(image_buffer,time,25,41);
   screen_colors(white,black,color);
   send_buffer_to_screen(image_buffer);
end;




procedure fprint_old_mci_window;

(**************************************************)
(*  The  fprint_old_mci_window  procedure  fills  *)
(*  the old delaer window with a new record.      *)
(**************************************************)

const
   space = '                   ';

begin
   screen_colors(white,black,color);
   with  mci_info  do
      begin
         fprint(copy((mci_name + space),1,19),14,60);
         fprint(copy((mci_user + space),1,19),15,60);
         fprint(copy((mci_password + space),1,19),16,60);
         fprint(copy((mci_telephone + space),1,19),17,60);
         fprint(copy((mci_local_area + space),1,19),19,60);
      end;
end;



Begin  (* main MCI *)
   load_screen_stack('MCI.SCR',3,top);
   window(1,1,80,25);
   gotoxy(1,1);
   initindex;
   openfiles;
   makewindow(1,1);
      .
      .
      .
   closefiles;
End.