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

MathGroup Archive 2009

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

Search the Archive

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


  • Prev by Date: Re: Non-deterministic numerical inaccuracies in Mathematica 7
  • Next by Date: Re: Aspect Ratio
  • Previous by thread: Re: Test for composite digit
  • Next by thread: Re: Re: Re: Test for composite digit