1 ! Copyright (C) 2017 John Benediktsson, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: ascii assocs checksums checksums.sha combinators
4 kernel math math.functions math.parser ranges
5 math.statistics sequences sets sorting splitting strings uuid ;
8 : find-escapes ( str -- set )
9 [ HS{ } clone 0 0 ] dip
12 { CHAR: ] [ 1 + dup 2 = [ drop over adjoin 0 1 ] when ] }
13 { CHAR: = [ dup 1 = [ [ 1 + ] dip ] when ] }
16 ] each 0 > [ over adjoin ] [ drop ] if ;
18 : find-number-escapes ( str -- set )
19 [ HS{ } clone SBUF" " clone 0 ] dip
24 drop dup >string pick adjoin
28 { [ dup digit? ] [ [ dup 1 = ] dip '[ [ _ over push ] dip ] [ ] if ] }
29 [ 2drop 0 over set-length 0 ]
31 ] each 0 > [ >string over adjoin ] [ drop ] if ;
33 : lowest-missing-number ( string-set -- min )
35 [ length ] histogram-by
36 dup keys length [0..b]
37 [ [ of ] keep over [ 10^ < ] [ nip ] if ] with find nip
38 [ '[ length _ = ] filter natural-sort ] keep ! remove natural-sort here
42 [ swap ?nth dup [ string>number ] when ] keep = not
43 ] with find nip number>string
45 ] keep CHAR: 0 pad-head ;
47 : lowest-missing ( set -- min )
48 members dup [ = not ] find-index
49 [ nip ] [ drop length ] if ;
51 : surround-by-brackets ( str delim -- str' )
52 [ "[" 1surround ] [ "]" 1surround ] bi surround ;
54 : surround-by-equals-brackets ( str n -- str' )
55 CHAR: = <repetition> surround-by-brackets ;
57 : escape-string ( str -- str' )
58 dup find-escapes lowest-missing surround-by-equals-brackets ;
60 : escape-strings ( strs -- str )
61 [ escape-string ] map concat escape-string ;
63 : number-escape-string ( str -- str' )
64 dup find-number-escapes lowest-missing-number surround-by-brackets ;
66 : number-escape-strings ( strs -- str )
67 [ number-escape-string ] map concat number-escape-string ;
69 : tag-payload ( str tag -- str' )
70 [ escape-string ] dip prepend ;
72 : escape-simplest ( str -- str' )
74 ! { [ dup { CHAR: ' CHAR: \r CHAR: \n CHAR: \s } values-of sum 0 = ] [ drop "'" prepend ] }
75 { [ dup CHAR: " of not ] [ drop "\"" "\"" surround ] }
76 [ drop escape-string ]
79 : uuid1-escape-string ( str -- str' ) uuid1 surround-by-brackets ;
80 : uuid4-escape-string ( str -- str' ) uuid4 surround-by-brackets ;
82 : sha1-escape-string ( str -- str' )
83 [ ] [ sha1 checksum-bytes bytes>hex-string ] bi surround-by-brackets ;
85 : sha256-escape-string ( str -- str' )
86 [ ] [ sha-256 checksum-bytes bytes>hex-string ] bi surround-by-brackets ;
88 GENERIC: sha1-escape-strings ( obj -- strs )
90 M: sequence sha1-escape-strings ( seq -- strs )
91 [ sha1-escape-string ] { } map-as ;
93 M: string sha1-escape-strings ( str -- strs )
94 split-lines sha1-escape-strings ;