Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TOOL_USE.ZIP/DISPEDIT.PAS

Pascal/Delphi Source File | 1989-03-01 | 24.7 KB | 899 lines

(*
 * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
 *
 * This is a component of the ProDoor System.
 * Do not distribute modified versions without my permission.
 * Do not remove or alter this notice or any other copyright notice.
 * If you use this in your own program you must distribute source code.
 * Do not use any of this in a commercial product.
 *
 *)

(*
 * dispedit - display/edit support functions for interactive
 *            configuration type programs. (3-1-89)
 *
 *)

{$i prodef.inc}

unit dispedit;

{$v-}

interface
   uses dos, crt, tools;

   type
      charset        = string[128];

      edit_functions = (display, edit, clear);

      border_styles  = (blank_border,          single_border,
                        double_border,         mixed_border,
                        taildouble_border,
                        solid_border,          evensolid_border,
                        thinsolid_border,      lohatch_border,
                        medhatch_border,       hihatch_border);

      display_image_type = array[1..2000] of record
         chr:  char;
         attr: byte;
      end;

      display_image_rec = record
         crt:  display_image_type;
         mode: word;
         attr: byte;
         wmin: word;
         wmax: word;
         x,y:  byte;
      end;

   var
      disp_mem:   ^display_image_type;


   const
      allchars:   charset = ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~';
      namechars:  charset = '!#$%&''()+-.0123456789:@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_{}~';

      YES         = 'Y';      NO          = 'N';
      BACKSPACE   = #8;       TAB         = #9;
      NEWLINE     = #13;      ESC         = #27;
      F1          = #201;     F2          = #202;
      F3          = #203;     F4          = #204;
      F5          = #205;     F6          = #206;
      F7          = #207;     F8          = #208;
      F9          = #209;     F10         = #210;
      HOME        = #213;     UP          = #214;
      PGUP        = #215;     LEFT        = #217;
      RIGHT       = #219;     ENDK        = #221;
      DOWN        = #222;     PGDN        = #223;
      INS         = #224;     DEL         = #225;
      CTRL_F1     = #236;     CTRL_F2     = #237;
      CTRL_F3     = #238;     CTRL_F9     = #244;
      CTRL_F10    = #245;     CTRL_PGUP   = #18;
      CTRL_PGDN   = #4;       CTRL_LEFT   = #1;
      CTRL_RIGHT  = #2;       CTRL_HOME   = #5;
      CTRL_END    = #3;       SHIFT_TAB   = #157;

      data_changed: boolean = false;

      py: integer = -1;
      px: integer = -1;

      traceopen: boolean = false;

   var
      tracefd: text;


   procedure disp(s: string);
   procedure displn(s: string);
   procedure dispnl;

   function make_string(ch: char; size: byte): string;

   procedure display_border(topx,topy,
                            botx,boty: integer;
                            style:     border_styles);

   procedure beep;

   function get_key: char;

   procedure edit_string ( func:      edit_functions;
                           x,y:       integer;
                           prompt:    string;
                           var data:  string;
                           width:     integer;
                           var term:  char );

   procedure edit_fname ( func:      edit_functions;
                          x,y:       integer;
                          prompt:    string;
                          var data:  string;
                          width:     integer;
                          isdir:     boolean;
                          var term:  char );

   procedure edit_chars  ( func:      edit_functions;
                           x,y:       integer;
                           prompt:    string;
                           var data;
                           width:     integer;
                           var term:  char );

   procedure edit_integer( func:     edit_functions;
                           x,y:      integer;
                           prompt:   string;
                           var data: integer;
                           width:    integer;
                           min,max:  integer;
                           var term: char );

   procedure edit_word   ( func:     edit_functions;
                           x,y:      integer;
                           prompt:   string;
                           var data: word;
                           width:    integer;
                           min,max:  word;
                           var term: char );

   procedure edit_real   ( func:     edit_functions;
                           x,y:      integer;
                           prompt:   string;
                           var data: real;
                           width:    integer;
                           deci:     integer;
                           var term: char );

   procedure edit_yesno(   func:      edit_functions;
                           x,y:       integer;
                           prompt:    string;
                           var data:  boolean;
                           var term:  char );

   procedure edit_funkey( func:      edit_functions;
                          x,y:       integer;
                          prompt:    string;
                          key:       char;
                          var term:  char );

   procedure select_next_entry( func:    edit_functions;
                                var en:  integer;
                                maxen:   integer;
                                var key: char);

   procedure clear_screen;

   procedure vscroll_bar(current, min, max: word;
                         x,y1,y2: byte);

   procedure hscroll_bar(current, min, max: word;
                         y,x1,x2: byte);

   procedure opentrace(name: string);
   procedure closetrace;

   procedure input(var line:  string;
                   maxlen:    integer);

   procedure save_display(var disp: display_image_rec);
   procedure restore_display(var disp: display_image_rec);
   procedure shadow_display;


implementation


   (* -------------------------------------------------- *)
   procedure disp(s: string);
   begin
      write(s);
      if traceopen then
         write(tracefd,s);
   end;

   procedure dispnl;
   begin
      disp(^M^J);
   end;

   procedure displn(s: string);
   begin
      disp(s);
      dispnl;
   end;


   (* -------------------------------------------------- *)
   function make_string(ch: char; size: byte): string;
   var
      st: string;
   begin
      fillchar(st[1],size,ch);
      st[0] := chr(size);
      make_string := st;
   end;


   (* -------------------------------------------------- *)
   procedure display_border(topx,topy,
                            botx,boty: integer;
                            style:     border_styles);
      (* display a window border.  enter with desired color settingx*)
   var
      left:        string[80];
      right:       string[80];
      top:         string[80];
      bottom:      string[80];
      width:       integer;
      b:           string[8];
      i,j:         integer;

   const
     border_table:  array[blank_border..hihatch_border] of string[8] =
       ('        ',  { blank     }         '┌─┐││└─┘',  { single    }
        '╔═╗║║╚═╝',  { double    }         '╒═╕││╘═╛',  { mixed     }
        '╠═╗║║╚═╝',  { taildouble}
        '████████',  { solid     }         '█▀████▄█',  { evensolid }
        '▐▀▌▐▌▐▄▌',  { thinsolid }         '░░░░░░░░',  { lohatch   }
        '▒▒▒▒▒▒▒▒',  { medhatch  }         '▓▓▓▓▓▓▓▓'); { hihatch   }

      topleft  = 1;    {border character locations in border strings}
      tophor   = 2;
      topright = 3;
      leftver  = 4;
      rightver = 5;
      botleft  = 6;
      bothor   = 7;
      botright = 8;

      filler = ^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J^@^H^J;

   begin
      b := border_table[style];
      width := botx - topx - 2;

   (* top and bottom of frame *)
      bottom[0]    := chr(width+2);
      top[0]       := chr(width+2);
      top[1]       := b[topleft];
      for i := 2 to width+1 do
         top[i] := b[tophor];
      top[width+2] := b[topright];

      bottom[0]       := chr(width+2);
      bottom[1]       := b[botleft];
      for i := 2 to width+1 do
         bottom[i] := b[bothor];
      bottom[width+2] := b[botright];


   (* sides of frame *)
      left := filler + filler;
      right := left;
      j := 1;
      for i := 2 to boty - topy do
      begin
         left[j]:= b[leftver];
         right[j]:= b[rightver];
         j := j + 3;
      end;
      left[0]:= chr (j - 1);
      right[0]:= left[0];

   (* draw the frame *)
      gotoxy(topx,topy);     disp(top);
      gotoxy(topx,topy+1);   disp(left);
      gotoxy(botx-1,topy+1); disp(right);
      gotoxy(topx,boty);     disp(bottom);
   end;


   (* -------------------------------------------------- *)
   procedure beep;
   begin
      disp(^G);
   end;


   (* -------------------------------------------------- *)
   function get_key: char;
   var
      c: char;
   begin
      c := readkey;
      if c = #0 then
         c := chr(ord(readkey) + 142);
      get_key := c;
   end;


   (* -------------------------------------------------- *)
   procedure raw_editor( func:       edit_functions;
                         x,y:        integer;
                         prompt:     string;
                         var data:   string;
                         width:      integer;
                         var term:   char;
                         upper:      boolean;
                         legal:      charset );
   var
      col:        integer;
      ch:         char;
      filler:     string;
      fillch:     char;
    { firstkey:   boolean; }

   begin

      if length(data) > width then
         data[0] := chr(width);
      if upper then
         stoupper(data);

      case func of
         display:
            fillch := '_';
         edit:
            fillch := '░';
         clear:
            begin
               fillch := ' ';
               data := '';
            end;
      end;

      filler := make_string( fillch, width - length(data) ) + ' ';

      lowvideo;
      gotoxy( x, y );
      disp( prompt );

      highvideo;
      disp( copy( data, 1, width ) );

      if func <> edit then
         lowvideo;
      disp( filler );
      highvideo;

   (* edit field contents only on edit calls *)
      if ( func <> edit ) then
         exit;

   (* general edit string function *)
      inc(x,length(prompt));
      col := 0;
    { firstkey := true; }
      term := '0';

      repeat
         gotoxy( x + col, y );
         ch := get_key;

         case ch of
            HOME: col := 0;

            ENDK: col := length(data);

            LEFT: if col > 0 then
                     dec(col)
                  else
                     term := UP;

            RIGHT:
                  if col < length(data) then
                     inc(col)
                  else
                     term := DOWN;

            DEL:  if col < length( data ) then
                  begin
                     delete( data, col + 1, 1 );
                     disp( copy( data, col + 1, width )+ fillch );
                     data_changed := true;
                  end;

            INS:  if col < length( data ) then
                  begin
                     insert( ' ',data, col+1 );
                     disp( copy( data, col+1, width ) );
                     data_changed := true;
                  end;

            BACKSPACE:
                  if col > 0 then
                  begin
                     delete( data, col, 1 );
                     disp( ^h + copy( data, col, width )+ fillch );
                     dec(col);
                     data_changed := true;
                  end
                  else
                     beep;

            F1..F10, ESC,
            NEWLINE, UP, DOWN,
            PGUP, PGDN,
            CTRL_HOME, CTRL_END:
                  term := ch;

            else  begin
                     if upper then
                        ch := upcase(ch);

                     if pos(ch,legal) > 0 then
                     begin

                      { if firstkey then
                        begin
                           data := '';
                           disp( make_string( fillch, width ) );
                           gotoxy( x + col, y );
                        end; }

                        if col < width then
                        begin
                           inc(col);
                           if col > length( data ) then
                              data := data + ch
                           else
                              data[ col ] := ch;

                           disp( ch );
                           data_changed := true;
                        end
                        else
                           beep;
                     end
                     else

                     begin
                        gotoxy(1,1);
                        write('ch=',ord(ch):3);
                        beep;
                     end;
                  end;
         end;

       { firstkey := false; }

      until term <> '0';

      gotoxy( x, y );
      highvideo;
      disp( data );

      lowvideo;
      disp( make_string( '_', width-length(data) ) );
   end;


   (* -------------------------------------------------- *)
   procedure edit_string( func:      edit_functions;
                          x,y:       integer;
                          prompt:    string;
                          var data:  string;
                          width:     integer;
                          var term:  char );
   begin
      raw_editor( func, x, y, prompt, data, width, term, false, allchars);
   end;


   (* -------------------------------------------------- *)
   procedure edit_fname ( func:      edit_functions;
                          x,y:       integer;
                          prompt:    string;
                          var data:  string;
                          width:     integer;
                          isdir:     boolean;
                          var term:  char );
   begin
      raw_editor( func, x, y, prompt, data, width, term, true, namechars);

      if isdir and (data[length(data)] <> '\') then
      begin
         inc(data[0]);
         data[length(data)] := '\';
      end;
   end;


   (* -------------------------------------------------- *)
   procedure edit_chars( func:      edit_functions;
                         x,y:       integer;
                         prompt:    string;
                         var data;
                         width:     integer;
                         var term:  char );
   var
      cdata:   array[1..255] of char absolute data;
      sdata:   string;
      i:       integer;

   begin
      for i := 1 to width do
         sdata[i] := cdata[i];
      sdata[0] := chr(width);
      while sdata[length(sdata)] = ' ' do
         dec(sdata[0]);

      raw_editor( func, x, y, prompt, sdata, width, term, false, allchars);

      sdata := ljust(sdata,width);
      for i := 1 to width do
         cdata[i] := sdata[i];
   end;


   (* -------------------------------------------------- *)
   procedure edit_integer( func:     edit_functions;
                           x,y:      integer;
                           prompt:   string;
                           var data: integer;
                           width:    integer;
                           min,max:  integer;
                           var term: char );
   var
      temp:       string;
      code:       integer;
      new_data:   integer;

   begin
      str(data,temp);      { convert data from float to string }

      repeat
         raw_editor( func, x, y, prompt, temp, width, term, false, '0123456789-');

         if func=edit then
            val( temp, new_data, code )
         else
            code := 0;              { convert string to int only when editing }

         if (func = edit) and (( new_data < min ) or ( new_data > max )) then
            code := 1;              { invalidate data data if out of range }

         if code <> 0 then
         begin
            beep;           { code is 0 if data is valid }
            str(data,temp);
            if (term >= F1) and (term <= F10) then
               exit;                { allow invalid data without change on F-keys}
         end;

      until ( code = 0 );

      if func=edit then
         data := new_data;
   end;


   (* -------------------------------------------------- *)
   procedure edit_word( func:     edit_functions;
                        x,y:      integer;
                        prompt:   string;
                        var data: word;
                        width:    integer;
                        min,max:  word;
                        var term: char );
   var
      temp:       string;
      code:       integer;
      new_data:   word;

   begin
      str(data,temp);      { convert data from float to string }

      repeat
         raw_editor( func, x, y, prompt, temp, width, term, false, '0123456789');

         if func=edit then
            val( temp, new_data, code )
         else
            code := 0;              { convert string to int only when editing }

         if (func = edit) and (( new_data < min ) or ( new_data > max )) then
            code := 1;              { invalidate data data if out of range }

         if code <> 0 then
         begin
            beep;           { code is 0 if data is valid }
            str(data,temp);
            if (term >= F1) and (term <= F10) then
               exit;                { allow invalid data without change on F-keys}
         end;

      until ( code = 0 );

      if func=edit then
         data := new_data;
   end;


   (* -------------------------------------------------- *)
   procedure edit_real   ( func:     edit_functions;
                           x,y:      integer;
                           prompt:   string;
                           var data: real;
                           width:    integer;
                           deci:     integer;
                           var term: char );
   var
      temp:       string;
      code:       integer;
      new_data:   real;

   begin
      str(data:0:deci,temp);      { convert data from float to string }

      repeat
         raw_editor( func, x, y, prompt, temp, width, term, true, '0123456789.E-');

         if func=edit then
            val( temp, new_data, code )
         else
            code := 0;              { convert string to int only when editing }

         if code <> 0 then
         begin
            beep;           { code is 0 if data is valid }
            str(data,temp);
            if (term >= F1) and (term <= F10) then
               exit;                { allow invalid data without change on F-keys}
         end;

      until ( code = 0 );

      if func=edit then
         data := new_data;
   end;


   (* -------------------------------------------------- *)
   procedure edit_yesno( func:      edit_functions;
                         x,y:       integer;
                         prompt:    string;
                         var data:  boolean;
                         var term:  char );
   var
      yesno:   string;

   begin
      if data then
         yesno := 'Y'
      else
         yesno := 'N';
      raw_editor( func, x, y, prompt, yesno, 1, term, true, 'YN');
      data := yesno[1] = 'Y';
   end;


   (* -------------------------------------------------- *)
   procedure edit_funkey( func:      edit_functions;
                          x,y:       integer;
                          prompt:    string;
                          key:       char;
                          var term:  char );
   begin
      if func = edit then
      begin
         gotoxy( x, y );
         textbackground(white);
         textcolor(black);
         disp( prompt );

         term := get_key;
         if term = NEWLINE then
            term := key;
      end;

      gotoxy( x, y );
      textbackground(black);
      textcolor(white);
      disp( prompt );
   end;


   (* -------------------------------------------------- *)
   procedure select_next_entry( func:    edit_functions;
                                var en:  integer;
                                maxen:   integer;
                                var key: char);
   begin
      if func = display then
         exit;

      case key of
         TAB, NEWLINE, DOWN:
            begin
               key := DOWN;
               if en < maxen then
                  inc(en)
               else
                  en := 1;
            end;

         UP:   if en > 1 then
                  dec(en)
               else
                  en := maxen;

         CTRL_HOME:
               begin
                  en := 1;
                  key := DOWN;
               end;

         CTRL_END:
               begin
                  en := maxen;
                  key := UP;
               end;
      end;
   end;

(* -------------------------------------------------- *)
   procedure clear_screen;
   begin
      clrscr;
      py := -1;
      px := -1;
   end;

(* -------------------------------------------------- *)
   procedure vscroll_bar(current, min, max: word;
                         x,y1,y2: byte);
   var
      y: integer;
      i: integer;
   begin
      y := ((current-min) * (y2-y1)) div (max-min) + y1;
      if y = py then
         exit;

      py := y;
      for i := y1 to y2 do
      begin
         gotoxy(x,i);
         if i = y then
            disp('█')
         else
            disp('░');
      end;
   end;

(* -------------------------------------------------- *)
   procedure hscroll_bar(current, min, max: word;
                         y,x1,x2: byte);
   var
      x: integer;
      i: integer;
   begin
      x := ((current-min) * (x2-x1)) div (max-min) + x1;
      if x = px then
         exit;

      px := x;
      for i := x1 to x2 do
      begin
         gotoxy(i,y);
         if i = x then
            disp('█')
         else
            disp('░');
      end;
   end;

   (* ------------------------------------------------------------ *)
   procedure input(var line:  string;
                   maxlen:    integer);
   var
      c:     char;

   begin
      line := '';

      repeat
         c := get_key;

         case c of
            ' '..#126:
               if length(line) < maxlen then
               begin
                  inc(line[0]);
                  line[length(line)] := c;
                  disp(c);
               end
               else
                  beep;

            ^H,#127:
               if length(line) > 0 then
               begin
                  dec(line[0]);
                  disp(^H' '^H);
               end;

            ^M:   ;

            ^C:   begin
                      displn('^C');
                      halt(99);
                  end;
         end;

      until (c = ^M);
   end;


(* -------------------------------------------------- *)
   procedure opentrace(name: string);
   begin
      assign(tracefd,name);
      rewrite(tracefd);
      traceopen := true;
   end;

   procedure closetrace;
   begin
      close(tracefd);
      traceopen := false;
   end;



(* -------------------------------------------------- *)
   procedure save_display(var disp: display_image_rec);
   begin
      disp.crt := disp_mem^;
      disp.mode := lastmode;
      disp.attr := textattr;
      disp.wmin := windmin;
      disp.wmax := windmax;
      disp.x := wherex;
      disp.y := wherey;
   end;

   procedure restore_display(var disp: display_image_rec);
   begin
      disp_mem^ := disp.crt;
      lastmode := disp.mode;
      textattr := disp.attr;
      windmin := disp.wmin;
      windmax := disp.wmax;
      gotoxy(disp.x,disp.y);
   end;


   procedure shadow_display;
   var
      i: integer;
   begin
      for i := 1 to 2000 do
         with disp_mem^[i] do
            attr := attr and 7;
   end;


(* -------------------------------------------------- *)
var
   Vmode: byte absolute $0040:$0049;   {Current video mode}
begin
   if (Vmode = 1{MDA}) or (Vmode = 7{VgaMono}) then
      disp_mem := ptr($B000,0)
   else
      disp_mem := ptr($B800,0);

   assignCrt(output);
   rewrite(output);
   directvideo := pos('/BIO',GetEnv('PCB')) = 0;
end.