Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MPICKE.ZIP/PICKER.PAS

Pascal/Delphi Source File | 1988-08-16 | 8.8 KB | 302 lines

UNIT Picker;
(*********************************************************************)
(*  UNIT PICKER                                                      *)
(*********************************************************************)
(*  Public domain routines for anyone's free use                     *)
(*  BY:  Frank H Carr         August 16, 1988                        *)
(*       Compuserve           71121,3247                             *)
(*       Gene Plantz IBBS     [phone]  ID0434                 *)
(*********************************************************************)

INTERFACE

USES
  crt;

TYPE
  menu = array[1..128] of string[15];
  boxpattern=string[9];

 Function Replicate(ch:char; num:integer):string;
 Procedure DrawBox(c1,r1,c2,r2:byte; box:boxpattern);
 Function Achoice(m:menu; col,row,num,depth,cols,position:byte):byte;


IMPLEMENTATION

(****************************************************)
(* FUNCTION REPLICATE                               *)
(* Returns a string of repeated characters.         *)
(****************************************************)
Function Replicate(ch:char; num:integer):string;
Var
 tempstr:string;
Begin
 tempstr:='';
 while num>0 do
   begin
     tempstr:=tempstr+ch;
     dec(num);
   end;
 replicate:=tempstr;
End;

(****************************************************)
(* PROCEDURE DRAWBOX                                *)
(* Draws a box using box pattern. First coordinates *)
(* are upper left corner, second coordinates are    *)
(* lower right.                                     *)
(****************************************************)
Procedure DrawBox(c1,r1,c2,r2:byte; box:boxpattern);
Var
 i,width:integer;
Begin
 width:=c2-c1-1;
 gotoxy(c1,r1);
 write(box[1],replicate(box[2],width),box[3]);
 for i:=r1+1 to r2-1 do
  begin
   gotoxy(c1,i);
   write(box[4],replicate(' ',width),box[8]);
  end;
 gotoxy(c1,r2);
 write(box[7],replicate(box[6],width),box[5]);
End;


(****************************************************)
(* FUNCTION ACHOICE                                 *)
(* Returns the array element number of the choice   *)
(* picked. Returns a 0 if <Esc> was pressed.        *)
(* Parameters: m - an string array of choice names  *)
(*             col,row - the upper left coordinates *)
(*                       of the box                 *)
(*             num - the number of elements in the  *)
(*                   array (choices)                *)
(*             depth - the number of choices        *)
(*                     displayed verticaly          *)
(*             cols - the number of choices         *)
(*                    displayed horizontaly         *)
(*             position - The default choice        *)
(****************************************************)
Function Achoice(m:menu; col,row,num,depth,cols,position:byte):byte;

Var
  i,maxlen,width,oldcol,oldrow,top:byte;
  ch:char;
  box:boxpattern;

 (*****************************)
 (* function colnum           *)
 (* returns the column number *)
 (* from 1 to cols            *)
 (*****************************)
 function colnum(p,c:byte):byte;
 begin
  colnum:=(p-1) mod c;
 end;

 (*****************************)
 (* procedure inverseon       *)
 (* sets inverse display mode *)
 (*****************************)
 procedure inverseon;
 Begin
  textcolor(0);
  textbackground(7);
 End;

 (*****************************)
 (* procedure inverseoff      *)
 (* sets regular display mode *)
 (*****************************)
 procedure inverseoff;
 begin
  textcolor(7);
  textbackground(0);
 end;

 (*****************************)
 (* function firstletter      *)
 (* returns the first non-    *)
 (* blank character of a      *)
 (* string                    *)
 (*****************************)
 function firstletter(str:string):char;
 var
   i:byte;
 begin
   i:=0;
   repeat
     inc(i);
   until str[i]<>' ';
   firstletter:=upcase(str[i]);
 end;

 (*****************************)
 (* procedure dispmenu        *)
 (* prints the selections     *)
 (* available in the box      *)
 (*****************************)
 procedure dispmenu;
 var
   i,colcount,rowcount:byte;
 begin
   colcount:=0;
   rowcount:=0;
   for i:=top to top+(depth*cols)-1 do
     begin
       gotoxy(col+(colcount*maxlen),row+rowcount);
       if cols > 1 then
         inc(colcount)
       else
         inc(rowcount);
       if colcount = cols then
         begin
           colcount:=0;
           inc(rowcount);
         end;
       if i <= num then
         if i=position then
           begin
             inverseon;
             write(m[i]);
             inverseoff;
           end
         else
           write(m[i])
       else
         write(replicate(' ',maxlen));
     end;
   gotoxy(col+1,row-1);
   if top > 1 then
     write('['+#24+']')
   else
     write(replicate(box[2],3));
   gotoxy(col+(cols*maxlen)-3,row+depth);
   if top < num-colnum(num,cols)-(depth*cols)+1 then
     write('['+#25+']')
   else
     write(replicate(box[6],3));
 end;


Begin   (***** of Achoice *****)
         { save old coords and find maximum length }
  oldcol:=wherex;
  oldrow:=wherey;
  box:='╔═╗║╝═╚║';
  top:=position-colnum(position,cols);
  if (depth > num) and (cols = 1) then
    depth:=num;
  if depth*cols > num then
    depth:=(num-colnum(num,cols)+cols) div cols;
  maxlen:=0;
  for i:=1 to num do
    if length(m[i]) > maxlen then
      maxlen:=length(m[i]);
         { make sure all lengths are the same }
  for i:=1 to num do
    m[i]:=m[i]+replicate(' ',maxlen-length(m[i]));

         { draw the box and display the menu initially }
  drawbox(col,row,col+(maxlen*cols)+1,row+depth+1,box);
  inc(col);
  inc(row);
  dispmenu;
  ch:=#1;

         { begining of loop to execute until a choice is made }
         { by pressing <Enter> or aborting with <Esc> }
  repeat
    gotoxy(oldcol,oldrow);
    ch:=upcase(readkey);
    if ch=#0 then
      case readkey of
        #71:begin                           {home}
              position:=1;
              top:=1;
            end;
        #79:begin                           {end}
              position:=num;
              top:=position-colnum(position,cols)-(cols*depth)+cols;
            end;
        #72:if position-cols >= 1 then           {up}
              begin
                dec(position,cols);
                if position < top then
                  dec(top,cols);
              end;
        #80:if position+cols <= num then         {down}
              begin
                inc(position,cols);
                if position > top+(depth*cols)-1 then
                  inc(top,cols);
              end;
        #75:if position > 1 then                 {left}
              begin
                dec(position);
                if position < top then
                  dec(top,cols);
              end;
        #77:if position < num then               {right}
              begin
               inc(position);
               if position > top+(cols*depth)-1 then
                 inc(top,cols);
              end;
        #81:if position+(depth*cols) < num then  {PgDn}
              begin
                inc(position,depth*cols);
                top:=position-colnum(position,cols);
                if top > num-(depth*cols)+1 then
                  top:=num-colnum(num,cols)-(depth*cols)+cols;
              end
            else
              begin
                position:=num;
                top:=position-colnum(position,cols)-(cols*depth)+cols;
              end;
        #73:if position-(depth*cols) > 0 then    {PgUp}
              begin
                dec(position,depth*cols);
                top:=position-colnum(position,cols);
              end
            else
              begin
                position:=1;
                top:=1;
              end;
      end    { of case }
    else
      begin                            { if its not an extended }
        i:=position;                   { scan code, check for }
        repeat                         { a valid letter pressed }
          inc(i);
          if i > num then
            i:=1;
        until (i=position) or (firstletter(m[i])=ch);
        if i <> position then
          position:=i;
        if position > top+(cols*depth)-1 then
          inc(top,cols);
        if position > top+(depth*cols)-1 then
          top:=position-colnum(position,cols);
        if top > num-(depth*cols)+1 then
          top:=num-colnum(num,cols)-(depth*cols)+cols;
        if position < top then
          top:=position-colnum(position,cols);
      end;
      dispmenu;
  until ch in [#27,#13];
  if ch=#27 then
    achoice:=0
  else
    achoice:=position;
  gotoxy(oldcol,oldrow);
End;


BEGIN
END.