Paste: Trumpet players

! Copyright (C) 2010 Marek Kubica.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators assocs io random ;
IN: trumpet

SINGLETONS: left right ;

<PRIVATE

: subtail ( seq n -- seq ) short tail ;

: subtail* ( seq n -- seq ) short tail* ;

: unclip-nlast ( seq n -- seq seq ) 2dup subtail* [ subtail ] dip ;

: suffix-last ( seq elt -- seq seq ) swap unclip-last pick suffix rot drop ;

PRIVATE>

: apply-rules ( seq -- seq ? ) {
  { [ dup 2 unclip-nlast { right left } = ] [ nip { left right } append t ] }
  [ drop f ]
} cond ;

: process-element ( seq elt -- seq ) suffix-last apply-rules
  [ suffix { } suffix ] [ suffix ] if ;

: clean-step ( seq -- seq ) { { } } [ process-element ] reduce concat ;

: step ( seq -- seq ) dup first swap clean-step rest swap prefix ;

: lr>string ( seq -- string ) [ H{ { left "<" } { right ">" } } at ] map
  concat ;

: in-order? ( seq -- ? ) dup [ [ left = ] all? ] [ [ right = ] all? ] bi* or ;

: while-unordered-and-changing ( seq -- )
  dup
  [ 2dup = [ f ] [ swap drop dup t ] if
    [ dup in-order? not ]
    and ]
  [ dup lr>string print flush step ] do while
  2drop ;

: main ( -- )
  10 iota [ drop { left right } random ] map
  while-unordered-and-changing ;

main

Annotation: Improved version

! Copyright (C) 2010 Marek Kubica.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators assocs io random ;
IN: trumpet

SINGLETONS: left right ;

<PRIVATE

: subtail ( seq n -- seq ) short tail ;

: subtail* ( seq n -- seq ) short tail* ;

: unclip-nlast ( seq n -- seq seq ) [ subtail ] [ subtail* ] 2bi ;

: suffix-last ( seq elt -- seq seq ) swap unclip-last pick suffix rot drop ;

PRIVATE>

: apply-rules ( seq -- seq ? ) {
  { [ dup 2 unclip-nlast { right left } = ] [ nip { left right } append t ] }
  [ drop f ]
} cond ;

: process-element ( seq elt -- seq ) suffix-last apply-rules
  [ suffix { } suffix ] [ suffix ] if ;

: clean-step ( seq -- seq ) { { } } [ process-element ] reduce concat ;

: step ( seq -- seq ) dup first swap clean-step rest swap prefix ;

: lr>string ( seq -- string ) [ H{ { left "<" } { right ">" } } at ] map
  concat ;

: in-order? ( seq -- ? ) dup [ [ left = ] all? ] [ [ right = ] all? ] bi* or ;

: while-unordered-and-changing ( seq -- )
  dup
  [ 2dup = [ f ] [ swap drop dup t ] if
    [ dup in-order? not ]
    and ]
  [ dup lr>string print flush step ] do while
  2drop ;

: main ( -- )
  10 iota [ drop { left right } random ] map
  while-unordered-and-changing ;

main

Annotation: After Blei's comments

! Copyright (C) 2010 Marek Kubica.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators assocs io random ;
IN: trumpet

SINGLETONS: left right ;

<PRIVATE

: subtail ( seq n -- tail-seq ) short tail ;

: subtail* ( seq n -- tail-seq ) short tail* ;

: unclip-nlast ( seq n -- head-seq tail-seq ) [ subtail ] [ subtail* ] 2bi ;

: suffix-last ( seq elt -- unclipped-seq suffixed-seq ) [ unclip-last ] dip suffix ;

PRIVATE>

: apply-rules ( seq -- seq ? ) {
  { [ dup 2 unclip-nlast { right left } = ] [ nip { left right } append t ] }
  [ drop f ]
} cond ;

: process-element ( seq elt -- seq ) suffix-last apply-rules
  [ suffix { } suffix ] [ suffix ] if ;

: clean-step ( seq -- seq ) { { } } [ process-element ] reduce concat ;

: step ( seq -- seq ) [ clean-step rest ] [ first ] bi prefix ;

: lr>string ( seq -- string ) [ { { left [ CHAR: < ] } { right [ CHAR: > ] } } case ] "" map-at ;

: in-order? ( seq -- ? ) [ [ left = ] all? ] [ [ right = ] all? ] bi or ;

: while-unordered-and-changing ( seq -- )
  dup
  [ 2dup = [ f ] [ swap drop dup t ] if
    [ dup in-order? not ]
    and ]
  [ dup lr>string print flush step ] do while
  2drop ;

: main ( -- )
  10 [ drop { left right } random ] replicate
  while-unordered-and-changing ;

main

New Annotation