Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/MENU456.ZIP/MENU456.PAS

Pascal/Delphi Source File | 1987-11-08 | 15.6 KB | 616 lines

{ This program demonstrates how choices from a menu can be made by pointing
  (like Lotus' 1-2-3) instead of entering a number.
  Most of the routines have been published previously in TUG Lines, I've
  modified some of them to suit my preferences.
}

program menu456;

const
  greeting    = 'Menu 4-5-6 , Version 860205';
  left_arrow  = #$88; {the values for the ADVANTAGE}
  right_arrow = #$86;
  up_arrow    = #$82;
  down_arrow  = #$8a;
  norm_video  = #$02;
  rev_video   = #$01;
  clr_eos     = #$0f; {clear to end of screen}
  max_choices = 6;    { one less than the actual number of choices}
  cr          = #$0d;
  esc         = #$1b;
  not_found   = $ff;
  get_drive   = 25;   { CP/M BDOS calls }
  set_drive   = 14;

type
  string80 = string[80];
  filename_type = string[14];
  choice_type = record         {more information could be included here}
    row           : integer;   { and that information returned by GET_CHOICE,}
    column        : integer;   { instead of just the position of the choice in}
    description   : string[10];{ the array}
    help          : string80;
  end;

var
  choice : array[0..max_choices] of choice_type;
  result : integer;
  current_drive : char;


procedure beep;
begin
  write(#$07);
end;

procedure clreos;
begin
  write(clr_eos);
end;

procedure clear_dialog;
begin
  gotoxy(01, 04); clreol;
  writeln; clreol;
  writeln; clreol;
  writeln; clreol;
  gotoxy(01, 04);
end;

procedure clear_menu;
begin
  gotoxy(01, 02); clreol;
  writeln; clreol;
end;

procedure pause;
var
  c : char;

begin
  gotoxy(01, 24);
  write(rev_video, 'Press any key to continue', norm_video);
  clreol;
  read(kbd, c);
end;

procedure display_greeting;

begin
  clrscr;
  gotoxy(20, 10);
  write(greeting);
  gotoxy(22, 11);
  write('Public Domain Software');
  gotoxy(18, 12);
  write('by Abrahamsen Consulting, 1986');
  pause;
  clrscr;
end;

function get_filename : filename_type;
var
  filename : filename_type;

begin
  write('(D:Filename.Ext) => ');
  readln(filename);
  get_filename := filename;
end;

procedure turn_on(choice : choice_type);  {highlights a menu choice}
begin
  with choice do
    begin
      gotoxy(column, row);
      write(rev_video, description, norm_video);
    end;
end;

procedure turn_off(choice : choice_type); {cancels the highlighting}
begin
  with choice do
    begin
      gotoxy(column, row);
      write(norm_video, description);
    end;
end;

procedure initialize_choices; { puts the descriptions of the menu choices}
                              { and their location on the screen in the  }
var                           { CHOICE array }
  i : integer;

begin
  with choice[0] do
    begin
      description := 'copy';
      help := 'copy a text file and give it a new name';
      row := 1;
      column := 1;
    end;
  with choice[1] do
    begin
      description := 'rename';
      help := 'rename any file on disk';
      row := 1;
      column := choice[0].column + length(choice[0].description) + 2;
    end;
  with choice[2] do
    begin
      description := 'erase';
      help := 'erase any file from disk';
      row := 1;
      column := choice[1].column + length(choice[1].description) + 2;
    end;
  with choice[3] do
    begin
      description := 'view';
      help := 'view a text file on the screen';
      row := 1;
      column := choice[2].column + length(choice[2].description) + 2;
    end;
  with choice[4] do
    begin
      description := 'directory';
      help := 'display the directory of the selected disk drive';
      row := 1;
      column := choice[3].column + length(choice[3].description) + 2;
    end;
  with choice[5] do
    begin
      description := 'select';
      help := 'select a new disk drive';
      row := 1;
      column := choice[4].column + length(choice[4].description) + 2;
    end;
  with choice[6] do
    begin
      description := 'quit';
      help := 'quit this program and return to your operating system';
      row := 1;
      column := choice[5].column + length(choice[5].description) + 2;
    end;

end;

procedure display_help(choice : choice_type);

begin
  gotoxy(01, 02);
  clreol;
  write(choice.help);
end;

procedure display_choices;

var
  i : integer;
  bar : string[80];

begin
  clear_menu;
  clear_dialog;
  bar[0] := char(80);
  fillchar(bar[1], 80, '=');
  gotoxy(01, 03);
  write(bar);
  gotoxy(01, 08);
  write(bar);
  for i := 0 to max_choices do
    with choice[i] do
      begin
        gotoxy(column, row);
        write(description);
      end;
   display_help(choice[0]);
   turn_on(choice[0]);

end; {display_choices}


function get_choice : integer;

var
  c : char;
  i, current, last : integer;
  valid_choices : set of char;

label
  skip_pointing;

begin
  last := 0;
  current := 0;
  valid_choices := [];
  for i := 0 to max_choices do  { build set of valid choices }
    valid_choices := valid_choices + [upcase(choice[i].description[1])];
  repeat                        {loop until they hit the RETURN key}
    read(kbd, c);
    c := upcase(c);
    if c in valid_choices then  { find index into array }
      begin
        turn_off(choice[0]);
        current := 0;
        while (c <> upcase(choice[current].description[1])) do
          current := current + 1;
        turn_on(choice[current]);
        goto skip_pointing;
      end;

    case c of
      right_arrow, ^D : begin
                          last := current;
                          current := last + 1;
                        end;

      left_arrow,  ^S : begin
                          last := current;
                          if last <> 0 then
                            current := last - 1
                          else
                            current := max_choices;
                        end;

       else             if c <> cr then beep;
    end; {case}

    if c in [left_arrow, right_arrow, ^D, ^S] then
      begin
        current := current mod (max_choices + 1);
        turn_off(choice[last]);
        display_help(choice[current]);
        turn_on(choice[current]);
      end;
  until c = cr; {end repeat}
skip_pointing:
  get_choice := current;
end; {get_choice}

procedure copy_file;
var
  file_in, file_out : text;
  filename_in, filename_out : filename_type;
  ok : boolean;
  line : string[80];

begin
  clear_dialog;
  gotoxy(01, 04);
  write('Enter filename to copy FROM ');
  filename_in := get_filename;
  if length(filename_in) > 0 then
    begin { filename_in supplied }
      {$I-}
      assign(file_in, filename_in);
      reset(file_in);
      {$I+}
      if ioresult = 0 then
        begin { no error opening file_in }
          write('Enter filename to copy TO ');
          filename_out := get_filename;
          if length(filename_out) > 0 then
            begin { filename_out supplied }
              {$I-}
              assign(file_out, filename_out);
              rewrite(file_out);
              {$I+}
              if ioresult = 0 then
                begin { no error opening file_out }
                  while not eof(file_in) do
                    begin
                      readln(file_in, line);
                      writeln(file_out, line);
                    end;
                  close(file_in);
                  close(file_out);
                end   { file copied }
              else
                begin { error opening file_out }
                  beep;
                  write('File not copied');
                  pause;
                end; { open error }
            end; { filename_out supplied }
        end; { no error opening file_in }
    end;  { filename_in supplied }
  clear_dialog;
end; { copy file }

procedure rename_file;

var
  oldfile : text;
  filename : filename_type;
  ok : boolean;

begin
  clear_dialog;
  gotoxy(01, 04);
  write('Enter old filename ');
  filename := get_filename;
  if length(filename) > 0 then
    begin
      assign(oldfile, filename);
      write('Enter new filename ');
      filename := get_filename;
      if length(filename) > 0 then
        begin
          {$I-}
          rename(oldfile, filename);
          {$I+}
          ok := (ioresult = 0);
          if not ok then
            begin
              beep;
              write('File not renamed');
              pause;
            end;
        end;
    end;
  clear_dialog;
end;

procedure erase_file;
var
  oldfile : text;
  filename : filename_type;
  ok : boolean;

begin
  clear_dialog;
  gotoxy(01, 04);
  write('Enter filename ');
  filename := get_filename;
  if length(filename) > 0 then
    begin
      assign(oldfile, filename);
      {$I-}
      close(oldfile);
      erase(oldfile);
      {$I+}
      ok := (ioresult = 0);
      if not ok then
        begin
          beep;
          write('File not found');
          pause;
        end;
    end;
end;

procedure view_file; { this works only for text files }
var
  oldfile : text;
  filename : filename_type;
  ok : boolean;
  line : string80;
  lines : integer;
  c : char;

begin
  clear_dialog;
  gotoxy(01, 04);
  write('Enter filename ');
  filename := get_filename;
  if length(filename) > 0 then { check to see if the file is present }
    begin
      assign(oldfile, filename);
      {$I-}
      reset(oldfile);
      {$I+}
      ok := (ioresult = 0);
      if not ok then
        begin
          beep;
          write('File not found');
          pause;
       end
    else
      while (c <> esc) and (not eof(oldfile)) do
        begin
          gotoxy(01, 04);
          clreos;
          lines := 1;
          while (lines < 21) and (not eof(oldfile)) do
            begin
              readln(oldfile, line);
              writeln(line);
              lines := lines + 1;
            end;
          write(rev_video, 'Press any key to continue, ESC to stop.', norm_video);
          read(kbd, c);
        end;
    gotoxy(01,04);
    clreos;
  end;
end;

procedure directory;

const
  files_per_page = 65;
  max_files      = 130; { always a multiple of files_per_page }
  scan_first     = 17;
  scan_next      = 18;
  set_dma        = 26;
  fcb_1          = $5c;
  fcb_2          = $80;

type
  dir_entry  = string[12];
  a_dir      = array[1..max_files] of dir_entry;

var
  number_of_files, number_of_pages, page_number, j, k : integer;
  dma_buf : array[1..130] of byte;
  dir_buf : a_dir;
  c : char;

{$A-}
procedure sort(left, right : integer); { sort filenames before display }
var
  new_left, new_right : integer;
  center_value, temp : dir_entry;

begin
  if ((right - left) > 1) then
    begin
      center_value := dir_buf[(left + right) div 2];
      new_left := left;
      new_right := right;
      while (new_left <= new_right) do
        begin
          while (dir_buf[new_left] < center_value) do
            new_left := succ(new_left);
          while (dir_buf[new_right] > center_value) do
            new_right := pred(new_right);
          if (new_left <= new_right) then
            begin
              temp := dir_buf[new_left];
              dir_buf[new_left] := dir_buf[new_right];
              dir_buf[new_right] := temp;
              new_left := succ(new_left);
              new_right := pred(new_right);
            end; { if }
       end; { while (new_left <= new_right) }
       sort(left, new_right);
       sort(new_left, right);
    end
  else
    if ((right - left) = 1) then
      if dir_buf[right] < dir_buf[left] then
        begin
          temp := dir_buf[right];
          dir_buf[right] := dir_buf[left];
          dir_buf[left] := temp;
        end;
end; { sort }
{$A+}

procedure display_dir_page(page_number, number_of_pages : integer);
var
  i, k, rows : integer;

begin
  gotoxy(01, 09);
  clreos;
  writeln('Selected drive => ', rev_video, current_drive, norm_video);
  gotoxy(50, 09);
  writeln('Files: ', number_of_files:3, '  Page: ', page_number:1, ' of ', number_of_pages:1);
  if page_number < number_of_pages then
    rows := 13
  else { this is the last page }
    begin
      i := number_of_files mod files_per_page; { how many files on last page }
      rows := i div 5; { in how many rows to display them? }
      if (i mod 5) > 0 then
        rows := rows + 1;
    end;
  k := (page_number - 1) * files_per_page; { offset into dir_buf for this page }
  for i := 1 to rows do
    writeln(dir_buf[k + i],        '   ',
            dir_buf[k + i + rows], '   ',
            dir_buf[k + i + (2 * rows)], '   ',
            dir_buf[k + i + (3 * rows)], '   ',
            dir_buf[k + i + (4 * rows)]);
  gotoxy(01, 24);
  write(rev_video, 'next page - downarrow   prev. page - uparrow  quit - <cr>', norm_video);
end;

begin
  mem[fcb_1] := 0;
  for j :=  1 to 11 do mem[fcb_1 + j] := ord('?');
  for j := 12 to 36 do mem[fcb_1 + j] := 0;
  for j :=  1 to max_files do dir_buf[j] := ' ';
  number_of_files := 1;
  bdos(set_dma, addr(dma_buf[1]));
  j := bdos(scan_first, fcb_1);    { get first filename }
  if j <> not_found then           { if no error, move filename }
    begin
      dma_buf[j * 32 + 1] := 11;
      move(dma_buf[j * 32 + 1], dir_buf[number_of_files], 12);
      j := bdos(scan_next, fcb_1); { find next filename }
      while (j <> not_found) and (number_of_files <= max_files) do
        begin
          number_of_files := number_of_files + 1;
          k := j * 32 + 1;
          dma_buf[k] := 11;
          move(dma_buf[k], dir_buf[number_of_files], 12);
          j := bdos(scan_next, fcb_1);
        end;
      bdos(set_dma, fcb_2);
      for j := 1 to number_of_files do insert('.', dir_buf[j], 9);
      sort(1, number_of_files);
      number_of_pages := number_of_files div files_per_page;
      if (number_of_files mod files_per_page) > 0 then
        number_of_pages := number_of_pages + 1;
      page_number := 1;
      repeat
        display_dir_page(page_number, number_of_pages);
        read(kbd, c);
        if (c = down_arrow) and (page_number < number_of_pages) then
          page_number := succ(page_number)
        else
          if (c = up_arrow) and (page_number > 1) then
            page_number := pred(page_number)
          else
            if not (c in [cr, esc]) then beep;
      until (c in [cr, esc]);
    end { if first scan is okay }
  else
    begin
      writeln;
      write('No files found.');
    end;
end; { directory }

procedure select_drive;

var
  drive : char;
  valid_drives : set of char;
  drive_number : integer;

begin
  drive := ' ';
  valid_drives := ['A', 'B'];
  while not (drive in valid_drives) do
    begin
      clear_dialog;
      write('Enter drive to select => ');
      read(drive);
      drive := upcase(drive);
      if not (drive in valid_drives) then
         begin
           beep;
           gotoxy(01, 24);
           clreol;
           write(rev_video, 'Invalid drive letter', norm_video);
         end; { invalid drive entered }
    end; { while }
  drive_number := ord(drive) - ord('A');
  current_drive := drive;
  bdos(set_drive, drive_number);
  directory;
end;  { select drive }

begin { main }
  initialize_choices;
  display_greeting;
  current_drive := chr(bdos(get_drive) + 65);
  repeat
    display_choices;
    result := get_choice;
    case result of
      0 : copy_file;
      1 : rename_file;
      2 : erase_file;
      3 : view_file;
      4 : directory;
      5 : select_drive;
      6 : clrscr;
    end; { case }
  until (result = max_choices);
end. { main }