Factorial base numbers indexing permutations of a collection: Difference between revisions

=={{header|Factor}}==

<lang factor>USING: assocs io kernel literals math math.factorials

math.parser math.ranges prettyprint qw random sequences

splitting ;

RENAME: factoradic math.combinatorics.private => _factoradic

RENAME: rotate sequences.extras => _rotate

IN: rosetta-code.factorial-permutations

CONSTANT: shoe $[

qw{ A K Q J 10 9 8 7 6 5 4 3 2 } qw{ ♠ ♥ ♦ ♣ }

[ append ] cartesian-map flip concat

]

! Factor can already make factoradic numbers, but they always

! have a least-significant digit of 0 to remove.

: factoradic ( n -- seq )

_factoradic dup [ drop but-last ] unless-empty ;

! Convert "3.1.2.0" to { 3 1 2 0 }, for example.

: string>factoradic ( str -- seq )

"." split [ string>number ] map ;

! Rotate a subsequence.

! E.g. 0 2 { 3 1 2 0 } (rotate) -> { 2 3 1 0 }.

: (rotate) ( from to seq -- newseq )

[ 1 + ] dip [ snip ] [ subseq ] 3bi -1 _rotate glue ;

! Only rotate a subsequence if from does not equal to.

: rotate ( from to seq -- newseq )

2over = [ 2nip ] [ (rotate) ] if ;

! The pseudocode from the task description

: fpermute ( factoradic -- permutation )

dup length 1 + <iota> swap <enumerated>

[ over + rot rotate ] assoc-each ;

! Use a factoradic number to index permutations of a collection.

: findex ( factoradic seq -- permutation )

[ fpermute ] [ nths concat ] bi* ;

: .f ( seq -- ) [ "." write ] [ pprint ] interleave ; ! Print a factoradic number

: .p ( seq -- ) [ pprint ] each nl ; ! Print a permutation

: show-table ( -- )

"Generate table" print 24

[ factoradic 3 0 pad-head dup .f fpermute " -> " write .p ]

each-integer nl ;

: show-shuffles ( -- )

"Generate given task shuffles" print

"Original deck:" print shoe concat print nl

"39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0"

"51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1"

[

dup

[ print ] [ string>factoradic shoe findex print nl ] bi*

] bi@ ;

: show-random-shuffle ( -- )

"Random shuffle:" print

51 52 [ n! ] bi@ [a,b] random factoradic shoe findex print ;

: main ( -- ) show-table show-shuffles show-random-shuffle ;

MAIN: main</lang>

{{out}}

<pre>

Generate table

0.0.0 -> 0123

0.0.1 -> 0132

0.1.0 -> 0213

0.1.1 -> 0231

0.2.0 -> 0312

0.2.1 -> 0321

1.0.0 -> 1023

1.0.1 -> 1032

1.1.0 -> 1203

1.1.1 -> 1230

1.2.0 -> 1302

1.2.1 -> 1320

2.0.0 -> 2013

2.0.1 -> 2031

2.1.0 -> 2103

2.1.1 -> 2130

2.2.0 -> 2301

2.2.1 -> 2310

3.0.0 -> 3012

3.0.1 -> 3021

3.1.0 -> 3102

3.1.1 -> 3120

3.2.0 -> 3201

3.2.1 -> 3210

Generate given task shuffles

Original deck:

A♠K♠Q♠J♠10♠9♠8♠7♠6♠5♠4♠3♠2♠A♥K♥Q♥J♥10♥9♥8♥7♥6♥5♥4♥3♥2♥A♦K♦Q♦J♦10♦9♦8♦7♦6♦5♦4♦3♦2♦A♣K♣Q♣J♣10♣9♣8♣7♣6♣5♣4♣3♣2♣

39.49.7.47.29.30.2.12.10.3.29.37.33.17.12.31.29.34.17.25.2.4.25.4.1.14.20.6.21.18.1.1.1.4.0.5.15.12.4.3.10.10.9.1.6.5.5.3.0.0.0

A♣3♣7♠4♣10♦8♦Q♠K♥2♠10♠4♦7♣J♣5♥10♥10♣K♣2♣3♥5♦J♠6♠Q♣5♠K♠A♦3♦Q♥8♣6♦9♠8♠4♠9♥A♠6♥5♣2♦7♥8♥9♣6♣7♦A♥J♦Q♦9♦2♥3♠J♥4♥K♦

51.48.16.22.3.0.19.34.29.1.36.30.12.32.12.29.30.26.14.21.8.12.1.3.10.4.7.17.6.21.8.12.15.15.13.15.7.3.12.11.9.5.5.6.6.3.4.0.3.2.1

2♣5♣J♥4♥J♠A♠5♥A♣6♦Q♠9♣3♦Q♥J♣10♥K♣10♣5♦7♥10♦3♠8♥10♠7♠6♥5♠K♥4♦A♥4♣2♥9♦Q♣8♣7♦6♣3♥6♠7♣2♦J♦9♥A♦Q♦8♦4♠K♦K♠3♣2♠8♠9♠

Random shuffle:

5♠K♣K♠4♣8♥7♠Q♥J♦3♠A♦3♣8♣6♥A♥3♥A♣10♥9♠10♣5♣J♣J♠J♥2♣K♥Q♦Q♣7♣6♦7♥2♥5♥2♠10♦2♦A♠4♦8♠4♠7♦10♠6♣9♣5♦4♥8♦9♦3♦6♠K♦9♥Q♠

</pre>