Paste: Trumpet players

Author:	Leonidas
Mode:	factor
Date:	Thu, 25 Feb 2010 11:25:11

Plain Text |

Delete Paste

! 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

Author:	Leonidas
Mode:	factor
Date:	Thu, 25 Feb 2010 21:40:17

Plain Text |

Delete Annotation

! 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

Author:	Leonidas
Mode:	factor
Date:	Thu, 25 Feb 2010 21:59:54

Plain Text |

Delete Annotation

! 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

Summary:
Author:
Mode:	PostgreSQLPowerCenter Parameter Fileactionscriptadaada95ans-forth94antantlrantlr4apacheconfapdlapplescriptaspaspect-jassembly-agcassembly-agsassembly-arm32assembly-m68kassembly-macro32assembly-mcs51assembly-parrotassembly-r2000assembly-x86avroawkbbatchbbjbcelbeanshellbibtexbinsource-agccc#c++cfscriptchillcilclipsclojurecmakecobolcoffeescriptcoldfusioncplex-lpcsscsvcvs-commitddartdjangodockerfiledotdoxygendrawj2ddsssleiffelembperlerlangfactorfhtmlforthfortranfortran90foxprofreemarkergcbasicgettextgherkingnuplotgogradlegroovygsphaskellhaxehexhl7v2hlslhtaccesshtmlhxmli4glicalendariconidlinforminiinno-setupinterlisiojamonjavajava module-infojavaccjavafxjavascriptjcljedit-actionsjflexjhtmljmkjsonjspkotlinlatexlexlilypondlispliterate-haskelllogslogtalklotosluam4macroschedulermailmakefilemaplemarkdownmavenmavscriptmetapostmlmodula3moinmqscmustache-templatemxmlmyghtymysqln3netrexxnqcnsis2objective-cobjectrexxoccamomnimarkopensipsoutlinepascalpatchperlphppikepl-sqlpl-sql9pl1plaintexplantumlpop11postscriptpovraypowerdynamopowershellprogressprologpropertiesprotobufpspptlpurepvwavepyrexpythonrakefilercprdrebolredcoderelax-ng-compactrenderman-ribrestrfcrhtmlroffrpm-specrtfrubyrustrviews#s+sassbtscalaschemesdl/prsgmlshellscriptshtmlsipsippslateslaxsmalltalksmartysmi-mibsql-loadersqrsquidconfstatasvn-commitswiftswigtcltemplate-toolkittextexinfotexttldtransact-sqltsptwikityposcripturluscriptvalavbscriptvelocityverilogvhdlvisualbasicvrml2wellknowntextxmlxqxslyabyamlzpt
Body:

Done