Paste: fogcreek

! Copyright (C) 2016 Alexander Ilin.
! https://www.reddit.com/r/dailyprogrammer/comments/442mec/20160203_challenge_252_intermediate_a_challenge/
USING: kernel arrays sets sequences assocs namespaces locals
    math math.order math.vectors math.statistics
    binary-search sorting splitting ;
IN: fogcreek

SYMBOL: output

CONSTANT: input0 "abcbba"
CONSTANT: input1 "ttvmswxjzdgzqxotby_lslonwqaipchgqdo_yz_fqdagixyrobdjtnl_jqzpptzfcdcjjcpjjnnvopmh"
CONSTANT: input2  "hpevfwqjmjryhemuqjoiatpjmddxdjwzskdcfgdtbmkbcxrnmjuoyddnqwluimjwvguxehszxzvbmufqlrepncxxbrrzxnzmkoyhrjcstvfazyhrhgssximjdfcmdjusylfkwbedyrsxovrmvjzaljfjmywpfnjgisoqbdyspgzlcmdjmhbpxhzvvhckidzuwzkauffsujmcrhvgeqvasjakgtzlxkthjqwxypmsovjbfshrrxtdvkmbyhejoeydnrdowuwhgmbvxmpixyttglsjgmcoqbberssfjraaqfrkmebsozsjfnubhktbbai_vxbifbofyednnutmxtisvfsktbqfijfzdjoqybuohtztysqelaqyixyaiolbgwylwfisfwubivuoablxsmrqggedwyiqvseevwbcxcfjttdbweedcjgnsorizflsjtmltcoaynsrsupavqwcyzhgiplwkohlhrainazaacvuqblpbzimgoxirejbshnbmdtgsbvlhpnugggencjaczqqiwixrwiyobmlkbwdlwcioqmjhoacdvcqdypxeichmgywocbcafumthdqrbjnpgnnmaasxiaxxfymcyiuqduztqneodstbcnjpeebgxgosoydvpzlqjuroebbehafsemanwprhwkircuhlgcftqsjdusrqetbthxclfokpdlspxzuvhxpbeqqbfpqffsgyilqltfxrmtimcugytazkerhcfnirtavcnmfdyictlncwttkmxyfhgejygfefqrjknuqsfldmjmwjdfqsicfrzbfazchdgznekwmhridelcejnkmcgmpgtihbwmplrtrrefoyhyzxpjjlkabbbgspeokzhpjxsvpfjmdsoripvfrgyzxodoeirwwdaofdmwqrqyvdijlfqyzfspdoyrhewxbpufdqcpqdolkmrnvedixzpfdakggkslxcrjbrmnynviihbkzaqqffkkcgwjbettexhlwlasdfjnslwsmnclhafvebxxfdozsjtdvobikrrsuysujwliobagobxmlyxjeltwzwxpyrnkdxfemotfncyriaycyfemygjmpboocgtsvttqntegvleynwgpjhyyysbltoxljsascsngbgfqmpzgpejzlmdkjzzlfxvagyrasmpzqntgqsvyqjugkhbrbkiqewlyftvsq_______znp_____xkwt______wef______tz______kfc_______ha_______pn__lmg__iakrbtiyfi__uojrxvx__tps__fp__pfpndbi__ggpalde__wmd__kn__ifiadob__hdljdbd__zl__whlwiltbcmt__haagmjg__dwx__oh__utnzudq__xstxxyc__vly__mr__viilzav__swosyvc__i__hnaqxyevjykc__wyfoyir__ewp__ij__mrdavxl__tcdtxqy__fnr__cf__mrkepwj__djhrsau____lhefqxgmuzdgf______tjg__fip__mi__b____xc__vjvhpqy______vff_____wuup_____kqct___htiggvvpetyvco__pqbrlox__ayj__af__dnn__kx__mlitytx____jauna__kncmiym__dlwushk____gjptzccgcnntt__hfqyxzi__eqn__vz__hlh__we__dtfkfvf__g__litm__zeqjtdl__bkdapxs__o__oxeouwerbfjr__ipcqmop__kec__ip__icc__ci__vpxxueu__eq__sau__nhheydy__efqkdgq__us__pzlndhkhdmk__cmfvzwcb_____xdka______trj______yj__xpi__he_______nb_______by__rrn__tvxvigjfpseyjjbrrtsfnmbrokdqtfzhhdtbhtvpiyshmvcqaypfxcvbgvbvwrkanjfcsjnanmktkwimnvynukcmgtqmovkrdmfuduqvbqydagsttictcnsrhfrpoebcehdzhjamykqpjtktufcvokljjijjsrivyhxtgwojgoujyhmekzsoczwlqnruwcuhudgfaijzrkewzgjvorsmabpcdmurctwjrddcnkmfvabjwlbqssihdybgfqchqdvjcsdllrlwmyikuvthguzfbgocaeqktvbcapzdcfjphqnhundtljqjeyfrkjspfvghqddxwxidtjjkctrkfcjmdpqyvavqbntpmkkuswfgbgalrysjfnzezjjscahoodjjelavydefzjmhsqfufsexlvvzziymsyqrcvhsrxjnysioswvjlqdbnwgyjlanmhzkbygkptycdoifsibytbrixggjeiepaybzxhvfsyayeptgpxbhhfkkpromhjykfxnujorlzcmkcmvvgmveyfkgiwgosznfpmbhixsakxfkuxhwcgularehpaguquulrjllxmkfzgnchrxzcfdklytpfnezergkwkhgalqlvdhkdgulgfaxtybqttcjtlgmfwaymaxlwaspyrboibwkzzbtgigyswbtpwxgphcmkfpmvbfjimnxctinqssshofhlvlpqcwiuacjyxyqmvaibezofvatyhpqvjubgcwqeoytloypjphoxeimumuvswxkgamodoxiciwmgxvsenkgdhttzlenjbszrksopicjcjnvsosrapkfilwsaoptdavlfglioqpwoqskbgikksnnuzvmxyrtrbjouvgokxgbnwxnivtykvhjkaydskzoowbhjrlojgeecdoggqqtomcdgrjzmlkhubyaewwtrlyutsptdrrigopueicoganyasrjeaiivzairulklovyrpckwpowprxtvhaeivpudfchxbwvtosmivpcsesbzpsynxitlisuifuehceonjeydljzuzpsgjllcywoxbblitscquxiykcjxhsgkbhfhfrshsrpyrcaetahuwbeybvlvkthxydkapxlfikdwudjkmjjsazajxpuikiqwsifhldfovqoycwmtlmcaycirhcehxnpfadrgyaogpcmomcgtmacnvbwfnimaqqvxijcbpmckwimloiinindfuakqjmpyjisxnbybtywhymnkdoyiphijzelmrazplgfcmcsjiovxqdxmuqulzklgx"

! { 1 8 9 } -- { 7 1 0 }
: pos>lengths ( positions -- lengths )
    differences 0 suffix ;

! { 1 8 9 15 80 } -- { 8 7 71 }
: pos>lengths-2 ( positions -- lengths )
    [ 2 tail-slice ] keep v- ;

! Create a list of { pos length }, which represents distance from a char to its next appearance in the input. Only the shortest possible length for each pos is included, which is good for the failure lookups (has-no-inner-pair?).
: char-pos>short-pos-lengths ( char-pos -- short-pos-lengths )
    [ nip dup pos>lengths 2array flip ] V{ } assoc>map
    concat natural-sort ;

: char-pos>pos-lengths ( char-pos short-pos-lengths -- pos-lengths )
    swap [ nip dup pos>lengths-2 2array flip ] V{ } assoc>map concat
    append natural-sort ;

: pos-lengths>descending-lengths ( pos-lengths -- seq )
    [ second 0 > ] filter
    [ reverse ] map
    [ [ first ] compare invert-comparison ] sort ;
! This sorts the list by descending length order, but for items with matching length the positions remain is ascending order, which what we want: if there are several lengths, we must check the leftmost first. Now we can use find on the sequence to find an item that's good for the result. That would be the first one to NOT contain another pair in it.

: search-index ( item seq -- index )
    [ <=> ] with search drop ; inline

:: has-no-inner-pair? ( length-pos short-pos-lengths -- ? )
    length-pos reverse dup short-pos-lengths search-index
    ! stack: item index
    1 + swap sum
    ! stack: start-index pair-end-pos
    short-pos-lengths swap
    ! stack: start-index short-pos-lengths pair-end-pos
    [ swap sum > ] curry find-from drop not ;

: append-output ( char -- )
    output get swap suffix output set ;

! Decrement by 1 all items in seq that are greater than value. Modifies seq.
: dec-all-greater! ( seq value -- seq )
    [ dupd > [ 1 - ] when ] curry map! ;

! Modifies char-pos, output.
:: delete-from-char-pos ( pos1 pos2 input-length char-pos -- )
    char-pos [ nip pos1 swap member? ] assoc-find drop
    pos1 swap remove!
    pos2 swap remove!
    dup empty? [ drop dup char-pos delete-at dup append-output ]
    [ input-length suffix! drop ] if
    drop
    ! Now decrement all positions after pos1 and pos2.
    char-pos [ nip pos1 dec-all-greater! pos2 dec-all-greater! drop ] assoc-each ;

:: extract-single-chars ( char-pos -- str )
    char-pos values [ length 1 = ] filter natural-sort
    char-pos [ value-at ] curry map
    dup char-pos [ delete-at ] curry each
    "" swap [ suffix ] each ;

: calculate-lengths ( char-pos -- pos-lengths short-pos-lengths )
    dup char-pos>short-pos-lengths
    [ char-pos>pos-lengths ] keep
    [ second 0 > ] filter ;

:: solve-char-pos ( input-length! char-pos -- str )
    ! Main loop modifies char-pos until it's empty, output is a side-effect.
    char-pos extract-single-chars output set
    [ char-pos assoc-empty? ]
    [
        char-pos calculate-lengths
        [ pos-lengths>descending-lengths ] dip
        [ has-no-inner-pair? ] curry find nip
        first2 [ + ] keep input-length char-pos delete-from-char-pos
        input-length 1 - input-length!
    ] until
    output get ;

: solve-input ( input -- output )
    dup length swap
    [ ] collect-index-by
    solve-char-pos "_" split1 drop ;

: solve0 ( -- output )
    input0 solve-input ;

: solve1 ( -- output )
    input1 solve-input ;

: solve2 ( -- output )
    input2 solve-input ;