From ba8eedb32fa39710d22d95b1da42ae494e5fa049 Mon Sep 17 00:00:00 2001 From: Christian Jaeger Date: Sun, 23 May 2021 23:44:10 +0100 Subject: Rename files to standard naming --- .../haskell/113-1-represent_integer_haskell.hs | 132 ---------- challenge-113/christian-jaeger/haskell/Makefile | 4 +- challenge-113/christian-jaeger/haskell/ch-1.hs | 132 ++++++++++ .../christian-jaeger/perl/113-1-represent_integer | 286 --------------------- .../perl/113-2-recreate_binary_tree | 112 -------- challenge-113/christian-jaeger/perl/ch-1.pl | 286 +++++++++++++++++++++ challenge-113/christian-jaeger/perl/ch-2.pl | 112 ++++++++ 7 files changed, 532 insertions(+), 532 deletions(-) delete mode 100644 challenge-113/christian-jaeger/haskell/113-1-represent_integer_haskell.hs create mode 100644 challenge-113/christian-jaeger/haskell/ch-1.hs delete mode 100755 challenge-113/christian-jaeger/perl/113-1-represent_integer delete mode 100755 challenge-113/christian-jaeger/perl/113-2-recreate_binary_tree create mode 100755 challenge-113/christian-jaeger/perl/ch-1.pl create mode 100755 challenge-113/christian-jaeger/perl/ch-2.pl diff --git a/challenge-113/christian-jaeger/haskell/113-1-represent_integer_haskell.hs b/challenge-113/christian-jaeger/haskell/113-1-represent_integer_haskell.hs deleted file mode 100644 index 9a8d3aa9cd..0000000000 --- a/challenge-113/christian-jaeger/haskell/113-1-represent_integer_haskell.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- [The Weekly Challenge - 113](https://perlweeklychallenge.org/blog/perl-weekly-challenge-113/), --- TASK #1: Represent Integer - --- You are given a positive integer `n` and a digit `d`. - --- Write a script to check if `n` can be represented as a sum of --- positive integers [all] having `d` at least once [in their decimal --- representation]. If check passes print 1 otherwise 0. - --- Note: there is a [blog post about this](http://functional-perl.org/docs/blog/perl-weekly-challenges-113.xhtml). - - -module Main where -import qualified Data.Set as Set -import Data.Maybe -import Data.Either -import Test.HUnit -import qualified System.Environment as Environment -import qualified System.Exit as Exit -import qualified Text.Read as Read - --- I'm using parens instead of $ and `let` instead of `where` to make --- the code look closer to the Perl version / more familiar to Perl --- programmers. - --- Also, using this now pretty wide-spread (but not sure about --- Haskell) piping operator to make the code look similar to OO code --- using method calls. -(|>) :: t1 -> (t1 -> t2) -> t2 -a |> b = b a - --- Unlike in the Perl version, I'm only implementing the algorithm --- used in `maybe_choose_optim_2` here: - -chooseOptim2 :: forall n. (Num n, Ord n) => n -> [n] -> Maybe [n] -chooseOptim2 ntop ns = - let nsSet = Set.fromList ns - check :: [n] -> Maybe [n] - check chosen = - let decide n = - let chosen' = n:chosen - missing = ntop - (sum chosen') - in - if missing == 0 then - Just (Right chosen') - else if missing < 0 then - Nothing - else - if Set.member missing nsSet then - Just (Right (missing : chosen')) - else - Just (Left (check chosen')) - decisions :: [Either (Maybe [n]) [n]] - decisions = ns |> map decide |> takeWhile isJust |> catMaybes - solutions :: [[n]] - solutions = rights decisions - recursions :: [Maybe [n]] - recursions = lefts decisions - in - case solutions of - (solution:_) -> Just solution - _ -> - case recursions |> catMaybes of - (solution:_) -> Just solution - _ -> Nothing - in - check [] - -validNumbers :: Integer -> Char -> [ Integer ] -validNumbers n d = - filter (\i -> elem d (show i)) [1..n] - -representable :: Integer -> Char -> Maybe [Integer] -representable n d = - let ns = validNumbers n d - in - chooseOptim2 n (reverse ns) - - ----------------------------------------------------------------------- - -tests :: [Test] -tests = map (\(n,d,r) -> TestCase( - assertEqual - ("> representable " ++ (show n) ++ " '" ++ [d, '\'']) - r - (representable n d))) - [ (25, '7', Nothing) - , (24, '7', Just [7, 17]) - , (200, '9', Just [9, 191]) - , (200, '8', Just [18, 182]) - , (200, '7', Just [27, 173]) - , (200, '6', Just [36, 164]) - , (20000, '8', Just [18, 19982]) - , (40000, '8', Just [18, 39982]) - , (40000, '6', Just [36, 39964]) - ] - -runTests :: IO Counts -runTests = runTestTT (TestList tests) - -usage :: String -> IO () -usage prog = putStrLn ("Usage: " ++ prog ++ " --test | N D") - -usageMsg :: String -> String -> IO () -usageMsg prog msg = do - putStrLn ("Error: " ++ msg) - usage prog - -exit, die :: IO () -exit = Exit.exitWith Exit.ExitSuccess -die = Exit.exitWith (Exit.ExitFailure 1) - -main_ :: String -> [String] -> IO () -main_ prog ["-h"] = usage prog >> exit -main_ prog ["--help"] = usage prog >> exit -main_ _pro ["--test"] = runTests >> return () -main_ prog [nstr, [d]] = do - case Read.readEither nstr of - Right n -> putStr $ show $ representable n d - Left msg -> usageMsg prog msg -main_ prog _ = usage prog >> die - -main :: IO () -main = do - args <- Environment.getArgs - p <- Environment.getProgName - main_ p args - return () - diff --git a/challenge-113/christian-jaeger/haskell/Makefile b/challenge-113/christian-jaeger/haskell/Makefile index 34571bb7fe..35d1e62474 100644 --- a/challenge-113/christian-jaeger/haskell/Makefile +++ b/challenge-113/christian-jaeger/haskell/Makefile @@ -1,2 +1,2 @@ -113-1-represent_integer_haskell: 113-1-represent_integer_haskell.hs - ghc -fdiagnostics-color=always -Wall -O2 113-1-represent_integer_haskell.hs +ch-1: ch-1.hs + ghc -fdiagnostics-color=always -Wall -O2 ch-1.hs diff --git a/challenge-113/christian-jaeger/haskell/ch-1.hs b/challenge-113/christian-jaeger/haskell/ch-1.hs new file mode 100644 index 0000000000..9a8d3aa9cd --- /dev/null +++ b/challenge-113/christian-jaeger/haskell/ch-1.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- [The Weekly Challenge - 113](https://perlweeklychallenge.org/blog/perl-weekly-challenge-113/), +-- TASK #1: Represent Integer + +-- You are given a positive integer `n` and a digit `d`. + +-- Write a script to check if `n` can be represented as a sum of +-- positive integers [all] having `d` at least once [in their decimal +-- representation]. If check passes print 1 otherwise 0. + +-- Note: there is a [blog post about this](http://functional-perl.org/docs/blog/perl-weekly-challenges-113.xhtml). + + +module Main where +import qualified Data.Set as Set +import Data.Maybe +import Data.Either +import Test.HUnit +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import qualified Text.Read as Read + +-- I'm using parens instead of $ and `let` instead of `where` to make +-- the code look closer to the Perl version / more familiar to Perl +-- programmers. + +-- Also, using this now pretty wide-spread (but not sure about +-- Haskell) piping operator to make the code look similar to OO code +-- using method calls. +(|>) :: t1 -> (t1 -> t2) -> t2 +a |> b = b a + +-- Unlike in the Perl version, I'm only implementing the algorithm +-- used in `maybe_choose_optim_2` here: + +chooseOptim2 :: forall n. (Num n, Ord n) => n -> [n] -> Maybe [n] +chooseOptim2 ntop ns = + let nsSet = Set.fromList ns + check :: [n] -> Maybe [n] + check chosen = + let decide n = + let chosen' = n:chosen + missing = ntop - (sum chosen') + in + if missing == 0 then + Just (Right chosen') + else if missing < 0 then + Nothing + else + if Set.member missing nsSet then + Just (Right (missing : chosen')) + else + Just (Left (check chosen')) + decisions :: [Either (Maybe [n]) [n]] + decisions = ns |> map decide |> takeWhile isJust |> catMaybes + solutions :: [[n]] + solutions = rights decisions + recursions :: [Maybe [n]] + recursions = lefts decisions + in + case solutions of + (solution:_) -> Just solution + _ -> + case recursions |> catMaybes of + (solution:_) -> Just solution + _ -> Nothing + in + check [] + +validNumbers :: Integer -> Char -> [ Integer ] +validNumbers n d = + filter (\i -> elem d (show i)) [1..n] + +representable :: Integer -> Char -> Maybe [Integer] +representable n d = + let ns = validNumbers n d + in + chooseOptim2 n (reverse ns) + + +---------------------------------------------------------------------- + +tests :: [Test] +tests = map (\(n,d,r) -> TestCase( + assertEqual + ("> representable " ++ (show n) ++ " '" ++ [d, '\'']) + r + (representable n d))) + [ (25, '7', Nothing) + , (24, '7', Just [7, 17]) + , (200, '9', Just [9, 191]) + , (200, '8', Just [18, 182]) + , (200, '7', Just [27, 173]) + , (200, '6', Just [36, 164]) + , (20000, '8', Just [18, 19982]) + , (40000, '8', Just [18, 39982]) + , (40000, '6', Just [36, 39964]) + ] + +runTests :: IO Counts +runTests = runTestTT (TestList tests) + +usage :: String -> IO () +usage prog = putStrLn ("Usage: " ++ prog ++ " --test | N D") + +usageMsg :: String -> String -> IO () +usageMsg prog msg = do + putStrLn ("Error: " ++ msg) + usage prog + +exit, die :: IO () +exit = Exit.exitWith Exit.ExitSuccess +die = Exit.exitWith (Exit.ExitFailure 1) + +main_ :: String -> [String] -> IO () +main_ prog ["-h"] = usage prog >> exit +main_ prog ["--help"] = usage prog >> exit +main_ _pro ["--test"] = runTests >> return () +main_ prog [nstr, [d]] = do + case Read.readEither nstr of + Right n -> putStr $ show $ representable n d + Left msg -> usageMsg prog msg +main_ prog _ = usage prog >> die + +main :: IO () +main = do + args <- Environment.getArgs + p <- Environment.getProgName + main_ p args + return () + diff --git a/challenge-113/christian-jaeger/perl/113-1-represent_integer b/challenge-113/christian-jaeger/perl/113-1-represent_integer deleted file mode 100755 index 0cd0c0e72c..0000000000 --- a/challenge-113/christian-jaeger/perl/113-1-represent_integer +++ /dev/null @@ -1,286 +0,0 @@ -#!/usr/bin/env perl - -my $copyright = <<'COPYRIGHT'; -# Copyright (c) 2021 by Christian Jaeger -# This is free software. See the file COPYING.md that came bundled -# with this file. -COPYRIGHT - -=pod - -L, -TASK #1: Represent Integer - -You are given a positive integer $N and a digit $D. - -Write a script to check if $N can be represented as a sum of positive -integers [all] having $D at least once [in their decimal -representation]. If check passes print 1 otherwise 0. - -=head1 NOTE - -There is a Haskell version of this script in the file -L<113-1-represent_integer_haskell.hs>. - -There is a L. - -=cut - -use strict; -use utf8; -use warnings; -use warnings FATAL => 'uninitialized'; -use experimental 'signatures'; -use feature 'current_sub'; # __SUB__ - -my ($mydir, $myname); - -BEGIN { - $0 =~ /(.*?)([^\/]+)\z/s or die "?"; - ($mydir, $myname) = ($1, $2); -} -use lib "$mydir/../../lib"; - -use FunctionalPerl v0.72.65; -use FP::Docstring; -use FP::Show; -use FP::List; -use FP::PureArray; -use FP::Lazy; -use FP::Either ":all"; -use FP::Predicates qw(is_defined); -use Chj::TEST ":all"; -use Chj::time_this; - -our $verbose = $ENV{VERBOSE}; - -sub maybe_choose_brute ($N, $ns) { - __ 'Choose a combination of numbers from $ns (repetitions allowed) - that added together equal $N; undef if not possible. This - solution is brute force in that it is picking additional - numbers from the left end of $ns, one after another, - depth-first.'; - - sub ($chosen) { - my $check = __SUB__; - warn "check (brute): " . show($chosen) if $verbose; - my $sum = $chosen->sum; - if ($sum == $N) { - $chosen - } elsif ($sum > $N) { - undef - } else { - $ns->any( - sub ($n) { - $check->(cons($n, $chosen)) - } - ) - } - } - ->(null) -} - -sub maybe_choose_optim_1 ($N, $ns) { - __ 'Choose a combination of numbers from $ns (repetitions allowed) - that added together equal $N; undef if not possible. This - solution uses a hashtable to check for each additional number; - i.e. it tries to minimize the number of numbers taken from - $ns (it is still searching depth-first).'; - my %ns = map { $_ => 1 } $ns->values; - - sub ($chosen) { - my $check = __SUB__; - warn "check (optim 1): " . show($chosen) if $verbose; - my $sum = $chosen->sum; - my $missing = $N - $sum; - if (not $missing) { - $chosen - } elsif ($missing < 0) { - undef - } else { - if (exists $ns{$missing}) { - cons $missing, $chosen - } else { - $ns->any( - sub ($n) { - $check->(cons($n, $chosen)) - } - ) - } - } - } - ->(null) -} - -sub maybe_choose_optim_2 ($N, $_ns) { - __ 'Choose a combination of numbers (repetitions allowed) from $ns - which must be sorted in decrementing order that added together - equal $N; undef if not possible. This solution does a - breadth-first search (and uses the hashtable check to see if - there will be a match with the next level like - maybe_choose_optim_1)'; - - # We want to use lazy evaluation to allow for the descriptive - # solution below, thus turn the purearray to a lazy list: - my $ns = $_ns->stream; - - my %ns = map { $_ => 1 } $_ns->values; - - sub ($chosen) { - my $check = __SUB__; - warn "check (optim 2): " . show($chosen) if $verbose; - - # Given an additional choice of a number $n (out of $ns) on - # top of $chosen, decide whether there's a solution either - # with the given numbers or when adding one more missing - # number by looking at %ns; or whether the chosen numbers are - # adding up to too much already (in which case undef is - # returned), or the search needs to resume via recursively - # calling $check. The latter case is not carried out - # immediately, but returned as a lazy term (a promise), to - # allow to delay diving deeper into the next recursion level - # to *after* checking all numbers in the current level - # (breadth-first search). - - # Using FP::Either's `Right` to indicate an immediate - # solution, `Left` to indicate a case that needs recursion - # (and only potentially yields a result), undef to signify a - # dead end. - - my $decide = sub ($n) { - warn "decide: checking $n on top of " . show($chosen) if $verbose; - my $chosen = cons $n, $chosen; - my $missing = $N - ($chosen->sum); - if (not $missing) { - Right $chosen - } elsif ($missing < 0) { - undef - } else { - if (exists $ns{$missing}) { - Right cons($missing, $chosen) - } else { - Left lazy { - $check->($chosen) - } - } - } - }; - - # Since $ns are sorted in decrementing order, if $decide - # returns undef, any subsequent number will fail, too, so we - # can stop further checks; `take_while` will only take the - # results up to that point. - - # Since $ns is a stream (a lazily computed list), the - # following `map` and `take_while` steps are lazy, too; - # $decide will never be evaluated for $n's that are smaller - # (coming further along in the reverse-ordered $ns) than any - # $n that can lead to a solution. - - my $decisions = $ns->map($decide)->take_while(\&is_defined); - - # Check for immediate solutions (solutions on our level) - # first, if that fails, get and evaluate the promises to - # recurse (go deeper): - - my $solutions = rights $decisions; - my $recursions = lefts $decisions; - unless ($solutions->is_null) { - $solutions->first - } else { - $recursions->any(\&force) - } - } - ->(null) -} - -# (But there may be smarter algorithms.) - -sub valid_numbers ($N, $D) { - purearray grep {/$D/} (1 .. $N) -} - -# You can explicitely choose the algorithm it via setting -# `MAYBE_CHOOSE` env var to its name, or by passing its reference as -# the 4th argument to maybe_representable. -my $MAYBE_CHOOSE = do { - if (my $str = $ENV{MAYBE_CHOOSE}) { - +{ - maybe_choose_brute => \&maybe_choose_brute, - maybe_choose_optim_1 => \&maybe_choose_optim_1, - maybe_choose_optim_2 => \&maybe_choose_optim_2 - }->{$str} - or die "invalid MAYBE_CHOOSE value" - } else { - undef - } -}; - -sub maybe_representable ($N, $D, $prefer_large = 1, - $maybe_choose = $MAYBE_CHOOSE) -{ - __ 'Returns the numbers containing $D that sum up to $N, or undef. - If $prefer_large is true, tries to use large numbers, - otherwise small (which is (much) less efficient).'; - my $ns = valid_numbers($N, $D); - $maybe_choose - //= ($prefer_large and not $ENV{NO_OPTIM}) - ? \&maybe_choose_optim_2 - : \&maybe_choose_brute; - $maybe_choose->($N, $prefer_large ? $ns->reverse : $ns) -} - -TEST { maybe_representable 25, 7 } undef; -TEST { maybe_representable 24, 7 } list(7, 17); - -TEST { maybe_representable 200, 9 } list(9, 191); -TEST { maybe_representable 200, 9, 0 } -list(29, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9); - -# The comments to the right in the following show the results that -# maybe_choose_optim_1 gave: - -TEST { maybe_representable 200, 8 } list(18, 182); # list(8, 8, 184); -TEST { maybe_representable 200, 8, 0 } -list(8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8); - -TEST { maybe_representable 200, 7 } list(27, 173); # list(7, 7, 7, 179); - -TEST { maybe_representable 200, 6 } list(36, 164); # list(6, 6, 6, 6, 176); - -unless ($ENV{NO_EXPENSIVE_TESTS}) { - TEST { - time_this { maybe_representable 20000, 8 } - } - list(18, 19982); # list(8, 8, 19984); - TEST { - time_this { maybe_representable 40000, 8 } - } - list(18, 39982); # list(8, 8, 39984); - TEST { - time_this { maybe_representable 40000, 6 } - } - list(36, 39964); # list(6, 6, 6, 6, 39976); -} - -# ---------------------------------------------------------------------- - -sub help { - print "Usage: $0 --repl | --test\n"; - exit 1 -} - -&{ - @ARGV - ? { - "--repl" => sub { - require FP::Repl::Trap; - FP::Repl::repl(); - }, - "--test" => sub { - run_tests __PACKAGE__; - } - }->{ $ARGV[0] } // \&help - : \&help -}; - diff --git a/challenge-113/christian-jaeger/perl/113-2-recreate_binary_tree b/challenge-113/christian-jaeger/perl/113-2-recreate_binary_tree deleted file mode 100755 index 29e3cfb546..0000000000 --- a/challenge-113/christian-jaeger/perl/113-2-recreate_binary_tree +++ /dev/null @@ -1,112 +0,0 @@ -#!/usr/bin/env perl - -my $copyright = <<'COPYRIGHT'; -# Copyright (c) 2021 by Christian Jaeger -# This is free software. See the file COPYING.md that came bundled -# with this file. -COPYRIGHT - -=pod - -L, -TASK #2: Recreate Binary Tree - -You are given a Binary Tree. - -Write a script to replace each node of the tree with the sum of all the remaining nodes. - -=head1 NOTE - -There is a L. - -=cut - -use strict; -use utf8; -use warnings; -use warnings FATAL => 'uninitialized'; -use experimental 'signatures'; - -my ($mydir, $myname); - -BEGIN { - $0 =~ /(.*?)([^\/]+)\z/s or die "?"; - ($mydir, $myname) = ($1, $2); -} -use lib "$mydir/../../lib"; - -use FP::Docstring; -use Chj::TEST ":all"; -use FP::Equal; - -package PFLANZE::Node { - use FP::Predicates qw(is_string maybe instance_of); - *is_maybe_Node = maybe instance_of("PFLANZE::Node"); - - use FP::Struct [ - [\&is_maybe_Node, "left"], - [\&is_string, "value"], - [\&is_maybe_Node, "right"] - ] => ("FP::Struct::Show", "FP::Struct::Equal"); - - sub map ($self, $fn) { - my $l = $self->left; - my $r = $self->right; - my $l2 = defined($l) ? $l->map($fn) : undef; - my $r2 = defined($r) ? $r->map($fn) : undef; - $fn->($l2, $self->value, $r2) - } - - _END_ -} -PFLANZE::Node::constructors->import; - -my $in = Node(Node(Node(undef, 4, Node(undef, 7, undef)), 2, undef), - 1, Node(Node(undef, 5, undef), 3, Node(undef, 6, undef))); - -TEST { equal $in, $in->map(\&Node) } 1; - -sub tree_sum($t) { - $t->map( - sub ($l, $value, $r) { - $value + ($l // 0) + ($r // 0) - } - ) -} - -TEST { tree_sum $in } 28; - -sub tree_recreate($t) { - my $sum = tree_sum($t); - $t->map( - sub ($l, $value, $r) { - Node($l, $sum - $value, $r) - } - ) -} - -TEST { tree_recreate $in } -Node(Node(Node(undef, 24, Node(undef, 21, undef)), 26, undef), - 27, Node(Node(undef, 23, undef), 25, Node(undef, 22, undef))); - -# ---------------------------------------------------------------------- - -sub help { - print "Usage: $0 --repl | --test\n"; - exit 1 -} - -&{ - @ARGV - ? { - "--repl" => sub { - require FP::Repl::Trap; - FP::Repl::repl(); - }, - "--test" => sub { - run_tests __PACKAGE__; - } - }->{ $ARGV[0] } // \&help - : \&help -}; - diff --git a/challenge-113/christian-jaeger/perl/ch-1.pl b/challenge-113/christian-jaeger/perl/ch-1.pl new file mode 100755 index 0000000000..0cd0c0e72c --- /dev/null +++ b/challenge-113/christian-jaeger/perl/ch-1.pl @@ -0,0 +1,286 @@ +#!/usr/bin/env perl + +my $copyright = <<'COPYRIGHT'; +# Copyright (c) 2021 by Christian Jaeger +# This is free software. See the file COPYING.md that came bundled +# with this file. +COPYRIGHT + +=pod + +L, +TASK #1: Represent Integer + +You are given a positive integer $N and a digit $D. + +Write a script to check if $N can be represented as a sum of positive +integers [all] having $D at least once [in their decimal +representation]. If check passes print 1 otherwise 0. + +=head1 NOTE + +There is a Haskell version of this script in the file +L<113-1-represent_integer_haskell.hs>. + +There is a L. + +=cut + +use strict; +use utf8; +use warnings; +use warnings FATAL => 'uninitialized'; +use experimental 'signatures'; +use feature 'current_sub'; # __SUB__ + +my ($mydir, $myname); + +BEGIN { + $0 =~ /(.*?)([^\/]+)\z/s or die "?"; + ($mydir, $myname) = ($1, $2); +} +use lib "$mydir/../../lib"; + +use FunctionalPerl v0.72.65; +use FP::Docstring; +use FP::Show; +use FP::List; +use FP::PureArray; +use FP::Lazy; +use FP::Either ":all"; +use FP::Predicates qw(is_defined); +use Chj::TEST ":all"; +use Chj::time_this; + +our $verbose = $ENV{VERBOSE}; + +sub maybe_choose_brute ($N, $ns) { + __ 'Choose a combination of numbers from $ns (repetitions allowed) + that added together equal $N; undef if not possible. This + solution is brute force in that it is picking additional + numbers from the left end of $ns, one after another, + depth-first.'; + + sub ($chosen) { + my $check = __SUB__; + warn "check (brute): " . show($chosen) if $verbose; + my $sum = $chosen->sum; + if ($sum == $N) { + $chosen + } elsif ($sum > $N) { + undef + } else { + $ns->any( + sub ($n) { + $check->(cons($n, $chosen)) + } + ) + } + } + ->(null) +} + +sub maybe_choose_optim_1 ($N, $ns) { + __ 'Choose a combination of numbers from $ns (repetitions allowed) + that added together equal $N; undef if not possible. This + solution uses a hashtable to check for each additional number; + i.e. it tries to minimize the number of numbers taken from + $ns (it is still searching depth-first).'; + my %ns = map { $_ => 1 } $ns->values; + + sub ($chosen) { + my $check = __SUB__; + warn "check (optim 1): " . show($chosen) if $verbose; + my $sum = $chosen->sum; + my $missing = $N - $sum; + if (not $missing) { + $chosen + } elsif ($missing < 0) { + undef + } else { + if (exists $ns{$missing}) { + cons $missing, $chosen + } else { + $ns->any( + sub ($n) { + $check->(cons($n, $chosen)) + } + ) + } + } + } + ->(null) +} + +sub maybe_choose_optim_2 ($N, $_ns) { + __ 'Choose a combination of numbers (repetitions allowed) from $ns + which must be sorted in decrementing order that added together + equal $N; undef if not possible. This solution does a + breadth-first search (and uses the hashtable check to see if + there will be a match with the next level like + maybe_choose_optim_1)'; + + # We want to use lazy evaluation to allow for the descriptive + # solution below, thus turn the purearray to a lazy list: + my $ns = $_ns->stream; + + my %ns = map { $_ => 1 } $_ns->values; + + sub ($chosen) { + my $check = __SUB__; + warn "check (optim 2): " . show($chosen) if $verbose; + + # Given an additional choice of a number $n (out of $ns) on + # top of $chosen, decide whether there's a solution either + # with the given numbers or when adding one more missing + # number by looking at %ns; or whether the chosen numbers are + # adding up to too much already (in which case undef is + # returned), or the search needs to resume via recursively + # calling $check. The latter case is not carried out + # immediately, but returned as a lazy term (a promise), to + # allow to delay diving deeper into the next recursion level + # to *after* checking all numbers in the current level + # (breadth-first search). + + # Using FP::Either's `Right` to indicate an immediate + # solution, `Left` to indicate a case that needs recursion + # (and only potentially yields a result), undef to signify a + # dead end. + + my $decide = sub ($n) { + warn "decide: checking $n on top of " . show($chosen) if $verbose; + my $chosen = cons $n, $chosen; + my $missing = $N - ($chosen->sum); + if (not $missing) { + Right $chosen + } elsif ($missing < 0) { + undef + } else { + if (exists $ns{$missing}) { + Right cons($missing, $chosen) + } else { + Left lazy { + $check->($chosen) + } + } + } + }; + + # Since $ns are sorted in decrementing order, if $decide + # returns undef, any subsequent number will fail, too, so we + # can stop further checks; `take_while` will only take the + # results up to that point. + + # Since $ns is a stream (a lazily computed list), the + # following `map` and `take_while` steps are lazy, too; + # $decide will never be evaluated for $n's that are smaller + # (coming further along in the reverse-ordered $ns) than any + # $n that can lead to a solution. + + my $decisions = $ns->map($decide)->take_while(\&is_defined); + + # Check for immediate solutions (solutions on our level) + # first, if that fails, get and evaluate the promises to + # recurse (go deeper): + + my $solutions = rights $decisions; + my $recursions = lefts $decisions; + unless ($solutions->is_null) { + $solutions->first + } else { + $recursions->any(\&force) + } + } + ->(null) +} + +# (But there may be smarter algorithms.) + +sub valid_numbers ($N, $D) { + purearray grep {/$D/} (1 .. $N) +} + +# You can explicitely choose the algorithm it via setting +# `MAYBE_CHOOSE` env var to its name, or by passing its reference as +# the 4th argument to maybe_representable. +my $MAYBE_CHOOSE = do { + if (my $str = $ENV{MAYBE_CHOOSE}) { + +{ + maybe_choose_brute => \&maybe_choose_brute, + maybe_choose_optim_1 => \&maybe_choose_optim_1, + maybe_choose_optim_2 => \&maybe_choose_optim_2 + }->{$str} + or die "invalid MAYBE_CHOOSE value" + } else { + undef + } +}; + +sub maybe_representable ($N, $D, $prefer_large = 1, + $maybe_choose = $MAYBE_CHOOSE) +{ + __ 'Returns the numbers containing $D that sum up to $N, or undef. + If $prefer_large is true, tries to use large numbers, + otherwise small (which is (much) less efficient).'; + my $ns = valid_numbers($N, $D); + $maybe_choose + //= ($prefer_large and not $ENV{NO_OPTIM}) + ? \&maybe_choose_optim_2 + : \&maybe_choose_brute; + $maybe_choose->($N, $prefer_large ? $ns->reverse : $ns) +} + +TEST { maybe_representable 25, 7 } undef; +TEST { maybe_representable 24, 7 } list(7, 17); + +TEST { maybe_representable 200, 9 } list(9, 191); +TEST { maybe_representable 200, 9, 0 } +list(29, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9); + +# The comments to the right in the following show the results that +# maybe_choose_optim_1 gave: + +TEST { maybe_representable 200, 8 } list(18, 182); # list(8, 8, 184); +TEST { maybe_representable 200, 8, 0 } +list(8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8); + +TEST { maybe_representable 200, 7 } list(27, 173); # list(7, 7, 7, 179); + +TEST { maybe_representable 200, 6 } list(36, 164); # list(6, 6, 6, 6, 176); + +unless ($ENV{NO_EXPENSIVE_TESTS}) { + TEST { + time_this { maybe_representable 20000, 8 } + } + list(18, 19982); # list(8, 8, 19984); + TEST { + time_this { maybe_representable 40000, 8 } + } + list(18, 39982); # list(8, 8, 39984); + TEST { + time_this { maybe_representable 40000, 6 } + } + list(36, 39964); # list(6, 6, 6, 6, 39976); +} + +# ---------------------------------------------------------------------- + +sub help { + print "Usage: $0 --repl | --test\n"; + exit 1 +} + +&{ + @ARGV + ? { + "--repl" => sub { + require FP::Repl::Trap; + FP::Repl::repl(); + }, + "--test" => sub { + run_tests __PACKAGE__; + } + }->{ $ARGV[0] } // \&help + : \&help +}; + diff --git a/challenge-113/christian-jaeger/perl/ch-2.pl b/challenge-113/christian-jaeger/perl/ch-2.pl new file mode 100755 index 0000000000..29e3cfb546 --- /dev/null +++ b/challenge-113/christian-jaeger/perl/ch-2.pl @@ -0,0 +1,112 @@ +#!/usr/bin/env perl + +my $copyright = <<'COPYRIGHT'; +# Copyright (c) 2021 by Christian Jaeger +# This is free software. See the file COPYING.md that came bundled +# with this file. +COPYRIGHT + +=pod + +L, +TASK #2: Recreate Binary Tree + +You are given a Binary Tree. + +Write a script to replace each node of the tree with the sum of all the remaining nodes. + +=head1 NOTE + +There is a L. + +=cut + +use strict; +use utf8; +use warnings; +use warnings FATAL => 'uninitialized'; +use experimental 'signatures'; + +my ($mydir, $myname); + +BEGIN { + $0 =~ /(.*?)([^\/]+)\z/s or die "?"; + ($mydir, $myname) = ($1, $2); +} +use lib "$mydir/../../lib"; + +use FP::Docstring; +use Chj::TEST ":all"; +use FP::Equal; + +package PFLANZE::Node { + use FP::Predicates qw(is_string maybe instance_of); + *is_maybe_Node = maybe instance_of("PFLANZE::Node"); + + use FP::Struct [ + [\&is_maybe_Node, "left"], + [\&is_string, "value"], + [\&is_maybe_Node, "right"] + ] => ("FP::Struct::Show", "FP::Struct::Equal"); + + sub map ($self, $fn) { + my $l = $self->left; + my $r = $self->right; + my $l2 = defined($l) ? $l->map($fn) : undef; + my $r2 = defined($r) ? $r->map($fn) : undef; + $fn->($l2, $self->value, $r2) + } + + _END_ +} +PFLANZE::Node::constructors->import; + +my $in = Node(Node(Node(undef, 4, Node(undef, 7, undef)), 2, undef), + 1, Node(Node(undef, 5, undef), 3, Node(undef, 6, undef))); + +TEST { equal $in, $in->map(\&Node) } 1; + +sub tree_sum($t) { + $t->map( + sub ($l, $value, $r) { + $value + ($l // 0) + ($r // 0) + } + ) +} + +TEST { tree_sum $in } 28; + +sub tree_recreate($t) { + my $sum = tree_sum($t); + $t->map( + sub ($l, $value, $r) { + Node($l, $sum - $value, $r) + } + ) +} + +TEST { tree_recreate $in } +Node(Node(Node(undef, 24, Node(undef, 21, undef)), 26, undef), + 27, Node(Node(undef, 23, undef), 25, Node(undef, 22, undef))); + +# ---------------------------------------------------------------------- + +sub help { + print "Usage: $0 --repl | --test\n"; + exit 1 +} + +&{ + @ARGV + ? { + "--repl" => sub { + require FP::Repl::Trap; + FP::Repl::repl(); + }, + "--test" => sub { + run_tests __PACKAGE__; + } + }->{ $ARGV[0] } // \&help + : \&help +}; + -- cgit