RosettaCodeData/Task/Minimal-steps-down-to-1/Mathematica/minimal-steps-down-to-1.math

$RecursionLimit = 3000;
ClearAll[MinimalStepToOne, MinimalStepToOneHelper]
MinimalStepToOne[n_Integer] := Module[{res},
  res = Reap[MinimalStepToOneHelper[{n}]][[-1, 1]];
  SortBy[res, Length]
  ]
MinimalStepToOneHelper[steps_List] := Module[{n, out},
  n = Last[steps];
  If[n == 1,
   Sow[steps];
   ,
   If[Divisible[n, 3],
    out = steps~Join~{" /3=> ", n/3};
    MinimalStepToOneHelper[out]
    ];
   If[Divisible[n, 2],
    out = steps~Join~{" /2=> ", n/2};
    MinimalStepToOneHelper[out]
    ];
   If[n > 1,
    out = steps~Join~{" -1=> ", n - 1};
    MinimalStepToOneHelper[out]
    ];
   ]
  ]
Do[
 sel = First[MinimalStepToOne[i]];
 Print[First[sel],
  ": (" <> ToString[(Length[sel] - 1)/2] <> " steps) ", sel // Row]
 ,
 {i, 1, 10}
 ]

$RecursionLimit = 3000;
ClearAll[MinimalStepToOne2, MinimalStepToOneHelper2]
MinimalStepToOne2[nn_Integer] :=
 Module[{res, done, solution, maxsteps},
  done = False;
  solution = {};
  MinimalStepToOneHelper2[steps_List] := Module[{n, out},
    n = Last[steps];
    If[n == 1,
     solution = steps;
     ,
     If[solution === {},
       If[Divisible[n, 3],
        out = steps~Join~{" /3=> ", n/3};
        MinimalStepToOneHelper2[out]
        ];
       If[Divisible[n, 2],
        out = steps~Join~{" /2=> ", n/2};
        MinimalStepToOneHelper2[out]
        ];
       If[n > 1,
        out = steps~Join~{" -1=> ", n - 1};
        MinimalStepToOneHelper2[out]
        ];
       ];
     ];
    ];
  MinimalStepToOneHelper2[{nn}];
  maxsteps = (Length[solution] - 1)/2;
  maxsteps
  ]

$RecursionLimit = 3000;
ClearAll[MinimalStepToOneMaxSteps, MinimalStepToOneMaxStepsHelper]
MinimalStepToOneMaxSteps[n_Integer, maxsteps_Integer] :=
 Module[{res},
  res = Reap[MinimalStepToOneMaxStepsHelper[{n}, maxsteps]][[-1, 1]];
  (Min[Length /@ res] - 1)/2
  ]
MinimalStepToOneMaxStepsHelper[steps_List, maxsteps_Integer] :=
 Module[{n, out},
  n = Last[steps];
  If[n == 1,
   Sow[steps];
   ,
   If[maxsteps > 0,
     If[Divisible[n, 3],
      out = steps~Join~{" /3=> ", n/3};
      MinimalStepToOneMaxStepsHelper[out, maxsteps - 1]
      ];
     If[Divisible[n, 2],
      out = steps~Join~{" /2=> ", n/2};
      MinimalStepToOneMaxStepsHelper[out, maxsteps - 1]
      ];
     If[n > 1,
      out = steps~Join~{" -1=> ", n - 1};
      MinimalStepToOneMaxStepsHelper[out, maxsteps - 1]
      ];
     ];
   ];
  ]

allsols = Table[
   max = MinimalStepToOne2[i];
   {i, MinimalStepToOneMaxSteps[i, max]}
   ,
   {i, 1, 2000}
   ];

a = Last[SortBy[GatherBy[allsols, Last], First /* Last]];
{a[[1, 2]], a[[All, 1]]}

$RecursionLimit = 3000;
ClearAll[MinimalStepToOne, MinimalStepToOneHelper]
MinimalStepToOne[n_Integer] := Module[{res},
  res = Reap[MinimalStepToOneHelper[{n}]][[-1, 1]];
  SortBy[res, Length]
  ]
MinimalStepToOneHelper[steps_List] := Module[{n, out},
  n = Last[steps];
  If[n == 1,
   Sow[steps];
   ,
   If[Divisible[n, 3],
    out = steps~Join~{" /3=> ", n/3};
    MinimalStepToOneHelper[out]
    ];
   If[Divisible[n, 2],
    out = steps~Join~{" /2=> ", n/2};
    MinimalStepToOneHelper[out]
    ];
   If[n > 2,
    out = steps~Join~{" -2=> ", n - 2};
    MinimalStepToOneHelper[out]
    ];
   ]
  ]
Do[
 sel = First[MinimalStepToOne[i]];
 Print[First[sel],
  ": (" <> ToString[(Length[sel] - 1)/2] <> " steps) ", sel // Row]
 ,
 {i, 1, 10}
 ]

$RecursionLimit = 3000;
ClearAll[MinimalStepToOne2, MinimalStepToOneHelper2]
MinimalStepToOne2[nn_Integer] :=
 Module[{res, done, solution, maxsteps},
  done = False;
  solution = {};
  MinimalStepToOneHelper2[steps_List] := Module[{n, out},
    n = Last[steps];
    If[n == 1,
     solution = steps;
     ,
     If[solution === {},
       If[Divisible[n, 3],
        out = steps~Join~{" /3=> ", n/3};
        MinimalStepToOneHelper2[out]
        ];
       If[Divisible[n, 2],
        out = steps~Join~{" /2=> ", n/2};
        MinimalStepToOneHelper2[out]
        ];
       If[n > 2,
        out = steps~Join~{" -2=> ", n - 2};
        MinimalStepToOneHelper2[out]
        ];
       ];
     ];
    ];
  MinimalStepToOneHelper2[{nn}];
  maxsteps = (Length[solution] - 1)/2;
  maxsteps
  ]

$RecursionLimit = 3000;
ClearAll[MinimalStepToOneMaxSteps, MinimalStepToOneMaxStepsHelper]
MinimalStepToOneMaxSteps[n_Integer, maxsteps_Integer] :=
 Module[{res},
  res = Reap[MinimalStepToOneMaxStepsHelper[{n}, maxsteps]][[-1, 1]];
  (Min[Length /@ res] - 1)/2
  ]
MinimalStepToOneMaxStepsHelper[steps_List, maxsteps_Integer] :=
 Module[{n, out},
  n = Last[steps];
  If[n == 1,
   Sow[steps];
   ,
   If[maxsteps > 0,
     If[Divisible[n, 3],
      out = steps~Join~{" /3=> ", n/3};
      MinimalStepToOneMaxStepsHelper[out, maxsteps - 1]
      ];
     If[Divisible[n, 2],
      out = steps~Join~{" /2=> ", n/2};
      MinimalStepToOneMaxStepsHelper[out, maxsteps - 1]
      ];
     If[n > 2,
      out = steps~Join~{" -2=> ", n - 2};
      MinimalStepToOneMaxStepsHelper[out, maxsteps - 1]
      ];
     ];
   ];
  ]

allsols = Table[
   max = MinimalStepToOne2[i];
   {i, MinimalStepToOneMaxSteps[i, max]}
   ,
   {i, 1, 2000}
   ];

a = Last[SortBy[GatherBy[allsols, Last], First /* Last]];
{a[[1, 2]], a[[All, 1]]}