Решение задачи о кодировании цифр на Haskell и Perl
14 ноября 2011
На прошлой неделе я в очередной раз принял участие в конкурсе по функциональному программированию от Даркуса. В этой заметке вы найдете постановку задачи, ее решение, а также кое-какие мои наблюдения касательно функционального программирования.
Итак, постановка задачи была следующая:
Дан индикатор, состоящий из n лампочек, которые могут гореть или не гореть. Дан алфавит из k символов, которые закодированы различными комбинациями горящих и не горящих лампочек на индикаторе. Необходимо определить максимальное число лампочек индикатора p (p ≤ n) и указать эти лампочки, которые, если и перегорят, то не влияют на однозначное распознавание всех символов алфавита.
Видели когда-нибудь цифры на электронных часах, состоящие из семи секций? Вот о такого рода индикаторах и идет речь. Разъяснения и иллюстрации к задаче можно найти здесь. Также, по традиции, после решения задачи задавался ряд дополнительных вопросов.
Для решения задачи был выбран язык программирования Haskell:
{-
Решение задачи "о лапочках и сигналах"
Постановка задачи: http://users.livejournal.com/_darkus_/612310.html
Ответ:
*Main> solveFirstTask sevenPosSignalSet
(2,[[True,True,True,True,True,False,False]])
*Main> solveFirstTask ninePosSignalSet
(5,[
[False,False,False,True,True,True,False,True,False],
[False,False,False,True,True,True,True,False,False],
[True,False,False,True,True,False,False,True,False],
[True,False,False,True,True,False,True,False,False]
])
False означает перегоревшую лампочку
Нумерация лампочек - сверху вниз, слева направо
К вопросу о связанной задаче
http://users.livejournal.com/_darkus_/338421.html
*Main> fst $ solveSecondTask multipleNinePosSignalSets
Доказывает, что придумать более надежную кодировку не так уж просто
*Main> length $ snd $ solveSecondTask multipleNinePosSignalSets
Cуществует 241 "оптимальная" кодировка
(c) Александр Алексеев 2011 | http://eax.me/
-}
-- сигнал = горящие лампочки
type Signal = [Bool]
-- неисправность - когда работает лишь часть лампочек
type Defect = Signal
type SignalSet = [Signal]
type DefectSet = [Defect]
-- размер "алфавита" (k)
signalsNumber :: SignalSet -> Int
signalsNumber set = length $ set
-- число битов/лампочек (n)
bitsNumber :: SignalSet -> Int
bitsNumber set = length $ head set
-- все возможные сигналы из n лампочек/бит
allSignals :: Int -> SignalSet
allSignals 0 = [[]]
allSignals bits =
let rest = allSignals (bits-1)
in map (False:) rest ++ map (True:) rest
-- все возможные неисправности
allDefects = allSignals
-- приводит ли неисправность к неоднозначности трактовки сигналов
isCriticalDefect :: Defect -> SignalSet -> Bool
isCriticalDefect defect sigSet =
(signalsNumber sigSet) /= (signalsNumber defectedSigSet)
where
defectedSigSet = nub $ map (\s -> zipWith (&&) s defect ) sigSet
-- все некритические неисправности
allNoncriticalDefects :: SignalSet -> DefectSet
allNoncriticalDefects sigSet =
filter (\d -> not $ isCriticalDefect d sigSet)
(allDefects $ bitsNumber sigSet)
-- решение задачи для заданного набора сигналов
solveFirstTask signSet =
foldl1 (\a b -> if fst b >= fst a then
if fst b == fst a then (fst a, snd a ++ snd b) else b
else a) $
map (\t -> (foldl (\x b -> if b then x else x+1) 0 t, [t]))
(allNoncriticalDefects signSet)
-- поиск оптимального набора сигналов из заданного множества
solveSecondTask signSets =
foldl1 (\x y -> if fst (fst x) >= fst (fst y) then -- x
if fst (fst x) == fst (fst y) then (fst x, snd x ++ snd y) else x
else y) $ zip (map solveFirstTask signSets) $
(map (\x -> [x]) signSets)
intArrToSignalSet :: [[Int]] -> SignalSet
intArrToSignalSet = map ( map (/= 0) )
sevenPosSignalSet :: SignalSet
sevenPosSignalSet = intArrToSignalSet [
[1, 1, 1, 0, 1, 1, 1], -- 0
[0, 0, 1, 0, 0, 1, 0], -- 1
[1, 0, 1, 1, 1, 0, 1], -- 2
[1, 0, 1, 1, 0, 1, 1], -- 3
[0, 1, 1, 1, 0, 1, 0], -- 4
[1, 1, 0, 1, 0, 1, 1], -- 5
[1, 1, 0, 1, 1, 1, 1], -- 6
[1, 0, 1, 0, 0, 1, 0], -- 7
[1, 1, 1, 1, 1, 1, 1], -- 8
[1, 1, 1, 1, 0, 1, 1] -- 9
]
ninePosSignalSet :: SignalSet
ninePosSignalSet = intArrToSignalSet [
[1, 1, 0, 1, 0, 1, 0, 1, 1], -- 0
[0, 0, 1, 1, 0, 0, 0, 1, 0], -- 1
[1, 0, 0, 1, 0, 0, 1, 0, 1], -- 2
[1, 0, 1, 0, 1, 0, 1, 0, 0], -- 3
[0, 1, 0, 1, 1, 0, 0, 1, 0], -- 4
[1, 1, 0, 0, 1, 0, 0, 1, 1], -- 5
[0, 0, 1, 0, 1, 1, 0, 1, 1], -- 6
[1, 0, 1, 0, 0, 1, 0, 0, 0], -- 7
[1, 1, 0, 1, 1, 1, 0, 1, 1], -- 8
[1, 1, 0, 1, 1, 0, 1, 0, 0] -- 9
]
unpackIntArrays = foldl (\x y -> [a ++ [b] | a <- x, b <- y ]) [[]]
multipleNinePosSignalSets :: [SignalSet]
multipleNinePosSignalSets = map intArrToSignalSet $ unpackIntArrays [
[[1,1,0,1,0,1,0,1,1]],
[[0,0,1,1,0,0,0,1,0],[0,0,0,1,0,0,0,1,0],[0,1,0,0,0,1,0,0,0]],
[[1,0,0,1,0,0,1,0,1],[1,0,0,1,1,1,0,0,1]],
[[1,0,1,0,1,0,1,0,0],[1,0,0,1,1,0,0,1,1],[1,0,1,0,1,0,0,1,1]],
[[0,1,0,1,1,0,0,1,0],[0,0,1,1,1,0,0,1,0]],
[[1,1,0,0,1,0,0,1,1],[1,1,0,0,1,0,1,0,0]],
[[0,0,1,0,1,1,0,1,1],[1,1,0,0,1,1,0,1,1]],
[[1,0,1,0,0,1,0,0,0],[1,0,0,1,0,0,0,1,0],[1,0,0,1,0,0,1,0,0]],
[[1,1,0,1,1,1,0,1,1]],
[[1,1,0,1,1,0,1,0,0],[1,1,0,1,1,0,0,1,1]]
]
Решение довольно простое и очевидное, если пораскинуть мозгами, так что не буду на нем подробно останавливаться. А вот на чем я хотел бы заострить внимание, так это на моей попытке решить ту же задачу с помощью Perl.
Как некоторые из вас могут помнить, недавно я писал о функциональном программировании на Perl и пришел к заключению, дескать ничто не мешает писать на Perl в функциональном стиле. Но выяснилось, что «можно писать в функциональном стиле» и «эффективно решать определенный класс задач» — не совсем одно и то же.
Вот, что у меня получилось при попытке переписать один-в-один свою программу на язык Perl:
use strict;
use List::MoreUtils qw/uniq/;
use List::Gen::Haskell;
# размер "алфавита" (k)
sub signalsNumber { scalar @_ }
# число битов/лампочек (n)
sub bitsNumber { scalar @{ $_[0] } }
# все возможные сигналы из n лампочек/бит
sub allSignals {
my $bits = shift;
return ([]) unless($bits);
my @rest = allSignals($bits-1);
(
(map { my @t = @{$_}; unshift @t, 0; \@t; } @rest), # 0 == false
(map { my @t = @{$_}; unshift @t, 1; \@t; } @rest) # 1 == true
)
}
# все возможные неисправности
sub allDefects { allSignals(@_); }
# приводит ли неисправность к неоднозначности трактовки сигналов
sub isCriticalDefect {
my ($pDefect, $pSigSet) = @_;
my @defectedSigSet = map {
zipWith { $_[0] && $_[1] } $_, $pDefect;
} @{$pSigSet};
@defectedSigSet = map {
my @t = split //; \@t
} uniq map { # uniq не умеет сравнивать указатели на массивы
join "", @{$_}
} @defectedSigSet;
signalsNumber(@{$pSigSet}) != signalsNumber(@defectedSigSet);
}
sub allNoncriticalDefects {
my @sigSet = @_;
grep {
!isCriticalDefect $_, \@sigSet
} allDefects( bitsNumber(@sigSet) );
}
sub solveFirstTask {
my $rslt = foldl1 {
my ($a, $b) = @_;
$b->[0] >= $a->[0]
? $b->[0] == $a->[0]
? [ $a->[0], [( @{$a->[1]}, @{$b->[1]} )] ]
: $b
: $a
} map {
my @d = @{$_};
my $cnt = foldl { $_[1] ? $_[0] : $_[0] + 1} 0, @d;
[ $cnt, [ \@d ] ];
} allNoncriticalDefects(@_);
@{$rslt};
}
# поиск оптимального набора сигналов из заданного множества
sub solveSecondTask {
my @signSets = @_;
my $zipped = zip # returns array ref !
[ map { my @t = solveFirstTask(@{$_}); \@t } @signSets ],
[ map { [ $_ ] } @signSets ];
my $rslt = foldl1 {
my ($x, $y) = @_;
$x->[0][0] >= $y->[0][0]
? $x->[0][0] == $y->[0][0]
? [ $x->[0], [( @{$x->[1]}, @{$y->[1]} )] ]
: $x
: $y
} @{$zipped};
@{$rslt};
}
sub sevenPosSignalSet {
(
[1, 1, 1, 0, 1, 1, 1], # 0
[0, 0, 1, 0, 0, 1, 0], # 1
[1, 0, 1, 1, 1, 0, 1], # 2
[1, 0, 1, 1, 0, 1, 1], # 3
[0, 1, 1, 1, 0, 1, 0], # 4
[1, 1, 0, 1, 0, 1, 1], # 5
[1, 1, 0, 1, 1, 1, 1], # 6
[1, 0, 1, 0, 0, 1, 0], # 7
[1, 1, 1, 1, 1, 1, 1], # 8
[1, 1, 1, 1, 0, 1, 1] # 9
)
}
sub ninePosSignalSet {
(
[1, 1, 0, 1, 0, 1, 0, 1, 1], # 0
[0, 0, 1, 1, 0, 0, 0, 1, 0], # 1
[1, 0, 0, 1, 0, 0, 1, 0, 1], # 2
[1, 0, 1, 0, 1, 0, 1, 0, 0], # 3
[0, 1, 0, 1, 1, 0, 0, 1, 0], # 4
[1, 1, 0, 0, 1, 0, 0, 1, 1], # 5
[0, 0, 1, 0, 1, 1, 0, 1, 1], # 6
[1, 0, 1, 0, 0, 1, 0, 0, 0], # 7
[1, 1, 0, 1, 1, 1, 0, 1, 1], # 8
[1, 1, 0, 1, 1, 0, 1, 0, 0] # 9
)
}
sub unpackIntArrays {
my $rslt = foldl {
my ($left, $right) = @_;
my @t = map {
my $a = $_;
map {
my $b = $_;
[( @{$a}, $b )]
} @{$right};
} @{$left};
\@t;
} [[]], @_;
@{$rslt};
}
sub multipleNinePosSignalSets {
unpackIntArrays (
[[1,1,0,1,0,1,0,1,1]],
[[0,0,1,1,0,0,0,1,0],[0,0,0,1,0,0,0,1,0],[0,1,0,0,0,1,0,0,0]],
[[1,0,0,1,0,0,1,0,1],[1,0,0,1,1,1,0,0,1]],
[[1,0,1,0,1,0,1,0,0],[1,0,0,1,1,0,0,1,1],[1,0,1,0,1,0,0,1,1]],
[[0,1,0,1,1,0,0,1,0],[0,0,1,1,1,0,0,1,0]],
[[1,1,0,0,1,0,0,1,1],[1,1,0,0,1,0,1,0,0]],
[[0,0,1,0,1,1,0,1,1],[1,1,0,0,1,1,0,1,1]],
[[1,0,1,0,0,1,0,0,0],[1,0,0,1,0,0,0,1,0],[1,0,0,1,0,0,1,0,0]],
[[1,1,0,1,1,1,0,1,1]],
[[1,1,0,1,1,0,1,0,0],[1,1,0,1,1,0,0,1,1]]
)
}
# ================================
sub dumpFirstTask { # Data::Dumper sucks in this case
my @t = @_;
print $t[0]."\n";
for my $tt (@{$t[1]}) {
print join("-", @{$tt})."\n";
}
}
my $time = time();
my @temp = solveFirstTask( sevenPosSignalSet );
dumpFirstTask(@temp);
@temp = solveFirstTask( ninePosSignalSet );
dumpFirstTask(@temp);
my @signSets = multipleNinePosSignalSets();
print "multipleNinePosSignalSets :: ".scalar(@signSets)."\n"; # 864
@temp = solveSecondTask(@signSets);
dumpFirstTask(@{$temp[0]});
print 'scalar(@{$temp[1]}) == '.scalar(@{$temp[1]})."\n";
$time = time() - $time;
print "time == $time\n";
Присмотритесь к коду повнимательнее. Налицо проблемы с читаемостью, постоянным получением и разыменованием ссылок, а также другими вещами (см комментарии). Кроме того, мне пришлось использовать вложенные map там, где в Haskell используются генераторы списоков (list comprehensions). Названные проблемы неплохо иллюстрирует функция unpackIntArrays:
# (в комментариях подсказывают, что unpackIntArrays = sequence)
sub unpackIntArrays {
my $rslt = foldl {
my ($left, $right) = @_;
my @t = map {
my $a = $_;
map {
my $b = $_;
[( @{$a}, $b )]
} @{$right};
} @{$left};
\@t;
} [[]], @_;
@{$rslt};
}
Вы не поверите, но это еще не самое страшное. Если первая часть задачи решается на Perl за вполне разумное время, то на дополнительный вопрос про поиск оптимального набора сигналов на моем компьютере вообще невозможно ответить без переписывания скрипта. Дело в том, что в варианте, приведенном выше, скрипту просто не хватает оперативной памяти:
На скриншоте не видно, но мое терпение тоже находилось на исходе. Откуда такая потребность в оперативной памяти? Кажется, я нигде не наплодил циклических ссылок. И программа делает то, что от нее требуется. Это несложно проверить, уменьшив количество перебираемых вариантов.
Для сравнения, вот как использует системные ресурсы программа на Haskell:
Гигабайт оперативки используют ОС и программы, которые мне лень было закрывать. То есть программа на Haskell практически не использует никакой памяти. Также программа на Haskell работает существенно быстрее скрипта на Perl.
Следует отметить, что проблемы полученного Perl-скрипта не относятся к разряду нерешаемых. Можно улучшить читаемость, воспользовавшись модулем List::Comprehensions, а также частично отказавшись от функционального подхода. Можно попытаться найти более подходящий алгоритм решения задачи для данного языка, или оптимизировать имеющийся алгоритм путем использования кэширования и временного сохранения данных на диск. Возможно, поможет использование Perl 6 вместо Perl 5 — языки во много похожи, но в шестом перле, кажется, есть ленивые вычисления и мемоизация.
Но, как понимаете, все это слабо утешает. Инструмент подходит для решения задачи, если позволяет решить ее легко и быстро, уложившись при этом во все ограничения. Как видите, из того, что для решения задачи целесообразно применить функциональный подход, еще не следует, что для ее решения стоит использовать Perl. Что не удивительно, ведь Perl изначально создавался совершенно для другого класса задач.
Метки: Haskell, Perl, Функциональное программирование.
Вы можете прислать свой комментарий мне на почту, или воспользоваться комментариями в Telegram-группе.