Warning: Cannot modify header information - headers already sent by (output started at /home/public/wp-content/themes/simplelin/functions.php:1) in /home/public/wp-includes/feed-rss2.php on line 8
haskell – Ben Barber https://babarber.uk mathematical storytelling Sat, 09 May 2020 15:25:29 +0000 en-US hourly 1 https://wordpress.org/?v=5.9.2 Diffy naive https://babarber.uk/546/diffy-naive/ https://babarber.uk/546/diffy-naive/#respond Sat, 09 May 2020 15:25:29 +0000 https://babarber.uk/?p=546 A week or so ago Rob Eastaway posted about the game Diffy on Twitter. Diffy begins with four numbers arranged around a cycle. Taking the (absolute values of) differences between adjacent pairs produces four more numbers around a cycle. If you start with positive integers then iterating this process eventually reaches 0, 0, 0, 0. How many iterations does it take?

A quick search (and the existence of Rob Eastaway’s talk on the subject) reveals that a fair amount is known about Diffy. I have deliberately not read any of it in detail. I don’t even know why you always reach zero, which is not as obvious as I had assumed: consider 0,0,0,1, say, which reaches zero in four steps, but increases the sum of the four numbers along the way. The question I looked at was “What is the maximum number of steps this process can take, beginning with numbers from [n] = \{1,\ldots,n\}?” Call this f(n).

Rob begins by asking us to show that f(12)+1 = 10. (+1 by counting the cycles we see along the way rather than the number of steps we take.) There are only 12^4 starting points so this takes no time at all if we break the spirit of the puzzle and use a computer. But there’s no need to be pointlessly inefficient. The length of a Diffy “game” is unchanged if we

  • add a constant to every number
  • rotate the numbers around the cycle
  • reverse the order of the numbers around the cycle
  • (multiply the numbers by a non-zero constant)

By applying the first three observations we can say that there will be a witness for the value of f(n) using numbers from [n] with the first number being 1, and the fourth number being at least as large as the second.

f' [x,y,z,w] = [abs (x-y), abs (y-z), abs (z-w), abs (w-x)]

g' xs = takeWhile (/=[0,0,0,0]) (iterate f' xs)

h' xs = length (g' xs) + 1

i' n = maximum [(h' [a,b,c,d], [a,b,c,d]) | a <- [1], b <- [a..n], c <- [a..n], d <- [b..n]] 

(Not pictured: good choice of variable names.)

So an n^4 exhaust is down to n^3/2 using symmetry.

My next thought in these situations is that we’re doing an awful lot of recomputation. If I’ve already scored 0,1,0,1, why should I reevaluate it when scoring 0,0,0,1? Why not store the score somewhere so we can look it up later?

f n = maximum (elems table) where
  table = array ((0,0,0),(n-1,n-1,n-1)) [((a,b,c), g a b c) | a <- [0..n-1], b <- [0..n-1], c <- [0..n-1]]
  g 0 0 0 = 1 -- represents c c c c for c > 0 the first time you reach it
  g a b c | a > c = g c b a
          | otherwise = (table ! normalise a (abs (b-a)) (abs (c-b)) c) + 1

normalise a b c d = let m = minimum [a,b,c,d]
                    in  normalise2 (a-m) (b-m) (c-m) (d-m)

normalise2 0 b c d = (b,c,d)
normalise2 a 0 c d = (c,d,a)
normalise2 a b 0 d = (d,a,b)
normalise2 a b c 0 = (a,b,c)

This is what I ended up with. It isn’t pretty. The thing that wasn’t, but should have been, immediately obvious is that the states I encounter along the way won’t be in the nicely normalised form we’ve just decided we want to work with, so the naive lookup table increases our time back up to n^4. On the other hand, normalising things like this is expensive compared to the computation we’re trying to save. It’s a very bad deal, and even if it weren’t I can’t afford n^3 memory for very large values of n.

So we’re back to computing f(n) honestly for each n in time O(n^3). The next observation is that if we want f(n) for lots of n we can do better: if f(n) is to be larger than f(n-1) then the pattern witnessing that had better use both 1 and n, taking us to O(n^2) for each new n. In fact, we can say a bit more. The 1 and n would either have to be adjacent or opposite.

    1 -- b        1 -- n
    |    |        |    |
    d -- n        d -- c

Then we still have some symmetries to play with with. In the opposite case, all of the edges are related by symmetries so we can assume that b-1 is the smallest difference. In the adjacent case there is less symmetry, but we can still assume that d-1 \leq n-c.

direct n = maximum ( [score 1 b n d | b <- [1..n`quot`2], d <- [b..n+1-b]]
                  ++ [score 1 n c d | c <- [1..n], d <- [1..n+1-c]] )

score 0 0 0 0 = 0
score a b c d = 1 + (score (abs (a-b)) (abs  (b-c)) (abs (c-d)) (abs (d-a)))

That’s not bad and will get you well up into the thousands without difficulty.

(Everything above is a mostly accurate representation of my progress through this problem, with light editing to fix errors and wholesale removal of dollar signs from my Haskell, since they confuse the LaTeX plugin. What follows is ahistorical, presenting an endpoint without all the dead ends along the way.)

So far we haven’t thought about the actual operation we’re iterating, so let’s do that now. Suppose that we’re in the opposite case with b and d strictly between 1 and n. Then replacing 1 by 2 and n by n-1 produces a pattern that goes to the same place as the original pattern under two rounds of iteration, so such patterns aren’t interesting in our search; they were considered in previous rounds. Similarly, in the adjacent case where c > d we can decrease c and n to obtain an equivalent-after-two-iterations pattern with a smaller value of n, so we don’t need to consider it. Finally, if we’re in the opposite case but b=1, say, then we could alternatively have viewed ourself as being in the adjacent case. So we can reduce our search to

direct n = maximum [score 1 a b n | a <- [1..n], b <- [a..n]]

for n^2/2 or, after further assuming that a-1 \leq n-b,

direct n = maximum [score 1 a b n | a <- [1..(n+1)]`quot`2], b <- [a..n-a+1]]

for n^2/4. (Once these computations are taking hours or days the constant factor improvements shouldn’t be undervalued.)

We’ve already seen that storing lots of information about previously computed results is not helpful, but we can store the known values of f(n) and its “inverse” g(k), the least n such that f(n) \geq k. Then when testing whether a,b,c,d scores at least k it might be worth checking whether \max(a,b,c,d) - \min(a,b,c,d) \geq g(k), which is the absolute minimum requirement to last at least k rounds. But our scoring function is so cheap that you don’t have to do very much at all of this sort of thing before it becomes too expensive, and in practice the optimal amount of checking seems to be zero.

Unless we can somehow do the checking without actually doing the checking? If we’re currently trying to check whether f(n) \geq k+1 then we’d better have the smallest and largest differences differing by at least g(k)-1. That -1 is the point at which I throw my hands up and switch to the interval [0,n] rather than [n] = [1,n], which means you have to keep an eye out for off by one errors when comparing earlier results with what comes next. We already have

    \[0 \leq a \leq b \leq n, \qquad a \leq n-b.\]

The largest difference at the beginning is n, so we additionally require that either n-a \geq g(k) or n-(b-a) \geq g(k). Rearranging, either a \leq n - g(k) or a \geq g(k) - n + b. This takes us to

newRecord n = maximum [score 0 a b n | b <- [..n], a <- h b]
  where
    gk = firstTimeWeCanGet ! (recordUpTo ! (n-1)) -- see full listing
    h b = let top = min b (n-b) in
          if   n-gk < b-n+gk && n-gk < top
          then [0..n-gk] ++ [b-n+gk..top]
          else [0..top]

with a cheap improvement from doing the first round of the iteration by hand.

newRecord n = maximum [score a (b-a) (n-b) n | b <- [0..n], a <- f b] + 1

There’s at least one more idea worth considering. We haven’t used the fourth symmetry, of multiplying by non-zero constants. The practical use would be to divide out any common factors of a,b,n, but doing the gcd each time is too expensive. I had greater hopes for checking that at least one of them is odd, which should save a quarter of the work half of the time, for a total saving of about 12%, but it doesn’t seem to help, even if you enforce it by never generating the bad pairs a, b, the same way we are able to do for the size consideration in the current listing.

This will produce the (k,g(k)) pairs up to (28,19513) in 100 minutes on my 3.6GHz machine. It hasn’t found the next pair yet after a few days of searching. It’s possible that some of the optimisation considerations (especially for what should be the cheap cases like eliminating a\equivb\equiv b \equiv n \equiv 0 \pmod 2) change for large k as naive scoring becomes more expensive, but my haphazard trials have had inconsistent results, both algorithmically and in terms of apparently making the compiler stop favouring certain optimisations.

(0,0)
(1,1)
(2,1)
(3,1)
(4,1)
(5,3)
(6,3)
(7,4)
(8,9)
(9,11)
(10,13)
(11,31)
(12,37)
(13,44)
(14,105)
(15,125)
(16,149)
(17,355)
(18,423)
(19,504)
(20,1201)
(21,1431)
(22,1705)
(23,4063)
(24,4841)
(25,5768)
(26,13745)
(27,16377)
(28,19513)
]]>
https://babarber.uk/546/diffy-naive/feed/ 0
The number of maximal left-compressed intersecting families https://babarber.uk/374/maximal-left-compressed-intersecting-families/ https://babarber.uk/374/maximal-left-compressed-intersecting-families/#respond Fri, 23 Feb 2018 12:57:11 +0000 http://babarber.uk/?p=374 A family of sets \mathcal A \subseteq [n]^{(r)} (subsets of \{1, \ldots, n\} of size r) is intersecting if every pair of sets in \mathcal A have a common element.  If n < 2r then every pair of sets intersect, so |\mathcal A| can be as large as \binom n r.  If n \geq 2r then the Erdős–Ko–Rado theorem states that |\mathcal A| \leq \binom {n-1} {r-1}, which (up to relabelling of the ground set) is attained only by the star \mathcal S of all sets containing the element 1.

A hands on proof of the Erdős–Ko–Rado theorem use a tool called compression.  A family \mathcal A is left-compressed if for every A \in \mathcal A, any set obtained from A by deleting an element and replacing it by a smaller one is also in \mathcal A.  You can show by repeatedly applying a certain compression operator that for every intersecting family \mathcal A there is a left-compressed intersecting family \mathcal A' of the same size.  Thus it suffices to prove the Erdős–Ko–Rado theorem for left-compressed families, which is easy to do by induction.

There is a strong stability result for large intersecting families.  The Hilton–Milner family consists of all sets that contain 1 and at least one element of [2,r+1], together with [2,r+1] itself.  This is an intersecting family, and in fact is the largest intersecting family not contained in a star.  The Hilton–Milner family has size O(n^{r-2}), so any family that gets anything like close to the Erdős–Ko–Rado bound must be a subset of a star.

As part of an alternative proof of the Hilton–Milner theorem, Peter Borg partially answered the following question.

Let \mathcal A \subseteq [n]^{(r)} be an intersecting family and let X \subseteq [n].  Let \mathcal A(X) = \{A \in \mathcal A : A \cap X \neq \emptyset\}.  For which X is |\mathcal A(X)| \leq |\mathcal S(X)|?

Borg used that fact that this is true for X = [2,r+1] to reprove the Hilton–Milner theorem.  In Maximum hitting for n sufficiently large I completed the classification of X for which this is true for large n.  The proof used the apparently new observation that, for n \geq 2r, every maximal left-compressed intersecting family in [n]^{(r)} corresponds to a unique maximal left-compressed intersecting family of [2r]^{(r)}.  In particular, the number of maximal left-compressed intersecting families for n \geq 2r is independent of n.  For r=1, 2, 3, 4, 5, 6 there are 1, 2, 6, 72, 37145, 1081162102034 (OEIS) such families respectively.  In the rest of this post I’ll explain how I obtained these numbers.

We want to count maximal left-compressed intersecting families of [2r]^{(r)}.  The maximal part is easy: the only way to get two disjoint sets of size r from [2r] is to take a set and its complement, so we must simply choose one set from each complementary pair.  To make sure the family we generate in this way is left-compressed we must also ensure that whenever we choose a set A we must also choose every set B with B \leq A, where B \leq A means “B can be obtained from A by a sequence of compressions”.  The compression order has the following properties.

  • If A = \{a_1 < \cdots < a_r\} and B = \{b_1 < \cdots < b_r\} then A \leq B if and only if a_i \leq b_i for each i.
  • A \leq B if and only if B^c \leq A^c.

Here’s one concrete algorithm.

  1. Generate a list of all sets from [2r-1]^{(r)}.  This list has one set from each complementary pair.
  2. Put all A from the list with A < A^c into \mathcal A.  (These sets must be in every maximal left-compressed intersecting family.)  Note that we never have A^c < A as A^c contains 2r but A doesn’t.
  3. Let A be the first element of the list and branch into two cases depending on whether we take A or A^c.
    • If we take A, also take all B from the list with B < A and B^c for all B from the list with B^c < A. (Since B^c contains 2r and A doesn’t, the second condition will never actually trigger.)
    • If we take A^c, also take all B from the list with B < A^c and B^c for all B from the list with B^c < A^c. (It is cheaper to test A < B than the second condition to avoid taking complements.)
  4. Repeat recursively on each of the two lists generated in the previous step.  Stop on each branch whenever the list of remaining options is empty.

The following is a fairly direct translation of this algorithm into Haskell that makes no attempt to store the families generated and just counts the number of possibilities.  A source file with the necessary import’s and the choose function is attached to the end of this post.

r = 5

simpleOptions = [a | a <- choose r [1..(2*r-1)], not [dollar-sign] a `simpleLeftOf` (simpleComplement a)]

simpleLeftOf xs ys = all id [dollar-sign] zipWith (<=) xs ys

simpleComplement a = [1..(2*r)] \\ a

simpleCount [] = 1
simpleCount (a:as) = simpleCount take + simpleCount leave
  where
    -- take a
    -- all pairs with b < a or b^c < a are forced
    -- second case never happens as b^c has 2r but a doesn't
    take = [b | b <- as, not [dollar-sign] b `simpleLeftOf` a]
    -- leave a, and so take a^c
    -- all pairs with b < a^c or b^c < a^c (equivalently, a < b) are forced
    c = simpleComplement a
    leave = [b | b <- as, not (b `simpleLeftOf` c || a `simpleLeftOf` b)]

This will compute the number of maximal left-compressed intersecting families for r \leq 5 in a fraction of a second.  For r=6 it would probably find the answer in less than a month.  I obtained the value for r=6 in a couple of days on a single core by using a better representation of the sets in our family.

The dream is to pack all of the elements of our list into a single machine word and perform each comparison in a small number of instructions.  For example, we could encode an element of [12]^{(6)} by writing each element as 4 binary digits then concatenating them in increasing order to obtain a 24 bit word.  But comparing two such words as integers compares the corresponding sets lexicographically rather than pointwise.  Edward Crane suggested that as the lists are so short and the elements are so small we can afford to be quite a lot more wasteful in our representation: we can write each element of our set in unary!  The rest of this section should be considered joint work with him.

The first iteration of the idea is to write each element x of [12] as a string of x 1’s followed by 12-x 0’s, then concatenate these strings to obtain a representation of our set.  This representation has the great advantage that we can compare sets pointwise by comparing strings bitwise, and we can do this using very few binary operations: a is contained in b if and only if a \& b = a.

Unfortunately this representation uses 72 bits in total, so won’t fit into a 64-bit machine word. Observing that we never use 0 and encoding by x-1 1‘s followed by 11-x 0‘s saves only 6 bits. But we can do even better by encoding each element of the set differently. The first element is always at least 1, the second is always at least 2 and so on. Similarly, the first element is at most 7, the second at most 8 and so on. Working through the details we arrive at the following representation.

Identify each element of [12]^{(6)} by an “up-and-right” path from the bottom left to the top right corner of a 6 \times 6 grid: at the ith step move right if i is in your set and up if it isn’t. Then A \leq B if and only if the path corresponding to A never goes below the path corresponding to B. So we can compare sets by comparing the regions below the corresponding paths. Recording these regions can be done using 36 bits, which happily sits inside a machine word. This representation also has the helpful property that taking the complement of a set corresponds to reflecting a path about the up-and-right diagonal, so the representation of the complement of a set can be obtained by swapping certain pairs of bits followed by a bitwise NOT.

The value for r=6 was obtained using this new representation and the old algorithm, with one minor tweak.  It’s a bad idea to start with a lexicographically ordered list of sets, as the early decisions will not be meaningful and not lead to much of a reduction in the length of the the lists.  Optimal selection of which pair to decide at each stage is probably a complicated question.  As a compromise I randomised the order of the list at the start of the process, then took the first remaining pair at each stage.

The Haskell source is here.  There are a few more performance tricks to do with the exact bit representation of the sets, which I’m happy to discuss if anything is unclear.

]]>
https://babarber.uk/374/maximal-left-compressed-intersecting-families/feed/ 0