[Prev][Next][Index][Thread]

Re: New Scientist Puzzle

In article <97t76m$6s5$1@reader1.fr.uu.net>, "Marc Battyani" 
<Marc.Battyani@fractalconcept.com> wrote:

> "Reinout Heeck" <reinz@Desk.org> wrote in
> > Bruce Hoult wrote:
> > >
> > > In article <97lnps$ppc$1@news.netmar.com>, jsgraham@my-deja.com wrote:
> > >
> > > > This puzzle was originally posted on a mailing list for the Icon
> > > > programming language.  Thought members of this group might also
> > > > want to give it a shot.
> > > >
> > > > VIER and NEUN represent 4-digit squares, each letter denoting a
> > > > distinct digit. You are asked to find the value of each, given the
> > > > further requirement that each uniquely determines the other.
> > > >
> > > > The "further requirement" means that of the numerous pairs of
> > > > answers, choose the one in which each number only appears once
> > > > in all of the pairs.
> > >
> > > No doubt APL is shorter, but good old perl ain't too bad...
> > >
> > > #!/usr/local/bin/perl
> > > for $a(32..99){b:for $b(32..99){
> > >     @cnt=();
> > >     for(1..8){$cnt[substr($a*$a.$b*$b,$_-1,1)].=$_}
> > >     for(0..9){next b if(sort{$b<=>$a}@cnt)[$_]!=(58,36,7,4,2,1)[$_]}
> > >     $a{$a}++;$b{$b}++;$p{$a}=$b
> > > }}
> > > while(($a,$b)=each%p){print$a*$a," ",$b*$b,"\n"if$a{$a}*$b{$b}==1}
> ...
> > ---------------------------
> >
> > | squares neuns pairs tallies results |
> >
> > squares := (1000 sqrt ceiling to: 9999 sqrt truncated)
> >                collect: [ :n | n squared printString ].
> > neuns := squares select: [ :string |
> >                string first == string last
> >                    and: [string asSet size==3]].
> > pairs := OrderedCollection new.
> > tallies := Bag new.
> > squares do: [ :square |
> >     neuns do: [ :neun |
> >         ((square at: 3 )==(neun at: 2)
> >             and: [(square,neun) asSet size = 6])
> >                 ifTrue:
> 
> >                     pairs add: square -> neun.
> >                     tallies add: square; add: neun ]]].
> > results := pairs select: [ :pair |
> >                 (tallies occurrencesOf: pair key) == 1
> >                     and: [(tallies occurrencesOf: pair value) == 1]]
> >
> > ---------------------------
> >
> > this code yields results =
> >   OrderedCollection ('6241'->'9409')
> 
> I should work, but couldn't resist...
> A Lisp version:
> 
> (let ((sqrs (loop for i from (ceiling (sqrt 1000)) upto (isqrt 9999)
>                collect (format nil "~d" (* i i))))
>       (vns '()))
>   (dolist (vier sqrs)
>     (dolist (neun sqrs)
>       (when (and (char= (aref neun 0)(aref neun 3))
>                  (char= (aref vier 2)(aref neun 1))
>                  (char/= (aref vier 0)(aref vier 1)(aref vier 2)
>                          (aref vier 3)(aref neun 0)(aref neun 2)))
>         (push (list vier neun) vns))))
>   (loop for (v n) in vns do
>     (if (= 1 (count v vns :key #'first)(count n vns :key #'second))
>       (format t "~%Found ~a ~a~%~%" v n))))
> 
> Found 6241 9409

Oh well, here's a Dylan version then...

------------------------------------------------------
module: vier-neun

begin
  let (vs, ns) = values(#(), #());
  let sqrs = map(method(n) format-to-string("%d", n * n) end,
                 make(<range>, from: isqrt(1000) + 1, to: isqrt(9999)));
  for (vier in sqrs)
    for (neun in sqrs)
      if (neun[0] = neun[3] & neun[1] = vier[2] &
            concatenate(vier, neun).remove-duplicates.size = 6)
        vs := pair(vier, vs);
        ns := pair(neun, ns)
      end
    end
  end;
  for(v in vs, n in ns)
    if (choose(curry(\=,v), vs).size * choose(curry(\=,n), ns).size = 1)
      format-out("Found %s %s\n", v, n)
    end
  end
end
------------------------------------------------------
bash$ ./vier-neun 
Found 6241 9409
------------------------------------------------------

-- Bruce