Permuted multiples

Permuted multiples is a draft programming task. It is not yet considered ready to be promoted as a complete task, for reasons that should be found in its talk page.

Attribution

The following task is taken from Project Euler.

Task

Find the smallest positive integer n such that, when expressed in decimal, 2*n, 3*n, 4*n, 5*n, and 6*n contain exactly the same digits but in a different order.

AppleScript

Translation of: Phix

— except that the 'steps' figure here is cumulative. Also, for six different numbers to have the same digits, each must have at least three digits, none of which can be 0. So the smallest possible value of n is 123. 'Steps' are the number of 'n's actually tried when n * 6 doesn't exceed the next power of 10. While no power of 10 is exactly divisible by 6, it is technically the point at which the number of digits increases, so I've pedantically adjusted the logic to reflect this.  :) The number of steps between 100,000 and the final arrival at 142,857 is 14,286, which is interesting.

<lang applescript>use AppleScript version "2.3.1" -- Mac OS X 10.9 (Mavericks) or later. use sorter : script "Insertion Sort" -- <https://www.rosettacode.org/wiki/Sorting_algorithms/Insertion_sort#AppleScript>

on decDigits(n)

   set digits to {n mod 10 as integer}
   set n to n div 10
   repeat until (n = 0)
       set beginning of digits to n mod 10 as integer
       set n to n div 10
   end repeat
   return digits

end decDigits

on join(lst, delim)

   set astid to AppleScript's text item delimiters
   set AppleScript's text item delimiters to delim
   set txt to lst as text
   set AppleScript's text item delimiters to astid
   return txt

end join

on task()

   set {output, n, n10, steps} to {{}, 123, 1000, 0}
   repeat
       if (n * 6 < n10) then
           set steps to steps + 1
           set nl to decDigits(n)
           tell sorter to sort(nl, 1, -1)
           set found to true
           repeat with i from 2 to 6
               set inl to decDigits(n * i)
               tell sorter to sort(inl, 1, -1)
               if (inl ≠ nl) then
                   set found to false
                   exit repeat
               end if
           end repeat
           if (found) then exit repeat
           set n to n + 3
       else
           set end of output to "Nothing below " & n10 & (" (" & steps & " steps)")
           set n to n10 + 2
           set n10 to n10 * 10
           -- set steps to 0
       end if
   end repeat
   
   set end of output to "    n = " & n & (" (" & steps & " steps altogether)")
   repeat with i from 2 to 6
       set end of output to (i as text) & " * n = " & i * n
   end repeat
   
   return join(output, linefeed)

end task

task()</lang>

Output:

<lang applescript>"Nothing below 1000 (15 steps) Nothing below 10000 (237 steps) Nothing below 100000 (2459 steps)

   n = 142857 (16745 steps altogether)

2 * n = 285714 3 * n = 428571 4 * n = 571428 5 * n = 714285 6 * n = 857142"</lang>

Factor

Library: Factor-numspec

Works with: Factor version 0.99 2021-06-02

<lang factor>USING: formatting io kernel lists lists.lazy math math.ranges math.vectors numspec present prettyprint sequences sets ;

multiples ( n -- seq )

   [ 2 * ] [ 6 * ] [ ] tri <range> [ present ] map ;

all-set-eq? ( seq -- ? )

   dup ?first [ set= ] curry all? ;

! Ordered lazy list of numbers that start with a '1' digit NUMSPEC: starting-with-one 1 1_ ... ;

smallest-permuted-multiple ( -- n )

   starting-with-one [ multiples all-set-eq? ] lfilter car ;

{ 2 3 4 5 6 } " n: " write smallest-permuted-multiple dup . over n*v [ "×%d: %d\n" printf ] 2each</lang>

Output:

 n: 142857
×2: 285714
×3: 428571
×4: 571428
×5: 714285
×6: 857142

Go

Translation of: Wren

Library: Go-rcu

<lang go>package main

import (

   "fmt"
   "rcu"
   "sort"

)

// assumes l1 is sorted but l2 is not func areSame(l1, l2 []int) bool {

   if len(l1) != len(l2) {
       return false
   }
   sort.Ints(l2)
   for i := 0; i < len(l1); i++ {
       if l1[i] != l2[i] {
           return false
       }
   }
   return true

}

func main() {

   i := 100 // clearly a 1 or 2 digit number is impossible
   nextPow := 1000
   for {
       digits := rcu.Digits(i, 10)
       if digits[0] != 1 {
           i = nextPow
           nextPow *= 10
           continue
       }
       sort.Ints(digits)
       allSame := true
       for j := 2; j <= 6; j++ {
           digits2 := rcu.Digits(i*j, 10)
           if !areSame(digits, digits2) {
               allSame = false
               break
           }
       }
       if allSame {
           fmt.Println("The smallest positive integer n for which the following")
           fmt.Println("multiples contain exactly the same digits is:")
           fmt.Println("    n =", i)
           for k := 2; k <= 6; k++ {
               fmt.Printf("%d x n = %d\n", k, k*i)
           }
           return
       }
       i = i + 1
   }

}</lang>

Output:

The smallest positive integer n for which the following
multiples contain exactly the same digits is:
    n = 142857
2 x n = 285714
3 x n = 428571
4 x n = 571428
5 x n = 714285
6 x n = 857142

Julia

<lang julia>n = minimum([n for n in 1:2000000 if sort(digits(2n)) == sort(digits(3n)) == sort(digits(4n)) == sort(digits(5n))== sort(digits(6n))]) println("n: $n, 2n: $(2n), 3n: $(3n), 4n: $(4n), 5n: $(5n), 6n: $(6n)")

</lang>

Output:

n: 142857, 2n: 285714, 3n: 428571, 4n: 571428, 5n: 714285, 6n: 857142

Nim

Searching among multiples of 3 between 102 and 1_000 div 6, 1_002 and 10_000 div 6, 10_002 and 100_000 div 6, etc. (see discussion).

<lang Nim>from algorithm import sorted

func search(): int =

 var start = 100
 while true:
   for i in countup(start + 2, 10 * start div 6, 3):
     let digits = sorted($i)
     block check:
       for j in 2..6:
         if sorted($(i * j)) != digits:
           break check
       # Found.
       return i
   start *= 10

let n = search() echo " n = ", n for k in 2..6:

 echo k, "n = ", k * n</lang>

Output:

 n = 142857
2n = 285714
3n = 428571
4n = 571428
5n = 714285
6n = 857142

Pascal

Create an array of the digits fixed 1 as first digit and 0 "1023456789"
Don't use the fact, that second digit must be < 6.Runtime negligible. <lang pascal>program euler52; {$IFDEF FPC}

 {$MOde DElphi} {$Optimization On}

{$else}

 {$Apptype console}

{$ENDIF} uses

 sysutils;

const

 Base = 10;

type

 TUsedDigits = array[0..Base-1] of byte;
 tDigitsInUse =   set of 0..Base-1;

var

 UsedDigits :tUsedDigits;
 gblMaxDepth : NativeInt;

procedure InitUsed; Var

i : NativeInt;

Begin

 For i := 2 to Base-1 do 
   UsedDigits[i] := i;
 UsedDigits[0] := 1;
 UsedDigits[1] := 0;  

end;

function GetUsedSet(const UsedDigits: tUsedDigits):tDigitsInUse; var

 i : NativeInt;

begin

 result := [];
 For i := 0 to gblMaxDepth do
   include(result,UsedDigits[i]);

end;

function CheckMultiples(const UsedDigits: tUsedDigits;OrgInUse:tDigitsInUse):NativeInt; var

 SumDigits :tUsedDigits;
 i,c,s,j : integer;

begin

 result := 0;  
 SumDigits := UsedDigits;    

 j := 2;// first doubled
 repeat
   c := 0;
   For i := gblMaxdepth downto 0 do  
   Begin
     s := UsedDigits[i]+SumDigits[i]+c;
     c := ord(s >= base);
     SumDigits[i] := s-c*base;
   end;
   IF (c > 0) then
     break;
   if GetUsedSet(SumDigits) <> OrgInUse then
     break;
   inc(j);  
 until j > 6;

 IF j > 6 then
 Begin
   result := 0;  
   //Output in Base 10
   For i := 0 to gblMaxdepth do 
     result := result * Base +UsedDigits[i];
   For i := 1 to 6 do       
     writeln(i*result);
   writeln;  
 end;    

end;

procedure Check; Begin

 CheckMultiples(UsedDigits,GetUsedSet(UsedDigits))

end;

procedure GetNextUsedDigit(StartIdx:NativeInt); var

 i : NativeInt;
 DigitTaken: Byte;

Begin

 For i := StartIDx to Base-1 do
 Begin
   //swap i with Startidx
   DigitTaken := UsedDigits[i]; 
   UsedDigits[i]:= UsedDigits[StartIdx];
   UsedDigits[StartIdx] := DigitTaken;      

// write(StartIdx:3,i:3,DigitTaken:3,' ');

   IF StartIdx <gblMaxDepth then
     GetNextUsedDigit(StartIdx+1)
   else
     check;
   //undo swap i with Startidx      
   UsedDigits[StartIdx] := UsedDigits[i]; 
   UsedDigits[i]:= DigitTaken;
 end;  

end; var

 T : INt64;

Begin

 T := GetTickCount64;
 For gblMaxDepth := 2 to Base-1 do
 Begin
   InitUsed;
   writeln('With ',gblMaxdepth+1,' digits');    
   GetNextUsedDigit(1);
 end;  
 T := GetTickCount64-T;
 write('Done in ',T/1000:0:3);
 {$IFDEF WINdows}
   readln;
 {$ENDIF}  

end.</lang>

Output:

With 3 digits
With 4 digits
With 5 digits
With 6 digits
142857
285714
428571
571428
714285
857142

With 7 digits
1428570
2857140
4285710
5714280
7142850
8571420

1429857
2859714
4289571
5719428
7149285
8579142

With 8 digits
14298570
28597140
42895710
57194280
71492850
85791420

With 9 digits
With 10 digits
Done in 0.054

Phix

Maintain a limit (n10) and bump the iteration whenever *6 increases the number of digits, which (as [was] shown) cuts the number of iterations by a factor of nearly thirteen and a half times (as in eg [as was] 67 iterations instead of 900 to find nothing in 100..1,000). Also as noted on the talk page, since sum(digits(3n)) is a multiple of 3 and it uses the same digits as n, then sum(digits(n)) will also be the very same multiple of 3 and hence n must (also) be divisible by 3, so we can start each longer-digits iteration on 10^k+2 (since remainder(10^k,3) is always 1) and employ a step of 3, and enjoy a better than 40-fold overall reduction in iterations.

with javascript_semantics
integer n = 3, n10 = 10, steps = 0
while true do
    if n*6>=n10 then
        printf(1,"Nothing less than %,d (%,d steps)\n",{n10,steps})
        n = n10+2
        n10 *= 10
        steps = 0
    else
        string ns = sort(sprintf("%d",n))
        integer i -- (to test after loop)
        for i=2 to 6 do
            string ins = sort(sprintf("%d",n*i))
            if ins!=ns then exit end if
        end for
        if i=7 then exit end if
        n += 3
        steps += 1
    end if
end while
constant fmt="""
Smallest positive integer n for which (2..6)*n contain the same digits:
    n = %d
2 x n = %d
3 x n = %d
4 x n = %d
5 x n = %d
6 x n = %d
"""
printf(1,fmt,sq_mul(n,tagset(6)))

Output:

Nothing less than 10 (0 steps)
Nothing less than 100 (2 steps)
Nothing less than 1,000 (22 steps)
Nothing less than 10,000 (222 steps)
Nothing less than 100,000 (2,222 steps)
Smallest positive integer n for which (2..6)*n contain the same digits:
    n = 142857
2 x n = 285714
3 x n = 428571
4 x n = 571428
5 x n = 714285
6 x n = 857142

Raku

<lang perl6>put display (^∞).map(1 ~ *).race.map( -> \n { next unless [eq] (2,3,4,5,6).map: { (n × $_).comb.sort.join }; n } ).first;

sub display ($n) { join "\n", " n: $n", (2..6).map: { "×$_: {$n×$_}" } }</lang>

Output:

 n: 142857
×2: 285714
×3: 428571
×4: 571428
×5: 714285
×6: 857142

REXX

<lang rexx>/*REXX program finds and displays the smallest positive integer n such that ··· */ /*───────────────────────── 2*n, 3*n, 4*5, 5*6, and 6*n contain the same decimal digits.*/

                       do n=1                                /*increment N from unity. */
                       b= 2*n                                /*calculate product of 2*n*/
                       t= 3*n                                /*    "        "     " 3*n*/
                              if verify(t,b)>0  then iterate /*product have req. digs ?*/
                       q= 4*n                                /*calculate product of 4*n*/
                              if verify(q,b)>0  then iterate /*product have req. digs ?*/
                              if verify(q,t)>0  then iterate /*   "      "   "     "  "*/
                       v= 5*n                                /*calculate product of 5*n*/
                              if verify(v,b)<0  then iterate /*product have req. digs ?*/
                              if verify(v,t)>0  then iteratr /*   "      "   "     "  "*/
                              if verify(v,q)>0  then iteratr /*   "      "   "     "  "*/
                       s= 6*n                                /*calculate product of 6*n*/
                              if verify(s,b)>0  then iterate /*product have req. digs ?*/
                              if verify(s,t)>0  then iterate /*   "      "   "     "  "*/
                              if verify(s,q)>0  then iterate /*   "      "   "     "  "*/
                              if verify(s,v)>0  then iterate /*   "      "   "     "  "*/
                       leave                                 /*found the numbers, show.*/
                       end   /*n*/

_= left(, 9) /*used for indentation. */ say _ ' n =' commas(n) /*display value of n. */ say _ '2*n =' commas(b) /* " " " 2*n. */ say _ '3*n =' commas(t) /* " " " 3*n. */ say _ '4*n =' commas(q) /* " " " 4*n. */ say _ '5*n =' commas(v) /* " " " 5*n. */ say _ '6*n =' commas(s) /* " " " 6*n. */ exit 0 /*stick a fork in it, we're all done. */ /*──────────────────────────────────────────────────────────────────────────────────────*/ commas: parse arg ?; do jc=length(?)-3 to 1 by -3; ?=insert(',', ?, jc); end; return ?</lang>

output   when using the internal default input:

            n = 142,857
          2*n = 285,714
          3*n = 428,571
          4*n = 571,428
          5*n = 714,285
          6*n = 857,142

Ring

<lang ring> load "stdlib.ring"

see "working..." + nl see "Permuted multiples are:" + nl per = list(6) perm = list(6)

for n = 1 to 1000000

   for x = 2 to 6
       perm[x] = []
   next
   perStr = list(6)
   for z = 2 to 6
       per[z] = n*z
       perStr[z] = string(per[z])
       for m = 1 to len(perStr[z])
           add(perm[z],perStr[z][m])
       next
   next
   for y = 2 to 6
       perm[y] = sort(perm[y])
       perStr[y] = list2str(perm[y])
       perStr[y] = substr(perStr[y],nl,"")
   next
   
   if perStr[2] = perStr[3] and perStr[2] = perStr[4] and perStr[2] = perStr[5] and perStr[2] = perStr[6]
      see "n   = " + n + nl
      see "2*n = " + (n*2) + nl
      see "3*n = " + (n*3) + nl
      see "4*n = " + (n*4) + nl
      see "5*n = " + (n*5) + nl
      see "6*n = " + (n*6) + nl
      exit
   ok

next

see "done..." + nl </lang>

Output:

working...
Permuted multiples are:
n   = 142857
2*n = 285714
3*n = 428571
4*n = 571428
5*n = 714285
6*n = 857142
done...

Wren

Library: Wren-math

One thing that's immediately clear is that the number must begin with '1' otherwise the higher multiples will have more digits than it has. <lang ecmascript>import "/math" for Int

// assumes l1 is sorted but l2 is not var areSame = Fn.new { |l1, l2|

   if (l1.count != l2.count) return false
   l2.sort()
   for (i in 0...l1.count) {
       if (l1[i] != l2[i]) return false
   }
   return true

}

var i = 100 // clearly a 1 or 2 digit number is impossible var nextPow = 1000 while (true) {

   var digits = Int.digits(i)
   if (digits[0] != 1) {
       i = nextPow
       nextPow = nextPow * 10
       continue
   }
   digits.sort()
   var allSame = true
   for (j in 2..6) {
       var digits2 = Int.digits(i * j)
       if (!areSame.call(digits, digits2)) {
           allSame = false
           break
       }
   }
   if (allSame) {
       System.print("The smallest positive integer n for which the following")
       System.print("multiples contain exactly the same digits is:")
       System.print("    n = %(i)")
       for (k in 2..6) System.print("%(k) x n = %(k * i)")
       return
   }
   i = i + 1

}</lang>

Output:

The smallest positive integer n for which the following
multiples contain exactly the same digits is:
    n = 142857
2 x n = 285714
3 x n = 428571
4 x n = 571428
5 x n = 714285
6 x n = 857142