[R] A little exercise in R!
(Ted Harding)
Ted.Harding at wlandres.net
Sat Apr 14 17:00:17 CEST 2012
Well, this "Olympiad" challenge led to some interesting responses.
First, Bert Gunther noted that the arragement of 1:17 must have
17 at one end, allowing it to be solved on paper in a few minutes.
That would definitely be in the spirit of the Olympiad, where
'"In the Olympiad it's about starting with a problem that anybody
could understand, then coming up with that clever idea that enables
you to solve it," she [Ceri Fiddes] said.'
However, it was not in the spirit of my own challenge, which was
to write neat self-contained R code to solve it. So while Bert gets
special mention for clearing the pole-vault bar without a pole,
starting from a hand-stand position, there's no Gold there!
Justin Haynes posted it to stackoverflow, and gave the link to
Vincent Zoonekynd's answer. This recognised the underlying
graph-theoretic issue. However, his code wheeled on the igraph
package and used its graph.adjacency() function to solve it.
Neat, but flouted my rule that use of such an existing R package
was illegitimate. You are not allowed to win the 100 metres by
riding a motorcycle.
Petr Savicky's solution is the approach I preferred, and indeed
is along the lines of my own approach (and much neater than what
I achieved). Yes, recursion is indeed allowable, since it is built-in
to R's functionality. In this line of approach, starting from any
given integer and proceeding by selecting from allowable next
integers, you sooner or later encounter a multiple choice. So you
are tracing down the branches of a tree to see how far you can get.
Some minor changes to Petr's code generalise it to being able to
answer Bert's later speculation about "can this always be done?",
i.e. is it just for 1:17, or what? Here is Petr's code as revised
(Petr's original commands, where changed, are preceded by "##",
and followed by my changes):
##extend <- function(x)
extend <- function(x,N)
{
## y <- setdiff((1:17), x)
y <- setdiff((1:N), x) # for any 1:N, not just 1:17
if (length(y) == 0) {
## cat(x, "\n")
cat(N) ; cat(": ") ; cat(x, "\n") # To show which N
return
}
## y <- y[(y + x[length(x)]) %in% (1:5)^2]
M <- ceiling(sqrt((N-1)+N)) # To include accessible squares
y <- y[(y + x[length(x)]) %in% (1:M)^2] # as here
for (z in y) {
extend(c(x, z),N)
}
}
##for (i in 1:17) extend(i)
## 16 9 7 2 14 11 5 4 12 13 3 6 10 15 1 8 17
## 17 8 1 15 10 6 3 13 12 4 5 11 14 2 7 9 16
Now to see what comes out for 1:N, N=1:17
for( N in (1:17) ){for (i in (1:N)) extend(i,N)}
# 1: 1
# 15: 8 1 15 10 6 3 13 12 4 5 11 14 2 7 9
# 15: 9 7 2 14 11 5 4 12 13 3 6 10 15 1 8
# 16: 8 1 15 10 6 3 13 12 4 5 11 14 2 7 9 16
# 16: 16 9 7 2 14 11 5 4 12 13 3 6 10 15 1 8
# 17: 16 9 7 2 14 11 5 4 12 13 3 6 10 15 1 8 17
# 17: 17 8 1 15 10 6 3 13 12 4 5 11 14 2 7 9 16
So, in addition to the original 1:17 case, we can also do it
for 1:15 and 1:16 (as well as the trivial 1:1). But how
far up can we take it? It turns out we can get suprisingly
prolific results! Take just going from 18:25 (which follows
on from the 1:17 above):
for( N in (18:25) ){for (i in (1:N)) extend(i,N)}
# 23: 2 23 13 12 4 21 15 10 6 19 17 8 1 3 22 14 11 5 20 16 9 7 18
# 23: 9 16 20 5 11 14 22 3 1 8 17 19 6 10 15 21 4 12 13 23 2 7 18
# 23: 18 7 2 23 13 12 4 21 15 10 6 19 17 8 1 3 22 14 11 5 20 16 9
# 23: 18 7 9 16 20 5 11 14 2 23 13 12 4 21 15 10 6 19 17 8 1 3 22
# 23: 18 7 9 16 20 5 11 14 22 3 1 8 17 19 6 10 15 21 4 12 13 23 2
# 23: 22 3 1 8 17 19 6 10 15 21 4 12 13 23 2 14 11 5 20 16 9 7 18
# 25: 2 23 13 12 24 25 11 14 22 3 1 8 17 19 6 10 15 21 4 5 20 16 9 7 18
# 25: 3 22 14 2 23 13 12 4 21 15 10 6 19 17 8 1 24 25 11 5 20 16 9 7 18
# 25: 4 21 15 10 6 19 17 8 1 3 22 14 2 23 13 12 24 25 11 5 20 16 9 7 18
# 25: 8 17 19 6 10 15 21 4 12 13 23 2 14 22 3 1 24 25 11 5 20 16 9 7 18
# 25: 9 16 20 5 4 21 15 10 6 19 17 8 1 3 22 14 11 25 24 12 13 23 2 7 18
# 25: 10 15 21 4 12 13 23 2 14 22 3 6 19 17 8 1 24 25 11 5 20 16 9 7 18
# 25: 11 25 24 12 13 23 2 14 22 3 1 8 17 19 6 10 15 21 4 5 20 16 9 7 18
# 25: 13 23 2 14 22 3 1 8 17 19 6 10 15 21 4 12 24 25 11 5 20 16 9 7 18
# 25: 18 7 2 23 13 12 24 25 11 14 22 3 1 8 17 19 6 10 15 21 4 5 20 16 9
# 25: 18 7 9 16 20 5 4 21 15 10 6 19 17 8 1 3 22 14 2 23 13 12 24 25 11
# 25: 18 7 9 16 20 5 4 21 15 10 6 19 17 8 1 3 22 14 11 25 24 12 13 23 2
# 25: 18 7 9 16 20 5 11 25 24 1 3 22 14 2 23 13 12 4 21 15 10 6 19 17 8
# 25: 18 7 9 16 20 5 11 25 24 1 8 17 19 6 3 22 14 2 23 13 12 4 21 15 10
# 25: 18 7 9 16 20 5 11 25 24 1 8 17 19 6 10 15 21 4 12 13 3 22 14 2 23
# 25: 18 7 9 16 20 5 11 25 24 1 8 17 19 6 10 15 21 4 12 13 23 2 14 22 3
# 25: 18 7 9 16 20 5 11 25 24 12 4 21 15 10 6 19 17 8 1 3 13 23 2 14 22
# 25: 18 7 9 16 20 5 11 25 24 12 4 21 15 10 6 19 17 8 1 3 22 14 2 23 13
# 25: 18 7 9 16 20 5 11 25 24 12 13 23 2 14 22 3 1 8 17 19 6 10 15 21 4
# 25: 22 14 2 23 13 3 1 8 17 19 6 10 15 21 4 12 24 25 11 5 20 16 9 7 18
# 25: 23 2 14 22 3 13 12 4 21 15 10 6 19 17 8 1 24 25 11 5 20 16 9 7 18
So you also get solutions (non-unique) for 1:23 (6, basically 3,
of them) and for 1:25 (20, basically 10, of them). The case
for( N in (26:100) ){for (i in (1:N)) extend(i,N)}
is left as an exercise for the reader.
Meanwhile, I await solutions from the teams who are competing in
the Circuit of the Universe, hurdling over all the (approx) 10^14.6
permutations of 1:17 (reports suggest that CERN may be in the lead).
Thanks for the responses, and best wishes to all,
Ted.
On 14-Apr-2012 04:59:48 Bert Gunter wrote:
> Folks:
>
> IMHO this is exactly the **wrong** way t go about this. These are
> mathematical exercises that should employ mathematical thinking, not
> brute force checking of cases.
>
> Consider, for example, the 1 to 17 sequence given by Ted. Then 17
> **must** be one end of the sequence and 16 the other. (Why?) Hence,
> starting from the 17 end, the values ** must** be 17 8 1 ...
> Proceeding in this way, it takes only a couple of minutes to solve.
>
> The more interesting point which I think the question was really
> about, is can this always be done? I haven't given this any thought,
> but there may be an easy proof or counterexample. If the answer to
> this latter is no, then perhaps even more interesting is to
> characterize the set of numbers where it can/cannot be done.
>
> But this is all way off topic, no?
>
> Cheers,
> Bert
>
>
>
> On Fri, Apr 13, 2012 at 6:26 PM, Philippe Grosjean
> <phgrosjean at sciviews.org> wrote:
>> Hi all,
>>
>> I got another solution, and it would apply probably for the ugliest one :-(
>> I made it general enough so that it works for any series from 1 to n (n not
>> too large, please... tested up to 30).
>>
>> Hint for a better algorithm: inspect the object 'friends' in my code: there
>> is a nice pattern appearing there!!!
>>
>> Best,
>>
>> Philippe
>>
>> ..............................................<¡}))><........
>> _) ) ) ) )
>> ( ( ( ( ( _ _Prof. Philippe Grosjean
>> _) ) ) ) )
>> ( ( ( ( ( _ _Numerical Ecology of Aquatic Systems
>> _) ) ) ) ) _ Mons University, Belgium
>> ( ( ( ( (
>> ..............................................................
>>
>> findSerie <- function (n, tmax = 500) {
>> _## Check arguments
>> _n <- as.integer(n)
>> _if (length(n) != 1 || is.na(n) || n < 1)
>> _ _stop("'n' must be a single positive integer")
>>
>> _tmax <- as.integer(tmax)
>> _if (length(tmax) != 1 || is.na(tmax) || tmax < 1)
>> _ _stop("'tmax' must be a single positive integer")
>>
>> _## Suite of our numbers to be sorted
>> _nbrs <- 1:n
>>
>> _## Trivial cases: only one or two numbers
>> _if (n == 1) return(1)
>> _if (n == 2) stop("The pair does not sum to a square number")
>>
>> _## Compute all possible pairs
>> _omat <- outer(rep(1, n), nbrs)
>> _## Which pairs sum to a square number?
>> _friends <- sqrt(omat + nbrs) %% 1 < .Machine$double.eps
>> _diag(friends) <- FALSE # Eliminate pairs of same numbers
>>
>> _## Get a list of possible neighbours
>> _neigb <- apply(friends, 1, function(x) nbrs[x])
>>
>> _## Nbr of neighbours for each number
>> _nf <- sapply(neigb, length)
>>
>> _## Are there numbers without neighbours?
>> _## then, problem impossible to solve..
>> _if (any(!nf))
>> _ _stop("Impossible to solve:\n _ _",
>> _ _ _paste(nbrs[!nf], collapse = ", "),
>> _ _ _" sum to square with nobody else!")
>>
>> _## Are there numbers that can have only one neighbour?
>> _## Must be placed at one extreme
>> _toEnds <- nbrs[nf == 1]
>> _## I must have two of them maximum!
>> _l <- length(toEnds)
>> _if (l > 2)
>> _ _stop("Impossible to solve:\n _ _",
>> _ _ _"More than two numbers form only one pair:\n _ _",
>> _ _ _paste(toEnds, collapse = ", "))
>>
>> _## The other numbers can appear in the middle of the suite
>> _inMiddle <- nbrs[!nbrs %in% toEnds]
>>
>> _generateSerie <- function (neigb, toEnds, inMiddle) {
>> _ _## Allow to generate serie by picking candidates randomly
>> _ _if (length(toEnds) > 1) toEnds <- sample(toEnds)
>> _ _if (length(inMiddle) > 1) inMiddle <- sample(inMiddle)
>>
>> _ _## Choose a number to start with
>> _ _res <- rep(NA, n)
>>
>> _ _## Three cases: 0, 1, or 2 numbers that must be at an extreme
>> _ _## Following code works in all cases
>> _ _res[1] <- toEnds[1]
>> _ _res[n] <- toEnds[2]
>>
>> _ _## List of already taken numbers
>> _ _taken <- toEnds
>>
>> _ _## Is there one number in res[1]? Otherwise, fill it now...
>> _ _if (is.na(res[1])) {
>> _ _ _ _taken <- inMiddle[1]
>> _ _ _ _res[1] <- taken
>> _ _}
>>
>> _ _## For each number in the middle, choose one acceptable neighbour
>> _ _for (ii in 2:(n-1)) {
>> _ _ _prev <- res[ii - 1]
>> _ _ _allpossible <- neigb[[prev]]
>> _ _ _candidate <- allpossible[!(allpossible %in% taken)]
>> _ _ _if (!length(candidate)) break # We fail to construct the serie
>> _ _ _## Take randomly one possible candidate
>> _ _ _if (length(candidate) > 1) take <- sample(candidate, 1) else
>> _ _ _ _take <- candidate
>> _ _ _res[ii] <- take
>> _ _ _taken <- c(taken, take)
>> _ _}
>>
>> _ _## If we manage to go to the end, check last pair...
>> _ _if (length(taken) == (n - 1)) {
>> _ _ _take <- nbrs[!(nbrs %in% taken)]
>> _ _ _res[n] <- take
>> _ _ _taken <- c(take, taken)
>> _ _}
>> _ _if (length(taken) == n && !(res[n] %in% neigb[[res[n - 1]]]))
>> _ _res[n] <- NA # Last one pair not allowed
>>
>> _ _## Return the series
>> _ _return(res)
>> _}
>>
>> _for (trial in 1:tmax) {
>> _ _cat("Trial", trial, ":")
>> _ _serie <- generateSerie(neigb = neigb, toEnds = toEnds,
>> _ _ _inMiddle = inMiddle)
>> _ _cat(paste(serie, collapse = ", "), "\n")
>> _ _flush.console() # Print text now
>> _ _if (!any(is.na(serie))) break
>> _}
>> _if (any(is.na(serie))) {
>> _ _cat("\nSorry, I did not find a solution\n\n")
>> _} else cat("\n** I got it! **\n\n")
>> _return(serie)
>> }
>>
>> findSerie(17)
>>
>>
>> On 13/04/12 23:34, (Ted Harding) wrote:
>>>
>>> Greetings all!
>>> A recent news item got me thinking that a problem stated
>>> therein could provide a teasing little exercise in R
>>> programming.
>>>
>>> http://www.bbc.co.uk/news/uk-england-cambridgeshire-17680326
>>>
>>> _ Cambridge University hosts first European 'maths Olympiad'
>>> _ for girls
>>>
>>> _ The first European girls-only "mathematical Olympiad"
>>> _ competition is being hosted by Cambridge University.
>>> _ [...]
>>> _ Olympiad co-director, Dr Ceri Fiddes, said competition questions
>>> _ encouraged "clever thinking rather than regurgitating a taught
>>> _ syllabus".
>>> _ [...]
>>> _ "A lot of Olympiad questions in the competition are about
>>> _ proving things," Dr Fiddes said.
>>>
>>> _ "If you have a puzzle, it's not good enough to give one answer.
>>> _ You have to prove that it's the only possible answer."
>>> _ [...]
>>> _ "In the Olympiad it's about starting with a problem that anybody
>>> _ could understand, then coming up with that clever idea that
>>> _ enables you to solve it," she said.
>>>
>>> _ "For example, take the numbers one up to 17.
>>>
>>> _ "Can you write them out in a line so that every pair of numbers
>>> _ that are next to each other, adds up to give a square number?"
>>>
>>> Well, that's the challenge: Write (from scratch) an R program
>>> that solves this problem. And make it neat.
>>>
>>> NOTE: If there should happen to be some R package that can solve
>>> this kind of problem already, without you having to think much,
>>> then its use is illegitimate! (I.e. will be deemed "regurgitation").
>>>
>>> Over to you.
>>>
>>> With best wishes,
>>> Ted.
>>>
>>> -------------------------------------------------
>>> E-Mail: (Ted Harding)<Ted.Harding at wlandres.net>
>>> Date: 13-Apr-2012 _Time: 22:33:43
>>> This message was sent by XFMail
>>>
>>> ______________________________________________
>>> R-help at r-project.org mailing list
>>> https://stat.ethz.ch/mailman/listinfo/r-help
>>> PLEASE do read the posting guide
>>> http://www.R-project.org/posting-guide.html
>>> and provide commented, minimal, self-contained, reproducible code.
>>>
>>>
>>
>> ______________________________________________
>> R-help at r-project.org mailing list
>> https://stat.ethz.ch/mailman/listinfo/r-help
>> PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
>> and provide commented, minimal, self-contained, reproducible code.
>
>
>
> --
>
> Bert Gunter
> Genentech Nonclinical Biostatistics
>
> Internal Contact Info:
> Phone: 467-7374
> Website:
> http://pharmadevelopment.roche.com/index/pdb/pdb-functional-groups/pdb-biostat
> istics/pdb-ncb-home.htm
-------------------------------------------------
E-Mail: (Ted Harding) <Ted.Harding at wlandres.net>
Date: 14-Apr-2012 Time: 16:00:10
This message was sent by XFMail
More information about the R-help
mailing list