# How to determine the unique combination of digits satisfying a given relation?

Is there a method to determine the unique combination of numbers a, b, c and d which satisfy the relation below, and which yields the output with the numbers in the given order. Example for 2023 is given here. Looking to see if such combination exists for > 1000 but < 9999

a = 2;
b = 0;
c = 2;
d = 3;

(a + b + c + d)*(a^2 + b^2 + c^2 + d^2)^2

IntegerDigits[(a + b + c + d)*(a^2 + b^2 + c^2 + d^2)^2]

(* Output is  2023  *)


Maybe this?

Solve[
{
(a + b + c + d)*(a^2 + b^2 + c^2 + d^2)^2 == 1000 a + 100 b + 10 c + d,
1 <= a <= 9,
0 <= b <= 9,
0 <= c <= 9,
0 <= d <= 9},
{a, b, c, d},
Integers]

• Elegance in its simplicity! Jan 15, 2023 at 6:11

Using FindInstance:

Clear[a, b, c, d, expr]
expr = (a + b + c + d)*(a^2 + b^2 + c^2 + d^2)^2
sol = FindInstance[expr == 2023, {a, b, c, d}, Integers, 12]


{{a -> 0, b -> 2, c -> 2, d -> 3}, {a -> 0, b -> 2, c -> 3, d -> 2}, {a -> 0, b -> 3, c -> 2, d -> 2}, {a -> 2, b -> 0, c -> 2, d -> 3}, {a -> 2, b -> 0, c -> 3, d -> 2}, {a -> 2, b -> 2, c -> 0, d -> 3}, {a -> 2, b -> 2, c -> 3, d -> 0}, {a -> 2, b -> 3, c -> 0, d -> 2}, {a -> 2, b -> 3, c -> 2, d -> 0}, {a -> 3, b -> 0, c -> 2, d -> 2}, {a -> 3, b -> 2, c -> 0, d -> 2}, {a -> 3, b -> 2, c -> 2, d -> 0}}

FromDigits[{a, b, c, d}] /. sol

{223, 232, 322, 2023, 2032, 2203, 2230, 2302, 2320, 3022, 3202, 3220}


It is all the numbers with exactly these four digits.

Using brute force:

Cases[
{#, expr /. Thread[{a, b, c, d} -> IntegerDigits[#, 10, 4]]} & /@
Range[10000],
{_, 2023}
]


{{223, 2023}, {232, 2023}, {322, 2023}, {2023, 2023}, {2032, 2023}, {2203, 2023}, {2230, 2023}, {2302, 2023}, {2320, 2023}, {3022, 2023}, {3202, 2023}, {3220, 2023}}

I might not be understanding fully what you are asking. But if you want to find the solutions that give 2023, may be this will work. If this is not what you meant, will delete this answer.

r = (a + b + c + d)*(a^2 + b^2 + c^2 + d^2)^2;
sol = Solve[r == 2023, {a, b, c, d}, Integers]


Cases[#, Rule[x_, y_] :> y] & /@ %
p = Position[FromDigits[#] & /@ %, 2023]


Extract[sol, p]