Add solutions, under the names as published in FunctionalPerl

6 files changed, 534 insertions, 0 deletions

diff --git a/challenge-113/christian-jaeger/README b/challenge-113/christian-jaeger/README
new file mode 100644
index 0000000000..4ef4f11c10
--- /dev/null
+++ b/challenge-113/christian-jaeger/README
@@ -0,0 +1 @@
+Solution by Christian Jaeger
diff --git a/challenge-113/christian-jaeger/blog.txt b/challenge-113/christian-jaeger/blog.txt
new file mode 100644
index 0000000000..67c3250920
--- /dev/null
+++ b/challenge-113/christian-jaeger/blog.txt
@@ -0,0 +1 @@
+http://functional-perl.org/docs/blog/perl-weekly-challenges-113.xhtml
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
new file mode 100644
index 0000000000..9a8d3aa9cd
--- /dev/null
+++ b/challenge-113/christian-jaeger/haskell/113-1-represent_integer_haskell.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/haskell/Makefile b/challenge-113/christian-jaeger/haskell/Makefile
new file mode 100644
index 0000000000..34571bb7fe
--- /dev/null
+++ b/challenge-113/christian-jaeger/haskell/Makefile
@@ -0,0 +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 
diff --git a/challenge-113/christian-jaeger/perl/113-1-represent_integer b/challenge-113/christian-jaeger/perl/113-1-represent_integer
new file mode 100755
index 0000000000..0cd0c0e72c
--- /dev/null
+++ b/challenge-113/christian-jaeger/perl/113-1-represent_integer
@@ -0,0 +1,286 @@
+#!/usr/bin/env perl
+
+my $copyright = <<'COPYRIGHT';
+# Copyright (c) 2021 by Christian Jaeger <copying@christianjaeger.ch>
+# This is free software. See the file COPYING.md that came bundled
+# with this file.
+COPYRIGHT
+
+=pod
+
+L<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.
+
+=head1 NOTE
+
+There is a Haskell version of this script in the file
+L<113-1-represent_integer_haskell.hs>.
+
+There is a L<blog post about this|http://functional-perl.org/docs/blog/perl-weekly-challenges-113.xhtml>.
+
+=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
new file mode 100755
index 0000000000..29e3cfb546
--- /dev/null
+++ b/challenge-113/christian-jaeger/perl/113-2-recreate_binary_tree
@@ -0,0 +1,112 @@
+#!/usr/bin/env perl
+
+my $copyright = <<'COPYRIGHT';
+# Copyright (c) 2021 by Christian Jaeger <copying@christianjaeger.ch>
+# This is free software. See the file COPYING.md that came bundled
+# with this file.
+COPYRIGHT
+
+=pod
+
+L<The Weekly Challenge - 113|https://perlweeklychallenge.org/blog/perl-weekly-challenge-113/>,
+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<blog post about this|http://functional-perl.org/docs/blog/perl-weekly-challenges-113.xhtml>.
+
+=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
+};
+