Fancy input for console program.

fancyInput.pas

program fancyInput;

(*****************************************************************************
  This program demonstrates fancy input mechanism for console application by
  simply using CRT unit. For example selecting an item from a drop down menu,
  length-limited phone number input, and yes/no input. Hopefully, new Pascal
  beginners will learn something from this sample program. Thank you. :)

  //! WARNING! This program requires FPC v3.2+ with compiler option -S2chij-

  Author: @pakLebah a.k.a Mr. Bee
  Update: January, 2020
 *****************************************************************************)

uses CRT;

type
  ArrayOfString = array of string;
  ArrayOfChar   = array of char;

// text positioning shortcut
procedure writeAt(const x, y: integer; const text: string);
begin
  gotoXY(x, y);
  write(text);
end;

// text coloring shortcut
procedure textColors(const fore, back: integer; const text: string);
begin
  textColor(fore);
  textBackground(back);
  write(text);
end;

// print menu with selected item
procedure printMenu(const x, y, selected: integer; const items: ArrayOfString);
var
  i: integer;
begin
  for i := 0 to length(items)-1 do
  begin
    gotoXY(x, y+i);
    if i = selected then
      textColors(black, lightGray, '» '+items[i]+' «')
    else
      textColors(lightGray, darkgray, '  '+items[i]+'  ');
  end;
end;

// clear printed menu items
procedure clearMenu(const x, y, count: integer);
var
  i: integer;
begin
  for i := 1 to count do
  begin
    gotoXY(x, y+i-1);
    clrEOL;
  end;
  gotoXY(x, y);
end;

// read input using menu selection
function readMenu(const items: ArrayOfString; const isRotate: boolean): integer;
var
  key: char = #0;
  i, line, sel: integer;
  count, row, col: integer;
begin
  sel := 0;
  col := whereX;
  row := whereY;
  count := length(items);
  highVideo;

  // make sure there is enough lines for menu items
  line := screenHeight - row;
  if line <= count then
  begin
    for i := 1 to count do writeln;
    row := row - (count-line);
  end;
  printMenu(col, row, sel, items);

  repeat
    if keyPressed then
    begin
      key := readKey;
      if key = #0 then                 // control keys
      begin
        key := readKey;
        case key of
          #72, #75: sel -= 1;          // up+left arrow
          #77, #80: sel += 1;          // down+right arrow
        end;
        // limit cursor movement
        if sel < 0 then
          if isRotate then sel := count-1 else sel := 0;
        if sel > count-1 then
          if isRotate then sel := 0 else sel := count-1;
      end
      else                             // ASCII keys
      begin
        case key of
          #13 : {nothing};             // enter to select item
          #27 : sel := -1;             // esc to cancel menu
        end;
      end;
      printMenu(col, row, sel, items);
    end;
  until (key = #13) or (key = #27);

  // clear menu and print selection
  normVideo;
  clearMenu(col, row, count);
  if sel >= 0 then writeln(items[sel]) else writeln('–');
  result := sel;
end;

// query using menu selection
function askMenu(const query: string; const items: ArrayOfString): integer;
begin
  write(query); ClrEol;
  result := readMenu(items, length(items) >= 4);
end;

// query using selected answer
function askBool(const query: string; const answers: ArrayOfChar): boolean;
var
  key: char;
  valid: boolean = false;
  i, answer, count: integer;
begin
  write(query);
  count := length(answers);
  repeat
    if keyPressed then
    begin
      key := readKey;
      // validate input against answers
      for i := 0 to count-1 do
      begin
        valid := (upCase(key) = upCase(answers[i])) or (key = #27);
        if valid and (key <> #27) then
        begin
          answer := i+1;
          write(key);
          break;
        end;
      end;
      // array item must be even, first half for true values
      result := (answer <= count div 2) and (key <> #27);
    end;
  until valid or (key = #27);
  writeln;
end;

// query accepting numbers only
function askNumber(const query: string; const count: integer): string;
var
  key: char;
  valid: boolean = false;
  i, cursor, col: integer;
begin
  // just skip invalid query
  if count <= 0 then writeln(query) else write(query);
  if count <= 0 then exit;

  // print length limit
  col := whereX;
  if count > 0 then  // show input length limit
    for i := 1 to count do write('_');
  gotoXY(col, whereY);

  cursor := 1;
  result := '';
  repeat
    if keyPressed then
    begin
      key := readKey;
      // validate digit input
      if cursor = 1 then
        valid := (key in ['0'..'9','+','-',#13,#27]) and (cursor <= count+1)
      else
        valid := (key in ['0'..'9',#8,#13,#27]) and (cursor <= count+1);
      // print digit only
      if valid and not (key in [#8,#13,#27]) then
      begin
        cursor += 1;
        if (count > 0) and (cursor > count) then cursor := count+1;
        // accept input only within limit
        if cursor <= count+1 then
        begin
          writeAt(col+cursor-2, whereY, key);
          result += key;
          // reject input beyond limit
          if cursor = count+1 then
          begin
            result[count] := key;
            result := copy(result, 1, cursor-1);
          end;
        end;
      end;
      // cancel input (escape)
      if valid and (key = #27) then
      begin
        gotoXY(col, whereY);
        for i := 1 to count do write('_');
        result := '';
      end;
      // erase last char (backspace)
      if valid and (key = #8) and (cursor > 1) then
      begin
        cursor -= 1;
        result := copy(result, 1, cursor-1);  // remove last char
        writeAt(col+cursor, whereY, key+'_');
        gotoXY(col+cursor-1, whereY);
      end;
    end;
  until (key = #13) or (key = #27);
  writeln;
end;

// query for simple unlimited text
function askText(const query: string): string;
begin
  write(query); ClrEOL;
  readln(result);
end;

(***** MAIN PROGRAM *****)

var
  // this open array declaration requires FPC v3.2+
  teachers: ArrayOfString = ('Bambang, S.Pd','Ningsih, A.Md','Drs. Pujiyono');
  studies : ArrayOfString = ('Fisika ','Biologi','Sosial ','Bahasa ');
  grades  : ArrayOfString = ('Kelas 7','Kelas 8','Kelas 9');
  genders : ArrayOfString = ('Laki-laki','Perempuan');
var
  gender, grade, study, teacher: integer;
  name, address, phone: string;
  again: boolean = false;

begin
  repeat
    // get input
    writeln('MASUKKAN DATA BERIKUT');
    writeln('–––––––––––––––––––––');
    name    := askText  ('Nama lengkap    : ');
    gender  := askMenu  ('Jenis kelamin   : ',genders);
    address := askText  ('Alamat rumah    : ');
    phone   := askNumber('Nomor ponsel    : ',15);
    grade   := askMenu  ('Tingkat kelas   : ',grades);
    study   := askMenu  ('Jurusan studi   : ',studies);
    teacher := askMenu  ('Nama wali kelas : ',teachers);
    writeln;
    // confirm input
    writeln('Data telah diterima:');
    writeln('Nama lengkap    = ',name);
    if gender  >= 0 then writeln('Jenis kelamin   = ',genders[gender]);
    writeln('Alamat rumah    = ',address);
    writeln('Nomor ponsel    = ',phone);
    if grade   >= 0 then writeln('Tingkat kelas   = ',grades[grade]);
    if study   >= 0 then writeln('Jurusan studi   = ',studies[study]);
    if teacher >= 0 then writeln('Nama wali kelas = ',teachers[teacher]);
    writeln;
    // repeat input
    again := askBool('Mengisi data lagi? (Y/T) ',['Y','T']);
    if again then writeln else writeln('Terima kasih.');
  until not again;
end.

video_demo.gif