Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2009

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Re: Re: Test for composite digit

  • To: mathgroup at smc.vnet.net
  • Subject: [mg95016] Re: [mg94991] Re: [mg94972] Re: [mg94930] Test for composite digit
  • From: DrMajorBob <btreat1 at austin.rr.com>
  • Date: Sat, 3 Jan 2009 05:54:57 -0500 (EST)
  • References: <200812311106.GAA13449@smc.vnet.net>
  • Reply-to: drmajorbob at longhorns.com

Correction. There was a case where FixedPoint did not converge, for  
instance on next3[98304], where 9 is replaced by Infinity rather than  
extending the digit-list.

Below is a code that works and is also simpler. Note that "stick" is so  
named because it "sticks" with any legal digit string it reaches.

Part of the point was to generalize as much as I could. Redefine  
"allowed", and you'll get entirely different results.

FixedPoint iterations are limited (I think) to the number of digits in the  
input, and they're pretty FAST iterations.

Clear[allowed, minAllowed, ok3, better, stick, next4, take]
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
take[a_List, 0] = {minAllowed@1};
take[a_List, k_Integer] := Take[a, k]
ok3[k_, {j_}] := MemberQ[allowed[j], k]
better[9, _] = {Infinity};
better[k_, j_] :=
  better[k, j] = {Min@Complement[allowed[j], Range[0, k]]}
stick[d : {Infinity, ___Integer}] :=
  minAllowed /@ Range[1 + Length@d]
stick[d : {left___Integer, x_Integer, Infinity, right___Integer}] :=
  Join[{left}, better[x, 1 + Length@{left}],
   minAllowed /@ Range[2 + Length@{left}, Length@d]]
stick[d : {__Integer}] :=
  Module[{k, bad = Position[MapIndexed[ok3, d], False, 1, 1]},
   If[bad == {}, d,
    bad = bad[[1, 1]]; k = d[[bad]];
    Join[take[d, bad - 1], better[k, bad],
     minAllowed /@ Range[bad + 1, Length@d]]
    ]
   ]
next4[n_Integer] := FromDigits@FixedPoint[stick, IntegerDigits[n + 1]]

test4 = Rest@NestList[next4, 98304, 100]; // Timing

{0.009854, Null}

test2 = Rest@NestList[next2, 98304, 100]; // Timing

{8.75782, Null}

test2 == test4

True

next5[n_Integer] :=
  Length@Rest@FixedPointList[stick, IntegerDigits[n + 1]]
test[n_] := Tally[next5 /@ RandomInteger[{10^6, 10^7}, n]]
test[10000] // Timing

{2.10739, {{3, 5369}, {2, 3200}, {4, 1362}, {1, 58}, {7, 1}, {5,
    9}, {6, 1}}}

Bobby

On Thu, 01 Jan 2009 19:30:13 -0600, DrMajorBob <btreat1 at austin.rr.com>  
wrote:

> 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


  • Prev by Date: Re: Graph of some built-in functions blows up Mathematica V7
  • Next by Date: Re: Shorthand for MapThread
  • Previous by thread: Re: Re: Test for composite digit
  • Next by thread: Re: Stopping a running program