Power-Programmierung/CD1.mdf/pascal/library/dos/menu/pulldw/pulldown.pas

Pascal/Delphi Source File | 1987-12-04 | 17.6 KB | 743 lines

unit pulldown;

{- contains menu and window routines }
interface
uses dos,crt;
{$V-}



const
     VIDSEG       : word    = $b000;
     NOCURSOR               = $2000;
     PLAINCURSOR  : word    = $0607;

var
    ch:char;
    oldtextattr : integer;

type str80    = string[80];
     str30    = string[30];
     anystr   = string[255];
     windcoord=record
                 wx,wy,wwid,wheight,wcolor : integer;
                 lastx,lasty : integer;
                end;

     FKEYS = (UPKEY,DOWNKEY,LEFTKEY,RIGHTKEY,CR,HOMEKEY,ENDKEY,PGUPKEY,PGDNKEY,
             ESCKEY,f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,NOFKEY,TABKEY);

     savedwindow = array[1..2000] of byte;
     strptr      = ^string;
     FKEYSET     = set of FKEYS;

var
   wind           : array[1..10] of windcoord;
   fkey           : FKEYS;
   choice,choice2 : integer;
   savedwin       : array[1..5] of ^savedwindow;


procedure SetCursor(Newcursor:word);

procedure MoveToScreen(Var Source,Dest; Length: Integer);

procedure MoveFromScreen(Var Source,Dest; Length: Integer);

procedure read_key(var ch:char; var key:FKEYS);

procedure field_str(X,Y,L:integer;attribute:byte; s:str80);

procedure get_field_str(X,Y,L:integer;var s:str80);

procedure field_attr(x,y,len,attr : integer);

procedure makewindow(num,x,y,wid,height,color:integer;
                                    title:str80 );

procedure closewindow(num:integer);

procedure pulldownmenu(
                 var txt1   : anystr;
                 default,
                 subdefault : integer;
                 var choice,
                 subchoice  : integer
                                     );




implementation

const
  MENUFLOWTHRU : boolean = FALSE;

var
  color, revcolor, bordercolor : integer;


procedure InitDisplay;
{
  Initializes various global variables - must be called before using the
  above procedures and functions.  If this is compiled as a UNIT, simply
  place a call to InitDisplay before the 'end.'.
}

var
  Reg        : Registers;
  colorcard  :boolean;

begin
  Reg.AH := 15;
  Intr($10, Reg);
  ColorCard := Reg.AL <> 7;
  if ColorCard then
    VIDSEG := $B800
  else
    VIDSEG := $B000;
end; { InitDisplay }

procedure SetCursor(Newcursor:word);
var
  Reg : Registers;
begin
  with Reg do
  begin
    AH := 1;
    BH := 0;
    CX := NewCursor;
  end;
  Intr($10, Reg);
end;


procedure MoveToScreen(Var Source,Dest; Length: Integer);

  Begin
    If VIDSEG=$b000 Then Move(Source,Dest,Length)
    Else
     Begin
      Length:=Length Shr 1;
      Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
             Length /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
             $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
     End;
  End;

procedure MoveFromScreen(Var Source,Dest; Length: Integer);
  Begin
    If VIDSEG=$b000 Then Move(Source,Dest,Length)
    Else
     Begin
      Length:=Length Shr 1;
      Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Dest /$8B/$8E/
             Length /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
             $FB/$AB/$E2/$F0/$5D/$1F);
     End;
  End;




procedure read_key(var ch:char; var key:FKEYS);

{
  Returns a character in ch; or, if a function key was perssed, an FKEY
  type in key
}


var cch : char;

begin
  ch:=readkey;
  case ch of
   #13 : key := CR;
   #9  : key := TABKEY;
   #27 : if not(keypressed) then key := ESCKEY;
   #0  :
           begin
             cch:=readkey;
             case cch of
               #72 : key := UPKEY;
               #77 : key := RIGHTKEY;
               #80 : key := DOWNKEY;
               #75 : key := LEFTKEY;
               #71 : key := HOMEKEY;
               #79 : key := ENDKEY;
               else  key := NOFKEY;
             end;
           end;
   else key:=NOFKEY;
  end;
end;





procedure field_str(X,Y,L:integer;attribute:byte; s:str80);

{
  Similar to Turbo Prolog's field_str predicate.  Displays a string at
  coordinates x and y with a length of L.  If the string is shorter than
  L, then it is padded with spaces.  Attribute determines the color.
}

type
  stc = record
          ch  : char;
          color : byte;
        end;

var
  I,J,L1     : Integer;
  C          : Char;
  stbuf      : array[1..80] of stc;
  screen     : ^integer;

begin  {print}
  L1:= Length(S);
  J :=((Y-1)*160) + ((X-1)*2);      { compute starting location }
  fillchar(stbuf,sizeof(stbuf),attribute);
  screen := ptr(VIDSEG,j);
  i := 1;
  while i <= l do
      begin
        stbuf[ i ].ch := S[I];
        inc(i);
      end;

  while l1 < l do
      begin
        stbuf[l1+1].ch := ' ';
        inc(L1);
      end;
  if l1>l then l1:=l;

  movetoscreen(stbuf[1],screen^,l1 * 2);
end; { of print }





procedure get_field_str(X,Y,L:integer;var s:str80);

{
  Like field_str above, but with a different flow-pattern: S is returned.

}

type
  stc = record
          ch  : char;
          color : byte;
        end;

var
  I,J,L1     : Integer;
  C          : Char;
  stbuf      : array[1..80] of stc;
  screen     : ^ integer;
  s1         : str80 absolute s;

begin  {print}
  J :=((Y-1)*160) + ((X-1)*2);      { compute starting location }
  screen := ptr(VIDSEG,j);
  movefromscreen(screen^,stbuf[1],l*2);
  i := 1;
  while i <= l do
      begin
        s1[i] := stbuf[i].ch;
        inc(i);
      end;
  s1[0] := chr(l);
end; { of print }


procedure field_attr(x,y,len,attr : integer);

{
  changes the attribute a a field on the screen
}

var
  s  : str80;

begin
  get_field_str(x,y,len,S);
  field_str(x,y,len,attr,s);
end;


procedure parse(var s, piece: anystr);

{
  Only for parsing menu elements.  The parsing token is the '|' character.
  CAUTION: This procedure takes the string 's', returns the first parsed part
  in 'piece', and removes that piece from s.  S, therefore, is permanently
  altered.
}

var
   ix,l : integer;

begin
 while ( ord(s[0]) > 0 ) and ( s[1] = '|') do
   delete(s,1,1);

 ix:=pos('|',s);

 if ix=0 then
   begin
     piece:=s;
     s:='';
   end
 else
   begin
     piece := copy(s,1,ix-1);
     delete(s,1,ix);
   end;
end;



procedure savewindow(num,x,y,wid,height:integer);

{
  Saves on the heap the current contents of the screen defined by x,y,wid,
  and height.
}

var ix, i,start : integer;
pointer : ^integer;
size    : integer;
s       : string[80];

begin
  size := (wid+1) * (height+1) * 2;

  getmem(savedwin[num],size);
  ix := 1;
  for i := y to y+height do
    begin
      start:=((i-1)*160) + ((X-1)*2);
      pointer := ptr(VIDSEG,start);
      movefromscreen(pointer^ ,savedwin[num]^[ix],(wid+1)*2);
      ix := ix + (wid+1) *2;
    end;

end;




procedure DrawBox(X,Y,Wid,Height,color: integer);


var
   I : integer;

begin
      field_str(x,y,1,color,'┌');

      for i:= X+1 to X+Wid-1 do field_str(i,y,1,color,'─');
      field_str(x+wid,y,1,color,'┐');

      for i:= Y+1 to Y+height-1 do
        begin
             field_str(x,i,1,color,'│');
             field_str(x+wid,i,1,color,'│');
        end;

       field_str(x,y+height,1,color,'└');
       for i:= X+1 to X+Wid-1 do field_str(i,y+height,1,color,'─');
       field_str(x+wid,y+height,1,color,'┘');
end;

procedure makewindow(num,x,y,wid,height,color:integer;
                                    title:str80 );
{
  Similar to the Turbo Prolog predicate of the same name.
}

var
  i,diff, newx : integer;
  start,ix : integer;
  pointer : ^integer;
  oldattr:byte;

begin

  if wind[num].wx <> x then
   begin
    savewindow(num,x,y,wid,height);
    drawbox(x,y,wid,height,bordercolor);
    if length(title)>0 then
      begin
        diff:=wid-length(title);
        newx:=x+diff div 2;
        field_str(newx,y,length(title),bordercolor,title);
      end;
    window(x+1,y+1,x+wid-1,y+height-1);
{   textattr:=color;   }
{   clrscr;            }
{   textattr:=oldattr; }

    for i:= 1 to height-1 do
      field_str(x+1,y+i,wid-1,color,' ');

    with wind[num] do
      begin
       wx:=x;
       wy:=y;
       wwid:=wid;
       wheight:=height;
       wcolor:=color
      end;
   end;
end;



procedure closewindow(num:integer);
{
  Closes a window previously created with number = 'num'.  Restores the
  screen to its state previous to the window's creation. Releases heap memory
  used to store this image.
}

var ix, i,start : integer;
pointer         : ^integer;
size            : integer;

begin
  with wind[num] do
   if wx <> 0 then
    begin
      size := (wwid+1) * (wheight+1) * 2;
      ix := 1;
      for i := wy to wy+wheight do
        begin
          start:=((i-1)*160) + ((wx-1)*2);
          pointer := ptr(VIDSEG,start);
          movetoscreen(savedwin[num]^[ix],pointer^ ,(wwid+1)*2);
          ix := ix + (wwid+1) * 2;
        end;
    end;
  freemem(savedwin[num],size);
  wind[num].wx := 0;
  window(1,1,80,25);
end;

procedure menu(num,x,y,color : integer;
               title         : STR80;
               txt1          : anystr;
               default       : integer;
               var choice    : integer;
               var returnkey : FKEYS     );

{
  Implements a popup menu defined by a string txt1 in the format:

  'choice1|choice2|....choiceN'

  The string must be <= 255 chars long.
}

label
  stop;

var
  i,listlen,maxlen : integer;
  dir              : FKEYS;
  c                : char;
  s,s1             : anystr;
  txt              : array[1..20] of anystr;
  term             : FKEYSET;

begin
  if length(txt1)=1 then   { signals that no sub-menu is implemented here }
    begin
      choice    := 0;
      returnkey := NOFKEY;
      goto         stop;
    end;

  {
   If this menu is part of a pulldown system, then we want to exit when
   LEFTKEY or RIGHTKEY are pressed; otherwise, only if enter of escape are
   pressed.
  }

  if MENUFLOWTHRU then term := [LEFTKEY,RIGHTKEY,CR,ESCKEY]
   else term := [CR,ESCKEY];

  { paint picture of menu... }

  { parse s into choices and count them }
  listlen:=0;
  s:=txt1;
  i:=1;
  repeat
    parse(s,s1);
    txt[i]:=s1;
    inc(i);
  until (s = '') ;
  listlen := i-1;

  { find the longest choice, so that the window may be properly sized... }
  maxlen := 0;
  for i:= 1 to listlen do
    if length(txt[i]) > maxlen then maxlen := length(txt[i]);

  { ... present the choices }
  if x + maxlen + 2 > 80 then x := 80-maxlen-2;
  makewindow(num,x,y,maxlen+2,listlen+1,color,title);
  for i:= 1 to listlen  do
    field_str(x+1,y+i,maxlen+1,color,txt[i]);
  choice := default;
  repeat
    field_str(x+1,y+choice,maxlen+1,revcolor,txt[choice]);
    read_key(c,dir);
    case dir of
      UPKEY: begin
               field_str(x+1,y+choice,maxlen+1,color,txt[choice]);
               if choice = 1 then choice := listlen
                 else dec(choice);
             end;
    DOWNKEY: begin
               field_str(x+1,y+choice,maxlen+1,color,txt[choice]);
               if choice = listlen then choice := 1
                 else inc(choice);
             end;
   ESCKEY : if not MENUFLOWTHRU then choice := 0;
   ENDKEY : begin
            field_str(x+1,y+choice,maxlen+1,color,txt[choice]);
            choice := listlen;
            end;
  HOMEKEY : begin
            field_str(x+1,y+choice,maxlen+1,color,txt[choice]);
            choice := 1;
            end;
   NOFKEY : begin { use first letter of choice }
              c:=upcase(c);
              i:=0;
              repeat
                inc(i);
              until(txt[i][1]=c) or (i=listlen);
              if txt[i][1]=c then
                begin
                  field_str(x+1,y+choice,maxlen+1,color,txt[choice]);
                  choice:=i;
                  dir:=CR;
                  field_str(x+1,y+choice,maxlen+1,revcolor,txt[choice]);
                end;
            end;

    end;
  until (dir in term);
  closewindow(num);
  returnkey:=dir;
  stop:
end;


procedure pulldownmenu(
                 var txt1   : anystr;
                 default,
                 subdefault : integer;
                 var choice,
                 subchoice  : integer
                                     );
{
  Implements a pulldown menu system
}


var
  i,listlen,maxlen : integer;
  dir              : FKEYS;
  c                : char;
  s,s1             : anystr;
  txt              : array[1..10] of string[20];
  txtpos           : array[1..10] of integer;
  term             : FKEYSET;
  top              : str80;
  submen           : array[1..10] of strptr;
  subline          : string;
  cumlen           : integer;
  rkey             : FKEYS;
  items            : integer;

const
  curchoice:array[1..10] of integer=(1,1,1,1,1,1,1,1,1,1);
  { this allows us to return to the menu state in effect when the last
    choice was made.
  }
  PULLEDDOWN :boolean = FALSE;

begin
  term := [CR,ESCKEY];
  setcursor(NOCURSOR);   { the cursor muddies up the menus }
  (* paint picture of menu *)
  listlen:=0;
  s:=txt1; { assign to a local variable, since parsing destroys it }

  i:=1;
  txtpos[1]:=1;
  repeat
    parse(s,s1);
    txt[i]:=s1;
    inc(i);
  until (s = '') ;
  listlen := i-1;

  for i:=2 to listlen do
    txtpos[i]:= txtpos[i-1]+length(txt[i-1])+2;
    { the positions of the choices on the bar menu }

  top := txt1;
  cumlen:=length(txt1) + 1;

  { after getting and parsing the top line of the menu, get the strings
    defining the pulldown menus.  These must be typed constants, as must
    the top line, and they must be declared in order directly after the
    declaration of the top line ( see the program's constant declaration
    part, below.)  For top-menu items without a sub-menu (e.g., Edit, in
    the Turbo Parcal menu) declare a string like this:

                     const
                       s : string[1] = ' ';

  }

  for i := 1 to listlen do
    begin
      submen[i] := ptr(dseg,ofs(txt1)+cumlen);
      { typed constants are in the data segment in ver. 4.0. If using ver.
        3.0, try using 'cseg'
      }
      inc(cumlen,length(submen[i]^));
      inc(cumlen);
      {cumlen := cumlen + length(submen[i]^)+1;}
    end;




  gotoxy(1,1);
  for i:= 1 to listlen  do
    write(txt[i],'  ');

  choice := default;
  subchoice := subdefault;

  MENUFLOWTHRU:=TRUE;  { force a return from menu for LEFTKEY or RIGHTKEY }
  repeat
    field_str(txtpos[choice],1,ord(txt[choice][0]),revcolor,txt[choice]);
    subline:=submen[choice]^;
    if (subline = ' ') or ( not PULLEDDOWN) then
      read_key(c,dir)
    else
      menu(1,txtpos[choice],2,color,'',subline,
             curchoice[choice],subchoice,dir);
    case dir of
   LEFTKEY: begin
              field_str(txtpos[choice],1,ord(txt[choice][0]),color,txt[choice]);
              curchoice[choice]:=subchoice;
              if choice = 1 then choice := listlen
                else dec(choice);
            end;
  RIGHTKEY: begin
              field_str(txtpos[choice],1,ord(txt[choice][0]),color,txt[choice]);
              curchoice[choice]:=subchoice;
              if choice = listlen then choice := 1
                else inc(choice);
            end;
   ESCKEY : if PULLEDDOWN and (subline <> ' ') then
              begin
                PULLEDDOWN := FALSE;
                dir := NOFKEY;
                curchoice[choice] := subchoice;
              end
            else choice := 0;
       CR : case PULLEDDOWN of
            TRUE: if subline <> ' ' then
                    curchoice[choice] := subchoice
                  else curchoice[choice] := 1;
            FALSE:if subline <> ' ' then
                    begin
                      PULLEDDOWN := TRUE;
                      dir := NOFKEY;
                    end;
             end;
   DOWNKEY: PULLEDDOWN := TRUE;
   ENDKEY : begin
              field_str(txtpos[choice],1,ord(txt[choice][0]),color,txt[choice]);
              choice := listlen;
            end;
  HOMEKEY : begin
              field_str(txtpos[choice],1,ord(txt[choice][0]),color,txt[choice]);
              choice := 1;
            end;
   NOFKEY : begin
              c:=upcase(c);
              i:=0;
              repeat
                inc(i);
              until(txt[i][1]=c) or (i=listlen);
              if txt[i][1]=c then
                begin
                  field_str(txtpos[choice],1,ord(txt[choice][0]),color,txt[choice]);
                  choice:=i;
                  if submen[choice]^ = ' ' then dir:=CR
                    else PULLEDDOWN := true;
                  field_str(txtpos[choice],1,ord(txt[choice][0]),revcolor,txt[choice]);
                end;
            end;

    end;
  until (dir in term);
  MENUFLOWTHRU:=FALSE;
  setcursor(PLAINCURSOR);
end;



procedure initmenus;
{
  Defines the colors to be used for the menu windows and frames.  There
  is certainly a more direct way to do this.
  If compiled as a unit, make a call to this procedure in the initialization
  part.
}

begin
  fillchar(wind,sizeof(wind),0);
  textcolor(lightgray);
  textbackground(blue);
  color := textattr;
  if vidseg = $b800 then textcolor(blue)
    else textcolor(black);
  if vidseg = $b800 then textbackground(lightgray)
    else textbackground(white);
  revcolor := textattr;
  textcolor(lightgray);
  textbackground(black);
  bordercolor:=textattr;
  textattr:=color;
end;



begin
  oldtextattr := textattr;
  initdisplay;
  if VIDSEG =$B000 then PLAINCURSOR := $0B0C;
  initmenus;
  fillchar(wind,sizeof(wind),0);
  choice := 1; choice2:=1;
end.