1 ! Copyright (C) 2008 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs math kernel shuffle generalizations
4 words quotations arrays combinators sequences math.vectors
5 io.styles prettyprint vocabs sorting io generic
6 math.order locals.types locals.definitions ;
9 : badness ( word -- n )
68 : vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
70 GENERIC: noise ( obj -- pair )
72 M: word noise badness 1 2array ;
74 M: wrapper noise wrapped>> noise ;
76 M: let noise body>> noise ;
78 M: lambda noise body>> noise ;
80 M: object noise drop { 0 0 } ;
82 M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
84 M: array noise [ noise ] map vsum ;
86 : noise-factor ( x y -- z ) / 100 * >integer ;
88 : quot-noise-factor ( quot -- n )
89 ! For very short words, noise doesn't count so much
90 ! (so dup foo swap bar isn't penalized as badly).
92 { [ over 4 <= ] [ [ drop 0 ] dip ] }
93 { [ over 15 >= ] [ [ 2 * ] dip ] }
97 ! short words are easier to read
98 { [ dup 10 <= ] [ [ 2 / ] dip ] }
99 { [ dup 5 <= ] [ [ 3 / ] dip ] }
100 ! long words are penalized even more
101 { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }
102 { [ dup 20 >= ] [ [ 5/3 * ] dip ] }
103 { [ dup 15 >= ] [ [ 3/2 * ] dip ] }
105 } cond noise-factor ;
107 GENERIC: word-noise-factor ( word -- factor )
109 M: word word-noise-factor
110 def>> quot-noise-factor ;
112 M: lambda-word word-noise-factor
113 "lambda" word-prop quot-noise-factor ;
115 : flatten-generics ( words -- words' )
117 dup generic? [ "methods" word-prop values ] [ 1array ] if
120 : noisy-words ( -- alist )
121 all-words flatten-generics
122 [ word-noise-factor ] zip-with
125 : noise. ( alist -- )
126 standard-table-style [
128 [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
132 : vocab-noise-factor ( vocab -- factor )
133 vocab-words flatten-generics
134 [ word-noise-factor dup 20 < [ drop 0 ] when ] map
136 [ [ sum ] [ length 5 max ] bi /i ]
141 : noisy-vocabs ( -- alist )
142 loaded-vocab-names [ vocab-noise-factor ] zip-with
145 : noise-report ( -- )
147 noisy-words 80 head noise.
149 "NOISY VOCABS:" print
150 noisy-vocabs 80 head noise. ;