Дано N чисел (неотрицательных)

Получить все возможные верные двойные неравенства (A<B<C, A<B<=C, A<=B<C, A<=B<=C). В каждом из которых используются все данные числа.

Вот понадобилось сделать, выкладываю что получилось, может кому пригодится, код при желании думаю можно сократить. Алгоритм прост - полный перебор smile.gif

{$R-}

uses crt;

const
  n = 6;

  FILE_NAME = 'C:\numb3rs.txt';

type
  TSign   = array [0..1] of shortint;

  TDigits = array [1..n] of integer;

  TCompare = (less, _less);

  PSigns = ^Tsigns;
  TSigns = array [1..1] of 0..1;

const
  sign: TSign = (-1, +1);
  sz_cmp: array [TCompare] of string[2] = ('<', '<=');
  sz_sgn: array [0..1] of char = ('-', '+');
  max_shift: integer = 0;

var
  signs: PSigns;
  f: text;

function _inc(var i: integer): integer;
begin
  inc(i); _inc := i;
end;

procedure expression_print(const digits: TDigits;
 const left, right: integer; const lCompare, rCompare: TCompare);
var
  i, sign_num: integer;
begin
  sign_num := 0;

  i := 1;
  write(f, digits[i]);

  while (i < left) do begin
    write(f, sz_sgn[signs^[_inc(sign_num)]]);
    write(f, digits[_inc(i)]);
  end;

  write(f, sz_cmp[lCompare]);
  write(f, digits[_inc(i)]);

  while (i < right) do begin
    write(f, sz_sgn[signs^[_inc(sign_num)]]);
    write(f, digits[_inc(i)]);
  end;

  write(f, sz_cmp[rCompare]);
  write(f, digits[_inc(i)]);

  while (i < n) do begin
    write(f, sz_sgn[signs^[_inc(sign_num)]]);
    write(f, digits[_inc(i)]);
  end;

  writeln(f);writeln(f);
end;

function expression_true(const A, B, C: integer;
 const lCompare, rCompare: TCompare): boolean;

begin
  case lCompare of

     less: case rCompare of

        less: expression_true := (A < B) and (B <  C);
       _less: expression_true := (A < B) and (B <= C);

     end;

    _less: case rCompare of

        less: expression_true := (A <= B) and (B <  C);
       _less: expression_true := (A <= B) and (B <= C);

    end;

  end;
end;

procedure signs_refresh;
var
  i: integer;
begin
  if signs <> nil then
   for i := 1 to n - 3 do
    signs^[i] := 0;
end;

procedure signs_shift;
var
  _shift: 0..1;
  i: integer;

begin
  _shift := 1;
  i := n - 3;

  repeat
    if signs^[i] = 0 then begin
      signs^[i] := 1;
      _shift := 0;
    end else begin
      signs^[i] := 0;
      dec(i);
    end;
  until (i = 0) or (_shift = 0);

end;

procedure digits_print(const digits: TDigits);
var
  i: integer;
begin
  writeln;
  for i := 1 to n do write(digits[i]:3);
end;

procedure digits_swap(var digits: TDigits; const p, q: integer);
var T: integer;
begin
  T := digits[p]; digits[p] := digits[q]; digits[q] := T;
end;

procedure find_solutions(const digits: TDigits);
var
  i, j, k, s, sign_num, A, B, C,
   shift_num: integer;

  l_cmp, r_cmp: TCompare;
begin

  for l_cmp := less to _less do
   for r_cmp := less to _less do begin

    for i := 1 to n - 2 do
     for j := 1 to n - i - 1 do begin

       signs_refresh;
       shift_num := 0;

       repeat

         if signs <> nil then begin
           sign_num := 0;

           k := 1;
           A := digits[k];
           while (k < i) do
            A := A + sign[signs^[_inc(sign_num)]] * digits[_inc(k)];

           k := i + 1;
           B := digits[k];
           while (k < i + j) do
            B := B + sign[signs^[_inc(sign_num)]] * digits[_inc(k)];

           k := i + j + 1;
           C := digits[k];
           while (k < n) do
            C := C + sign[signs^[_inc(sign_num)]] * digits[_inc(k)];

         end else begin
           A := digits[1];
           B := digits[2];
           C := digits[3];
           shift_num := max_shift;
         end;

           if expression_true(A, B, C, l_cmp, r_cmp) then
            expression_print(digits, i, i + j, l_cmp, r_cmp);

           if signs <> nil then begin
             signs_shift;
             inc(shift_num);
           end;

      until shift_num = max_shift;
    end;
   end;

end;

procedure solve(digits: TDigits; i: integer);
var
  j: integer;
begin
  for j := i to n do begin
    if i <> j then begin
      digits_swap(digits, i, j);
      find_solutions(digits);
    end;
    solve(digits, i + 1);
  end;
end;

const
 _digits: TDigits = (1, 8, 2, 9, 3, 0);

begin
  clrscr;

  writeln('Working, please wait ...');

  assign(f, FILE_NAME);
  rewrite(f);

  if n > 3 then begin
    GetMem(signs, (n - 3) * sizeof(TSigns));
    max_shift := round(exp((n - 3) * ln(2)));
    signs_refresh;
  end
   else signs := nil;

  find_solutions(_digits);
  solve(_digits, 1);

  close(f);

  if signs <> nil then
   FreeMem(signs, (n - 3) * sizeof(TSigns));

  writeln('Done ...');
  writeln('The result is a written in a file "', FILE_NAME, '"');
  writeln('Press <Enter>');

  readln;
end.


например для чисел 1, 2, 2, 3
результат: (Показать/Скрыть)