Re: Re: Test for composite digit
- To: mathgroup at smc.vnet.net
- Subject: [mg94991] Re: [mg94972] Re: [mg94930] Test for composite digit
- From: DrMajorBob <btreat1 at austin.rr.com>
- Date: Thu, 1 Jan 2009 20:30:13 -0500 (EST)
- References: <200812311106.GAA13449@smc.vnet.net>
- Reply-to: drmajorbob at longhorns.com
A less confusing version:
Clear[allowed, ok3, better, stick, next3]
allowed[n_Integer?
Positive] := {{4, 6, 8, 9}, {0, 1, 2, 3, 5, 7}}[[Mod[n, 2, 1]]]
minAllowed[n_Integer?Positive] := Min@allowed@n
maxAllowed[n_Integer?Positive] := Max@allowed@n
ok3[k_, {j_}] := MemberQ[allowed[j], k]
better[k_, j_] :=
better[k, j] = {Min@Complement[allowed[j], Range[0, k]]}
stick[d : {one_Integer, ___Integer}] /; ! ok3[one, {1}] :=
If[one > maxAllowed@1,
minAllowed /@ Range[1 + Length@d],
Join[better[one, 1], minAllowed /@ Range[2, Length@d]]
]
stick[d : {one_Integer, two_Integer, ___Integer}] /; ! ok3[two, {2}] :=
If[
two > maxAllowed@2,
Join[better[one, 1], minAllowed /@ Range[2, Length@d]],
Join[{one}, better[two, 2], minAllowed /@ Range[3, Length@d]]
]
stick[d : {__Integer}] /;
Position[MapIndexed[ok3, d], False, 1, 1] == {} := d
stick[d : {__Integer}] :=
Module[{k, bad = Position[MapIndexed[ok3, d], False, 1, 1][[1, 1]]},
k = d[[bad]];
If[
k > maxAllowed@bad,
Join[Take[d, bad - 2], better[k, bad - 1],
minAllowed /@ Range[bad, Length@d]],
Join[Take[d, bad - 1], better[k, bad],
minAllowed /@ Range[bad + 1, Length@d]]
]
]
next3[n_Integer] := FromDigits@FixedPoint[stick, IntegerDigits[n + 1]]
RandomInteger[{1, 7*10^5}]
next2@% // Timing
next3@%% // Timing
354808
{1.39235, 404040}
{0.000342, 404040}
Bobby
On Thu, 01 Jan 2009 06:27:57 -0600, DrMajorBob <btreat1 at austin.rr.com>
wrote:
> Something like this (naive but effective):
>
> Clear[ok1, composite, next1]
> composite[n_] := n > 1 && ! PrimeQ@n
> SetAttributes[composite, Listable]
> ok1[n_] /; 1000 <= n <= 9999 :=
> Module[{digits = IntegerDigits[n]}, {True, False, True, False} ==
> composite@digits]
> ok1[n_] /; 100 <= n <= 999 :=
> Module[{digits = IntegerDigits[n]}, {True, False, True} ==
> composite@digits]
> next1[n_Integer] /; n < 10^4 :=
> Module[{k = n + 1}, While[k < 10^4 && ! ok1@k, k++]; k]
>
> test1 = Rest@NestList[next1, 844, 100]
>
> {854, 856, 858, 859, 874, 876, 878, 879, 904, 906, 908, 909, 914, \
> 916, 918, 919, 924, 926, 928, 929, 934, 936, 938, 939, 954, 956, 958, \
> 959, 974, 976, 978, 979, 4040, 4041, 4042, 4043, 4045, 4047, 4060, \
> 4061, 4062, 4063, 4065, 4067, 4080, 4081, 4082, 4083, 4085, 4087, \
> 4090, 4091, 4092, 4093, 4095, 4097, 4140, 4141, 4142, 4143, 4145, \
> 4147, 4160, 4161, 4162, 4163, 4165, 4167, 4180, 4181, 4182, 4183, \
> 4185, 4187, 4190, 4191, 4192, 4193, 4195, 4197, 4240, 4241, 4242, \
> 4243, 4245, 4247, 4260, 4261, 4262, 4263, 4265, 4267, 4280, 4281, \
> 4282, 4283, 4285, 4287, 4290, 4291}
>
> If you ALWAYS want to start with a composite digit and alternate, you
> could generalize to
>
> Clear[composite, ok2]
> composite[n_] := MemberQ[{4, 6, 8, 9}, n]
> SetAttributes[composite, Listable]
> ok2[digits_List] :=
> MatchQ[composite@
> digits, {PatternSequence[True, False] ..} | {PatternSequence[True,
> False] .., True} | {True}]
> ok2[n_Integer] := ok2@IntegerDigits@n
> ok2[other_] = False;
> next2[n_Integer] := Module[{k = n + 1}, While[! ok2@k, k++]; k]
>
> test2 = Rest@NestList[next2, 844, 100]
>
> {854, 856, 858, 859, 874, 876, 878, 879, 904, 906, 908, 909, 914, \
> 916, 918, 919, 924, 926, 928, 929, 934, 936, 938, 939, 954, 956, 958, \
> 959, 974, 976, 978, 979, 4040, 4041, 4042, 4043, 4045, 4047, 4060, \
> 4061, 4062, 4063, 4065, 4067, 4080, 4081, 4082, 4083, 4085, 4087, \
> 4090, 4091, 4092, 4093, 4095, 4097, 4140, 4141, 4142, 4143, 4145, \
> 4147, 4160, 4161, 4162, 4163, 4165, 4167, 4180, 4181, 4182, 4183, \
> 4185, 4187, 4190, 4191, 4192, 4193, 4195, 4197, 4240, 4241, 4242, \
> 4243, 4245, 4247, 4260, 4261, 4262, 4263, 4265, 4267, 4280, 4281, \
> 4282, 4283, 4285, 4287, 4290, 4291}
>
> test1 == test2
>
> True
>
> All that gets very slow for large n, however, so (slightly awkward)...
>
> Clear[allowed, ok3, better, stick, next3]
> allowed[n_Integer?
> Positive] := {{4, 6, 8, 9}, {0, 1, 2, 3, 5, 7}}[[Mod[n, 2, 1]]]
> ok3[k_, {j_}] := MemberQ[allowed[j], k]
> better[k_, j_] := {Min@Complement[allowed[j], Range[0, k]]}
> stick[d_List] /; VectorQ[d, IntegerQ] :=
> Module[{k, firstBad = Position[MapIndexed[ok3, d], False, 1, 1]},
> Which[
> firstBad == {}, d,
> firstBad == {{1}},
> If[(k = d[[1]]) > Max@allowed@1,
> Min /@ allowed /@ Range[1 + Length@d],
> Join[better[k, 1], Min /@ allowed /@ Range[2, Length@d]]
> ],
> firstBad == {{2}}, If[
> (k = d[[2]]) > Max@allowed@2,
> Join[{1 + d[[1]]}, Table[Min@allowed@k, {k, 2, Length@d}]],
> Join[{d[[1]]}, better[k, 2],
> Min /@ allowed /@ Range[3, Length@d]]
> ],
> True, firstBad = firstBad[[1, 1]]; If[
> (k = d[[firstBad]]) > Max@allowed@firstBad,
> Join[Take[d, firstBad - 2], {1 + d[[firstBad + 1]]},
> Table[Min@allowed@k, {k, firstBad, Length@d}]],
> Join[Take[d, firstBad - 1], better[k, firstBad],
> Min /@ allowed /@ Range[firstBad + 1, Length@d]]
> ]
> ]
> ]
> next3[n_Integer] := FromDigits@FixedPoint[stick, IntegerDigits[n + 1]]
>
> RandomInteger[{1, 7*10^5}]
> next2@% // Timing
> next3@%% // Timing
>
> 194872
>
> {5.74494, 404040}
>
> {0.000277, 404040}
>
> Bobby
>
> On Wed, 31 Dec 2008 05:06:40 -0600, Diana <diana.mecum at gmail.com> wrote:
>
>> Math folks,
>>
>> I am trying to write an algorithm which will test for a digit within a
>> number being composite, i.e. {4, 6, 8, or 9}
>>
>> For example:
>>
>> Let's say I start with the number 844. The next number in my sequence
>> will be the smallest number greater than 844 which satisfies:
>>
>> 1) a three digit number with first and third digits composite, and the
>> second digit not composite, or a
>> 2) a four digit number with first and third digits composite, and the
>> second and fourth digits not composite.
>>
>> The answer will be 854, and I want the algorithm to be able to find
>> this.
>>
>> I may then want to find a number of any specified arbitrary length
>> with digits composite or not composite as desired.
>>
>> Thanks,
>>
>> Diana
>>
>
>
>
--
DrMajorBob at longhorns.com