haskeem-0.7.0: fibo.scm

; Fibonacci routines, good & bad: these also show how to use trace
; AAAAAND a super-spiffy memoize function, slicker'n snot onna log!
; $Id: fibo.scm,v 1.4 2009-06-04 06:20:58 uwe Exp $

; efficient Fibonacci function: use accumulator to calculate in linear time

(define (fibo n)
  (define (fibo-acc i a1 a2)
    (if (= i 1)
	a1
	(fibo-acc (- i 1) (+ a1 a2) a1)))
  (trace fibo-acc #t)
  (cond ((< n 1) 0)
	((= n 1) 1)
	(else (fibo-acc n 1 0))))

; inefficient Fibonacci function: straight from definition,
; but exponential time

(define (bad-fibo n)
  (cond ((< n 1) 0)
	((= n 1) 1)
	(else (+ (bad-fibo (- n 1)) (bad-fibo (- n 2))))))
(trace bad-fibo #t)

; identical to bad-fibo, defined just so that we have an independent
; copy to play with

(define (memo-fibo n)
  (cond ((< n 1) 0)
	((= n 1) 1)
	(else (+ (memo-fibo (- n 1)) (memo-fibo (- n 2))))))
(trace memo-fibo #t)

; cache access: a cache is a list of dotted-pairs, with the car of each
; pair being the argument (list), and the cdr being the function value.
; return (#t . fval) if found, (#f . #f) if not found

(define (get-cache cache in)
  (cond ((null? cache) (cons #f #f))
	((eqv? (caar cache) in) (cons #t (cdar cache)))
	(else (get-cache (cdr cache) in))))

; return a memoized version of the given function
; this memoize function is fully variadic, so it can be applied to a
; function of any number of arguments
; the limiting factor in using this is that the cache is a simple list,
; so searching it is linear-time

(define (memoize fn)
  (if (procedure? fn)
      (let ((cache ()))
	(lambda args
	  (let ((cval (get-cache cache args)))
	    (if (car cval)
		(cdr cval)
		(let ((nval (apply fn args)))
		  (set! cache (cons (cons args nval) cache))
		  nval)))))
      fn))

(write-string "Defined (fibo n), (bad-fibo n), and (memo-fibo n)\n"
	      "(bad-fibo) and (memo-fibo) act identically until you run\n"
	      "\n"
	      "\t(set! memo-fibo (memoize memo-fibo))\n"
	      "\n"
	      "then, shazam! (memo-fibo) will act just like (fibo)\n"
	      "(actually, even better)\n")