[R] A little exercise in R!

[Philippe Grosjean]

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.
>
>