extra/rosetta-code/hailstone-sequence/hailstone-sequence.factor

   1 ! Copyright (c) 2012 Anonymous
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays io kernel math math.ranges prettyprint sequences vectors ;
   4 IN: rosetta-code.hailstone-sequence
   5
   6 ! http://rosettacode.org/wiki/Hailstone_sequence
   7
   8 ! The Hailstone sequence of numbers can be generated from a
   9 ! starting positive integer, n by:
  10
  11 ! * If n is 1 then the sequence ends.
  12 ! * If n is even then the next n of the sequence = n/2
  13 ! * If n is odd then the next n of the sequence = (3 * n) + 1
  14
  15 ! The (unproven), Collatz conjecture is that the hailstone
  16 ! sequence for any starting number always terminates.
  17
  18 ! Task Description:
  19
  20 ! 1. Create a routine to generate the hailstone sequence for a
  21 !    number.
  22
  23 ! 2. Use the routine to show that the hailstone sequence for the
  24 !    number 27 has 112 elements starting with 27, 82, 41, 124 and
  25 !    ending with 8, 4, 2, 1
  26
  27 ! 3. Show the number less than 100,000 which has the longest
  28 !    hailstone sequence together with that sequences length.
  29 !    (But don't show the actual sequence)!
  30
  31 : hailstone ( n -- seq )
  32     [ 1vector ] keep
  33     [ dup 1 number= ]
  34     [
  35         dup even? [ 2 / ] [ 3 * 1 + ] if
  36         2dup swap push
  37     ] until
  38     drop ;
  39
  40 : hailstone-main ( -- )
  41     27 hailstone dup dup
  42     "The hailstone sequence from 27:" print
  43     "  has length " write length .
  44     "  starts with " write 4 head [ unparse ] map ", " join print
  45     "  ends with " write 4 tail* [ unparse ] map ", " join print
  46
  47     ! Maps n => { length n }, and reduces to longest Hailstone sequence.
  48     100000 [1..b)
  49     [ [ hailstone length ] keep 2array ]
  50     [ [ [ first ] bi@ > ] most ] map-reduce
  51     first2
  52     "The hailstone sequence from " write pprint
  53     " has length " write pprint "." print ;
  54
  55 MAIN: hailstone-main