Paste: fast subpalindrome

USING: kernel io sequences accessors math strings ;
IN: subpalindrome

TUPLE: ps str len i plen pstr ;
: <ps> ( str -- ps ) dup length 1 0 "" ps boa ;

: palindrome? ( str -- ? ) dup reverse = ;
: ps-more? ( ps -- ? ) [ i>> ] [ len>> ] bi < ;

! recursive palindrome check
: ps-check ( len s from to -- len' s' from' to' )
    3dup nip [ length ] dip > [ over 0 >= ] dip and
    [   3dup [ over ] dip swap nth [ swap nth ] dip = 
        [ 1 + [ 1 - ] dip [ 2 + ] 3dip ps-check ] when
    ] when ;
: ps-check-init ( ps -- ps len s from to )
    dup [ str>> ] [ i>> ] bi [ 0 ] 2dip dup 1 + ;
: ps-longer? ( ps plen -- ps plen ? )
    [ dup plen>> ] dip swap over < ;

: ps-subpal ( ps from to -- ps' )
    pick str>> subseq dup length [ >>pstr ] dip >>plen ;

: ps-odd* ( ps plen -- ps' )
    [ dup i>> ] dip dup [ 1 - 2 / - dup ] dip + ps-subpal ;
: ps-odd ( ps -- ps' )
    ps-check-init [ 1 - ] dip ps-check 3drop 1 +
    ps-longer? [ ps-odd* ps-odd ] [ drop ] if ;

: ps-even* ( ps plen -- ps' )
    [ dup i>> ] dip dup [ 2 / - 1 + dup ] dip + ps-subpal ;
: ps-even ( ps -- ps' )
    ps-check-init ps-check 3drop
    ps-longer? [ ps-even* ps-even ] [ drop ] if ;

: find-lpal ( str -- lpal ) <ps>
        [ dup ps-more? ]
        [ ps-odd ps-even [ 1 + ] change-i ]
    while pstr>> ;

contents find-lpal print