Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/GET10.ZIP/GETREAL.PAS

Pascal/Delphi Source File | 1988-11-09 | 18.1 KB | 674 lines

procedure getreal

   (num_prompt:       screen_text;
    atr,atc:          byte;        {screen co-ords}
    low,high:         real;        {not checked if equal}
    decimal_places:   integer;     {UserDefinedFormat no. if negative}
    pattr,nattr:      byte;        {attributes}
var number:           real;
    default:          numstring);

{
  The field size required for low or high, whichever is larger, controls
  how big the field for entry of number is, unless low = high then nominal
  field size of 13 digits is used (11 significant digits, plus sign and
  decimal point). The value of decimal_places constrains the maximum range
  of the number.

  implied_lowest  implied_highest  decimal_places

  -2147483648     217483647               0
  -2147483648.0   217483647.0             1
  -999999999.99   99999999.99             2
  -99999999.999   9999999.999             3

  -9.9999999999   9.999999999            10

  The range may be constrained further by the parameters low and high.

  Dynamic validation is not attempted unless the range includes the number 0.
}
var
    UserFormat:     UserFormatRec;
    UnitSymbol:     SymbolStr;
    UseSymbolFirst,
    UseCommas,
    UseParentheses,
    UseSIdisplay:   boolean;


    UserDefinedFormat,
    finished,
    negative,
    numberok:       boolean;

    ThousandsDelimiter,
    DecimalPointChar,
    dchar:              char;

    lostr,histr,
    instr:          numstring;

    implied_lowest,
    implied_highest,
    default_number,
    last_number,
    save_number:    real;

    negintsize,
    posintsize,
    sign,
    FormatNo,
    FormattingOverhead,
    shift,
    mantissa_size,
    dot,
    output_size,
    nominal_field_size,
    dotpos,
    field_size:          byte;
    code:                integer;

function RealToUserFormat (amount: real): numstring;

var
    outstr:  numstring;
    threes,
    I:       integer;

begin
  if (pos('-',UnitSymbol) > 0) or
     (pos('+',UnitSymbol) > 0) then
    UnitSymbol := ''; {null}

  outstr := RealToString(amount,decimal_places);
  if amount < 0 then
    delete(outstr,1,1); {delete minus sign}

  threes := pos('.',outstr);

  if UseSIdisplay and (threes > 0) then
    outstr[threes] := DecimalPointChar;

  if UseCommas then
    begin
      if threes = 0 then
        threes := length(outstr);

      dec(threes,3);

      while threes > 1 do
        begin
          insert(ThousandsDelimiter,outstr,threes);
          dec(threes,3);
        end;
    end;

  if (amount < 0) then
    if UseParentheses then
    else outstr := '-' + outstr; {restore minus sign}

  if UseSymbolFirst then
    outstr := UnitSymbol + outstr
  else outstr := outstr + UnitSymbol;

  if (amount < 0) and UseParentheses then
    outstr := '(' + outstr + ')';

  RealToUserFormat := outstr;
end;


function validation_on: boolean;
{
  Dynamic validation not attempted unless: low <= 0 <= high (and low <> high)
}
begin
  validation_on := (low <> high) and
                   (finished or ((low <= 0) and (high >= 0)));

end;


function RealOutOfRange: boolean;
begin
  RealOutOfRange :=
    (validation_on and ((number < low) or (number > high)));
end;


function field_complete: boolean;
{
  Field is complete when it's full but not with asterisks or when
  min or maxlongint has been entered.
}
begin
  field_complete :=
    ((length(instr) = field_size) and (instr[1] <> '*')) or
    (int(number) = maxlongint) or (int(number) = - maxlongint - 1);
end;


function mantissa_complete: boolean;
{
  checks for decimal_places characters entered after '.' in instr
}
begin
  mantissa_complete := length(instr) - pos('.',instr) = decimal_places;
end;


procedure reset_number (reset_value: real);
{
  Resets number to value passed and converts it to a string for display
  removing trailing 0's and decimal pt if necessary. Note: this procedure
  needs to be executed even if number and reset_value are the same in case
  instr is set to asterisks -- otherwise it will not be reset.
}
begin
  number := reset_value;
  last_number := number;
  instr := RealToString(number,decimal_places);
  if number = 0 then
    instr := '';
  negative := number < 0;
  finished := false;

  if pos('.',instr) > 0 then {better than decimal_places > 0}

    begin
      while (instr[length(instr)] = '0') do
        dec(ord(instr[0])); {trailing 0s}

      if abs(int(number)) < billion then {chop the decimal pt}
        if instr[length(instr)] = '.' then
          dec(ord(instr[0]));
    end;

end;


procedure display_real_number (signed_number: real; SetFinished: boolean);
{
  Until the number is finished we shouldn't display any more decimal
  places than are already in the string -- instr.

}
var oldsize:     integer;
    dotpos,
    fattr:       byte;
    display_str: numstring;


procedure format_instr_for_display;
{
  This procedure is out of line for readability only
}
begin
  if (signed_number = 0) and ZeroAsBlank then
    instr := '';

  if UserDefinedFormat and not(instr = '') then
    begin
      instr := RealToUserFormat(signed_number);
      if signed_number < 0 then
        fattr := RedAttr;
    end
  else
    begin
      if ZeroFillNumbers then {takes precedence over ZeroAsBlank}
        begin
          if signed_number < 0 then
            delete(instr,1,1);
          while length(instr) < field_size do
            instr := '0' + instr;
          if signed_number < 0 then
            instr[1] := '-';
        end
     end;

   if RightJustifyNumbers then
     while length(instr) < output_size do
       instr := ' ' + instr;

   display_str := instr;
end;


begin
  finished := SetFinished;

  if EditingField and not finished and (fieldcursor <> 0) then
    fattr := fieldcursor
  else fattr := nattr;

  oldsize := length(instr); {must precede next line}
  instr := RealToString(signed_number,decimal_places);

  if RealOutOfRange then
    begin
      if not escaped then
        if EditingField then {no msg if field painting}
          error2(NumberWord + brighten(instr) + outside_validation_range
                + brighten(lostr) + ToWord + brighten(histr));

      fillchar (instr[1],output_size,'*');      {* fill field + length byte}
      instr[0] := chr(output_size);             {set length byte}
      oldsize := output_size;
    end;

  if finished then
    if instr[1] <> '*' then
      format_instr_for_display
    else {do nothing}
  else {decimal point will be a period, display as a comma if necessary}
    begin
      if negative and not (instr[1] in ['-','*']) then
        instr := '-' + instr;
      instr := copy(instr,1,oldsize);
      dotpos := pos('.',instr);
      display_str := instr;
      if UseSIdisplay and (dotpos > 0) then
        display_str[dotpos] := ',';
    end;

  Qfill(atr,atc,1,output_size,fattr,' ');

  if RightJustifyNumberEntry then
    Qwrite(atr,atc + output_size - length(instr),fattr,display_str)
  else Qwrite(atr,atc,fattr,display_str);
end;


procedure enter_default_value;
{
  Enter default if default is a valid number (illegal default values are
  ignored) and either ValidationOveride is true or the number falls within
  the validation range.

  This procedure may be amended to prompt for confirmation of default values.
}
begin
  val(default,default_number,code);

  if code = 0 then
    begin
      {use ConfirmDefault here}

      if ValidationOverride then
        begin
          low := 0;
          high := 0;
        end;

      if (low <> high) and
        ((default_number < low) or
        (default_number > high)) then
        error2(No_privilege)
      else reset_number(default_number);
    end
  else error2(default_is_invalid);
end;


procedure get_input;
begin

    display_real_number(number,false);
    if RightJustifyNumberEntry then
      getdigit(atr,atc + output_size,0)
    else getdigit(atr,atc + length(instr),0);
    clearerror2;

    if scancode = 0 then {amend string}
      begin

        dchar := chr(asciicode);

        if (length(instr) = field_size) and (dchar in ['0'..'9']) then
          if instr[1] = '*' then
            instr := ''
          else dchar := ^I; {don't allow it to get longer}

        case dchar of

          ^H       : if instr[1] = '*' then
                       reset_number(0)
                     else if length(instr) > 0 then
                       begin

(*                         if instr[length(instr)] = '.' then
                           dec(ord(instr[0])); {remove decimal pt}
*)
                        dec(ord(instr[0]));
                         negative := negative and (length(instr) > 0)
                       end;

           '-'     : if instr[1] <> '*' then
                       if (low < 0) or not validation_on then
                         negative := not negative;

           '+'     : if instr[1] <> '*' then
                       if (high > 0) or not validation_on then
                         negative := false;

           ',','.' : if instr[1] <> '*' then
                       if pos('.',instr) = 0 then
                         begin
                           if instr = '' then
                             instr := '0'
                           else if instr = '-' then
                                  instr := '-0';

                           finished := decimal_places = 0;
                           if not finished then
                             instr := instr + '.';
                         end;

           ^I      : finished := instr[1] <> '*';

           ^J,^M   : if instr[1] = '*' then
                       reset_number(save_number)
                     else

                       begin
                         if (default <> '') and
                           ((dchar = ^J) or (instr = '')) then
                           enter_default_value;
                         finished := true;
                       end;

           ^[      : begin
                       reset_number(save_number);
                       escaped := true;
                     end;

           ^Y      : reset_number(0);

           ^U      : reset_number(save_number);

           '0'..'9': { allow digits to be added except 0's to 0 or
                       non zero digits to maxlongint or minlongint }

                     begin
                       if (dchar = '0') then
                         begin
                           if ((instr = '0') or (instr = '-0')) then
                             {do nothing}
                           else instr := instr + dchar;
                         end
                       else
                         begin
                           if (copy(instr,1,10)  = strmaxlongint) or
                              (copy(instr,1,11) = strminlongint) then
                             {do nothing}
                           else
                             instr := instr + dchar;
                         end;

                       { Now add decimal point if integer part of number
                         must be complete. If the number just entered is
                         outside any validation constraints the last digit
                         and the decimal point added will be discarded.
                       }

                       dot := pos('.',instr);

                       if (decimal_places > 0) and (dot = 0) then
                         if ((instr[1] = '-')  and
                            (length(instr) = negintsize)) or
                            ((instr[1] <> '-') and
                            (length(instr) = posintsize)) then
                            instr := instr + '.';

                       {see if we are finished before the end of the field}

                       finished := (dot <> 0) and
                                   (mantissa_complete and AutoTab);
                     end;

        end; {case}


        if not escaped and (instr[1] <> '*') then {turn string into number}
          begin

            if negative then
              begin
                if (instr[1] <> '-') then
                  instr := '-' + instr;
              end
            else if instr[1] = '-' then
                   delete(instr,1,1);

            last_number := number;

            real_value(instr,number,code); {string -> number}

            if code <> 0 then
              begin
                error2(Number_must_be_in_range + brighten(strminlongint) +
                       ToWord + brighten(strmaxlongint));
                reset_number(last_number);
              end;

            finished := finished or (field_complete and AutoTab);
        end; {not escaped}
    end

  else {extended key}

    begin
      action := get_edit(command);

      {amend here to control what extended keys are acceptable}

      case action of

        tabback: finished := instr[1] <> '*';

        reset: if ValidationOverride then {user has privilege}
                 begin
                   if low <> high then
                     info2(Range_checking_suspended);

                   low := 0;
                   high := 0;

                   reset_number(save_number);
                 end
               else error2(No_privilege);

        help,
        upchar,
        downchar,
        leftchar,
        rightchar,
        pageup,
        pagedown,
        scrollup,
        scrolldown,
        goto_top,
        goto_bottom,
        abort,
        exit_screen,
        quit:

                 begin
                   reset_number(save_number);
                   finished := true;
                 end;

      else error2(Invalid_key);
      end; {case}
    end;
end;


procedure warn_user_number_is_invalid;
begin {reset number to last validated value}
  error2(Enter_a_number_between + brighten(lostr) + AndWord +
         brighten(histr));
  reset_number(last_number);
end;


begin {getreal}
  escaped := false;
  finished := false;     {used in setting validation_on & therefore field_size}

  save_number := number;
  last_number := number;

  if low > high then
    begin
      low := 0;
      high := 0;
    end;

  UserDefinedFormat :=
    (decimal_places < 0) and (abs(decimal_places) <= TotalUserFormats);

  if UserDefinedFormat then
    begin
      FormatNo       := abs(decimal_places);
      UserFormat     := UserFormatArray[FormatNo];
      UnitSymbol     := UserFormat.UnitSymbol;
      decimal_places := UserFormat.places;

      UseSymbolFirst := (UserFormat.UnitFormat AND SymbolFirst) > 0;
      UseCommas      := (UserFormat.UnitFormat AND Commas)      > 0;
      UseParentheses := (UserFormat.UnitFormat AND Parentheses) > 0;
      UseSIdisplay   := (UserFormat.UnitFormat AND SIdisplay)   > 0;

      FormattingOverhead := length(UnitSymbol);
    end
  else
    begin
      FormattingOverhead := 0;
      UseSIdisplay       := false;
    end;

  if UseSIdisplay then
    begin
      ThousandsDelimiter := SI_ThousandsDelimiter; {' ' or (default) '.'}
      DecimalPointChar   := ',';
    end
  else
    begin
      ThousandsDelimiter := ',';
      DecimalPointChar   := '.';
    end;


  if not decimal_places in [0..10] then
    decimal_places := DecimalDefault;
{
  No of decimal places implies max and min possible values for low and high.
  These will be used if low = high (user specified range checking off) or if
  the value of either low or high specified is not appropriate for the given
  number of decimal places.
}
  if decimal_places < 2 then
    implied_highest := maxlongint
  else
    begin
      implied_highest := 999999999.99; {2 decimal places}
      shift := decimal_places - 2;
      if shift > 0 then
        implied_highest := implied_highest / powerof(10,shift);
    end;

  if decimal_places < 2 then
    implied_lowest := pred(-maxlongint)
  else implied_lowest := -implied_highest;

  if (high > implied_highest) or (low  < implied_lowest) or (low = high) then
    begin
      high := implied_highest;
      low  := implied_lowest;
    end;

{
  ensure equivalence of string input and real limits
}

  strval(high,decimal_places);
  strval(low,decimal_places);

{
  Find out how many digits to allow for input. Lower number may be longer,
  e.g., with a range of -999.9 to 99.9.
}

  if decimal_places = 0 then
    nominal_field_size := 11
  else nominal_field_size := 13;

  lostr := RealToString(low,decimal_places);
  histr := RealToString(high,decimal_places);

  If UseSIdisplay then
    begin {ensure error message strings use correct character for decimal pt}
      dotpos := pos('.',lostr);
      if dotpos > 0 then
        lostr[dotpos] := ',';
      dotpos := pos('.',histr);
      if dotpos > 0 then
      histr[dotpos] := ',';
    end;


  negintsize := digits(low);
  posintsize := digits(high);

  if ValidationOverride or not validation_on then
    field_size := nominal_field_size
  else field_size := maxW(ord(lostr[0]),ord(histr[0]));

  mantissa_size := decimal_places;
  if decimal_places > 0 then
    inc(mantissa_size); {allow for decimal pt}

  if UserDefinedFormat then
    begin
      if lostr[1] = '-' then
         begin
           sign := 1;
           if UseParentheses then
             inc(FormattingOverhead);  {'-' turns to '('; allow for ')' }
         end
      else sign := 0;

      if UseCommas then {find out how many commas to allow for}
        inc(FormattingOverhead,pred(field_size - sign - mantissa_size) div 3);
    end;

  output_size := field_size + FormattingOverhead;

  SetCursor(CursorOn or CursorUnderline);
  clearerror2;
  numberok := false;

  display_prompt(num_prompt,atr,atc,pattr,output_size);

  if not PaintingFields then
    repeat
      reset_number(number);
      repeat
        get_input
      until finished or escaped or RealOutOfRange;

      numberok := (not RealOutOfRange) or Escaped;
      if not numberok then
        warn_user_number_is_invalid;

    until numberok
  else
    reset_number(number);

  display_real_number(number,true);
  SetCursor(CursorOff);
end; {getreal}