extra/reports/noise/noise.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://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 ;
   7 IN: reports.noise
   8
   9 : badness ( word -- n )
  10     H{
  11         { -nrot 5 }
  12         { -rot 3 }
  13         { bi@ 1 }
  14         { 2curry 1 }
  15         { 2drop 1 }
  16         { 2dup 1 }
  17         { 2keep 1 }
  18         { 2nip 2 }
  19         { 2over 4 }
  20         { 2swap 3 }
  21         { 3curry 2 }
  22         { 3drop 1 }
  23         { 3dup 2 }
  24         { 3keep 3 }
  25         { 4drop 2 }
  26         { 4dup 3 }
  27         { compose 1/2 }
  28         { curry 1/3 }
  29         { dip 1 }
  30         { 2dip 2 }
  31         { drop 1/3 }
  32         { dup 1/3 }
  33         { if 1/3 }
  34         { when 1/4 }
  35         { unless 1/4 }
  36         { when* 1/3 }
  37         { unless* 1/3 }
  38         { ?if 1/2 }
  39         { cond 1/2 }
  40         { case 1/2 }
  41         { keep 1 }
  42         { napply 2 }
  43         { ncurry 3 }
  44         { ndip 5 }
  45         { ndrop 2 }
  46         { ndup 3 }
  47         { nip 2 }
  48         { nkeep 5 }
  49         { npick 6 }
  50         { nrot 5 }
  51         { nwith 4 }
  52         { over 2 }
  53         { pick 4 }
  54         { rot 3 }
  55         { swap 1 }
  56         { swapd 3 }
  57         { with 1/2 }
  58
  59         { bi 1/2 }
  60         { tri 1 }
  61         { bi* 1/2 }
  62         { tri* 1 }
  63
  64         { cleave 2 }
  65         { spread 2 }
  66     } at 0 or ;
  67
  68 : vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
  69
  70 GENERIC: noise ( obj -- pair )
  71
  72 M: word noise badness 1 2array ;
  73
  74 M: wrapper noise wrapped>> noise ;
  75
  76 M: let noise body>> noise ;
  77
  78 M: lambda noise body>> noise ;
  79
  80 M: object noise drop { 0 0 } ;
  81
  82 M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
  83
  84 M: array noise [ noise ] map vsum ;
  85
  86 : noise-factor ( x y -- z ) / 100 * >integer ;
  87
  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).
  91     noise first2 {
  92         { [ over 4 <= ] [ [ drop 0 ] dip ] }
  93         { [ over 15 >= ] [ [ 2 * ] dip ] }
  94         [ ]
  95     } cond
  96     {
  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 ] }
 104         [ ]
 105     } cond noise-factor ;
 106
 107 GENERIC: word-noise-factor ( word -- factor )
 108
 109 M: word word-noise-factor
 110     def>> quot-noise-factor ;
 111
 112 M: lambda-word word-noise-factor
 113     "lambda" word-prop quot-noise-factor ;
 114
 115 : flatten-generics ( words -- words' )
 116     [
 117         dup generic? [ "methods" word-prop values ] [ 1array ] if
 118     ] map concat ;
 119
 120 : noisy-words ( -- alist )
 121     all-words flatten-generics
 122     [ word-noise-factor ] zip-with
 123     sort-values reverse ;
 124
 125 : noise. ( alist -- )
 126     standard-table-style [
 127         [
 128             [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
 129         ] assoc-each
 130     ] tabular-output ;
 131
 132 : vocab-noise-factor ( vocab -- factor )
 133     vocab-words flatten-generics
 134     [ word-noise-factor dup 20 < [ drop 0 ] when ] map
 135     [ 0 ] [
 136         [ [ sum ] [ length 5 max ] bi /i ]
 137         [ supremum ]
 138         bi +
 139     ] if-empty ;
 140
 141 : noisy-vocabs ( -- alist )
 142     loaded-vocab-names [ vocab-noise-factor ] zip-with
 143     sort-values reverse ;
 144
 145 : noise-report ( -- )
 146     "NOISY WORDS:" print
 147     noisy-words 80 head noise.
 148     nl
 149     "NOISY VOCABS:" print
 150     noisy-vocabs 80 head noise. ;
 151
 152 MAIN: noise-report