Hofstadter Figure-Figure sequences

From Rosetta Code
Revision as of 09:51, 10 December 2011 by 62.211.214.55 (talk) (Another D version)
Task
Hofstadter Figure-Figure sequences
You are encouraged to solve this task according to the task description, using any language you may know.

These two sequences of positive integers are defined as:

The sequence is further defined as the sequence of positive integers not present in .

Sequence R starts: 1, 3, 7, 12, 18, ...
Sequence S starts: 2, 4, 5, 6, 8, ...

Task:

  1. Create two functions named ffr and ffs that when given n return R(n) or S(n) respectively.
    (Note that R(1) = 1 and S(1) = 2 to avoid off-by-one errors).
  2. No maximum value for n should be assumed.
  3. Calculate and show that the first ten values of R are: 1, 3, 7, 12, 18, 26, 35, 45, 56, and 69
  4. Calculate and show that the first 40 values of ffr plus the first 960 values of ffs include all the integers from 1 to 1000 exactly once.
References

Ada

Specifying a package providing the functions FFR and FFS: <lang Ada>package Hofstadter_Figure_Figure is 

  function FFR(P: Positive) return Positive;

  function FFS(P: Positive) return Positive;

end Hofstadter_Figure_Figure;</lang>

The implementation of the package internally uses functions which generate an array of Figures or Spaces: <lang Ada>package body Hofstadter_Figure_Figure is 

  type Positive_Array is array (Positive range <>) of Positive;

  function FFR(P: Positive) return Positive_Array is
     Figures: Positive_Array(1 .. P+1);
     Space: Positive := 2;
     Space_Index: Positive := 2;
  begin
     Figures(1) := 1;
     for I in 2 .. P loop
        Figures(I) := Figures(I-1) + Space;
        Space := Space+1;
        while Space = Figures(Space_Index) loop
           Space := Space + 1;
           Space_Index := Space_Index + 1;
        end loop;
     end loop;
     return Figures(1 .. P);
  end FFR;

  function FFR(P: Positive) return Positive is
     Figures: Positive_Array(1 .. P) := FFR(P);
  begin
     return Figures(P);
  end FFR;

  function FFS(P: Positive) return Positive_Array is
     Spaces:  Positive_Array(1 .. P);
     Figures: Positive_Array := FFR(P+1);
     J: Positive := 1;
     K: Positive := 1;
  begin
     for I in Spaces'Range loop
        while J = Figures(K) loop
           J := J + 1;
           K := K + 1;
        end loop;
        Spaces(I) := J;
        J := J + 1;
     end loop;
     return Spaces;
  end FFS;

  function FFS(P: Positive) return Positive is
     Spaces: Positive_Array := FFS(P);
  begin
     return Spaces(P);
  end FFS;

end Hofstadter_Figure_Figure;</lang>

Finally, a test program for the package, solving the task at hand: <lang Ada>with Ada.Text_IO, Hofstadter_Figure_Figure;

procedure Test_HSS is 

  use Hofstadter_Figure_Figure;

  A: array(1 .. 1000) of Boolean := (others => False);
  J: Positive;

begin 

  for I in 1 .. 10 loop
     Ada.Text_IO.Put(Integer'Image(FFR(I)));
  end loop;
  Ada.Text_IO.New_Line;

  for I in 1 .. 40 loop
     J := FFR(I);
     if A(J) then
        raise Program_Error with Positive'Image(J) & " used twice";
     end if;
     A(J) := True;
  end loop;

  for I in 1 .. 960 loop
     J := FFS(I);
     if A(J) then
        raise Program_Error with Positive'Image(J) & " used twice";
     end if;
     A(J) := True;
  end loop;

  for I in A'Range loop
     if not A(I) then raise Program_Error with Positive'Image(I) & " unused";
     end if;
  end loop;
  Ada.Text_IO.Put_Line("Test Passed: No overlap between FFR(I) and FFS(J)");

exception 

  when Program_Error => Ada.Text_IO.Put_Line("Test Failed"); raise;

end Test_HSS;</lang>

The output of the test program: <lang> 1 3 7 12 18 26 35 45 56 69 Test Passed: No overlap between FFR(I) and FFS(J)</lang>

Common Lisp

<lang lisp>;;; equally doable with a list (flet ((seq (i) (make-array 1 :element-type 'integer :initial-element i :fill-pointer 1 :adjustable t))) 

 (let ((rr (seq 1)) (ss (seq 2)))
   (labels ((extend-r ()

(let* ((l (1- (length rr))) (r (+ (aref rr l) (aref ss l))) (s (elt ss (1- (length ss))))) (vector-push-extend r rr) (loop while (<= s r) do (if (/= (incf s) r) (vector-push-extend s ss)))))) 

     (defun seq-r (n)

(loop while (> n (length rr)) do (extend-r)) (elt rr (1- n))) 

     (defun seq-s (n)

(loop while (> n (length ss)) do (extend-r)) (elt ss (1- n))))))

(defun take (f n) 

 (loop for x from 1 to n collect (funcall f x)))

(format t "First of R: ~a~%" (take #'seq-r 10))

(mapl (lambda (l) (if (and (cdr l) (/= (1+ (car l)) (cadr l))) (error "not in sequence"))) 

     (sort (append (take #'seq-r 40)

(take #'seq-s 960)) #'<)) (princ "Ok")</lang>output<lang>First of R: (1 3 7 12 18 26 35 45 56 69) Ok</lang>

D

Translation of: Go

<lang d>import std.stdio, std.array, std.range, std.algorithm;

int delegate(in int) nothrow ffr, ffs;

static this() { 

   auto r = [0, 1], s = [0, 2];

   ffr = (in int n) {
       while (r.length <= n) {
           int nrk = r.length - 1;
           int rNext = r[nrk] + s[nrk];
           r ~= rNext;
           foreach (sn; r[nrk] + 2 .. rNext)
               s ~= sn;
           s ~= rNext + 1;
       }
       return r[n];
   };

   ffs = (in int n) {
       while (s.length <= n)
           ffr(r.length);
       return s[n];
   };

}

void main() { 

   writeln(map!ffr(iota(1, 11)));
   auto t = chain(map!ffr(iota(1, 41)), map!ffs(iota(1, 961)));
   writeln(equal(sort(array(t)), iota(1, 1001)));

}</lang> Output: 

[1, 3, 7, 12, 18, 26, 35, 45, 56, 69]
true

Alternative version

Translation of: Python

(Same output) <lang d>import std.stdio, std.array, std.range, std.algorithm;

struct ffr { 

   static int[] r = [int.min, 1];

   static int opCall(in int n) {
       assert(n > 0);
       if (n < r.length) {
           return r[n];
       } else {
           int ffr_n_1 = ffr(n - 1);
           int lastr = r[$ - 1];
           // extend s up to, and one past, last r
           ffs.s ~= array(iota(ffs.s[$ - 1] + 1, lastr));
           if (ffs.s[$ - 1] < lastr)
               ffs.s ~= lastr + 1;
           // access s[n-1] temporarily extending s if necessary
           size_t len_s = ffs.s.length;
           int ffs_n_1 = len_s > n ? ffs.s[n - 1] :
                                     (n - len_s) + ffs.s[$-1];
           int ans = ffr_n_1 + ffs_n_1;
           r ~= ans;
           return ans;
       }
   }

}

struct ffs { 

   static int[] s = [int.min, 2];

   static int opCall(in int n) {
       assert(n > 0);
       if (n < s.length) {
           return s[n];
       } else {
           foreach (i; ffr.r.length .. n+2) {
               ffr(i);
               if (s.length > n)
                   return s[n];
           }
           assert(0, "Whoops!");
       }
   }

}

void main() { 

   writeln(map!ffr(iota(1, 11)));
   auto t = chain(map!ffr(iota(1, 41)), map!ffs(iota(1, 961)));
   writeln(equal(sort(array(t)), iota(1, 1001)));

}</lang>

Factor

This example is incorrect. Please fix the code and remove this message.

Details: See talk page

The core of this algorithm builds up a list of S and R one at a time. The solution to task 1 follows. <lang factor>: next ( s r -- news newr ) 2dup [ last ] bi@ + suffix dup [ 

 [ dup last 1 + dup ] dip member? [ 1 + ] when suffix

] dip ;

SR ( n -- S(n) R(n) )

1 - [ { 2 } { 1 } ] dip [ next ] times [ last ] bi@ ;

ffs ( n -- S(n) ) SR drop ;
ffr ( n -- R(n) ) SR nip ;

</lang>

For tasks 3 and 4 we ignore the functions ffs and ffr and simply use next. <lang factor>( scratchpad ) { 2 } { 1 } 1000 [ next ] times  ! Generate the first 1000 values of S and R

--- Data stack: { 2 4 5 6 8 9 10 11 13 14 15 16 17 19 20 ~986 more~ } { 1 3 7 12 18 26 35 45 56 69 83 98 114 131 150 ~986 more~ } ( scratchpad ) dup 10 head . { 1 3 7 12 18 26 35 45 56 69 }

--- Data stack: { 2 4 5 6 8 9 10 11 13 14 15 16 17 19 20 ~986 more~ } { 1 3 7 12 18 26 35 45 56 69 83 98 114 131 150 ~986 more~ } ( scratchpad ) [ 960 head ] [ 40 head ] bi* append  ! Combine the first 960 terms of S and the first 40 of R

--- Data stack: { 2 4 5 6 8 9 10 11 13 14 15 16 17 19 20 ~985 more~ } ( scratchpad ) 1000 iota [ 1 + ] map [ dupd swap member? ] map t [ and ] reduce . clear t</lang>

Go

<lang go>package main

import "fmt"

var ffr, ffs func(int) int

// task 1, 2 func init() { 

   r := []int{0, 1}
   s := []int{0, 2}

   ffr = func(n int) int {
       for len(r) <= n {
           nrk := len(r) - 1       // last n for which r(n) is known
           rNxt := r[nrk] + s[nrk] // next value of r:  r(nrk+1)
           r = append(r, rNxt)     // extend sequence r by one element
           for sn := r[nrk] + 2; sn < rNxt; sn++ {
               s = append(s, sn)   // extend sequence s up to rNext
           }
           s = append(s, rNxt+1)   // extend sequence s one past rNext
       }
       return r[n]
   }

   ffs = func(n int) int {
       for len(s) <= n {
           ffr(len(r))
       }
       return s[n]
   }

}

func main() { 

   // task 3
   for n := 1; n <= 10; n++ {
       fmt.Printf("r(%d): %d\n", n, ffr(n))
   }
   // task 4
   var found [1001]int
   for n := 1; n <= 40; n++ {
       found[ffr(n)]++
   }
   for n := 1; n <= 960; n++ {
       found[ffs(n)]++
   }
   for i := 1; i <= 1000; i++ {
       if found[i] != 1 {
           fmt.Println("task 4: FAIL")
           return
       }
   }
   fmt.Println("task 4: PASS")

}</lang> Output: 

r(1): 1
r(2): 3
r(3): 7
r(4): 12
r(5): 18
r(6): 26
r(7): 35
r(8): 45
r(9): 56
r(10): 69
task 4: PASS

Haskell

<lang haskell>import Data.List (delete, sort)

-- Functions by Reinhard Zumkeller ffr n = rl !! (n - 1) where 

  rl = 1 : fig 1 [2 ..]
  fig n (x : xs) = n' : fig n' (delete n' xs) where n' = n + x

ffs n = rl !! n where 

  rl = 2 : figDiff 1 [2 ..]
  figDiff n (x : xs) = x : figDiff n' (delete n' xs) where n' = n + x

main = do 

   print $ map ffr [1 .. 10]
   let i1000 = sort (map ffr [1 .. 40] ++ map ffs [1 .. 960])
   print (i1000 == [1 .. 1000])</lang>

Output: 

[1,3,7,12,18,26,35,45,56,69]
True

Icon and Unicon

<lang Icon>link printf,ximage

procedure main() 

  printf("Hofstader ff sequences R(n:= 1 to %d)\n",N := 10)
  every printf("R(%d)=%d\n",n := 1 to N,ffr(n))

  L := list(N := 1000,0)
  zero := dup := oob := 0
  every n := 1 to (RN := 40) do 
     if not L[ffr(n)] +:= 1 then    # count R occurrence
        oob +:= 1                   # count out of bounds

  every n := 1 to (N-RN) do 
     if not L[ffs(n)] +:= 1 then    # count S occurrence 
        oob +:= 1                   # count out of bounds  
  
  every zero +:= (!L = 0)           # count zeros / misses
  every dup  +:= (!L > 1)           # count > 1's / duplicates
     
  printf("Results of R(1 to %d) and S(1 to %d) coverage is ",RN,(N-RN))
  if oob+zero+dup=0 then 
     printf("complete.\n")
  else 
     printf("flawed\noob=%i,zero=%i,dup=%i\nL:\n%s\nR:\n%s\nS:\n%s\n",
            oob,zero,dup,ximage(L),ximage(ffr(ffr)),ximage(ffs(ffs)))

end

procedure ffr(n) static R,S initial { 

  R := [1]
  S := ffs(ffs)               # get access to S in ffs
  }
  
  if n === ffr then return R  # secret handshake to avoid globals :)
  
  if integer(n) > 0 then 
     return R[n] | put(R,ffr(n-1) + ffs(n-1))[n]

end

procedure ffs(n) static R,S initial { 

  S := [2] 
  R := ffr(ffr)               # get access to R in ffr
  }
  
  if n === ffs then return S  # secret handshake to avoid globals :)
  
  if integer(n) > 0 then {
     if S[n] then return S[n]
     else {
        t := S[*S]  
        until *S = n do 
           if (t +:= 1) = !R then next # could be optimized with more code
           else return put(S,t)[*S]    # extend S
        }
  }

end</lang>

Library: Icon Programming Library

printf.icn provides formatting ximage.icn allows formatting entire structures

Output:

Hofstader ff sequences R(n:= 1 to 10)
R(1)=1
R(2)=3
R(3)=7
R(4)=12
R(5)=18
R(6)=26
R(7)=35
R(8)=45
R(9)=56
R(10)=69
Results of R(1 to 40) and S(1 to 960) coverage is complete.

J

<lang j>R=: 1 1 3 S=: 0 2 4 FF=: 3 :0 

 while. +./y>:R,&#S do.
   R=: R,({:R)+(<:#R){S
   S=: (i.<:+/_2{.R)-.R
 end.
 R;S

) ffr=: { 0 {:: FF@(>./@,) ffs=: { 1 {:: FF@(0,>./@,)</lang>

Required examples:

<lang j> ffr 1+i.10 1 3 7 12 18 26 35 45 56 69 

  (1+i.1000) -: /:~ (ffr 1+i.40), ffs 1+i.960

1</lang>

PicoLisp

<lang PicoLisp>(setq *RNext 2)

(de ffr (N) 

  (cache '(NIL) (pack (char (hash N)) N)
     (if (= 1 N)
        1
        (+ (ffr (dec N)) (ffs (dec N))) ) ) )

(de ffs (N) 

  (cache '(NIL) (pack (char (hash N)) N)
     (if (= 1 N)
        2
        (let S (inc (ffs (dec N)))
           (when (= S (ffr *RNext))
              (inc 'S)
              (inc '*RNext) )
           S ) ) ) )</lang>

Test: <lang PicoLisp>: (mapcar ffr (range 1 10)) -> (1 3 7 12 18 26 35 45 56 69)

(=
  (range 1 1000)
  (sort (conc (mapcar ffr (range 1 40)) (mapcar ffs (range 1 960)))) )

-> T</lang>

Perl 6

<lang perl6>my %r = 1 => 1; my %s = 1 => 2;

sub ffr ($n) { 

       return %r{$n} if %r.exists($n);
       %r{$n} = ffr($n - 1) + ffs($n - 1);
       return %r{$n};

}

sub ffs ($n) { 

       return %s{$n} if %s.exists($n);
       %s{$n} = (grep none( map &ffr, 1..$n), max(%s.values)+1..*)[0];
       return %s{$n};

}

say "first 10 values of R are:"; say map &ffr, 1..10;

  1. first 40 values of R

my @a = map &ffr, 1..40;

  1. first 960 values of S
  2. WARNING: be sure you got about 3GB of ram to burn

my @b = map &ffs, 1..960;

use Test; is sort(@a,@b), 1..1000, 'R(1..40) ∪ S(1..960) == 1..1000'; </lang>

Prolog

Constraint Handling Rules

CHR is a programming language created by Professor Thom Frühwirth.
Works with SWI-Prolog and module chr written by Tom Schrijvers and Jan Wielemaker <lang Prolog>:- use_module(library(chr)).

- chr_constraint ffr/2, ffs/2, hofstadter/1,hofstadter/2.
- chr_option(debug, off).
- chr_option(optimize, full).

% to remove duplicates ffr(N, R1) \ ffr(N, R2) <=> R1 = R2 | true. ffs(N, R1) \ ffs(N, R2) <=> R1 = R2 | true.

% compute ffr ffr(N, R), ffr(N1, R1), ffs(N1,S1) ==> 

        N > 1, N1 is N - 1 |

R is R1 + S1.

% compute ffs ffs(N, S), ffs(N1,S1) ==> 

        N > 1, N1 is N - 1 |

V is S1 + 1, ( find_chr_constraint(ffr(_, V)) -> S is V+1; S = V).

% init hofstadter(N) ==> ffr(1,1), ffs(1,2). % loop hofstadter(N), ffr(N1, _R), ffs(N1, _S) ==> N1 < N, N2 is N1 +1 | ffr(N2,_), ffs(N2,_).

</lang> Output for first task : 

 ?- hofstadter(10), bagof(ffr(X,Y), find_chr_constraint(ffr(X,Y)), L).
ffr(10,69)
ffr(9,56)
ffr(8,45)
ffr(7,35)
ffr(6,26)
ffr(5,18)
ffr(4,12)
ffr(3,7)
ffr(2,3)
ffr(1,1)
ffs(10,14)
ffs(9,13)
ffs(8,11)
ffs(7,10)
ffs(6,9)
ffs(5,8)
ffs(4,6)
ffs(3,5)
ffs(2,4)
ffs(1,2)
hofstadter(10)
L = [ffr(10,69),ffr(9,56),ffr(8,45),ffr(7,35),ffr(6,26),ffr(5,18),ffr(4,12),ffr(3,7),ffr(2,3),ffr(1,1)].

Code for the second task <lang Prolog>hofstadter :- hofstadter(960), % fetch the values of ffr bagof(Y, X^find_chr_constraint(ffs(X,Y)), L1), % fetch the values of ffs bagof(Y, X^(find_chr_constraint(ffr(X,Y)), X < 41), L2), % concatenate then append(L1, L2, L3), % sort removing duplicates sort(L3, L4), % check the correctness of the list ( (L4 = [1|_], last(L4, 1000), length(L4, 1000)) -> writeln(ok); writeln(ko)), % to remove all pending constraints fail. </lang> Output for second task 

 ?- hofstadter.
ok
false.

Python

<lang python>def ffr(n): 

   if n < 1 or type(n) != int: raise ValueError("n must be an int >= 1")
   try:
       return ffr.r[n]
   except IndexError:
       r, s = ffr.r, ffs.s
       ffr_n_1 = ffr(n-1)
       lastr = r[-1]
       # extend s up to, and one past, last r 
       s += list(range(s[-1] + 1, lastr))
       if s[-1] < lastr: s += [lastr + 1]
       # access s[n-1] temporarily extending s if necessary
       len_s = len(s)
       ffs_n_1 = s[n-1] if len_s > n else (n - len_s) + s[-1]
       ans = ffr_n_1 + ffs_n_1
       r.append(ans)
       return ans

ffr.r = [None, 1]

def ffs(n): 

   if n < 1 or type(n) != int: raise ValueError("n must be an int >= 1")
   try:
       return ffs.s[n]
   except IndexError:
       r, s = ffr.r, ffs.s
       for i in range(len(r), n+2):
           ffr(i)
           if len(s) > n:
               return s[n]
       raise Exception("Whoops!")

ffs.s = [None, 2]

if __name__ == '__main__': 

   first10 = [ffr(i) for i in range(1,11)]
   assert first10 == [1, 3, 7, 12, 18, 26, 35, 45, 56, 69], "ffr() value error(s)"
   print("ffr(n) for n = [1..10] is", first10)
   #
   bin = [None] + [0]*1000
   for i in range(40, 0, -1):
       bin[ffr(i)] += 1
   for i in range(960, 0, -1):
       bin[ffs(i)] += 1
   if all(b == 1 for b in bin[1:1000]):
       print("All Integers 1..1000 found OK")
   else:
       print("All Integers 1..1000 NOT found only once: ERROR")</lang>
Output
ffr(n) for n = [1..10] is [1, 3, 7, 12, 18, 26, 35, 45, 56, 69]
All Integers 1..1000 found OK

Alternative

<lang python>cR = [1] cS = [2]

def extend_RS(): x = cR[len(cR) - 1] + cS[len(cR) - 1] cR.append(x) cS += range(cS[-1] + 1, x) cS.append(x + 1)

def ff_R(n): assert(n > 0) while n > len(cR): extend_RS() return cR[n - 1]

def ff_S(n): assert(n > 0) while n > len(cS): extend_RS() return cS[n - 1]

  1. tests

print([ ff_R(i) for i in range(1, 11) ])

s = {} for i in range(1, 1001): s[i] = 0 for i in range(1, 41): del s[ff_R(i)] for i in range(1, 961): del s[ff_S(i)]

  1. the fact that we got here without a key error

print("Ok")</lang>output<lang>[1, 3, 7, 12, 18, 26, 35, 45, 56, 69] Ok</lang>

Ruby

Translation of: Tcl

<lang ruby>$r = [nil, 1] $s = [nil, 2]

def buildSeq(n) 

 current = [ $r[-1], $s[-1] ].max
 while $r.length <= n || $s.length <= n
   idx = [ $r.length, $s.length ].min - 1
   current += 1
   if current == $r[idx] + $s[idx]
     $r << current
   else
     $s << current
   end
 end

end

def ffr(n) 

 buildSeq(n)
 $r[n]

end

def ffs(n) 

 buildSeq(n)
 $s[n]

end

require 'set' require 'test/unit'

class TestHofstadterFigureFigure < Test::Unit::TestCase 

 def test_first_ten_R_values
   r10 = 1.upto(10).map {|n| ffr(n)}
   assert_equal(r10, [1, 3, 7, 12, 18, 26, 35, 45, 56, 69])
 end

 def test_40_R_and_960_S_are_1_to_1000
   rs_values = Set.new
   rs_values.merge( 1.upto(40).collect  {|n| ffr(n)} )
   rs_values.merge( 1.upto(960).collect {|n| ffs(n)} )
   assert_equal(rs_values, Set.new( 1..1000 ))
 end

end</lang>

outputs 

Loaded suite hofstadter.figurefigure
Started
..
Finished in 0.511000 seconds.

2 tests, 2 assertions, 0 failures, 0 errors, 0 skips

Tcl

Library: Tcllib (Package: struct::set)

<lang tcl>package require Tcl 8.5 package require struct::set

  1. Core sequence generator engine; stores in $R and $S globals

set R {R:-> 1} set S {S:-> 2} proc buildSeq {n} { 

   global R S
   set ctr [expr {max([lindex $R end],[lindex $S end])}]
   while {[llength $R] <= $n || [llength $S] <= $n} {

set idx [expr {min([llength $R],[llength $S]) - 1}] if {[incr ctr] == [lindex $R $idx]+[lindex $S $idx]} { lappend R $ctr } else { lappend S $ctr } 

   }

}

  1. Accessor procedures

proc ffr {n} { 

   buildSeq $n
   lindex $::R $n

} proc ffs {n} { 

   buildSeq $n
   lindex $::S $n

}

  1. Show some things about the sequence

for {set i 1} {$i <= 10} {incr i} { 

   puts "R($i) = [ffr $i]"

} puts "Considering {1..1000} vs {R(i)|i\u2208\[1,40\]}\u222a{S(i)|i\u2208\[1,960\]}" for {set i 1} {$i <= 1000} {incr i} {lappend numsInSeq $i} for {set i 1} {$i <= 40} {incr i} { 

   lappend numsRS [ffr $i]

} for {set i 1} {$i <= 960} {incr i} { 

   lappend numsRS [ffs $i]

} puts "set sizes: [struct::set size $numsInSeq] vs [struct::set size $numsRS]" puts "set equality: [expr {[struct::set equal $numsInSeq $numsRS]?{yes}:{no}}]"</lang> Output: 

R(1) = 1
R(2) = 3
R(3) = 7
R(4) = 12
R(5) = 18
R(6) = 26
R(7) = 35
R(8) = 45
R(9) = 56
R(10) = 69
Considering {1..1000} vs {R(i)|i∈[1,40]}∪{S(i)|i∈[1,960]}
set sizes: 1000 vs 1000
set equality: yes
Retrieved from "https://rosettacode.org/wiki/Hofstadter_Figure-Figure_sequences?oldid=203211"