fpc/packages/ncurses/tests/t3form.pp

program form_test_3;

{$MODE OBJFPC}

uses
  ncurses, form, libc;



function st_middle(scrlen, itemlen: Smallint): Smallint; inline;
begin
  st_middle := (scrlen - itemlen) div 2;
end;


procedure draw;

function randomchar: chtype;
var
  ch: Char = #0;
begin
  while not (ch in ['0'..'9','A'..'Z','a'..'z']) do
    ch := Char(Random(123));
  randomchar := chtype(ch);
end;

function randompair: longint;
var
  pair: longint = 0;
begin
  while not (pair in [1..5]) do
    pair := Random(6);
  randompair := pair;
end;

var
  y, x:  Smallint;
begin
  for y := 0 to LINES - 1 do
    for x := 0 to COLS - 1 do
      mvaddch(y, x, randomchar OR COLOR_PAIR(randompair));
end;

const
  enumval: array[0..2] of PChar = ('one', 'two', 'three');
  desc: array[0..5] of PChar =
              (
                'TYPE_ALPHA    Char data, a min width 8',
                'TYPE_ENUM      one, two, three',
                'TYPE_INTEGER     -300 .. 300',
                'TYPE_NUMERIC    -30.0 .. 30.0',
                'TYPE_REGEXP ^http://.+\.(ru|net|com)\s*$',
                'TYPE_IPV4     An IP Version 4 address.'
              );
var
  my_bg: NC_FPC_COLOR = COLOR_BLACK;
  form_win: PWINDOW;

  pair: Smallint;
  field: array[0..6] of PFIELD;
  my_form: PFORM;
  i, frows, fcols, ch: Longint;
begin

try
  setlocale(LC_ALL, '');

  (* Initialize curses *)
   initscr();
   cbreak();
   noecho();
   keypad(stdscr, TRUE);

  (* Initialize colors *)
   if has_colors() then
   begin
     start_color();
     if (use_default_colors() = OK) then
       my_bg := -1
     else
       my_bg := COLOR_BLACK;

     init_pair(1, COLOR_YELLOW, my_bg);
     init_pair(2, COLOR_MAGENTA, my_bg);
     init_pair(3, COLOR_WHITE, my_bg);
     init_pair(4, COLOR_CYAN, my_bg);
     init_pair(5, COLOR_GREEN, my_bg);
     init_pair(6, COLOR_WHITE, COLOR_BLUE);
     init_pair(7, COLOR_BLACK, COLOR_CYAN);
   end;


   for i := 0 to 5 do
   begin
     field[i] := new_field(1, 30, 2 + i * 3, 10, 0, 0);
     field_opts_off(field[i], O_AUTOSKIP);
     if i AND 1 = 0 then
       pair := 7
     else
       pair := 6;
     set_field_fore(field[i], COLOR_PAIR(pair));
     set_field_back(field[i], A_UNDERLINE OR COLOR_PAIR(pair));
     //set_field_pad(field[i],chtype(' '));
   end;
   draw;
   refresh();

   field[6] := nil;

   set_field_type(field[0],TYPE_ALPHA,8);
   set_field_type(field[1],TYPE_ENUM,PPChar(enumval),0,0);
   set_field_type(field[2],TYPE_INTEGER,3,-300,300);
   set_field_type(field[3],TYPE_NUMERIC,8,-30.0,30.0);
   set_field_type(field[4],TYPE_REGEXP,'^http://.+\.(ru|net|com)\s*$');
   set_field_type(field[5],TYPE_IPV4);


   my_form := new_form(field);

(* Calculate the area required for the form *)
   scale_form(my_form, @frows, @fcols);

(* Create the window to be associated with the form *)
   //form_win := newwin(rows + 4, cols + 4, 4, 4);
   form_win := newwin(frows + 4, fcols + 4, st_middle(LINES,frows+4), st_middle(COLS,fcols+4));
   keypad(form_win, TRUE);

(* Set main window and sub window *)
   set_form_win(my_form, form_win);
   set_form_sub(my_form, derwin(form_win, frows, fcols, 2, 2));

(* Print a border around the main window and print a title *)
   box(form_win, 0, 0);
   //print_in_middle(my_form_win, 1, 0, cols + 4, "My Form", COLOR_PAIR(1));

   post_form(my_form);
   wrefresh(form_win);

   for i := 0 to 5 do
     mvwaddstr(form_win, 3 + i * 3, 1,desc[i]);
   wrefresh(form_win);

   //set_field_buffer(field[0], 0, 'Test Field');
   //refresh();

  (* Loop through to get user requests *)
    ch := wgetch(form_win);
    while (ch <> KEY_F(1)) AND (ch <> 27) do
    begin
      case ch of
        9:   { TAB }
        begin
          if form_driver(my_form, REQ_NEXT_WORD) <> E_OK then
          begin
            form_driver(my_form, REQ_VALIDATION);
            form_driver(my_form, REQ_NEXT_FIELD);
            form_driver(my_form, REQ_END_LINE);
          end;
        end;
        KEY_NPAGE:
    (* Go to next field *)
        begin
          form_driver(my_form, REQ_VALIDATION);
          form_driver(my_form, REQ_NEXT_FIELD);
            { Go to the end of the present buffer
              Leaves nicely at the last character }
          form_driver(my_form, REQ_END_LINE);
        end;
        KEY_PPAGE:
    (* Go to previous field *)
        begin
          form_driver(my_form, REQ_VALIDATION);
          form_driver(my_form, REQ_PREV_FIELD);
          form_driver(my_form, REQ_END_LINE);
        end;
        KEY_DOWN:
          if form_driver(my_form, REQ_DOWN_CHAR) <> E_OK then
          begin
            form_driver(my_form, REQ_VALIDATION);
            form_driver(my_form, REQ_DOWN_FIELD);
          end;
        KEY_UP:
          if form_driver(my_form, REQ_UP_CHAR) <> E_OK then
          begin
            form_driver(my_form, REQ_VALIDATION);
            form_driver(my_form, REQ_UP_FIELD);
          end;
        KEY_LEFT:
          if form_driver(my_form, REQ_LEFT_CHAR) <> E_OK then
          begin
            form_driver(my_form, REQ_VALIDATION);
            form_driver(my_form, REQ_LEFT_FIELD);
            form_driver(my_form, REQ_END_LINE);
          end;
        KEY_RIGHT:
          if form_driver(my_form, REQ_RIGHT_CHAR) <> E_OK then
          begin
            form_driver(my_form, REQ_VALIDATION);
            form_driver(my_form, REQ_RIGHT_FIELD);
          end;
        KEY_BACKSPACE: form_driver(my_form, REQ_DEL_PREV);
        10: { ENTER }
          begin
            form_driver(my_form, 10);
            if form_driver(my_form, REQ_NEXT_LINE) <> E_OK then
            begin
              form_driver(my_form, REQ_VALIDATION);
              form_driver(my_form, REQ_NEXT_FIELD);
              form_driver(my_form, REQ_END_LINE);
            end;
          end;
      else
          { If this is a normal character, it gets
            Printed }
        form_driver(my_form, ch);
      end;
      ch := wgetch(form_win);
    end;

  finally

    unpost_form(my_form);
    free_form(my_form);
    delwin(form_win);
    endwin();

    for i := 0 to 5 do
    begin
      if field_status(field[i]) then
      begin
        writeln;
        writeln('Value ', i,':');
        writeln(field_buffer(field[i], 0));
      end;
      free_field(field[i]);
    end
  end;
end.