Keskustelu: Koodit: 8th: permutaatiot

: a:swap  \ a n n -- a
  2dup 2 a:close 3rev 2 a:close -rot a:@
  _swap ( rot drop a:! ) a:2each 2drop ;

private

: generate  \ a n --
  a:new ( 0 a:push ) 2 pick times -rot
  over 4 pick w:exec
  0
  repeat
    dup 2 pick n:< if
      3 pick over a:_@ over n:< if
        dup 2 n:mod 0 n:= if
          2 pick 0 2 pick a:swap drop
        else
          2 pick 4 pick 2 pick a:_@ 2 pick a:swap drop
        then
        2 pick 5 pick w:exec
        3 pick over a:@ n:1+ 2 pick swap a:! drop
        drop 0
      else
        3 pick over 0 a:! drop
        n:1+
      then
    else
      break
    then
  again 2drop 2drop drop ;

public

\ Note: callback word receives array reference
: a:permutations  \ a w --
  swap a:len #p:generate ;

: s:translate  \ s1 s2 s3 -- s
  3 a:close ( null s:/ ) a:map a:open m:zip swap dup m:@? nip "" a:join ;


\ Now, try solving alphametics...
\ It might be a good idea to test there are no more than 10 unique alphabets in alphametics puzzle.
"SEND MORE + MONEY =" constant alphametics
alphametics /[A-Z]/ r:/ ' s:cmp a:sort ' s:= a:uniq "" a:join s:len constant num-of-unique-chars constant unique-chars

: any-leading-zeros?
  /\b[0]/ r:match nip ;

: app:main
  "0123456789" null s:/
  ( 0 num-of-unique-chars a:slice "" a:join
    alphametics unique-chars rot s:translate dup any-leading-zeros? not if
      dup eval if
        . cr break
      else
        drop
      then
    else
      drop
    then ) a:permutations ;