「レッスンは何曜日？」をFactorで(横へな21)

USING: kernel sequences sequences.deep math math.order math.parser
       arrays splitting assocs sorting ;
IN: 21lesson

! 希望リストから配属候補を求める
: wish-list>candidate ( wish-list -- candidate )
    { 1 2 3 4 5 } swap [
        [ second first over = ] filter
        [ first ] map swap drop
    ] curry map ;

! 先頭4つだけにする
: only4 ( seq -- seq ) dup length 4 min head ;

! 配属リストに候補を追加する
: append-candidate-to-assigned ( assigned candidate -- assigned' )
    [ append only4 ] 2map ;

! 配属された社員を希望リストから削除する
: delete-assigned-from-wish-list ( assigned wish-list -- wish-list' )
    swap flatten [ swap first swap index not ] curry filter ;

! 希望リストの順位を繰り上げる
: shift-wish-list ( wish-list -- wish-list' )
    [ dup first swap second rest { } 2sequence ] map ;

! 最も高い希望を配属する
: assign-first-wish ( assigned wish-list -- assigned' wish-list' )
    [ wish-list>candidate append-candidate-to-assigned ] keep
    dupd delete-assigned-from-wish-list
    shift-wish-list ;

! 配属する
: assign-wish ( wish-list -- assigned )
    { { 0 { 0 0 0 0 0 } } } append
    5 { } <array> swap
    5 [ assign-first-wish ] times
    drop ;

! 入力文字列を希望リストに変換する
: >wish-list ( str -- wish-list )
    "|" split [ "_" split [ first string>number ]
        [ second [ digit> ] { } map-as ] bi { } 2sequence ] map ;

! 配属リストを文字列に変換する
: assigned>string ( assigned -- str )
    { 1 2 3 4 5 } swap zip
    [ second length 0 = not ] filter
    [
        dup first number>string "_" append
        swap second natural-sort
        [ number>string ] map ":" join append
    ] map "|" join ;

! 解く
: solve ( str -- str ) >wish-list assign-wish assigned>string ;