basis/math/primes/factors/factors.factor

   1 ! Copyright (C) 2007-2009 Samuel Tardieu.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators command-line io kernel make
   4 math math.functions math.parser math.primes math.ranges
   5 namespaces sequences sequences.product sorting ;
   6 IN: math.primes.factors
   7
   8 <PRIVATE
   9
  10 : count-factor ( n d -- n' c )
  11     [ 1 ] 2dip [ /i ] keep
  12     [ dupd /mod zero? ] curry [ nip [ 1 + ] dip ] while drop
  13     swap ;
  14
  15 : write-factor ( n d -- n' d' )
  16     2dup divisor? [
  17         [ [ count-factor ] keep swap 2array , ] keep
  18         ! If the remainder is a prime number, increase d so that
  19         ! the caller stops looking for factors.
  20         over prime? [ drop dup ] when
  21     ] when ;
  22
  23 : (group-factors) ( n -- seq )
  24     [
  25         2
  26         [ 2dup sq < ] [ write-factor next-prime ] until
  27         drop dup 2 < [ drop ] [ 1 2array , ] if
  28     ] { } make ;
  29
  30 PRIVATE>
  31
  32 : group-factors ( n -- seq )
  33     dup prime? [ 1 2array 1array ] [ (group-factors) ] if ; flushable
  34
  35 : unique-factors ( n -- seq ) group-factors keys ; flushable
  36
  37 : factors ( n -- seq )
  38     group-factors [ first2 swap <array> ] map concat ; flushable
  39
  40 : totient ( n -- t )
  41     {
  42         { [ dup 2 < ] [ drop 0 ] }
  43         [ dup unique-factors [ 1 [ 1 - * ] reduce ] [ product ] bi / * ]
  44     } cond ; foldable
  45
  46 : divisors ( n -- seq )
  47     dup 1 = [
  48         1array
  49     ] [
  50         group-factors dup empty? [
  51             [ first2 [0,b] [ ^ ] with map ] map
  52             [ product ] product-map natural-sort
  53         ] unless
  54     ] if ;
  55
  56 : unix-factor ( string -- )
  57     dup string>number [
  58         [ ": " append write ]
  59         [ factors [ number>string ] map " " join print ] bi*
  60     ] [
  61         "factor: `" "' is not a valid positive integer" surround print
  62     ] if* flush ;
  63
  64 : run-unix-factor ( -- )
  65     command-line get [
  66         [ readln [ unix-factor t ] [ f ] if* ] loop
  67     ] [
  68         [ unix-factor ] each
  69     ] if-empty ;
  70
  71 MAIN: run-unix-factor