programming mathematica to find a specific perfect square number set - wolfram-mathematica

A colleague of mine gave the following question to his C programming class which i found very interesting. It can easily be done in any programming language and immediately i thought wolfram.
The question is this:
The number 25 is a unique perfect square, If we increase each digit by one, it becomes 36 which is also a a perfect square!
write a program to find another set of numbers with the same qualities.
I am sure this can be easily done in mathematica.
Can someone explain how i can do this in mathematica. please note the reason of the question is just an excuse to get me into mathematica programming of which i know nothing.
thanks to all.

A more functional solution.
Table[x^2, {x, 1, 100}] // Select[IntegerQ[Sqrt[FromDigits[IntegerDigits[#] + 1]]] &]
How should the digit 9 be handled?
IntegerDigits[19]
(* {1, 9} *)
IntegerDigits[19] + 1
(* {2, 10} *)
FromDigits[IntegerDigits[19] + 1]
(* 30 *)
Should the +1 carry so the resulting number is 20 rather than 30?

You can easily expand this to any base and you only need to know how long the number is in a given base. What I mean is the following. Assume in base 10, the number 25. To check the premise, we need to add 11. But 11 is nothing more than:
25 + 11
= 25 + 10^1 + 10^0
= 25 + (10^2-1)/(10-1)
= 36 = 6^2
imagine now the number 72 × 72 = 5184, but represented in base 3 (518410 = 210100003). Doing now the computation in base 3, you get
21010000 + 11111111
= 21010000 + 3^7 + 3^6 + 3^5 + 3^4 + 3^3 + 3^2 + 3^1 + 3^0
= 21010000 + (3^8-1)/(3-1)
= 102121111 = 10102^2
where 1021211113 = 846410 = 9210 × 9210.
As you notice, all you need to do is add the number (bn - 1)/(b-1) to the number and check if it is a square. Here n, represents the total amount of digits of the number x in base b.
With a simple lookuptable, you do this in Mathematica as:
b = 10
x = Table[n^2, {n, 1, 1000}];
Select[x, MemberQ[x, # + (b^IntegerLength[#, b] - 1)/(b - 1)] &];
{25, 289, 2025, 13225, 100489, 198025, 319225, 466489}
and the full list for base 2 till base 10 is then:
Table[Select[x, MemberQ[x, # + (b^IntegerLength[#, b] - 1)/(b - 1)] &], {b, 2, 10}]

Instead of throwing you into the ocean, lets help you paddle around in the shallow end of the pool first.
n=1;
While[n<100,
d=IntegerDigits[n];(*get the list of digits making up n*)
newd=d+1;(*add one to every element of the list giving a new list*)
newn=FromDigits[newd];(*turn that new list of digits back into a number*)
If[IntegerQ[Sqrt[newn]],Print[{n,newn}]];
n++
]
That doesn't only look at square values of n, but it might give you the hint needed about how to increment the digits and test for a square result.
There are always at least a dozen different ways of doing anything in Mathematica and some of the culture revolves around making the programs as short, and potentially cryptic, as possible. You can start picking that up later. Simplicity seems better when getting started with a new language.
I hope you have fun.

find[from_, to_] := Module[{a, b, c, d, e},
a = Range[from, to];
b = a^2;
c = IntegerDigits[b];
(*Add 1's to the digits of the square,
except where the square contains a 9*)
d = MapThread[
If[MemberQ[#2, 9], Null,
#1 + FromDigits[ConstantArray[1, Length[#2]]]] &,
{b, c}];
(*Find the positions where the square roots are integers*)
e = Position[Sqrt[d], _?IntegerQ, {1}];
Extract[a, e]]
find[1, 1000000]
{5, 45, 115, 2205, 245795, 455645}
For example
Sqrt[45^2 + 1111]
56
and
Sqrt[455645^2 + 111111111111]
564556

Related

Coin change with split into two sets

I'm trying to figure out how to solve a problem that seems a tricky variation of a common algorithmic problem but require additional logic to handle specific requirements.
Given a list of coins and an amount, I need to count the total number of possible ways to extract the given amount using an unlimited supply of available coins (and this is a classical change making problem https://en.wikipedia.org/wiki/Change-making_problem easily solved using dynamic programming) that also satisfy some additional requirements:
extracted coins are splittable into two sets of equal size (but not necessarily of equal sum)
the order of elements inside the set doesn't matter but the order of set does.
Examples
Amount of 6 euros and coins [1, 2]: solutions are 4
[(1,1), (2,2)]
[(1,1,1), (1,1,1)]
[(2,2), (1,1)]
[(1,2), (1,2)]
Amount of 8 euros and coins [1, 2, 6]: solutions are 7
[(1,1,2), (1,1,2)]
[(1,2,2), (1,1,1)]
[(1,1,1,1), (1,1,1,1)]
[(2), (6)]
[(1,1,1), (1,2,2)]
[(2,2), (2,2)]
[(6), (2)]
By now I tried different approaches but the only way I found was to collect all the possible solution (using dynamic programming) and then filter non-splittable solution (with an odd number of coins) and duplicates. I'm quite sure there is a combinatorial way to calculate the total number of duplication but I can't figure out how.
(The following method first enumerates partitions. My other answer generates the assignments in a bottom-up fashion.) If you'd like to count splits of the coin exchange according to coin count, and exclude redundant assignments of coins to each party (for example, where splitting 1 + 2 + 2 + 1 into two parts of equal cardinality is only either (1,1) | (2,2), (2,2) | (1,1) or (1,2) | (1,2) and element order in each part does not matter), we could rely on enumeration of partitions where order is disregarded.
However, we would need to know the multiset of elements in each partition (or an aggregate of similar ones) in order to count the possibilities of dividing them in two. For example, to count the ways to split 1 + 2 + 2 + 1, we would first count how many of each coin we have:
Python code:
def partitions_with_even_number_of_parts_as_multiset(n, coins):
results = []
def C(m, n, s, p):
if n < 0 or m <= 0:
return
if n == 0:
if not p:
results.append(s)
return
C(m - 1, n, s, p)
_s = s[:]
_s[m - 1] += 1
C(m, n - coins[m - 1], _s, not p)
C(len(coins), n, [0] * len(coins), False)
return results
Output:
=> partitions_with_even_number_of_parts_as_multiset(6, [1,2,6])
=> [[6, 0, 0], [2, 2, 0]]
^ ^ ^ ^ this one represents two 1's and two 2's
Now since we are counting the ways to choose half of these, we need to find the coefficient of x^2 in the polynomial multiplication
(x^2 + x + 1) * (x^2 + x + 1) = ... 3x^2 ...
which represents the three ways to choose two from the multiset count [2,2]:
2,0 => 1,1
0,2 => 2,2
1,1 => 1,2
In Python, we can use numpy.polymul to multiply polynomial coefficients. Then we lookup the appropriate coefficient in the result.
For example:
import numpy
def count_split_partitions_by_multiset_count(multiset):
coefficients = (multiset[0] + 1) * [1]
for i in xrange(1, len(multiset)):
coefficients = numpy.polymul(coefficients, (multiset[i] + 1) * [1])
return coefficients[ sum(multiset) / 2 ]
Output:
=> count_split_partitions_by_multiset_count([2,2,0])
=> 3
(Posted a similar answer here.)
Here is a table implementation and a little elaboration on algrid's beautiful answer. This produces an answer for f(500, [1, 2, 6, 12, 24, 48, 60]) in about 2 seconds.
The simple declaration of C(n, k, S) = sum(C(n - s_i, k - 1, S[i:])) means adding all the ways to get to the current sum, n using k coins. Then if we split n into all ways it can be partitioned in two, we can just add all the ways each of those parts can be made from the same number, k, of coins.
The beauty of fixing the subset of coins we choose from to a diminishing list means that any arbitrary combination of coins will only be counted once - it will be counted in the calculation where the leftmost coin in the combination is the first coin in our diminishing subset (assuming we order them in the same way). For example, the arbitrary subset [6, 24, 48], taken from [1, 2, 6, 12, 24, 48, 60], would only be counted in the summation for the subset [6, 12, 24, 48, 60] since the next subset, [12, 24, 48, 60] would not include 6 and the previous subset [2, 6, 12, 24, 48, 60] has at least one 2 coin.
Python code (see it here; confirm here):
import time
def f(n, coins):
t0 = time.time()
min_coins = min(coins)
m = [[[0] * len(coins) for k in xrange(n / min_coins + 1)] for _n in xrange(n + 1)]
# Initialize base case
for i in xrange(len(coins)):
m[0][0][i] = 1
for i in xrange(len(coins)):
for _i in xrange(i + 1):
for _n in xrange(coins[_i], n + 1):
for k in xrange(1, _n / min_coins + 1):
m[_n][k][i] += m[_n - coins[_i]][k - 1][_i]
result = 0
for a in xrange(1, n + 1):
b = n - a
for k in xrange(1, n / min_coins + 1):
result = result + m[a][k][len(coins) - 1] * m[b][k][len(coins) - 1]
total_time = time.time() - t0
return (result, total_time)
print f(500, [1, 2, 6, 12, 24, 48, 60])

How can I find all possible sums and differences of numbers in a vector?

Let's say I have a vector called numbers.
Numbers = {1, 5, 6, 8}. (A possibility I have though of is to double the size of the vector and include all the negative numbers, but I still don't have a good solution to find all the possible sums.)
Possible solutions:
4 = 5 - 1
1 = 1
19 = 8 + 6 + 5
I want the search to stop when I've found a number I will be looking for, but my main issue is just to find all of the different sums.
This is very similar to the subset sum problem but I haven't really found a solution that I can understand / that includes negative numbers.
Use dynamic programming.
Let (a_0, ..., a_{n-1}) be your array of numbers.
Let A(k) be the set of all possible sums/differences of (a_0, ..., a_{k-1}).
Then you can easily deduce A(k) from A(k-1). Be sure that all repetitions are removed, using hash table or sorting or anything.
The point is that, if there is an upper bound m of the a_i's, then A(k) contains at most 2mk + 1 elements. Thus the complexity is reduced from O(3^n) to something like O(mn^2).
This is probably the best thing you can do: for example, if the a_i's are increasing exponentially, then the size of the final result is also exponential.
Think in the ternary representation {0, 1, 2}, you have a set of numbers, where every number can appear as positive, negative or not appear, then you could represent this posibilities as ternary {0, 1, 2} and use it with coef -> {-1, 0, 1} you can compute all combination easily.
coef -> (-1 , 0, 1)-> ternary '0' -> value '-1', ternary '1' -> value '0' and ternary 2 -> value '1'.
Numbers -> {n0, n1, n2, .. ni}
Ternary representation -> (t0)*3^0 + (t1)*3^1 + (t2)*3^2 + .. + (ti)*3^i
Coef -> {c0 , c1, c2, .. ci}
Result -> C0*n0 + C1*n1 + C2*n2 + .. + Ci*ni
An example:
Numbers = {1, 5, 6, 8}
Total combinations -> 3^4 = 81
combination number (c) ∈ [0 , 80].
f.e: c = 79 -> 2221(ternary)
Ternary (reverse) {1, 2, 2, 2} to coef {0, 1, 1, 1}
result (79d/2221t): 0*1 + 1*5 + 1*6 + 1*8 = 19
To calculate all combinations, you must to calculate this steps in a loop (i -> 0 .. 3^4)

Getting the equation for the line of intersection using Mathematica

I have a nasty expression that I am playing around with on Mathematica.
(-X + (2 X - X^2)/(
2 (-1 + X)^2 ((1 + 2 (-1 + p) X - (-1 + p) X^2)/(-1 + X)^2)^(3/2)))/X
I graphed it along with the plane z = 0 where X and p are both restricted from 0 to 1:
Plot3D[{nasty equation is here, 0}, {p , 0, 1}, {X, 0, 1}]
I decided it would be interesting to obtain the equation for the intersection of the plane generated from the nasty equation and z = 0. So I used solve:
Solve[{that nasty equation == 0}, {p, X}, Reals]
and the output was even nastier with some results having the # symbol in it ( I have no idea what it is, and I am new to Mathematica). Is there a way to get an equation for the nice line of intersection between the nasty equation and z = 0 where p and X are restricted from 0 to 1? In the graph generated from Plot3D I see that the line of intersection appears to be some nice looking half parabola looking thing. I would like the equation for that if possible. Thank you!
For complicated nasty equations Reduce is often more powerful and less likely to give you something that you will later find has hidden assumptions inside the result. Notice I include your constraint about the range of p and X to give Reduce the maximum amount of
information that I can to help it produce the simplest possible solution for you.
In[1]:= Reduce[(-X + (2 X-X^2)/(2 (-1 + X)^2 ((1 + 2 (-1 + p) X - (-1 + p) X^2)/
(-1 + X)^2)^(3/2)))/X == 0 && 0 < X < 1 && 0 < p < 1, {X, p}]
Out[1]= 0<X<1 && p == Root[12 - 47*X + 74*X^2 - 59*X^3 + 24*X^4 - 4*X^5 + (-24 +
108*X - 192*X^2 + 168*X^3 - 72*X^4 + 12*X^5)*#1 + (-48*X + 144*X^2 - 156*X^3 +
72*X^4 - 12*X^5)*#1^2 + (-32*X^2 + 48*X^3 - 24*X^4 + 4*X^5)*#1^3 & , 1]
Root is a Mathematica function representing a root of a usually complicated polynomial
that would often be much larger if the actual root were written out in algebra, but we
can see whether the result is understandable enough to be useful by using ToRadicals.
Often Reduce will return several different alternatives using && (and) and || (or) to
let you see the details you must understand to correctly use the result. See how I
copy the entire Root[...] and put that inside ToRadicals. Notice how Reduce returns
answers that include information about the ranges of variables. And see how I give Simplify the domain information about X to allow it to provide the greatest possible simplification.
In[2]:= Simplify[ToRadicals[Root[12 - 47 X + 74 X^2 - 59 X^3 + 24 X^4 - 4 X^5 +
(-24 + 108 X - 192 X^2 + 168 X^3 - 72 X^4 + 12 X^5) #1 + (-48 X + 144 X^2 -
156 X^3 + 72 X^4 - 12 X^5) #1^2 + (-32 X^2 + 48 X^3 - 24 X^4+ 4 X^5)#1^3&,1]],
0 < X < 1]
Out[2]= (8*X - 24*X^2 + 26*X^3 - 12*X^4 + 2*X^5 + 2^(1/3)*(-((-2 + X)^8*(-1 +
X)^2*X^3))^(1/3))/(2*(-2 + X)^3*X^2)
So your desired answer of where z= 0 will be where X is not zero, to avoid 0/0 in
your original equation, and where 0 < X < 1, 0 < p < 1 and where p is a root of that
final complicated expression in X. That result is a fraction and to be a root you
might take a look at where the numerator is zero to see if you can get any more
information about what you are looking for.
Sometimes you can learn something by plotting an expression. If you try to plot that final result you may end up with axes, but no plot. Perhaps the denominator is causing problems. You can try plotting just the numerator. You may again get an empty plot. Perhaps it is your cube root giving complex values. So you can put your numerator inside Re[] and plot that, then repeat that but using Im[]. Those will let you plot just the real and imaginary parts. You are doing this to try to understand where the roots might be. You should be cautious with plots because sometimes, particularly for complicated nasty expressions, the plot can make mistakes or hide desired information from you, but when used with care you can often learn something from this.
And, as always, test this and everything else very carefully to try to make sure that no mistakes have been made. It is too easy to "type some stuff into Mathematica, get some stuff out", think you have the answer and have no idea that there are significant errors hidden.

Get number of Nth place of modified Fibonacci sequence

In an interview today, I was given this sequence, which is sort of a modified Fibonacci:
1, 1, 2, 4, 6, 13, 19, 42, 61, 135, ...,
I was asked to write a function to return the number at place n.
So, if n = 4, the function should return 4, n = 6 return 13, etc.
As I'm sure you already noticed, the difference is that even items equal the previous 4 items, while odd items equal the previous 2.
It isn't a problem if you use recursion. That's what I did, but it's not the approach I would have liked.
The Fibonacci calculation goes something like this (in PHP):
$n = 17;
$phi = (1 + sqrt(5)) / 2;
$u = (pow($phi, $n) - pow(1 - $phi, $n)) / sqrt(5);
$u being, in this case, 1597.
However, I have no idea how to solve it with a modified version of a Fibonacci sequence like this one.
If I understand you correctly, you want to compute efficiently [i.e. in O( log(n) )] sequence defined as:
a[2n + 5] = a[2n + 4] + a[2n + 3] + a[2n + 2] + a[2n + 1]
a[2n + 2] = a[2n + 1] + a[2n]
Let's define two new sequences. First one will correspond to the values of a on even positions, the second one to the values on even positions:
b[n] = a[2n]
c[n] = a[2n + 1]
Now we have:
c[n] = b[n] + c[n - 1] + b[n - 1] + c[n - 2]
b[n] = c[n - 1] + b[n - 1]
Subtracting the second equation from the first we get (after some transformation):
b[n] = ( c[n] - c[n-1] ) /2
Next substitute this formula into first equation to get formula for c:
c[n] = 2 c[n-1] + c[n-2]
Notice that this equation involves only elements from c. Therefore now it is possible to compute elements of c, using techniques described here. By transforming equations a little bit further you will be able to compute b efficiently as well.
Like every sequence defined by a linear recurrence with constant coefficients, the Fibonacci numbers have a closed-form solution.
http://en.wikipedia.org/wiki/Fibonacci_number#Closed-form_expression
However, I do not know how to create a closed form expression for this particular sequence.
What I can add is that you can solve Fibonacci or any similar sequence without recursion, e.g.:
http://forum.codecall.net/topic/41540-fibonacci-with-no-recursion-for-fun/
So you can solve the problem using a loop rather than the stack.

Code Golf: Countdown Number Game

Locked. This question and its answers are locked because the question is off-topic but has historical significance. It is not currently accepting new answers or interactions.
Challenge
Here is the task, inspired by the well-known British TV game show Countdown. The challenge should be pretty clear even without any knowledge of the game, but feel free to ask for clarifications.
And if you fancy seeing a clip of this game in action, check out this YouTube clip. It features the wonderful late Richard Whitely in 1997.
You are given 6 numbers, chosen at random from the set {1, 2, 3, 4, 5, 6, 8, 9, 10, 25, 50, 75, 100}, and a random target number between 100 and 999. The aim is to use the six given numbers and the four common arithmetic operations (addition, subtraction, multiplication, division; all over the rational numbers) to generate the target - or as close as possible either side. Each number may only be used once at most, while each arithmetic operator may be used any number of times (including zero.) Note that it does not matter how many numbers are used.
Write a function that takes the target number and set of 6 numbers (can be represented as list/collection/array/sequence) and returns the solution in any standard numerical notation (e.g. infix, prefix, postfix). The function must always return the closest-possible result to the target, and must run in at most 1 minute on a standard PC. Note that in the case where more than one solution exists, any single solution is sufficient.
Examples:
{50, 100, 4, 2, 2, 4}, target 203
e.g. 100 * 2 + 2 + (4 / 4) (exact)
e.g. (100 + 50) * 4 * 2 / (4 + 2) (exact)
{25, 4, 9, 2, 3, 10}, target 465
e.g. (25 + 10 - 4) * (9 * 2 - 3) (exact)
{9, 8, 10, 5, 9, 7}, target 241
e.g. ((10 + 9) * 9 * 7) + 8) / 5 (exact)
{3, 7, 6, 2, 1, 7}, target 824
e.g. ((7 * 3) - 1) * 6 - 2) * 7 (= 826; off by 2)
Rules
Other than mentioned in the problem statement, there are no further restrictions. You may write the function in any standard language (standard I/O is not necessary). The aim as always is to solve the task with the smallest number of characters of code.
Saying that, I may not simply accept the answer with the shortest code. I'll also be looking at elegance of the code and time complexity of the algorithm!
My Solution
I'm attempting an F# solution when I find the free time - will post it here when I have something!
Format
Please post all answers in the following format for the purpose of easy comparison:
Language
Number of characters: ???
Fully obfuscated function:
(code here)
Clear (ideally commented) function:
(code here)
Any notes on the algorithm/clever shortcuts it takes.
Python
Number of characters: 548 482 425 421 416 413 408
from operator import *
n=len
def C(N,T):
R=range(1<<n(N));M=[{}for i in R];p=1
for i in range(n(N)):M[1<<i][1.*N[i]]="%d"%N[i]
while p:
p=0
for i in R:
for j in R:
m=M[i|j];l=n(m)
if not i&j:m.update((f(x,y),"("+s+o+t+")")for(y,t)in M[j].items()if y for(x,s)in M[i].items() for(o,f)in zip('+-*/',(add,sub,mul,div)))
p|=l<n(m)
return min((abs(x-T),e)for t in M for(x,e)in t.items())[1]
you can call it like this:
>>> print C([50, 100, 4, 2, 2, 4], 203)
((((4+2)*(2+100))/4)+50)
Takes about half a minute on the given examples on an oldish PC.
Here's the commented version:
def countdown(N,T):
# M is a map: (bitmask of used input numbers -> (expression value -> expression text))
M=[{} for i in range(1<<len(N))]
# initialize M with single-number expressions
for i in range(len(N)):
M[1<<i][1.0*N[i]] = "%d" % N[i]
# allowed operators
ops = (("+",lambda x,y:x+y),("-",lambda x,y:x-y),("*",lambda x,y:x*y),("/",lambda x,y:x/y))
# enumerate all expressions
n=0
while 1:
# test to see if we're done (last iteration didn't change anything)
c=0
for x in M: c +=len(x)
if c==n: break
n=c
# loop over all values we have so far, indexed by bitmask of used input numbers
for i in range(len(M)):
for j in range(len(M)):
if i & j: continue # skip if both expressions used the same input number
for (x,s) in M[i].items():
for (y,t) in M[j].items():
if y: # avoid /0 (and +0,-0,*0 while we're at it)
for (o,f) in ops:
M[i|j][f(x,y)]="(%s%s%s)"%(s,o,t)
# pick best expression
L=[]
for t in M:
for(x,e) in t.items():
L+=[(abs(x-T),e)]
L.sort();return L[0][1]
It works through exhaustive enumeration of all possibilities. It is a bit smart in that if there are two expressions with the same value that use the same input numbers, it discards one of them. It is also smart in how it considers new combinations, using the index into M to prune quickly all the potential combinations that share input numbers.
Haskell
Number of characters: 361 350 338 322
Fully obfuscated function:
m=map
f=toRational
a%w=m(\(b,v)->(b,a:v))w
p[]=[];p(a:w)=(a,w):a%p w
q[]=[];q(a:w)=[((a,b),v)|(b,v)<-p w]++a%q w
z(o,p)(a,w)(b,v)=[(a`o`b,'(':w++p:v++")")|b/=0]
y=m z(zip[(-),(/),(+),(*)]"-/+*")++m flip(take 2 y)
r w=do{((a,b),v)<-q w;o<-y;c<-o a b;c:r(c:v)}
c t=snd.minimum.m(\a->(abs(fst a-f t),a)).r.m(\a->(f a,show a))
Clear function:
-- | add an element on to the front of the remainder list
onRemainder :: a -> [(b,[a])] -> [(b,[a])]
a`onRemainder`w = map (\(b,as)->(b,a:as)) w
-- | all ways to pick one item from a list, returns item and remainder of list
pick :: [a] -> [(a,[a])]
pick [] = []
pick (a:as) = (a,as) : a `onRemainder` (pick as)
-- | all ways to pick two items from a list, returns items and remainder of list
pick2 :: [a] -> [((a,a),[a])]
pick2 [] = []
pick2 (a:as) = [((a,b),cs) | (b,cs) <- pick as] ++ a `onRemainder` (pick2 as)
-- | a value, and how it was computed
type Item = (Rational, String)
-- | a specification of a binary operation
type OpSpec = (Rational -> Rational -> Rational, String)
-- | a binary operation on Items
type Op = Item -> Item -> Maybe Item
-- | turn an OpSpec into a operation
-- applies the operator to the values, and builds up an expression string
-- in this context there is no point to doing +0, -0, *0, or /0
combine :: OpSpec -> Op
combine (op,os) (ar,as) (br,bs)
| br == 0 = Nothing
| otherwise = Just (ar`op`br,"("++as++os++bs++")")
-- | the operators we can use
ops :: [Op]
ops = map combine [ ((+),"+"), ((-), "-"), ((*), "*"), ((/), "/") ]
++ map (flip . combine) [((-), "-"), ((/), "/")]
-- | recursive reduction of a list of items to a list of all possible values
-- includes values that don't use all the items, includes multiple copies of
-- some results
reduce :: [Item] -> [Item]
reduce is = do
((a,b),js) <- pick2 is
op <- ops
c <- maybe [] (:[]) $ op a b
c : reduce (c : js)
-- | convert a list of real numbers to a list of items
items :: (Real a, Show a) => [a] -> [Item]
items = map (\a -> (toRational a, show a))
-- | return the first reduction of a list of real numbers closest to some target
countDown:: (Real a, Show a) => a -> [a] -> Item
countDown t is = snd $ minimum $ map dist $ reduce $ items is
where dist is = (abs . subtract t' . fst $ is, is)
t' = toRational t
Any notes on the algorithm/clever shortcuts it takes:
In the golf'd version, z returns in the list monad, rather than Maybe as ops does.
While the algorithm here is brute force, it operates in small, fixed, linear space due to Haskell's laziness. I coded the wonderful #keith-randall algorithm, but it ran in about the same time and took over 1.5G of memory in Haskell.
reduce generates some answers multiple times, in order to easily include solutions with fewer terms.
In the golf'd version, y is defined partially in terms of itself.
Results are computed with Rational values. Golf'd code would be 17 characters shorter, and faster if computed with Double.
Notice how the function onRemainder factors out the structural similarity between pick and pick2.
Driver for golf'd version:
main = do
print $ c 203 [50, 100, 4, 2, 2, 4]
print $ c 465 [25, 4, 9, 2, 3, 10]
print $ c 241 [9, 8, 10, 5, 9, 7]
print $ c 824 [3, 7, 6, 2, 1, 7]
Run, with timing (still under one minute per result):
[1076] : time ./Countdown
(203 % 1,"(((((2*4)-2)/100)+4)*50)")
(465 % 1,"(((((10-4)*25)+2)*3)+9)")
(241 % 1,"(((((10*9)/5)+8)*9)+7)")
(826 % 1,"(((((3*7)-1)*6)-2)*7)")
real 2m24.213s
user 2m22.063s
sys 0m 0.913s
Ruby 1.9.2
Number of characters: 404
I give up for now, it works as long as there is an exact answer. If there isn't it takes way too long to enumerate all possibilities.
Fully Obfuscated
def b a,o,c,p,r
o+c==2*p ?r<<a :o<p ?b(a+['('],o+1,c,p,r):0;c<o ?b(a+[')'],o,c+1,p,r):0
end
w=a=%w{+ - * /}
4.times{w=w.product a}
b [],0,0,3,g=[]
*n,l=$<.read.split.map(&:to_f)
h={}
catch(0){w.product(g).each{|c,f|k=f.zip(c.flatten).each{|o|o.reverse! if o[0]=='('};n.permutation{|m|h[x=eval(d=m.zip(k)*'')]=d;throw 0 if x==l}}}
c=h[k=h.keys.min_by{|i|(i-l).abs}]
puts c.gsub(/(\d*)\.\d*/,'\1')+"=#{k}"
Decoded
Coming soon
Test script
#!/usr/bin/env ruby
[
[[50,100,4,2,2,4],203],
[[25,4,9,2,3,10],465],
[[9,8,10,5,9,7],241],
[[3,7,6,2,1,7],824]
].each do |b|
start = Time.now
puts "{[#{b[0]*', '}] #{b[1]}} gives #{`echo "#{b[0]*' '} #{b[1]}" | ruby count-golf.rb`.strip} in #{Time.now-start}"
end
Output
→ ./test.rb
{[50, 100, 4, 2, 2, 4] 203} gives 100+(4+(50-(2)/4)*2)=203.0 in 3.968534736
{[25, 4, 9, 2, 3, 10] 465} gives 2+(3+(25+(9)*10)*4)=465.0 in 1.430715549
{[9, 8, 10, 5, 9, 7] 241} gives 5+(9+(8)+10)*9-(7)=241.0 in 1.20045702
{[3, 7, 6, 2, 1, 7] 824} gives 7*(6*(7*(3)-1)-2)=826.0 in 193.040054095
Details
The function used for generating the bracket pairs (b) is based off this one: Finding all combinations of well-formed brackets
Ruby 1.9.2 second attempt
Number of characters: 492 440(426)
Again there is a problem with the non-exact answer. This time this is easily fast enough but for some reason the closest it gets to 824 is 819 instead of 826.
I decided to put this in a new answer since it is using a very different method to my last attempt.
Removing the total of the output (as its not required by spec) is -14 characters.
Fully Obfuscated
def r d,c;d>4?[0]:(k=c.pop;a=[];r(d+1,c).each{|b|a<<[b,k,nil];a<<[nil,k,b]};a)end
def f t,n;[0,2].each{|a|Array===t[a] ?f(t[a],n): t[a]=n.pop}end
def d t;Float===t ?t:d(t[0]).send(t[1],d(t[2]))end
def o c;Float===c ?c.round: "(#{o c[0]}#{c[1]}#{o c[2]})"end
w=a=%w{+ - * /}
4.times{w=w.product a}
*n,l=$<.each(' ').map(&:to_f)
h={}
w.each{|y|r(0,y.flatten).each{|t|f t,n.dup;h[d t]=o t}}
puts h[k=h.keys.min_by{|i|(l-i).abs}]+"=#{k.round}"
Decoded
Coming soon
Test script
#!/usr/bin/env ruby
[
[[50,100,4,2,2,4],203],
[[25,4,9,2,3,10],465],
[[9,8,10,5,9,7],241],
[[3,7,6,2,1,7],824]
].each do |b|
start = Time.now
puts "{[#{b[0]*', '}] #{b[1]}} gives #{`echo "#{b[0]*' '} #{b[1]}" | ruby count-golf.rb`.strip} in #{Time.now-start}"
end
Output
→ ./test.rb
{[50, 100, 4, 2, 2, 4] 203} gives ((4-((2-(2*4))/100))*50)=203 in 1.089726252
{[25, 4, 9, 2, 3, 10] 465} gives ((10*(((3+2)*9)+4))-25)=465 in 1.039455671
{[9, 8, 10, 5, 9, 7] 241} gives (7+(((9/(5/10))+8)*9))=241 in 1.045774539
{[3, 7, 6, 2, 1, 7] 824} gives ((((7-(1/2))*6)*7)*3)=819 in 1.012330419
Details
This constructs the set of ternary trees representing all possible combinations of 5 operators. It then goes through and inserts all permutations of the input numbers into the leaves of these trees. Finally it simply iterates through these possible equations storing them into a hash with the result as index. Then it's easy enough to pick the closest value to the required answer from the hash and display it.

Resources