New Scientist Puzzle
jsgr...@my-deja.com
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.
Steve Graham
----- Posted via NewsOne.Net: Free (anonymous) Usenet News via the Web -----
http://newsone.net/ -- Free reading and anonymous posting to 60,000+ groups
NewsOne.Net prohibits users from posting spam. If this or other posts
made through NewsOne.Net violate posting guidelines, email ab...@newsone.net
Ben Bishop
>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.
I'm still unclear on a few points -- does this mean the E in VIER must
be the same digit as the E in NEUN?
I also presume that neither V nor N can be 0 since the numbers are 4
digits, and although 0xxx might be 4 digits, it is non-canonic.
There are only 68 4-digit integral squares (32**2 -> 99**2), so it
would seem a rather simple, brute force, method would solve it.
Ben
Ben Bishop
>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.
Given some of the assumptions I stated in my prior post, I came up with
the following brute-force method:
F N=32:1:99 S SQ=N*N,NEUN($E(SQ,2),N)=SQ,VIER($E(SQ,3),II)=SQ
which populates all the possible 4 digit squares.
Then, remove NEUN numbers which do not match the pattern:
S NN="NEUN" F S NN=$Q(@NN) Q:NN="" S SQ=@NN DO
. I $E(SQ)'=$E(SQ,4) KILL @NN Q ;not n--n format
. I $L($TR(SQ,$E(SQ)))'=2 KILL @NN Q ;unlikely nnXn or nXnn
. F I=0:1:9 I I'=$E(SQ),$L($TR(SQ,I))<3 KILL @NN Q ;unlikely: nZZn
Do something similar to VIER numbers (require unique digits)
S VV="VIER" F S VV=$Q(@VV) Q:VV="" S SQ=@VV DO
. F I=0:1:9 I $L($TR(SQ,I))<3 KILL @VV Q ;not unique digits
. S E=$E(SQ,3) I '$D(NEUN(E)) KILL @VV Q ;no comparable NEUN number
So that gives us a list of numbers which match NEUN and a list of numbers
which match VIER and both have the 'E' digit comperable. Now build the
list of hits:
S NN="NEUN" F S NN=$Q(@NN) Q:NN="" S N=@NN DO
. S VV="VIER" F S VV=$Q(@VV) Q:VV="" S V=@VV DO
.. ;
.. i $E(N,2)'=$E(V,3) Q ;E's don't match
.. I $L($TR(N,V))'=3 Q ;can only have 1 digit overlap
.. ;
.. W !,"NEUN="_N,?20,"VIER="_V ;matching hit
Using the above, I got:
NEUN=9409 (97**2) VIER=6241 (79**2)
1521 (39**2) 4356 (66**2)
7056 (84**2)
1681 (41**2) 7569 (87**2)
4624 (68**2) 1369 (37**2)
7569 (87**2)
5625 (75**2) 1369 (37**2)
1764 (42**2)
4761 (69**2)
The first one (9409 & 6241) being the only single-hit where neither of the
squares are valid for any of the other solutions.
Now back to our regularly scheduled work ...
Ben
m_l...@my-deja.com
Approach: straightforward (it's less than 10000 iterations anyway)
----- code -----
include bf1.fth \ loading BacFORTH, see http://www.forth.org.ru/~mlg
: ? @ . ; \ standard but missing in T32Forth
DECIMAL
: numbers ( --> m ) \ 4-digit squares
PRO 99 32 DO I DUP * CONT LOOP
;
: _dig ( m --> n m' ) 10 /MOD ;
: n>digits ( m --> n0 n1 n2 n3 ) ( <-- ??? )
PRO
SP@ >R
_dig _dig _dig _dig DROP \ split into digits
CONT
R> SP! DROP \ remove garbage from stack
;
VARIABLE v
VARIABLE i
VARIABLE e
VARIABLE r
VARIABLE n
VARIABLE u
CREATE digit->letter 10 CELLS ALLOT
digit->letter 10 CELLS ERASE
: !! ( digit var --> ) ( ??? <-- ) \ bind digit & var; may leave garbage
PRO
OVER digit->letter [] ONFALSE
2DUP B!
SWAP digit->letter []^ B!
CONT
;
: ?? ( digit var --> ) ( <-- ) \ check if var is bound with digit
@ = RUSH> ONTRUE
;
: main
numbers n>digits n !! e !! u !! n ??
numbers n>digits v !! i !! e ?? r !!
CR ." vier = " v ? i ? e ? r ? ." neun = " n ? e ? u ? n ?
;
---- end code ----
---- run ----
main
vier = 4 3 5 6 neun = 1 5 2 1
vier = 7 0 5 6 neun = 1 5 2 1
vier = 7 5 6 9 neun = 1 6 8 1
vier = 1 3 6 9 neun = 4 6 2 4
vier = 7 5 6 9 neun = 4 6 2 4
vier = 1 3 6 9 neun = 5 6 2 5
vier = 1 7 6 4 neun = 5 6 2 5
vier = 4 7 6 1 neun = 5 6 2 5
vier = 6 2 4 1 neun = 9 4 0 9 ok[Dec]
---- end run ----
Rod Dorman
>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.
Try VIER = 6241 = 79**2
and NEUN = 9409 = 97**2
--
-- Rod --
ro...@polylogics.com
Geoff Summerhayes
<jsgr...@my-deja.com> wrote in message news:97lnps$ppc$1...@news.netmar.com...
> 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.
You mean if I know what VIER is there exists only one unique sol'n
for NEUN and vice versa? Cute, that leaves only one case.
Geoff - I may not know Lisp, but my Prolog's not bad! :-)
Marc Battyani
"Geoff Summerhayes" <sNuOmS...@hNoOtSmPaAiMl.com> wrote in message
news:t9tfpgd...@corp.supernews.com...
If you like Prolog you should look at Screamer:
http://www.cis.upenn.edu/~screamer-tools/home.html
Marc
Bruce Hoult
> 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}
jsgr...@my-deja.com
heard how dense a language that it is, I bet your program will only be 10
characters, right?(;-)
Steve
===
In article <97m8eo$6rp$1...@news.panix.com>, Rod Dorman
<ro...@panix.com>
writes:
Morten Kromberg
(apologies to my cycle club for the misuse of their web server, but being
the webmaster should give you SOME privileges :-). I've put an image of it
on the web page to avoid problems with APL special symbols.
I haven't spent enough time on it to get it down to 10 characters. Maybe
later :-)
If you run the function under Dyalog APL, it returns:
9409 6241
Morten
-----Original Message-----
From: APL Language Discussion [mailto:AP...@unb.ca]On Behalf Of News
Gateway
Sent: 2. marts 2001 09:03
To: AP...@LISTSERV.UNB.CA
Subject: Re: New Scientist Puzzle
X-From: jsgr...@my-deja.com
Roger Hui
> Subject: New Scientist Puzzle
> Newsgroups: comp.lang.apl, comp.lang.basic, comp.lang.c,
> comp.lang.forth, comp.lang.lisp, comp.lang.mumps, comp.lang.smalltalk
> Date: 2001-03-01 07:04:03 PST
>
> 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.
>
The puzzle can be solved in J as follows:
The 4-digit squares are (>.%:1000) squared to
(<.%:9999) squared, or, as a character matrix,
s=: 4":,.*:32+i.68
4{.s
1024
1089
1156
1225
_4{.s
9216
9409
9604
9801
To form all pairs of such squares, catenate
each row to all other rows, and make into
a matrix, thus:
p=: ,/ ,"1"1 _ ~ s
$p
4624 8
4{.p
10241024
10241089
10241156
10241225
_4{.p
98019216
98019409
98019604
98019801
The pattern of digit assignments must be the
same as the pattern of letters in 'vierneun',
and so:
a=: ((i.~'vierneun')-:"1 i.~"1 p)#p
$a
9 8
a
13694624
13695625
17645625
43561521
47615625
62419409
70561521
75691681
75694624
Finally, choose numbers that are unique
in all the pairs. An item is unique if
its index of first occurrence is the same
as its index of last occurrence. Thus:
((4{."1 a) *.&(i.~ = i:~) (4}."1 a))#a
62419409
Collecting together the essential lines:
s=: 4":,.*:32+i.68
p=: ,/ ,"1"1 _ ~ s
a=: ((i.~'vierneun')-:"1 i.~"1 p)#p
((4{."1 a) *.&(i.~ = i:~) (4}."1 a))#a
62419409
Forming all pairs is linear in the size of
the result; all other operations are linear
in the size of the argument(s).
Knut Arild Erstad
:
: 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.
Here's a CL solution:
(defun lists-match (list1 list2)
(loop with map = ()
for elt1 in list1
for elt2 in list2
do (let ((a1 (find elt1 map :key #'car)) ;; same as assoc
(a2 (find elt2 map :key #'cdr))) ;; "reverse" assoc
(cond ((and (null a1) (null a2))
(push (cons elt1 elt2) map))
((not (eq a1 a2))
(return nil))))
finally (return t)))
(defun integer->digits (i &optional (base 10))
(loop while (> i 0)
with digits = ()
do (multiple-value-bind (n rest)
(floor i base)
(push rest digits)
(setq i n))
finally (return digits)))
(defun all-vier-neun-answers ()
(let ((squares (loop for i from 32 to 99 collect (* i i)))
(answers ()))
(dolist (n1 squares)
(let ((digits1 (integer->digits n1)))
(when (lists-match digits1 '(n e u n))
(dolist (n2 squares)
(let ((digits2 (integer->digits n2)))
(when (lists-match (nconc digits2 digits1)
'(v i e r n e u n))
(push (cons n2 n1) answers)))))))
answers))
(defun vier-neun ()
(let ((all-answers (all-vier-neun-answers))
(unique-answers ()))
(dolist (answer all-answers)
(unless (find-if (lambda (ans)
(and (not (eq answer ans))
(or (= (car answer) (car ans))
(= (cdr answer) (cdr ans)))))
all-answers)
(push answer unique-answers)))
unique-answers))
* (vier-neun)
((6241 . 9409))
--
Knut Arild Erstad
Nobody loves me but my mother, and she could be jivin' too.
-- B.B King
WildHeart'2k1
> p=: ,/ ,"1"1 _ ~ s
> a=: ((i.~'vierneun')-:"1 i.~"1 p)#p
> ((4{."1 a) *.&(i.~ = i:~) (4}."1 a))#a
> 62419409
Here's my rather ugly K rendering of Roger's elegant solution:
s:4$(32+!68)^2
p:,/s,\:/:s
a: p @ & ({x?/:x}"vierneun")~/:{x?/:x}'p
k:{*:'x@&1=#:'x:=x}'+{(4#x;4_ x)}'a
a k[0] @ &k[0] _in\: k[1]
,"62419409"
If any K expert is listening on these frequencies, please, feel compelled to
provide a better solution :)
--
WildHeart'2k1
Deepak Goel
> [jsgr...@my-deja.com]
> :
> : 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.
>
> Here's a CL solution:
hmmm..
anybody did it by hand?
Morten Kromberg
also improve the APL solution. I have updated the page
http://www.ckkronborg.dk/nsapl.htm with a version which illustrates this.
Manually transliterated code below (w used in place of omega). And {} used
both for transliteration and dynamic functions, but you can probably get the
gist of it. Otherwise, check out the picture on the web page.
r{is}4 0{format},rฐ.,r{is}(31+{iota}68)*2 //
4624x8-column char matrix NEUNVIER
r{is}(12315628={10{decode}w{iota}w}จ{split}r){compress first}r // Same
pattern as NEUNVIER or 12315628
r{is}m{enclose}(~{first}{or}/{w{element}(({iota}{shape}w){neq}w{iota}w)/w{is
}{split}w}จ(m{is}8{reshape}4{take}1){enclose}r){compress first}r // Unique
entries in each group of 4 columns
/ Morten
Marcel Hendrix
> Language: BacFORTH (Forth + backtracking)
> Approach: straightforward (it's less than 10000 iterations anyway)
The fact that the solution is vier = 79, neun = 97 seems to imply a much
simpler approach is possible. Anyhow, the brute force one suits me.
-marcel
----------------------------------------------------------------------
DOC
(*
jsgr...@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.
Steve Graham
*)
ENDDOC
[DEFINED] -work [IF] -work [THEN] MARKER -work
\ What are the squares between 10,000 and 9,999?
\ 1. These are formed by square 32 <= candidate <= 99.
\ 2. 1.tens = 2.hundreds
\ 3. 2.thousands = 2.ones
\ 4. 1.thousands unique
\ 5. 1.hundreds unique
\ 6. 1.ones unique
\ 7. 2.tens unique
3 =: .1
2 =: .10
1 =: .100
0 =: .1000
CREATE numbers #99 #32 - 1+ 4 CHARS * ALLOT
CREATE list1 #15 CHARS ALLOT
CREATE list2 #15 CHARS ALLOT
0 VALUE #sols
: [IX] ( ix -- addr ) #32 - 4 CHARS * numbers + ;
: .number ( addr ix -- )
CHARS + C@
[CHAR] ( EMIT DUP 0 .R ." ) --> "
[IX] 4 0 DO C@+ EMIT SPACE LOOP DROP ;
: !numbers ( -- )
#100 #32 DO I I * ( square )
U>D <# # # # # #>
I [IX] SWAP MOVE
LOOP ;
!numbers FORGET !numbers
: UNIQUE? ( 'n1 'n2 char -- flag )
0 LOCALS| cnt char 'n2 'n1 |
'n1 4 0 DO C@+ char = 1 AND +TO cnt LOOP DROP
'n2 4 0 DO C@+ char = 1 AND +TO cnt LOOP DROP
cnt 1 = ;
: OK? ( n1 n2 -- )
2DUP [IX] SWAP [IX] LOCALS| 'n1 'n2 |
'n1 .10 + C@ 'n2 .100 + C@ =
'n2 .1000 + C@ 'n2 .1 + C@ = AND
'n1 'n2 'n1 .1000 + C@ UNIQUE? AND
'n1 'n2 'n1 .100 + C@ UNIQUE? AND
'n1 'n2 'n1 .1 + C@ UNIQUE? AND
'n1 'n2 'n2 .10 + C@ UNIQUE? AND
IF list2 #sols CHARS + C!
list1 #sols CHARS + C!
1 +TO #sols
ELSE 2DROP
ENDIF ;
: n=UNIQUE? ( addr sz ix -- )
CHARS 2 PICK + C@ 0 LOCALS| cnt char |
0 ?DO C@+ char = 1 AND +TO cnt LOOP DROP
cnt 1 = ;
: .UNIQUE-PAIRS ( -- )
#sols 0 ?DO list1 #sols I n=UNIQUE?
list2 #sols I n=UNIQUE? AND
IF CR list1 I ." vier " .number 2 SPACES
list2 I ." neun " .number
ENDIF
LOOP ;
: FILTER ( -- )
#99 #32 DO #100 I 1+ DO J I OK? LOOP LOOP
.UNIQUE-PAIRS ;
\ This is instantaneous.
\ FORTH> filter
\ vier (79) --> 6 2 4 1 neun (97) --> 9 4 0 9 ok
Steve Graham
Thanks for submitting the MUMPS solution. I've received a number of
them, in addition to programs in APL, Icon, K, LISP, Perl, Prolog, Smalltalk
and SPITBOL. Very interesting for someone who has spent most of their life
in MUMPS. I would love to be able to decipher the APL and K submissions,
too.
Steve
Thanks for submitting the program.
"Ben Bishop" <a...@nautilus.shore.net> wrote in message
news:FZun6.6585$JG.8...@news.shore.net...
David Ness
>
> Here's my rather ugly K rendering of Roger's elegant solution:
>
> s:4$(32+!68)^2
> p:,/s,\:/:s
> a: p @ & ({x?/:x}"vierneun")~/:{x?/:x}'p
> k:{*:'x@&1=#:'x:=x}'+{(4#x;4_ x)}'a
> a k[0] @ &k[0] _in\: k[1]
> ,"62419409"
>
> If any K expert is listening on these frequencies, please, feel compelled to
> provide a better solution :)
> --
I don't find it ugly at all. Just for amusement, here's something that
shares a lot with your solution, but goes at it in a completely different
(and very inefficient) way. I don't recommend it, except as a curiosity:
------------
/ <$Permutations and Combinations - Ver DN-1A(2) - [KPO-CFOY]$>
/ The `vier - neun' problem: an inefficient but different way
comb:{,/x{n,''(+\#:'x)#\:,/1+x}/n:|!y-x-:1}
perm:{:[x>1;<:',/(!x),'\:perm[x-1];,0]}
sq:{x=(_ x^0.5)^2}
D: . +(,(`v `i `e `r `n `u)),,+,/(comb[6;10])[;perm[6]]
ans:&(sq'10 _sv D[`v `i `e `r])*sq'10 _sv D[`n `e `u `n]
k:*:'' aa @' &:'1=#:''aa:=:'({(+4#x;+4_ x)} dd:D[`v `i `e `r `n `e `u `n;ans])
(+ dd) @ k[0] @ &k[0] _lin\: k[1]
--------------
This produces
,6 2 4 1 9 4 0 9
There are a couple of things here that may make this worth posting. First, the
comb[x;y] generates all combinations of y objects taken x at a time. I have
forgotten if this was due to Arthur or to Roger, but it certainly was more
clever than I could come up with. The `perm[x]' generates all permutations of
x objects. The code is mine, but I'd appreciate better from someone who knows.
This solution, in case it isn't obvious, gets the answer by actually trying
all assignments (151,200 of them) to the possible letters. It then narrows
the scan to the (15) elements that satisfy being `squares' (I didn't arbitrarily
eliminate leading zeros), and finally focuses on the one solution where
a only one solution exists for both numbers.
Stefano Lanzavecchia
life
> in MUMPS. I would love to be able to decipher the APL and K submissions,
While I know the time in a human's lifetime is limited, I can recommend
http://www.kx.com/ where you can find a tutorial, all the documentation and
a free version of the K interpreter for download. It's really small and it's
well worth it. It's cross-platform as well...
--
WildHeart'2k1 (at home)
David Ness
`vier-neun' problem, to wit:
Solve the `vier-neun' problem for other German numerals that have four
letter names.
I have not been tempted, at least so far, to generalize even further, for
example into the numerals of other languages. I am happy to leave that exercise
to someone who can spell numerals in other languages better than I can.
Here is my adapted Lanzavecchia/Hui code:
------------
/ <$`Vier/Neun Squares Puzzle (Generalized) - Ver DN-1A(1) - [XXX-XXXX]$>
skp: z,'z:("eins";"zwei";"drei";"vier";"funf";"acht";"neun")
num:num @ &(#z)=skp ?/: num:,/z ,\:/:z
dj:{[arg] `0:"\n",arg,"\n"
a: p @ & ({x?/:x}arg)~/:{x?/:x}'p:,/s,\:/:s:4$(32+!68)^2
if[0=#k:{*:'x@&1=#:'x:=x}'+{(4#x;4_ x)}'a;:(arg;-1)]
`0:t:"\t",'a k[0] @ &k[0] _in\: k[1]
(arg;#t)}
-------------
Typing
dj'num
will result, among other things, in a list:
(("zweieins";2)
("dreieins";2)
("viereins";6)
("funfeins";2)
("achteins";0)
("neuneins";-1)
...
("zweineun";1)
("dreineun";1)
("vierneun";1)
("funfneun";-1)
("achtneun";1))
which indicates each `problem' and the number of solutions found for that
particular problem. The difference between `0' and `-1' is that 0 represents
places where there are solutions but none of them satisfy the `single/single'
restriction. `-1' occurs when there are no solutions even relaxing this
assumption.
John R. Clark Ka6JCx
Since we know they are 4 digit squares we can generate all possible
values and start to do an elimination.
Let V be the universe and A be the possible values for NEUN
A{<-}((V[;2]{/=}V[;3])^(V[;1]=V[;4])){slashbar}V{<-}{format}(({rho}V),1)
{rho}V{<-}(33{drop}{iota}99)*2
By removing duplicates from V we can obtain possible VIER values
V{<-}(NODUPS {each}{enclose}[2] V){slashbar}V
If we cut out the values of V that fail we have a solution
A,CUT{each}{enclose}[2] A
1521 4356
7056
1681 7569
4624 1369
7569
5625 1369
1764
4761
7569
9409 5041
6241
{del}NODUPS[#]{del}
[0] Z{<-}NODUPS X
[1] Z{<-}1={max}/+/X{jot}.=X
{del}CUT[#]{del}
[0] Z{<-}CUT X
[1]
Z{<-}((V[;1]{/=}X[1])^(V[;2]{/=}X[2])^(V[;3]=X[2])^(V[;4]{/=}X[4]))
{slashbar}V
There are probably more sophisticated ways
John R. Clark
David Ness
>
> A posible solution to the VIER and NEUN problem.
>
>
> If we cut out the values of V that fail we have a solution
>
> A,CUT{each}{enclose}[2] A
> 1521 4356
> 7056
> 1681 7569
> 4624 1369
> 7569
> 5625 1369
> 1764
> 4761
> 7569
> 9409 5041
> 6241
>
Looks to me like either
(1) you've cut and pasted badly; or
(2) you've got a bug---
9409, 5041 doesn't look like a solution to me, for example...
Steve Graham
take a look.
Steve
-===
"Stefano Lanzavecchia" <lste...@hotmail.com> wrote in message
news:97qnjt$k0a$1...@lacerta.tiscalinet.it...
John Sullivan
Tripathi <Trip...@svg.com>
>This is a MIME message. If you are reading this text, you may want to
>consider changing to a mail reader or gateway that understands how to
>properly handle MIME multipart messages.
>
No thank you. There are enough viruses in the world, and I don't want
them on my computer.
Please post in plaintext only.
--
John Sullivan Remove the dots in yDdraigGoch for my real address.
-------------
Virtuoso: someone who plays pieces of music of little artistic merit
faster and louder than anyone else.
Reinout Heeck
No doubt perl is shorter but this naive Smalltalk implementation is more
intention revealing ;-)
---------------------------
| 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')
Cheers!
Reinout Heeck
-------------
re...@desk.org
Bruce Hoult
<Marc.B...@fractalconcept.com> wrote:
> "Reinout Heeck" <re...@Desk.org> wrote in
> > Bruce Hoult wrote:
> > >
> > > In article <97lnps$ppc$1...@news.netmar.com>, jsgr...@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
Jason Kantz
(defun VIER-NEUN ()
;; collect squares, separating into N**N and ****
;; [notice that there aren't that many N**Ns]
(do ((N**N '())
(**** '())
(i (ceiling (sqrt 1000)) (1+ i)))
((> i (isqrt 9999))
(select-pair N**N ****))
(let ((str (format nil "~d" (* i i))))
(if (char= (schar str 0) (schar str 3))
(push str N**N)
(push str ****)))))
(defun select-pair (N**Ns ****)
(let ((pairs '()))
;; collect pairs fitting the VIER NEUN pattern
(dolist (NEUN N**Ns)
(dolist (VIER ****)
(if (pairp VIER NEUN)
(push (list VIER NEUN) pairs))))
;; select a pair such that each number only appears once
;; in all of the pairs
(dolist (pair pairs)
(if (= 1
(count (first pair) pairs :key #'first)
(count (second pair) pairs :key #'second))
(return-from select-pair pair)))))
(defun pairp (VIER NEUN)
(and (char= (schar NEUN 0)
(schar NEUN 3))
(char= (schar VIER 2)
(schar NEUN 1))
(char/= (schar VIER 0)
(schar VIER 1)
(schar VIER 2)
(schar VIER 3)
(schar NEUN 0)
(schar NEUN 2))))
==
Jason Kantz
http://kantz.com/jason
Neil Schemenauer
from math import sqrt
def uniq(chars):
d = {}
for c in chars:
d[c] = 1
return d.keys()
vs = []
ns = []
sqrs = ["%d" % n**2 for n in range(sqrt(1000)+1, sqrt(9999))]
for vier in sqrs:
for neun in sqrs:
if (neun[0] == neun[3] and neun[1] == vier[2] and
len(uniq(vier + neun)) == 6):
vs.append(vier)
ns.append(neun)
for v, n in zip(vs, ns):
if vs.count(v) == ns.count(n) == 1:
print "Found", v, n
Roger Hui
> Stealing Roger Huis elegant idea for verifying the pattern of the digits can
> also improve the APL solution. I have updated the page
> http://www.ckkronborg.dk/nsapl.htm with a version which illustrates this.
>
> Manually transliterated code below (w used in place of omega). And {} used
> both for transliteration and dynamic functions, but you can probably get the
> gist of it. Otherwise, check out the picture on the web page.
>
> r{is}4 0{format},r{jot}.,r{is}(31+{iota}68)*2
> r{is}(12315628={10{decode}w{iota}w}{each}{split}r){compress first}r
> r{is}m{enclose}(~{first}{or}/{w{element}(({iota}{shape}w){neq}w{iota}w)/
> w{is}{split}w}{each}(m{is}8{reshape}4{take}1){enclose}r){compress first}r
Comparing of this APL solution to the J solution posted earlier:
s=: 4":,.*:32+i.68
p=: ,/ ,"1"1 _ ~ s
a=: ((i.~'vierneun')-:"1 i.~"1 p)#p
((4{."1 a) *.&(i.~ = i:~) (4}."1 a))#a
a. Forming the 4624 8 column character matrix.
APL: r{is}4 0{format}{uparrow},r{jot}.,r{is}(31+{iota}68)*2
J: s=: 4":,.*:32+i.68
p=: ,/ ,"1"1 _ ~ s
Comments:
- I inserted {uparrow} after {format}; the {uparrow} is
in the webpage even though it is not in the manually
translated version above. I am curious on what sort
of computation {uparrow} does, that can make a 9248 element
vector (the ravel of the outer product) into a 4624 2 matrix.
- Slight simplification for J due to the use of the square
function *:
- The J solution could have avoided the temporary name s
because of the use of ~ (reflexive):
p=: ,/ ,"1"1 _ ~ 4":,.*:32+i.68
- Slight simplification for J due to the use of complex
numbers to encode the left argument for format
(4j0 (i.e. 4) instead of 4 0). In the general case in J,
the number of elements in the format control left argument
matches the number of columns in the right argumet;
in APL, the number of elements in the format control is
twice the number of columns.
- The J solution can be simplified by using outer product
like the APL solution: p=: ,/ ,"1/ ~ 4 ": ,.*:32+i.68
Also, J has the option of forming the pairs after
formatting (using ,"1/~) or before formatting (,"0/~).
In this case "after" is faster than by a factor of 40
than "before". This makes sense as catenation is
cheaper than formatting ("after" requires formatting
68 numbers; "before" requires 4624.)
b. Select according to the letter assignments.
APL: r{is}(12315628={10{decode}w{iota}w}{each}{split}r){compress first}r
J: a=: ((i.~'vierneun')-:"1 i.~"1 p)#p
Comments:
- I wonder if the phrase f{each}{split}x is supported
by special code in the APL interpreter? The analoguous
f"r x (f rank r) in J is supported by special code for
many functions f, and in this case of i.~"1 the time
difference is a factor of 4.
- How would you code the test in APL, if the vector result
of dyadic iota can not be encoded as a single number?
(Say if the vector result had 20 digits?) In the old
APL days I would do it using an inner product,
({w{iota}w}{each}{split}r) {and}.=1 2 3 1 5 6 2 8 .
In J I can do as above, vector -:"1 matrix (match rank 1).
How do you do the vector match in modern APL?
In J, of the two ways of doing the test,
( i.~'vierneun') -:"1 i.~"1 p
(10#.i.~'vierneun') = 10#.i.~"1 p
takes about the same time, because the time for i.~"1 p
dominates (taking over 95% of the time for the expression).
On aa-:"1 bb vs. (10#.aa)=10#.bb where aa=:i.~'vierneun'
and bb=: 10#.i.~"1 p , the former is faster by a factor
of 3 than the latter. This makes sense the 10#. (10 decode)
requires traversing every byte of the arguments and requires
doing more on every byte. Match can do no worse than
traversing every byte and doing less on each byte, and as
well can quit on encountering a non-matching byte.
- The J solution has the option of switching the arguments
of the # through the use of ~ (reflexive), thus:
a=: p #~ (i.~'vierneun')-:"1 i.~"1 p
c. Selecting the rows that are unique in each 4-column field
APL: r{is}(~{first}{or}/{w{element}(({iota}{shape}w){neq}w{iota}w)/
w{is}{split}w}{each}(8{reshape}4{take}1){enclose}r){compress first}r
J: ((4{."1 a) *.&(i.~ = i:~) (4}."1 a))#a
Comments:
- To compare apples to apples, I took out the m{encose} just
before the final assignment to r (its practical effect is
just to put a blank between the first 4 columns and the last 4).
The assignment to m is then obviated.
- The w{is}{split}w seems necessary because the APL {iota}
requires vector or scalar arguments. Since the i. (and i:)
in J accommodate arrays of any dimension, the analoguous
operation (<"_1 w) is unnecessary.
I wonder if APL optimizes dyadic {iota} on such arguments?
(Arguments x which is the {split} of some y?) In J,
for the array p computed in step a above, i.~p is faster
by a factor of 4 than i.~q where q=: <"_1 p . J does
not bother optimize i. on <"_1 p, i.e. to prescan q for the
fact that in is the "split" of something, because it "knows"
that a split is not necessary for i. .
- I believe the APL solution can be made simpler and faster
if it used the idea in the J solution, that the unique
items are those whose index of first occurrence equals
the index of last occurrence (i.~ = i:~) .
~ {first}{or}/ {w{element}(({iota}{shape}w){neq}w{iota}w)/w{is}{split}w}
{first}{and}/ {(w{iota}w)=(1+{shape}w)-({reverse}w){iota}w{is}{split}w}
- The J solution benefits from the existence of the & operator,
where x f&g y is (g x) f (g y)
- The J solution can be made more readable by using ~ ,
to put the long left argument of # to the right:
a #~ (4{."1 a) *.&(i.~ = i:~) (4}."1 a)
Improved J solution:
p=: ,/ ,"1/ ~ 4":,.*:32+i.68
a=: p #~ (i.~'vierneun')-:"1 i.~"1 p
a #~ (4{."1 a) *.&(i.~ = i:~) (4}."1 a)
Veli-Matti Jantunen
David Ness wrote:
> Lanzavecchia(Hui)'s code inspired me to try a small generalization of the
> `vier-neun' problem, to wit:
> Solve the `vier-neun' problem for other German numerals that have four
> letter names.
Hmm.. what about this one (made hastily with Dyalog APL). If needed,
this could be
enhanced to a) cut off the non-unique pairs (I was too lazy to make
this) and b) handle
other languages ( Finnish would be an interesting case..)
The code tries to optimise the algorithm _before_ outer product! (I
still get
goosebumps using the jot :) )
{del} z{<-}y G4D x;a;i;j;mat;xv;yv;#IO;#ML
[1] @ German 4-Digits. eg: 'vier' G4D 'neun'
[2]
[3] (#IO #ML){<-}1 3
[4] mat{<-}{format},[''](31+{iota}68)*2
[5] (i j){<-}(1 1 1 2 2 3)(2 3 4 3 4 4)
[6] a{<-}{split}mat[;i]=mat[;j]
[7] yv{<-}{split}({enlist}a{match}{each}{enclose}y[i]=y[j]){slashbar}mat
[8] xv{<-}{split}({enlist}a{match}{each}{enclose}x[i]=x[j]){slashbar}mat
[9]
[10] mat{<-}{disclose},yv{jot}.,xv
[11] (i j){<-}(4/{iota}4)(16{rho}{iota}4)
[12] a{<-}{split}mat[;i]=mat[;j+4]
[13] z{<-}({enlist}a{match}{each}{enclose}y[i]=x[j]){slashbar}mat
[14] z{<-}(9{rho}1 1 1 1 0)\z
[15]
[16] @ VMJ
{del}
-Veli-Matti
>
Morten Kromberg
1) Apologies for leaving the <uparrow> out of the manual transliteration. It
is a real pain that discussion forum etiquette does not allow the use of
HTML formatting or attachments, this drastically reduces the efficiency of
communications. Good thing I'm allowed to use these things in my daily work!
The right argument to the up arrow does not have 9248 elements, it is a
4624-element vector (68*2) containing two-element vectors. When you <mix>
this, it becomes a 4624x2 matrix.
2) Yes, J does allow a whole bunch of slight but elegant simplifications!
3) You could also format before catenation in the APL solution, with a
little less elegance than in J:
r{is}{mix},r{jot}.,r{is}{split}4 0{format}(31+{iota}68}{jot}.*,2
4) If I could not take advantage of the fact that there are only 8 digits, I
would say:
r{is}(({w{iota}w}{each}{split}r){elementof}{enclose}{w{iota}w}'neunvier'){co
mpress first}r
This does seem to be faster in APL, as your analysis suggests.
5) The questions regarding what APL special-cases are best answered by
someone from Dyadic, if they are watching this thread and have time to
respond. A few simple timings seems to suggest that they are NOT
special-cased. However, I believe that dyadic iota and "element of" use
hashing, which may give them the same benefits in more general cases.
6) Agree with your analysis of the last line, APL can take advantage of this
and it does seem faster. I'll post the improved function on the web page
(http://www.ckkronborg.dk/nsapl.htm) in case anyone is interested.
/ Morten
-----Original Message-----
From: APL Language Discussion [mailto:AP...@unb.ca]On Behalf Of Roger
Hui
Sent: 4. marts 2001 13:51
To: AP...@LISTSERV.UNB.CA
Subject: Re: New Scientist Puzzle
Roger Hui
> The right argument to the up arrow does not have 9248 elements, it is a
> 4624-element vector (68*2) containing two-element vectors. When you <mix>
> this, it becomes a 4624x2 matrix.
Thanks. I'd forgotten that APL does the equivalent
of <@f on everything.
> 5) The questions regarding what APL special-cases are best answered by
> someone from Dyadic, if they are watching this thread and have time to
> respond. A few simple timings seems to suggest that they are NOT
> special-cased. However, I believe that dyadic iota and "element of" use
> hashing, which may give them the same benefits in more general cases.
You can discover a lot just by timings.
Regarding hashing and the dyadic iota family (iota,
epsilon, etc.): Hashing alone is not enough. J also
uses hashing for (<"_1 x) i. <"_1 y , but this case
is a lot slower than just x i. y ; it is necessarily
slower unless it prescans the arguments to see that
it is really just x i. y . Cases like
(0 1; (0,3-2);0,1.5-0.5) e. (0 1;0 2)
items having the same value but different internal
representations, gums up the hashing. So, I am curious,
does APL optimize ({split}x){iota}({split}y)
(epsilon, etc.)? (Timing a few examples would answer
this question.) J does not, but it does not need to
because the array i. array case is available.
Similar comments on f{each}{split}x vs. f"r x .
Stefano Lanzavecchia
I am collecting them and will publish a few, in particular the APL and J
ones but some written in other languages as well for comparison, hopefully
not to feed a silly language flame war, on a small magazine of the British
APL Association, for which I am now the editor.
You can have a look at an online version of the magazine at this webpage:
http://www.vector.org.uk/ where you can find sample of articles published in
the printed version. As you can see while a serious magazine, it's also
reasonably informal, therefore there is no shame at all involved in having
published code which could be thought as less than optimal. Instead, there's
a good chance that a version quickly hacked together would have some
pedagogic and exemplar value because it shows what the language is capable
of when put to the edges.
Anyway, my question is: if the author of any of the solution appeared in
these newsgroups (I have APL, J, K, MUMPS, Common Lisp, Dylan, Smalltalk,
Perl, Python from which to choose from) strongly objects to have his
solution published against his or her name, to please let me know and I will
remove the solution from my pool. Otherwise I'll work on the assumption that
by posting a message in a public newsgroups the author implicitely indicated
that, while not necessary proud, does not mind to see his work published for
public consumption.
By the way, it's quite likely that the readers of Vector are less than the
sums of the readers of these newgroups...
Thank you everybody, and I hope you shared my fun in the solution of the
little puzzle and in the comparison of the different languages.
Stefano Lanzavecchia
From: "John R. Clark Ka6JCx" <rcm...@nwark.com>
Newsgroups: comp.lang.apl
Sent: Saturday, March 03, 2001 17:31
Subject: Re: New Scientist Puzzle
> A posible solution to the VIER and NEUN problem.
Another possible solution. This time in the form of a dynamic function
(Dyalog APL only). This is only an exercise of style (and not necessarily
good style). The solution, by itself, features as good (?) points:
- complete absence of assignment
- the essence of the problem factored in an outer product
I am not pleased by how I solved the request of uniqueness of the solution.
The code is not translated using APL2ASCII because curly brackets are
fundamental in dynamic functions. Therefore I assume that you'll be able to
recognise APL operators by their name and by the fact that as I've already
said there are no names used (all the functions are anonymous). I use "w" to
indicate omega, "a" to indicate alpha, "aa" to indicate "alphaalpha" (the
function argument of a user-defined operator built as a dynamic function)
and "<-" to indicate the left arrow because I don't need "<" as less-than
anywhere in the solution.
Here we go:
vierneun<-{
{
(4 take[2]w){
(first ^/{(w iota w)=1+(rho w)iota w}compose split each a
w)/[1]a,w
} (-4)take[2]w
}{
mix(sign first compose rho each w)/w
}{
,w jot.(({w iota w)'vierneun'){(aa match {w iota w]a,w)/a,w})w
}{
split 4 0 format,[zilde](32+iota 68)*2+#IO<-0
}#ML #IO<-1
}
Usage:
vierneun ''
(the argument is a dummy)
The solution should be read from bottom to top and it's another rephrasing
of Roger's J solution. Because of its nature it is a one-liner...
--
WildHeart'2k1 (at Home)
Koji Kawakami
using simple approach
[0] r{<-}spuzzle;t
[1] r{<-}'2i4' {quad}fmt (4624 2){rho}
r({jot}.(,{rank}0)r{<-}(31+{iota}68)*2 all possible 4 digit
combinations
[2]
r{<-}((r[;3]=r[;6])^r[;5]=r[;8]){/-}r
a rough sieve
[3] r{<-}('vierneun'{in}{on}{/=}{rank}1
r)[;1]{/-}r
pattern matching
[4] r{<-}(({or}{/-}(1=+/t){/-}t{<-}=r[;1 2 3 4])^{or}{/-}(1=+/t){/-}t{<-}=r[;5
6 7 8]){/-}r unique pair only
[5] r{<-}1 1 1 1 0 1 1 1
1\r
purely cosmetic char result
It executes 70 mili-seconds on Linux of 200 Mhz Peintium II, apl is SAX.
Note: On SAX monadic = {nubin} in line [4]
monadic{/=} {nubsieve} in line [3]
{in} {find} pattern matching
primitive in line [3]
{on} {dieresis jot} in line
[3] [ left f{on}g right <-> (g left ) f ( g right) ], J's & op
{rank} {dieresis jot} in line [1]
and [3]
As you can see, the above solution can be written as one linner with a temp
varable <t> used in line [4].
.../koji
Stefano Lanzavecchia
Here's my contribution in Ocaml.
let range from to_ =
let rec r_ from to_ acc =
if from > to_ then
List.rev acc
else r_ (from + 1) to_ (from :: acc)
in
r_ from to_ [];;
let vierneun =
let squares =
let lbound = truncate(ceil(sqrt(1000.0)))
and ubound = truncate(sqrt(9999.0))
and strsq f = string_of_int (f * f) in
List.map strsq (range lbound ubound)
in let countuniq s =
let rec c_ s i acc count =
if i<String.length s then
if List.mem (String.get s i) acc then
c_ s (i+1) acc count
else
c_ s (i+1) ((String.get s i)::acc) (count+1)
else
count
in
c_ s 0 [] 0
in let uniqpairs vn =
let rec u_ v_ n_ acc disn disv =
match (v_,n_) with
(hv_::tv_, hn_::tn_) -> if List.mem hv_ tv_ ||
List.mem hn_ tn_ ||
List.mem hn_ disn ||
List.mem hv_ disv then
u_ tv_ tn_ acc (hn_::disn) (hv_::disv)
else
u_ tv_ tn_ ((hv_,hn_)::acc) disn disv
| ([],[]) -> acc
| (_,_) -> acc
in match vn with
(vier_s,neun_s) -> u_ vier_s neun_s [] [] []
in let neun =
List.filter (function n -> (String.get n 3)=(String.get n 0)) squares
in let select vn =
match vn with
(v_,n_) -> (String.get v_ 2)=(String.get n_ 1) &&
6=countuniq (v_^n_)
and allpairs =
List.flatten (List.map (function i1 -> List.map (function i2 -> (i1,i2))
neun) squares)
in let pairs =
List.split (List.filter select allpairs)
in
uniqpairs pairs;;
=================================
vierneun;;
- : (string * string) list = ["6241", "9409"]
Shiva Tripathi
{del}SEARCH;A;B;N;S;T;NEUN;VIER
[1] A{<-}B{<-}0{take}#{<-}'***** CANDIDATES *****'
[2] S{<-}{transpose} 10 10 10 10 {represent}(31+{iota}68)*2
[3] N{<-}1{take}{rho}NEUN{<-}(S[;1]=S[;4])/[1]S @ NEUN CANDIDATES
[4] VIER{<-}(S[;3]{epsilon}NEUN[;2])/[1]S @ VIER CANDIDATES
[5] LOOP:{->}(0=+/T{<-}(~{or}/VIER{epsilon}NEUN[N; 1 3])^VIER[;3]{epsilon}{+
+}NEUN[N;2])/TST
[6] 'NEUN: ',({format}S{<-}10{basevalue},NEUN[N;]),' HAS FOLLOWING VIER({+
+}S)'
[7] B{<-}B,#{<-}T{<-}10{basevalue}{transpose}T/[1]VIER
[8] A{<-}A,({rho}T){rho}S
[9] TST:{->}(0<N{<-}N-1)/LOOP
[10] '***** FINAL SOLUTION *****'
[11] 'NEUN: ',{format}A{<-}(S{<-}1=+/A{jot}.=A)/A{<-}(T{<-}1=+/B{jot}.=B)/A
[12] 'VIER: ',{format}S/T/B
{del}
The program produces the following output:
***** CANDIDATES *****
NEUN: 9409 HAS FOLLOWING VIER(S)
1444 3844 6241 7744
NEUN: 5625 HAS FOLLOWING VIER(S)
1369 1764 3364 3969 4761 8464
NEUN: 4624 HAS FOLLOWING VIER(S)
1369 3969 6561 7569
NEUN: 1681 HAS FOLLOWING VIER(S)
3364 3969 7569
NEUN: 1521 HAS FOLLOWING VIER(S)
4356 7056
***** FINAL SOLUTION *****
NEUN: 4624
VIER: 6561
I'll work at reading MIME messages next.
Shiva Tripathi
>>> News Gateway <owner...@sol.sun.csd.unb.ca> 03/03/01 06:13PM >>>
X-From: John Sullivan <jo...@y.ddraig.goch.demon.co.uk>
Steve Graham
I'm been quite pleased with the reception which this puzzle has received,
particularly in the APL newsgroup. You can see a compilation of most of the
solutions at http://members.home.net/js.graham/vierneun.html
Best of luck.
Steve Graham
P.S. Would anyone be interested in another, slightly more complex puzzle???
===
"Stefano Lanzavecchia" <lste...@hotmail.com> wrote in message
news:9832qa$bbb$1...@pegasus.tiscalinet.it...
Wade Humeniuk
little verbose.
--------------->>>>>>
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
Marc
"Steve Graham" <js.g...@home.com> wrote in message
news:ERfp6.359416$ge4.12...@news2.rdc2.tx.home.com...
Steve Graham
Thanks for the reminder. I had failed to link in Marc's entry.
Not being fluent in LISP, I cannot comment on the verbosity or
correctness of the solutions.
Steve Graham
===
"Wade Humeniuk" <hume...@cadvision.com> wrote in message
news:9846ck$3qf$1...@news3.cadvision.com...
Marcel Hendrix
> particularly in the APL newsgroup. You can see a compilation of most of the
> solutions at http://members.home.net/js.graham/vierneun.html
It is interesting to look at the solution strategies followed. Unfortunately
I can't read (most) of them... It would be nice if there were explanations of
the diverse approaches for non-multilinguists to read.
For instance, APL has a 5 line solution, but seems to use a monstrous
array on which it does pattern matching? I could (and would like to)
learn a great deal by implementing such strategies in other languages.
-marcel
WildHeart'2k1
> It is interesting to look at the solution strategies followed.
Unfortunately
> I can't read (most) of them... It would be nice if there were explanations
of
> the diverse approaches for non-multilinguists to read.
As far as I can tell, apart from minor details, the Python, Smalltalk and
Dylan (and the Ocaml I derived mixing the 3 I just mentioned) are pretty
much the same.
The prolog solution is interesting because it almost literally (in English)
implement the statement of the problem.
> For instance, APL has a 5 line solution, but seems to use a monstrous
> array on which it does pattern matching? I could (and would like to)
> learn a great deal by implementing such strategies in other languages.
The APL and J solutions (and the K derived from the latter), while harder to
read, also implement the statement quite literally but only to trained eyes.
In particular the array mentioned is of moderate size. In one of the
solutions proposed, the outer product of all the possible squares is still
only a less than 5000 elements array (68*68).
I would be glad to get into the details of the APL or J solutions, but once
I tried and I quickly figured out that it would require too many details on
the languages themselves.
J (and K) and all its documentation and tutorials can be downloaded for free
from the web pages of the vendors producing the interpreters and, if
interested, I recommend the download. The installation procedure is, in both
cases, very easy and quite unintrusive and the documentation includes
primers which explain a good deal about the language and can guide a
beginner to become proficient enough to understand the solutions proposed.
--
WildHeart'2k1
Geoff Summerhayes
"WildHeart'2k1" <stf+in...@apl.it> wrote in message
news:985niv$4qa4$1...@stargate1.inet.it...
>
>
> The prolog solution is interesting because it almost literally (in English)
> implement the statement of the problem.
>
Unfortunately, the Prolog solution has a flaw in it that isn't exposed because
the problem only has one solution. write/1 doesn't allow backtracking, the
program as it stood only produced the first solution it came across.
My revised solution follows, I've altered the digit-picking logic to do the
comparisons automatically instead of having to hand-code them, takes longer
but is scalable. create_number/3 is also more general than before.
I've also altered some of the variable names to make the logic a little clearer.
leading_digit(X,L,[X|L]) :-
member(X,[1,2,3,4,5,6,7,8,9]),
\+ member(X,L).
digit(X,L,[X|L]) :-
member(X,[0,1,2,3,4,5,6,7,8,9]),
\+ member(X,L).
pure_square(A) :-
B is round(sqrt(A)), A is B * B.
create_number([],N,N).
create_number([H|T],N,NR):-
N1 is N*10+H,
create_number(T,N1,NR).
passes_criteria(V,I,E,R,N,U,VIER,NEUN) :-
create_number([V,I,E,R],0,VIER),
create_number([N,E,U,N],0,NEUN),
pure_square(VIER),pure_square(NEUN).
possible_solutions(VIER,NEUN) :-
leading_digit(V,[],L), leading_digit(N,L,L1),
digit(I,L1,L2), digit(E,L2,L3),
digit(R,L3,L4), digit(U,L4,_),
passes_criteria(V,I,E,R,N,U,VIER,NEUN).
count_matches(_,[],0).
count_matches([X,Y],[[X,_]|T],V):-!,count_matches([X,Y],T,V1),V is V1 + 1.
count_matches([X,Y],[[_,Y]|T],V):-!,count_matches([X,Y],T,V1),V is V1 + 1.
count_matches(A,[_|T],V):-count_matches(A,T,V).
solve(V,N):-
bagof([X,Y],possible_solutions(X,Y),Possibles),
member([V,N],Possibles),
count_matches([V,N],Possibles,Count),
1 is Count.
% d:/prolog/lisp.prolog compiled 0.00 sec, 5,780 bytes
?- solve(VIER,NEUN).
VIER = 6241
NEUN = 9409 ;
No
?-
---Geoff---
Michael Horsch
version of it available, but since no one else provided comments,
I won't either. :-) The CLP(FD) engine I am using is provided
by Sicstus Prolog. The run time is about 40msec on a Sparc Ultra10.
% sictus prolog file: vn.pl
:- use_module(library(clpfd)).
:- use_module(library(lists)).
solve(P,Q) :-
setof((PP,QQ), pair(PP,QQ), Pairs),
unique(Pairs, (P,Q)).
unique(Pairs, (P,Q)) :-
select((P,Q), Pairs, Rs),
\+ member((P,_), Rs),
\+ member((_,P), Rs),
\+ member((Q,_), Rs),
\+ member((_,Q), Rs).
pair(P,Q) :-
domain([V,I,E,R,N,U], 0, 9),
P #= V*1000 + I*100 + E*10 + R,
Q #= N*1000 + E*100 + U*10 + N,
V #> 0,
N #> 0,
domain([X1,X2,Y1,Y2], 0, 9),
X #= X1*10 + X2,
Y #= Y1*10 + Y2,
X1 #> 0,
Y1 #> 0,
P #= X*X,
Q #= Y*Y,
all_different([V,I,E,R,N,U]),
labeling([], [P,Q]).
% eof
Mike
--
Michael C. Horsch
Department of Computer Science
University of Saskatchewan
http://www.cs.usask.ca/faculty/horsch/home.shtml
Randy MacDonald
The slashdot (that's "key" to you J folk...) website mentions
a perl string that decodes some sort of video format.
http://slashdot.org/article.pl?sid=01/03/06/1954213&mode=thread
perhaps that will intrigue some.
--
|\/| Randy A MacDonald ||I'm leery of x where x=x is not true
|\\| ra...@godin.on.ca | Roger Hui
BSc(Math) UNBF '83 | I'd be more leery of the "=" myself.
Natural Born APL'er | R.A. MacDonald
I use Real J | APL: If you can say it, it's done.
------------------------------------------------<-NTP>----{ gnat }-
Leo Wong and Mary Murphy
\ Of the pairs of 4-digit squares on the pattern VIER and NEUN where
\ each letter stands for a distinct digit, find the pair(s) whose
\ squares are not paired with any other square.
: squares \ count 4digits+tally 4digits+tally...
create ( n -- ) 0 c, 5 * chars allot does> ( -- a u 0 ) count 0 ;
: tally ( a -- a' ) 4 chars + ;
: nextsq ( a -- a' ) 5 chars + ;
: >square ( a n -- a' ) 5 * chars + ;
40 squares viers 10 squares neuns \ actual count: 36 viers, 5 neuns
: c++ ( a -- ) dup c@ 1+ swap c! ;
: 4-digit-square ( n -- a ) dup * s>d <# #s #> drop ;
: cut ( c ca u -- n ) rot scan nip ; \ n=remaining chars including c
: neun? ( a -- ? ) \ NEUN if N=N and N<>E<>U
count over 3 cut 1 = swap count swap c@ <> and ;
: vier? ( a -- ? ) \ VIER if V<>I<>E<>R
3 0 do count over 3 i - cut if drop false leave then loop ;
: add-square ( sq a u 0 -- ) \ up count, zero tally, put square
drop over 1 chars - c++ >square 0 over tally c! 4 cmove ;
: viers&neuns ( -- ) \ always follow by tallying pairs
0 ['] viers >body c! 0 ['] neuns >body c! \ initialize each use
100 32 do i 4-digit-square
dup vier? if viers add-square else
dup neun? if neuns add-square else drop then then loop ;
: pair? ( neun vier -- ? ) \ pair if E=E and N and U not in VIER
>r dup char+ c@ r@ 2 chars + c@ -
swap count r@ 4 cut swap char+ c@ r> 4 cut or or 0= ;
: -tally ( neuns|viers ) ?do 0 over tally c! nextsq loop drop ;
: tally++ ( square -- ) tally c++ ;
: tally-pairs ( -- )
neuns -tally viers -tally \ initalize each use
neuns ?do dup
viers ?do
2dup pair? if 2dup tally++ tally++ then
nextsq loop 2drop
nextsq loop drop ;
: once ( square -- ) tally c@ 1 = ;
: found ( neun vier -- ) cr ." Found: " 4 type space 4 type ;
: kismet ( -- )
neuns ?do dup
once if viers ?do 2dup
pair? if dup once if 2dup found then then
nextsq loop drop then
nextsq loop drop ;
: vn ( -- ) viers&neuns tally-pairs kismet ; vn
\ Leo
\ --
\ he...@albany.net
\ http://www.albany.net/~hello/
apinkus
Here is an implementation in Yacas:
10 # CharAt(string_IsString,index_IsInteger) <-- StringMid(index,1,string);
20 # CharAt(string_IsString,index_IsList ) <-- MapSingle("CharAt",index);
CharAt(index_IsInteger) <-- CharAt(string,index);
UnFence("CharAt",1);
[
pairs := {};
sqrs := MapSingle("String",(N(Ceil(Sqrt(1000))) .. N(Floor(Sqrt(9999))))^2);
neuns := Select({{i},CharAt(i,1) = CharAt(i,4)},sqrs);
ForEach(vier,sqrs)
ForEach(neun,neuns)
if (CharAt(vier,3) = CharAt(neun,2))
if (Length(VarList(CharAt(vier:neun,1 .. 8))) = 6)
[ pairs := {vier,neun} : pairs; ];
sides := Transpose(pairs);
result:={};
ForEach(solution,pairs)
if (Count(sides[1],solution[1]) = 1 And Count(sides[2],solution[2]) = 1)
[ result := (solution:result); ];
Echo({result});
];
which, when run, gives:
In> Load("test")
{{"6241","9409"}}
Out> True;
Arguably the CharAt function should be part of the language...
Fun exercise!
Ayal
jsgr...@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.
>
> Steve Graham
>
> ----- Posted via NewsOne.Net: Free (anonymous) Usenet News via the Web -----
> http://newsone.net/ -- Free reading and anonymous posting to 60,000+ groups
> NewsOne.Net prohibits users from posting spam. If this or other posts
> made through NewsOne.Net violate posting guidelines, email ab...@newsone.net
ole...@my-deja.com
from my message there:
-[cut]--------------------------------------------------
Here is an adaptation of Roger's alrorithm in C.
I don't know how to post it on [Steve Graham's] collection, but
this might restore the decency to "conventional" languages.
Also it shows how a language like J can serve as a great
prototyping tool.
#include <stdio.h>
#include <string.h>
void main(void)
{ int i, j, k, n=0; wchar_t p[1000], v[]=L"vierneun", s[9];
for (i=32;i<=99;i++) for (j=32;j<=99;j++) {
swprintf(s,L"%04d%04d",i*i,j*j);
for (k=0;k<8;k++) if (wcschr(s,s[k])-s != wcschr(v,v[k])-v) break;
if (k==8) { p[n++] = i*i; p[n++] = j*j; } }
for (i=0;i<n;i+=2) if (wcschr(p,p[i]) == wcsrchr(p,p[i])
&& wcschr(p,p[i+1]) == wcsrchr(p,p[i+1])) break;
printf("%04d%04d\n",p[i],p[i+1]);
}
"John D. Baker" <baker***@***.net> wrote:
> I've been following this thread with interest. It's
> always illuminating to see how different people
> and different tools come up with very different
> solutions.
>
> Looking over the compilation at:
>
> http://members.home.net/js.graham/vierneun.html
>
> It struck me that no "conventional" C, C++, VB, Java, COBOL
> solutions have been been posted. This puzzle illustrates why
> oddball programming languages persist despite a relentless
> and oppressive effort by the software industry to
> generate standard commodity programmers. In many cases, like
> this one, they are more productive, creative and
> fun!
>
> --
> John D. Baker
> bak...@kos.net
-[cut]--------------------------------------------------
In article <97lnps$ppc$1...@news.netmar.com>,
Steve Graham
Glad you enjoyed it. Thanks for the submission; I've added it to
http://members.home.net/js.graham/vierneun.html
Steve
===
"apinkus" <api...@xs4all.nl> wrote in message
news:3AAC189A...@xs4all.nl...
Jeffrey A. Wormsley
in... Certaily isn't 5 lines like the K solution, but then I can't read
the K solution ;^).
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
Function Match(I,J : Integer): Boolean;
Procedure FindMatches;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
Function TForm1.Match(I,J : Integer): Boolean;
Var S : String;
K, L : Byte;
Begin
Result := False; // Assume no match
S := IntToStr(Sqr(I)) + IntToStr(Sqr(J)); // Build string
If (S[3] <> S[6]) or (S[5] <> S[8]) then // Check the E's and N's
Exit; // Exit if not matched
S := S[1] + S[2] + S[3] + S[4] + S[5] + S[7]; // Remove dup E's and N's
For K := 1 to Length(S) - 1 Do // Scan for dups
For L := K + 1 to Length(S) Do
If S[K] = S[L] then // If dup found
Exit; // Exit
Result := True; // Good match if this far
End;
Procedure TForm1.FindMatches;
Var I, J, A, B : Byte;
Begin
For I := 34 to 89 do
Begin
A := I div 10; B := I mod 10; // Get digits
If A <> B then // Can't work if equal
Begin
J := A + (B * 10); // Transpose digits
If Match(I,J) then // Check for match
Memo1.Lines.Add( 'VIER = ' + IntToStr(Sqr(I)) +
' NEUN = ' + IntToStr(Sqr(J)) +
' (' + IntToStr(I) + ',' + IntToStr(J) + ')');
End;
End;
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
FindMatches;
end;
end.
Jeff.
David Combs
>I picked up the subject from the J Forum. Follows a quote
>from my message there:
>
Please, an ignorant qustion from a mostly-lurker here
on comp.lang.lisp:
(1) What is "j"?
(2) What, where, etc, is the "J Forum"?
Thanks,
David
David Ness
The short answer is "J is the language Iverson developed after he did APL".
Try http://jsoftware.com for more information.
Jim Lucas
>
> Please, an ignorant qustion from a mostly-lurker here
> on comp.lang.lisp:
>
> (1) What is "j"?
>
> (2) What, where, etc, is the "J Forum"?
J is, depending on your point of view, a descendant or dialect of APL. I'm of
the latter persuasion.
Aside from the fact that J uses an all-ASCII character set, the differences
between J and the commercial dialects of APL is no greater (in my opinion) than
the differences among those dialects. However, those differences (even among
the commercial dialects) are not inconsequential.
I recommend that you check out the website www.jsoftware.com. The J Forum is a
mailing list, rather than a newsgroup, for those interested in J. You can
learn more about that on the website. You can also download J for free, if
you're interested.
How much do you know about APL? If it's not much, but you're interested in
learning more, you might be interested in other implementations that you can
try for free, depending on your operating system. Just ask, and this entire
newsgroup will help you with information and advice.
/Jim Lucas
Skip Cave
To get some insight into the rationale that brought Ken Iverson to create
the J language dialect of APL, take a look at the Iverson and McIntyre
papers on my web site at: http://home1.gte.net/res057qw/APL_J/
These papers describe the development of APL and the transition to J, that
was driven by Ken's pursuit of language notation perfection.
Skip Cave
Mikhail Gambarian
easily understood and fairly short.
I cannot understand prolog decition at all. Of course it is my fault
also.
William Tanksley
>I looked on decitions in different languages - python looked best - most
>easily understood and fairly short.
>I cannot understand prolog decition at all. Of course it is my fault
>also.
The Prolog definition is without doubt the most straightforward -- but you
have to know a little bit about Prolog to understand it. Prolog is a
logical programming language -- you state the logical constraints, and
Prolog generates code which meets those constraints.
Look at the code, and notice how everything it says is simply a
restatement of the original problem description. There's hardly room for
a bug (said with a wry smile).
I believe that a good programmer should take time every once in a while to
learn a really different language, different from all the others you know.
Prolog is a good candidate.
-Billy
--
-William "Billy" Tanksley