\ vn-2.f VIER NEUN in Forth - Leo Wong 11 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 1 : ,cpattern ( a u -- ) over c@ >r begin 1 /string dup while over c@ r@ = c, repeat 2drop r> drop ; : ,pattern ( a u -- ) dup , begin dup while 2dup ,cpattern 1 /string repeat 2drop ; : pattern= ( a u pattern -- ? ) over over @ - if 2drop drop false exit then cell+ >r begin dup while 2dup over c@ >r begin 1 /string dup while over c@ r> tuck = r> count swap >r 0<> - if r> 2drop 2drop 2drop false exit then >r repeat 2drop r> drop 1 /string repeat 2drop r> drop true ; : pattern create ( a u -- ) ,pattern does> ( a u -- ? ) pattern= ; s" vier" pattern vier s" neun" pattern neun s" vierneun" pattern pair : 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 : square ( n -- n*n ) dup * ; : digits ( n -- a ) s>d <# #s #> ; : c++ ( a -- ) dup c@ 1+ swap c! ; : add-square ( a u a u 0 -- ) \ up count, zero tally, put square drop over 1 chars - c++ >square 0 over tally c! swap cmove ; : viers&neuns ( -- ) \ always follow by tallying pairs 0 ['] viers >body c! 0 ['] neuns >body c! \ in case of reuse 100 32 do i square digits 2dup vier if viers add-square else 2dup neun if neuns add-square else 2drop then then loop ; : together ( neun vier -- pad 8 ) pad 4 cmove pad 4 chars + 4 cmove pad 8 ; : tally++ ( square -- ) tally c++ ; : tally-pairs ( -- ) \ use right after vier&neuns neuns ?do dup viers ?do 2dup together 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 together 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