-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs math kernel shuffle generalizations\r
-words quotations arrays combinators sequences math.vectors\r
-io.styles prettyprint vocabs sorting io generic\r
-math.statistics math.order locals.types\r
-locals.definitions ;\r
-IN: reports.noise\r
-\r
-: badness ( word -- n )\r
- H{\r
- { -nrot 5 }\r
- { -rot 3 }\r
- { bi@ 1 }\r
- { 2curry 1 }\r
- { 2drop 1 }\r
- { 2dup 1 }\r
- { 2keep 1 }\r
- { 2nip 2 }\r
- { 2over 4 }\r
- { 2swap 3 }\r
- { 3curry 2 }\r
- { 3drop 1 }\r
- { 3dup 2 }\r
- { 3keep 3 }\r
- { 4drop 2 }\r
- { 4dup 3 }\r
- { compose 1/2 }\r
- { curry 1/3 }\r
- { dip 1 }\r
- { 2dip 2 }\r
- { drop 1/3 }\r
- { dup 1/3 }\r
- { if 1/3 }\r
- { when 1/4 }\r
- { unless 1/4 }\r
- { when* 1/3 }\r
- { unless* 1/3 }\r
- { ?if 1/2 }\r
- { cond 1/2 }\r
- { case 1/2 }\r
- { keep 1 }\r
- { napply 2 }\r
- { ncurry 3 }\r
- { ndip 5 }\r
- { ndrop 2 }\r
- { ndup 3 }\r
- { nip 2 }\r
- { nkeep 5 }\r
- { npick 6 }\r
- { nrot 5 }\r
- { nwith 4 }\r
- { over 2 }\r
- { pick 4 }\r
- { rot 3 }\r
- { swap 1 }\r
- { swapd 3 }\r
- { with 1/2 }\r
-\r
- { bi 1/2 }\r
- { tri 1 }\r
- { bi* 1/2 }\r
- { tri* 1 }\r
-\r
- { cleave 2 }\r
- { spread 2 }\r
- } at 0 or ;\r
-\r
-: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;\r
-\r
-GENERIC: noise ( obj -- pair )\r
-\r
-M: word noise badness 1 2array ;\r
-\r
-M: wrapper noise wrapped>> noise ;\r
-\r
-M: let noise body>> noise ;\r
-\r
-M: lambda noise body>> noise ;\r
-\r
-M: object noise drop { 0 0 } ;\r
-\r
-M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;\r
-\r
-M: array noise [ noise ] map vsum ;\r
-\r
-: noise-factor ( x y -- z ) / 100 * >integer ;\r
-\r
-: quot-noise-factor ( quot -- n )\r
- #! For very short words, noise doesn't count so much\r
- #! (so dup foo swap bar isn't penalized as badly).\r
- noise first2 {\r
- { [ over 4 <= ] [ [ drop 0 ] dip ] }\r
- { [ over 15 >= ] [ [ 2 * ] dip ] }\r
- [ ]\r
- } cond\r
- {\r
- ! short words are easier to read\r
- { [ dup 10 <= ] [ [ 2 / ] dip ] }\r
- { [ dup 5 <= ] [ [ 3 / ] dip ] }\r
- ! long words are penalized even more\r
- { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }\r
- { [ dup 20 >= ] [ [ 5/3 * ] dip ] }\r
- { [ dup 15 >= ] [ [ 3/2 * ] dip ] }\r
- [ ]\r
- } cond noise-factor ;\r
-\r
-GENERIC: word-noise-factor ( word -- factor )\r
-\r
-M: word word-noise-factor\r
- def>> quot-noise-factor ;\r
-\r
-M: lambda-word word-noise-factor\r
- "lambda" word-prop quot-noise-factor ;\r
-\r
-: flatten-generics ( words -- words' )\r
- [\r
- dup generic? [ "methods" word-prop values ] [ 1array ] if\r
- ] map concat ;\r
-\r
-: noisy-words ( -- alist )\r
- all-words flatten-generics\r
- [ dup word-noise-factor ] { } map>assoc\r
- sort-values reverse ;\r
-\r
-: noise. ( alist -- )\r
- standard-table-style [\r
- [\r
- [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row\r
- ] assoc-each\r
- ] tabular-output ;\r
-\r
-: vocab-noise-factor ( vocab -- factor )\r
- vocab-words flatten-generics\r
- [ word-noise-factor dup 20 < [ drop 0 ] when ] map\r
- [ 0 ] [\r
- [ [ sum ] [ length 5 max ] bi /i ]\r
- [ supremum ]\r
- bi +\r
- ] if-empty ;\r
-\r
-: noisy-vocabs ( -- alist )\r
- loaded-vocab-names [ dup vocab-noise-factor ] { } map>assoc\r
- sort-values reverse ;\r
-\r
-: noise-report ( -- )\r
- "NOISY WORDS:" print\r
- noisy-words 80 head noise.\r
- nl\r
- "NOISY VOCABS:" print\r
- noisy-vocabs 80 head noise. ;\r
-\r
-MAIN: noise-report\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs math kernel shuffle generalizations
+words quotations arrays combinators sequences math.vectors
+io.styles prettyprint vocabs sorting io generic
+math.statistics math.order locals.types
+locals.definitions ;
+IN: reports.noise
+
+: badness ( word -- n )
+ H{
+ { -nrot 5 }
+ { -rot 3 }
+ { bi@ 1 }
+ { 2curry 1 }
+ { 2drop 1 }
+ { 2dup 1 }
+ { 2keep 1 }
+ { 2nip 2 }
+ { 2over 4 }
+ { 2swap 3 }
+ { 3curry 2 }
+ { 3drop 1 }
+ { 3dup 2 }
+ { 3keep 3 }
+ { 4drop 2 }
+ { 4dup 3 }
+ { compose 1/2 }
+ { curry 1/3 }
+ { dip 1 }
+ { 2dip 2 }
+ { drop 1/3 }
+ { dup 1/3 }
+ { if 1/3 }
+ { when 1/4 }
+ { unless 1/4 }
+ { when* 1/3 }
+ { unless* 1/3 }
+ { ?if 1/2 }
+ { cond 1/2 }
+ { case 1/2 }
+ { keep 1 }
+ { napply 2 }
+ { ncurry 3 }
+ { ndip 5 }
+ { ndrop 2 }
+ { ndup 3 }
+ { nip 2 }
+ { nkeep 5 }
+ { npick 6 }
+ { nrot 5 }
+ { nwith 4 }
+ { over 2 }
+ { pick 4 }
+ { rot 3 }
+ { swap 1 }
+ { swapd 3 }
+ { with 1/2 }
+
+ { bi 1/2 }
+ { tri 1 }
+ { bi* 1/2 }
+ { tri* 1 }
+
+ { cleave 2 }
+ { spread 2 }
+ } at 0 or ;
+
+: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
+
+GENERIC: noise ( obj -- pair )
+
+M: word noise badness 1 2array ;
+
+M: wrapper noise wrapped>> noise ;
+
+M: let noise body>> noise ;
+
+M: lambda noise body>> noise ;
+
+M: object noise drop { 0 0 } ;
+
+M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
+
+M: array noise [ noise ] map vsum ;
+
+: noise-factor ( x y -- z ) / 100 * >integer ;
+
+: quot-noise-factor ( quot -- n )
+ #! For very short words, noise doesn't count so much
+ #! (so dup foo swap bar isn't penalized as badly).
+ noise first2 {
+ { [ over 4 <= ] [ [ drop 0 ] dip ] }
+ { [ over 15 >= ] [ [ 2 * ] dip ] }
+ [ ]
+ } cond
+ {
+ ! short words are easier to read
+ { [ dup 10 <= ] [ [ 2 / ] dip ] }
+ { [ dup 5 <= ] [ [ 3 / ] dip ] }
+ ! long words are penalized even more
+ { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }
+ { [ dup 20 >= ] [ [ 5/3 * ] dip ] }
+ { [ dup 15 >= ] [ [ 3/2 * ] dip ] }
+ [ ]
+ } cond noise-factor ;
+
+GENERIC: word-noise-factor ( word -- factor )
+
+M: word word-noise-factor
+ def>> quot-noise-factor ;
+
+M: lambda-word word-noise-factor
+ "lambda" word-prop quot-noise-factor ;
+
+: flatten-generics ( words -- words' )
+ [
+ dup generic? [ "methods" word-prop values ] [ 1array ] if
+ ] map concat ;
+
+: noisy-words ( -- alist )
+ all-words flatten-generics
+ [ dup word-noise-factor ] { } map>assoc
+ sort-values reverse ;
+
+: noise. ( alist -- )
+ standard-table-style [
+ [
+ [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
+ ] assoc-each
+ ] tabular-output ;
+
+: vocab-noise-factor ( vocab -- factor )
+ vocab-words flatten-generics
+ [ word-noise-factor dup 20 < [ drop 0 ] when ] map
+ [ 0 ] [
+ [ [ sum ] [ length 5 max ] bi /i ]
+ [ supremum ]
+ bi +
+ ] if-empty ;
+
+: noisy-vocabs ( -- alist )
+ loaded-vocab-names [ dup vocab-noise-factor ] { } map>assoc
+ sort-values reverse ;
+
+: noise-report ( -- )
+ "NOISY WORDS:" print
+ noisy-words 80 head noise.
+ nl
+ "NOISY VOCABS:" print
+ noisy-vocabs 80 head noise. ;
+
+MAIN: noise-report
projects / factor.git / blobdiff