cubbi.com: fibonacci numbers in forth
Forth
Date: 1960 (Standardized in ANSI X3.215-1994)
Type: Concatenative language
Usage: embedded systems, OS loaders, other space-critical applications
Note, Forth, strictly speaking, is not concatenative, but it *looks* like it is. Charles Moore pursued different goals, but in doing so he almost discovered concatenative languages. Consider the evolution of conditionals, for example, from forth's "IF word" to postscript's "if operator" to joy and factor's "if combinator".
ALGORITHM 1A: NAIVE BINARY RECURSION
\ This program calculates the nth fibonacci number
\ using alrogirhtm 1A: naive binary recursion
\ 
\ compiled: N/A
\ executed: gforth-fast f1a.fs n

\ If n1 is greater than 1, calculate n1-1 and n1-2, recurse twice, 
\ add the results and return the sum. Otherwise, return n1 unchanged.
: fib ( n1 -- n2 )
  dup 1 > if 
  1- dup 1- recurse swap recurse + then
;

\ The word f takes care of the negative arguments and calls fib(abs n)
\ If n1 is negative, and even (2 mod 0=), negate the result of fib
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth-fast ./f1a.fs <n>" cr then
;

main
bye

ALGORITHM 1B: CACHED BINARY RECURSION / MEMOIZATION
\ This program calculates the nth fibonacci number
\ using alrogirhtm 1B: cached binary recursion
\ 
\ compiled: N/A
\ executed: gforth f1b.fs n

\ If n1 is greater than 1, calculate n1-1 and n1-2, recurse twice, 
\ add the results and return the sum. Otherwise, return n1 unchanged.
\ before recursing, checks addr[n1] for the non-zero precalculated result
\ and returns that result if found
: mfib ( addr n1 -- addr n2 )
  dup 1 > if \ only bother doing anything if n1>1
    2dup cells + @ dup 0= if \ is the addr[n1] still empty?
      drop dup >r
      1- 2dup 1- recurse 2swap recurse nip + \ recurse twice and sum results
      2dup swap r> cells + !  \ store result at addr[n1]
    else nip then then
;

\ initialize the memoization array for function call results
\ and call mfib
: fib ( n1 -- n2 )
  dup 1+ cells allocate throw \ allocate n1+1 aus of memory
  swap 2dup 1+ cells erase \ clear the allocated memory
  over cell+ 1 swap ! \ store 1 in the second cell 
  mfib swap free throw \ call mfib and free the allocated memory
;

\ The word f takes care of the negative arguments and calls fib:
\ If n1 is negative, turn it positive, call fib, then check if n1 
\ was even (2 mod 0=) and negate the result of fib if so.
\ If n1 was odd, return the result of fib as is.
\ if n1 was not negative, call fib with no changes
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f1b.fs <n>" cr then
;

main
bye

ALGORITHM 2A: CACHED LINEAR RECURSION / RANDOM-ACCESS CONTAINER
\ This program calculates the nth fibonacci number
\ using alrogirhtm 2A: cached linear iteration with stack as the container
\ 
\ compiled: N/A
\ executed: gforth f2a.fs n

\ sums n1 and n2, decrementing x until x is zero
: fibrec ( ... n1 n2 X -- n1 n2 ... nx 0 )
  1- dup 0> if
  over 3 pick + swap recurse else
  drop then
;

\ initialize the stack with numbers 0 and 1, then executes "2dup +" n-1 times
: fib ( n1 -- n2 )
  dup 0> if 0 1 rot \ stack contains 0, 1, n
  fibrec \ stack contains 0, 1, ... f(n)
  >r begin 0= until r> then \ drop intermediate values
;

\ The word f takes care of the negative arguments and calls fib:
\ If n1 is negative, turn it positive, call fib, then check if n1 
\ was even (2 mod 0=) and negate the result of fib if so.
\ If n1 was odd, return the result of fib as is.
\ if n1 was not negative, call fib with no changes
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f2a.fs <n>" cr then
;

main
bye

ALGORITHM 2B: LINEAR RECURSION WITH ACCUMULATOR
\ This program calculates the nth fibonacci number
\ using alrogirhtm 2B: linear recursion with accumulator
\ 
\ compiled: N/A
\ executed: gforth f2b.fs n

\ This function is called with n 0 1 on stack. On every iteration,
\ it decrements nc, returns n1 if it became negative, otherwise
\ recurses with nc-1, n2, n1+n2
: fib ( nc n1 n2 -- n )
  rot 1- dup 0< if 2drop else \ if nc-1 < 0, return nc-1
  over 2swap + recurse then \ add and swap the accumulators and recurse
;

\ The word f takes care of the negative arguments and calls fib(0,1,abs n)
\ If n1 is negative, and even (2 mod 0=), negate the result of fib
: f ( n1 -- n2 )
  dup abs 0 1 fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f2b.fs <n>" cr then
;

main
bye

ALGORITHM 2C: IMPERATIVE LOOP WITH MUTABLE VARIABLES
\ This program calculates the nth fibonacci number
\ using alrogirhtm 2C: imperative loop with mutable variables
\ 
\ compiled: N/A
\ executed: gforth f2c.fs n


\ starting with 1 and 0 on stack, on every iteration add and swap.
\ in the end, drop the first argument and return the second
: fib ( n1 -- n2 )
   1 0 rot 0 ?do swap over + loop nip
;

\ The word f takes care of the negative arguments and calls fib(abs n)
\ If n1 is negative and even, negates the result of fib
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f2c.fs <n>" cr then
;

main
bye

ALGORITHM 3A: MATRIX MULTIPLICATION
\ This program calculates the nth fibonacci number
\ using alrogirhtm 3A: matrix multiplication
\ 
\ compiled: N/A
\ executed: gforth f3a.fs n

\ All matrices all square NxN matrices represented as addr, N on stack

\ allocate and initialize an N x N square matrix
: make-mat ( n1 n2 ... nN^2 N -- addr N )
  dup >r dup * dup cells allocate throw \ allocate N*N memory
  swap 0 u+do swap over i cells + ! loop r> \ for i in 0..N*N write to addr[i-1]
;

\ copy matrix, allocates new memory
: dup-mat ( a N -- a1 N a2 N)
  dup dup * dup cells allocate throw  \ a1 N N*N a2
  swap 3 pick 2 pick rot cells move over \ a1 N a2 N
;

\ dispose of a matrix
: drop-mat ( a N -- )
  drop free throw
;

\ show matrix (for debugging)
: .m ( a N -- a N )
  2dup dup * 0 u+do dup i cells + @ . loop cr drop
;

\ make a NxN matrix full of zeroes
: make-zero-mat ( N -- a N)
  dup dup * 0 u+do 0 swap loop make-mat
;

\ multiply matrix a2 and matrix a1, both are square NxN matrices
: *m ( a1 N a2 N -- a3 N )
  drop swap dup make-zero-mat                       \ a1 a2 N a3 N
  0 u+do i 2 pick 0 u+do i 3 pick 0 u+do i          \ a1 a2 N a3 i j k
     4 pick 3 pick * over + 7 pick swap cells + @   \ ... a1[i][k]
     over 6 pick * 3 pick + 7 pick swap cells + @ * \ ... a1[i][k]*a2[k][j]
     5 pick 4 pick * 3 pick + 5 pick swap cells +   \ ... &a3[i][j]
     dup @ rot + swap ! 
  drop loop drop loop drop loop                     \ a1 a2 N a3
  over 2swap drop-mat rot over drop-mat
;

\ raise NxN matrix a to p'th power using exponentiation by squaring
: mat-power ( a N p -- a N )
  dup 1 > if
     2 /mod 2swap dup-mat 4 roll recurse \ p%2 old_a N a^(p/2) N
     dup-mat *m                          \ p%2 old_a N a^(p/2)^2 N
     2swap 4 roll 0= if drop-mat         \ even p: return a^(p/2)^2
                     else *m then        \ odd p: return a^(p/2)^2*old_a
  else drop then \ for p <= 1, return a unchanged
;

\ The word fib raises matrix (1 1)(1 0) to n-1'st power
\ and returns the top left element of the result. Returns 0 if n was 0
: fib ( n1 -- n2 )
  dup 0= if 0 else                    \ return 0 if n1 is 0
  0 1 1 1 2 make-mat rot 1- mat-power \ raise (1 1)(1 0) to n-1'st
  over @ -rot drop-mat then           \ return a[0][0] and delete a
;

\ The word f takes care of the negative arguments and calls fib(abs n)
\ If n1 is negative and even, negates the result of fib
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f3a.fs <n>" cr then
;

main
bye

ALGORITHM 3B: FAST RECURSION
\ This program calculates the nth fibonacci number
\ using alrogirhtm 3B: fast recursion
\ 
\ compiled: N/A
\ executed: gforth f3b.fs n

\ the word fast-fib calculates a pair of fibonacci numbers according to
\ the recurrent relationship: 
\ F(2n-1) = F(n-1)^2 + F(n)^2
\ F(2n) = (2F(n-1) + F(n))F(n)
: fast-fib ( n -- n1 n2 )
  dup 0<= if drop 0 0 else
  dup 1 = if drop 0 1 else
  2 /mod recurse 2dup + 3 roll 0= if \ F(n-1), F(n), F(n+1)
     -rot 2dup dup * swap dup * + 2swap + rot * else
     rot over + rot tuck dup * -rot * rot dup * rot +
  then then then
; 

\ The word fib calls the recursive word fast-fib and returns the second 
\ of the two values it produces
: fib ( n1 -- n2 )
  fast-fib nip
;

\ The word f takes care of the negative arguments and calls fib(abs n)
\ If n1 is negative and even, negates the result of fib
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f3b.fs <n>" cr then
;

main
bye

ALGORITHM 3C: BINET'S FORMULA WITH ROUNDING
\ This program calculates the nth fibonacci number
\ using alrogirhtm 3C: Binet's formula with rounding
\ 
\ compiled: N/A
\ executed: gforth f3c.fs n

\ The word fib calculates the nth fibonacci number
\ as floor( phi^n/sqrt(5) + 1/2), where phi = (1+sqrt(5.0))/2;
: fib ( n1 -- n2 )
  s>f 5e fsqrt fdup 1e f+ f2/ frot f** fswap f/ fround f>s
;

\ The word f takes care of the negative arguments and calls fib(abs n)
\ If n1 is negative and even, negates the result of fib
: f ( n1 -- n2 )
  dup abs fib swap
  dup 0< swap 2 mod 0= and if negate then
;

\ The word fib_print prints the n'th Fibonacci number
: fib_print ( n -- )
  dup . ." th Fibonacci number is " f . cr
;

\ If only one command-line argument was given (argc==2) and the argument
\ can be converted to an integer, pass the number to fib_print
\ otherwise print the usage information
: main ( -- )
 argc @ 2 = 
 next-arg s>number?
 3 roll and if
     d>s fib_print else
     ." Usage: gforth ./f3c.fs " cr then
;

main
bye