IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Комбинации двойных неравенств
сообщение
Сообщение #1


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

Репутация: -  44  +


Дано 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
результат: (Показать/Скрыть)


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 23.10.2020 7:34
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name