\ vn-1.f VIER NEUN in Forth - Leo Wong 9 March 2001 + \ 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. \ See also solution 2 : 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 : vier? ( a -- ? ) \ VIER if V<>I<>E<>R 3 0 do count over 3 i - cut if drop false leave then loop ; : neun? ( a -- ? ) \ NEUN if N=N and N<>E<>U count over 3 cut 1 = swap count swap c@ <> and ; : 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! \ in case of reuse 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 \ in case not just after neuns&viers 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 Wong hello@albany.net