extra/reports/noise/noise.factor

   1 ! Copyright (C) 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors assocs math kernel shuffle generalizations\r
   4 words quotations arrays combinators sequences math.vectors\r
   5 io.styles prettyprint vocabs sorting io generic\r
   6 math.statistics math.order locals.types\r
   7 locals.definitions ;\r
   8 IN: reports.noise\r
   9 \r
  10 : badness ( word -- n )\r
  11     H{\r
  12         { -nrot 5 }\r
  13         { -rot 3 }\r
  14         { bi@ 1 }\r
  15         { 2curry 1 }\r
  16         { 2drop 1 }\r
  17         { 2dup 1 }\r
  18         { 2keep 1 }\r
  19         { 2nip 2 }\r
  20         { 2over 4 }\r
  21         { 2swap 3 }\r
  22         { 3curry 2 }\r
  23         { 3drop 1 }\r
  24         { 3dup 2 }\r
  25         { 3keep 3 }\r
  26         { 4drop 2 }\r
  27         { 4dup 3 }\r
  28         { compose 1/2 }\r
  29         { curry 1/3 }\r
  30         { dip 1 }\r
  31         { 2dip 2 }\r
  32         { drop 1/3 }\r
  33         { dup 1/3 }\r
  34         { if 1/3 }\r
  35         { when 1/4 }\r
  36         { unless 1/4 }\r
  37         { when* 1/3 }\r
  38         { unless* 1/3 }\r
  39         { ?if 1/2 }\r
  40         { cond 1/2 }\r
  41         { case 1/2 }\r
  42         { keep 1 }\r
  43         { napply 2 }\r
  44         { ncurry 3 }\r
  45         { ndip 5 }\r
  46         { ndrop 2 }\r
  47         { ndup 3 }\r
  48         { nip 2 }\r
  49         { nkeep 5 }\r
  50         { npick 6 }\r
  51         { nrot 5 }\r
  52         { ntuck 6 }\r
  53         { nwith 4 }\r
  54         { over 2 }\r
  55         { pick 4 }\r
  56         { rot 3 }\r
  57         { spin 3 }\r
  58         { swap 1 }\r
  59         { swapd 3 }\r
  60         { tuck 2 }\r
  61         { with 1/2 }\r
  62 \r
  63         { bi 1/2 }\r
  64         { tri 1 }\r
  65         { bi* 1/2 }\r
  66         { tri* 1 }\r
  67 \r
  68         { cleave 2 }\r
  69         { spread 2 }\r
  70     } at 0 or ;\r
  71 \r
  72 : vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;\r
  73 \r
  74 GENERIC: noise ( obj -- pair )\r
  75 \r
  76 M: word noise badness 1 2array ;\r
  77 \r
  78 M: wrapper noise wrapped>> noise ;\r
  79 \r
  80 M: let noise body>> noise ;\r
  81 \r
  82 M: lambda noise body>> noise ;\r
  83 \r
  84 M: object noise drop { 0 0 } ;\r
  85 \r
  86 M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;\r
  87 \r
  88 M: array noise [ noise ] map vsum ;\r
  89 \r
  90 : noise-factor ( x y -- z ) / 100 * >integer ;\r
  91 \r
  92 : quot-noise-factor ( quot -- n )\r
  93     #! For very short words, noise doesn't count so much\r
  94     #! (so dup foo swap bar isn't penalized as badly).\r
  95     noise first2 {\r
  96         { [ over 4 <= ] [ [ drop 0 ] dip ] }\r
  97         { [ over 15 >= ] [ [ 2 * ] dip ] }\r
  98         [ ]\r
  99     } cond\r
 100     {\r
 101         ! short words are easier to read\r
 102         { [ dup 10 <= ] [ [ 2 / ] dip ] }\r
 103         { [ dup 5 <= ] [ [ 3 / ] dip ] }\r
 104         ! long words are penalized even more\r
 105         { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }\r
 106         { [ dup 20 >= ] [ [ 5/3 * ] dip ] }\r
 107         { [ dup 15 >= ] [ [ 3/2 * ] dip ] }\r
 108         [ ]\r
 109     } cond noise-factor ;\r
 110 \r
 111 GENERIC: word-noise-factor ( word -- factor )\r
 112 \r
 113 M: word word-noise-factor\r
 114     def>> quot-noise-factor ;\r
 115 \r
 116 M: lambda-word word-noise-factor\r
 117     "lambda" word-prop quot-noise-factor ;\r
 118 \r
 119 : flatten-generics ( words -- words' )\r
 120     [\r
 121         dup generic? [ "methods" word-prop values ] [ 1array ] if\r
 122     ] map concat ;\r
 123 \r
 124 : noisy-words ( -- alist )\r
 125     all-words flatten-generics\r
 126     [ dup word-noise-factor ] { } map>assoc\r
 127     sort-values reverse ;\r
 128 \r
 129 : noise. ( alist -- )\r
 130     standard-table-style [\r
 131         [\r
 132             [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row\r
 133         ] assoc-each\r
 134     ] tabular-output ;\r
 135 \r
 136 : vocab-noise-factor ( vocab -- factor )\r
 137     words flatten-generics\r
 138     [ word-noise-factor dup 20 < [ drop 0 ] when ] map\r
 139     [ 0 ] [\r
 140         [ [ sum ] [ length 5 max ] bi /i ]\r
 141         [ supremum ]\r
 142         bi +\r
 143     ] if-empty ;\r
 144 \r
 145 : noisy-vocabs ( -- alist )\r
 146     vocabs [ dup vocab-noise-factor ] { } map>assoc\r
 147     sort-values reverse ;\r
 148 \r
 149 : noise-report ( -- )\r
 150     "NOISY WORDS:" print\r
 151     noisy-words 80 head noise.\r
 152     nl\r
 153     "NOISY VOCABS:" print\r
 154     noisy-vocabs 80 head noise. ;\r
 155 \r
 156 MAIN: noise-report\r