extra/reports/noise/noise.factor

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