extra/benchmark/knucleotide/knucleotide.factor

   1 USING: kernel locals io io.files splitting strings io.encodings.ascii
   2        hashtables sequences assocs math namespaces prettyprint
   3        math.parser combinators arrays sorting unicode.case ;
   4
   5 IN: benchmark.knucleotide
   6
   7 : float>string ( float places -- string )
   8     swap >float number>string
   9     "." split1 rot
  10     over length over <
  11     [ CHAR: 0 pad-tail ]
  12     [ head ] if "." glue ;
  13
  14 : discard-lines ( -- )
  15     readln
  16     [ ">THREE" head? [ discard-lines ] unless ] when* ;
  17
  18 : read-input ( -- input )
  19     discard-lines
  20     ">" read-until drop
  21     CHAR: \n swap remove >upper ;
  22
  23 : tally ( x exemplar -- b )
  24     clone [ [ inc-at ] curry each ] keep ;
  25
  26 : small-groups ( x n -- b )
  27     swap
  28     [ length swap - 1 + ] 2keep
  29     [ [ over + ] dip subseq ] 2curry map ;
  30
  31 : handle-table ( inputs n -- )
  32     small-groups
  33     [ length ] keep
  34     H{ } tally >alist
  35     sort-values reverse
  36     [
  37       dup first write bl
  38       second 100 * over / 3 float>string print
  39     ] each
  40     drop ;
  41
  42 :: handle-n ( inputs x -- )
  43     inputs x length small-groups :> groups
  44     groups H{ } tally :> b
  45     x b at [ 0 ] unless*
  46     number>string 8 CHAR: \s pad-tail write ;
  47
  48 : process-input ( input -- )
  49     dup 1 handle-table nl
  50     dup 2 handle-table nl
  51     { "GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT" }
  52     [ [ dupd handle-n ] keep print ] each
  53     drop ;
  54
  55 : knucleotide ( -- )
  56     "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
  57     ascii [ read-input ] with-file-reader
  58     process-input ;
  59
  60 MAIN: knucleotide