Skip to main content
deleted 20 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196

Here's a probably quite slow alternativepossibility

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] := expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] := Module[{curr = l, tag}, Reap[Quiet[ While[curr =!= False, If[doMath@curr == target, PrintTemporary@Sow[curr /. formattingRules, tag]]; curr = next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates] 

Now you do

search[Range[9], 100] 

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made faster. As it is, it prints temporarily the partial results, including a few duplicates due to the associative property of Plus and Times. Perphaps you want to remove that PrintTemporary behaviour or change it to an option. The final result has these duplicates removed. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

Here's a probably quite slow alternative

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] := expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] := Module[{curr = l, tag}, Reap[Quiet[ While[curr =!= False, If[doMath@curr == target, PrintTemporary@Sow[curr /. formattingRules, tag]]; curr = next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates] 

Now you do

search[Range[9], 100] 

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made faster. As it is, it prints temporarily the partial results, including a few duplicates due to the associative property of Plus and Times. Perphaps you want to remove that PrintTemporary behaviour or change it to an option. The final result has these duplicates removed. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

Here's a possibility

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] := expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] := Module[{curr = l, tag}, Reap[Quiet[ While[curr =!= False, If[doMath@curr == target, PrintTemporary@Sow[curr /. formattingRules, tag]]; curr = next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates] 

Now you do

search[Range[9], 100] 

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made faster. As it is, it prints temporarily the partial results, including a few duplicates due to the associative property of Plus and Times. Perphaps you want to remove that PrintTemporary behaviour or change it to an option. The final result has these duplicates removed. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

deleted 7 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196

Here's a probably quite slow alternative

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] := expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] := Module[{curr = l, tag}, Reap[Quiet[ While[curr =!= False, If[doMath@curr == target, PrintTemporary@Sow[curr /. formattingRules, tag]]; curr = next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates] 

Now you do

search[Range[9], 100] 

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made way less-slowfaster. As it is, it prints temporarily the partial results, perphapsincluding a few duplicates due to the associative property of Plus and Times. Perphaps you want to remove that PrintTemporary behaviour or change it to an option. The final result has these duplicates removed. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

Here's a probably quite slow alternative

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] := expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] := Module[{curr = l, tag}, Reap[Quiet[ While[curr =!= False, If[doMath@curr == target, PrintTemporary@Sow[curr /. formattingRules, tag]]; curr = next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates] 

Now you do

search[Range[9], 100] 

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made way less-slow. As it is, it prints temporarily the partial results, perphaps you want to remove that or change it to an option. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

Here's a probably quite slow alternative

next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] := expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] := Module[{curr = l, tag}, Reap[Quiet[ While[curr =!= False, If[doMath@curr == target, PrintTemporary@Sow[curr /. formattingRules, tag]]; curr = next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates] 

Now you do

search[Range[9], 100] 

After 25 minutes I got 2145 solutions. Speed wasn't on my mind when I coded this, so surely it can be made faster. As it is, it prints temporarily the partial results, including a few duplicates due to the associative property of Plus and Times. Perphaps you want to remove that PrintTemporary behaviour or change it to an option. The final result has these duplicates removed. It also outputs the subtraction as "+ -". This can also be fixed without much work. The output cell can be evaluated to verify the results

added 101 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196
next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[Append[arg1, First@arg2]op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introducesintroduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more. To search (unelegant code warning)

Defining

search[l_, target_]formattingRules := Module[{curr =i l,: tag{__Integer}, Reap[  :> FromDigits@i, Quiet[   While[currHoldForm[Plus] =!=-> Falsenext`Plus,  If[ReleaseHold[curr /. ListHoldForm[Times] -> Composition[FromDigitsnext`Times, List]] ==   HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] target&),   HoldForm[Divide] -> PrintTemporary@Sow[next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] :=    currexpr /. {i_ListList :-> FromDigits@iComposition[FromDigits,  List] // ReleaseHold search[l_, target_] :=    Module[{curr HoldForm[Plus]= ->l, next`Plustag}, HoldForm[Times]   -> next`Times,Reap[Quiet[   While[curr =!= False,    HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), If[doMath@curr == target,    HoldForm[Divide]PrintTemporary@Sow[curr ->/. next`Divide}formattingRules, tag]];   curr = next[curr]]next@curr], Divide::infy], tag][[-1, 1]] // DeleteDuplicates ] DeleteDuplicates] 
next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[Append[arg1, First@arg2], Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduces as a list of digits, and returns the next candidate to try in the same format, or False if there are no more. To search (unelegant code warning)

search[l_, target_] := Module[{curr = l, tag}, Reap[  Quiet[   While[curr =!= False,  If[ReleaseHold[curr /. List -> Composition[FromDigits, List]] ==   target,   PrintTemporary@Sow[ curr /. {i_List :> FromDigits@i,  HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times,   HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &),  HoldForm[Divide] -> next`Divide},tag]]; curr = next[curr]], Divide::infy],tag][[-1, 1]]// DeleteDuplicates ] 
next`ops = HoldForm /@ {Plus, Times, Divide, Subtract}; (nextOp[#1] = #2) & @@@ Most@Transpose@{next`ops, RotateLeft@next`ops}; next`children = True; SetAttributes[{next`Plus, next`Times}, Flat]; next[{i_}] := False; next[l_List] := HoldForm[Plus][{l[[1]]}, l[[2 ;;]]]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg1]}, op[res, arg2] /; res =!= False]; next[op_[arg1_, arg2_]] /; next`children := With[{res = next[arg2]}, op[arg1, res] /; res =!= False]; next[HoldForm[Subtract][arg1_, arg2 : {_}]] := False; next[op_[arg1_, arg2_]] := Block[{next`children = False}, next[op[flatten@arg1, flatten@arg2]]]; next[op_[arg1_List, {arg2_}]] := nextOp[op][{arg1[[1]]}, arg1[[2 ;;]]~Append~arg2]; next[op_[arg1_List, arg2_List]] := op[arg1~Append~First@arg2, Rest@arg2]; flatten[exp_] := Flatten@Cases[exp, {_}, {0, Infinity}] 

next is a function that receives a current candidate expression of the form HoldForm[operator][...] where the ultimate integers are introduced as a list of digits, and returns the next candidate to try in the same format, or False if there are no more.

Defining

formattingRules = {i : {__Integer} :> FromDigits@i, HoldForm[Plus] -> next`Plus, HoldForm[Times] -> next`Times, HoldForm[Subtract] -> (next`Plus[#1, Times[-1, #2]] &), HoldForm[Divide] -> next`Divide}; 

try

NestList[next, Range[9], 30] /. formattingRules // Column 

To search

doMath[expr_] :=    expr /. List -> Composition[FromDigits, List] // ReleaseHold search[l_, target_] :=    Module[{curr = l, tag},    Reap[Quiet[ While[curr =!= False,    If[doMath@curr == target,    PrintTemporary@Sow[curr /. formattingRules, tag]];   curr = next@curr], Divide::infy], tag][[-1, 1]] //  DeleteDuplicates] 
added 298 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196
Loading
added 211 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196
Loading
added 124 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196
Loading
added 20 characters in body
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196
Loading
Source Link
Rojo
  • 43.1k
  • 7
  • 100
  • 196
Loading