Paste: lots of supporting words
Author: | randy7 |
Mode: | factor |
Date: | Fri, 6 Mar 2009 22:13:34 |
Plain Text |
USING: prettyprint strings kernel arrays math sequences lil-utils
namespaces assocs generalizations fry ;
IN: seperate-text
SYMBOL: vik
: >vik
vik get swap suffix vik set ;
: (next-index)
[ 2dup ] dip start* ;
: (all-indices)
dup f = not [
(next-index) dup >vik
dup [ 1+ ] when (all-indices)
]
[ 3drop vik get ] if ; recursive
: all-indices
V{ } clone vik set
swap 0 (all-indices) sift >array ;
: find-all-firsts
all-indices ;
: find-all-seconds
[ nip length ] 2keep all-indices
[ + ] with map ;
: 1bi1@
[ curry ] curry bi@ bi ; inline
: 1bi2*
[ [ curry ] curry ] bi@ bi* bi ; inline
: (match-min) [ > ] curry filter dup empty? [ drop f ] [ first ] if ;
: close-match
[ swap [ (match-min) ] keep swap 2array ] curry map ;
: complement
{ f f } suffix
[ [ second ] map 0 prefix ] [ [ first ] map ] bi zip
[ { 0 0 } = not ] filter ;
: fix-complements
length '[ [ first2 dup f = [ drop _ ] when 2array ] map ] call ;
: extract-indices
[ first2 rot subseq ] with map ;
: (find-all-indices)
[ find-all-firsts ] [ find-all-seconds ] 1bi2* ;
: find-all
(find-all-indices) close-match ;
: (findings)
pick [ find-all ] dip swap ;
: extract-complements
(findings) complement over fix-complements extract-indices ;
: extract-all
(findings) extract-indices ;
: extract-one
(findings) dup empty? [ nip ] [ first 1array extract-indices ] if ;
: extract-both
(findings) [ ] [ complement ] bi
[ over ] dip swap fix-complements
[ extract-indices ] 1bi1@ ;
: strip-tags
"<" ">" extract-complements " " join ;
: (all-clean?)
any-overlap? not ;
: find-start-end-index
dup (find-all-indices) zip ;
SYMBOL: accum
: >accum accum set ;
: new-accum V{ } clone >accum ;
: accum> accum get ;
: (remove-overlaps)
dup empty? [ drop ] [
[ rest-slice ] [ 1 head first ] bi
accum> swap 2dup any-overlap?
[ 2drop ] [ suffix >accum ] if
(remove-overlaps)
] if ;
: remove-overlaps
new-accum (remove-overlaps) accum> ;
: make-slices
swap [ [ first2 ] dip <slice> ] curry map ;
: customized-slices
swap [ [ first2 2dup ] dip <slice> >string 3array ] curry map ;
New Annotation