Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

memoization

  • Loading branch information...
commit 9f6572117bf58e5d2534e5382fb5a0e1f0fc72a5 1 parent f26cbd1
Andres Raba authored

Showing 1 changed file with 121 additions and 0 deletions. Show diff stats Hide diff stats

  1. +121 0 3.3/3.27.scm
121 3.3/3.27.scm
... ... @@ -0,0 +1,121 @@
  1 +
  2 +(define (entry tree) (car tree))
  3 +
  4 +(define (left-branch tree) (cadr tree))
  5 +
  6 +(define (right-branch tree) (caddr tree))
  7 +
  8 +(define (make-tree entry left right)
  9 + (list entry left right))
  10 +
  11 +(define (same-key? key1 key2)
  12 + (define tolerance 0.01)
  13 + (if (and (number? key1) (number? key2))
  14 + (< (abs (- key1 key2)) tolerance)
  15 + (equal? key1 key2)))
  16 +
  17 +(define (lt key1 key2)
  18 + (compare < string<? key1 key2))
  19 +
  20 +(define (gt key1 key2)
  21 + (compare > string>? key1 key2))
  22 +
  23 +(define (compare numcomp strcomp key1 key2)
  24 + (if (and (number? key1) (number? key2))
  25 + (numcomp key1 key2)
  26 + (strcomp (tostring key1) (tostring key2))))
  27 +
  28 +(define (tostring val)
  29 + (cond ((string? val) val)
  30 + ((symbol? val) (symbol->string val))
  31 + ((number? val) (number->string val))
  32 + (else (error "tostring: argument must be an atom, given" val))))
  33 +
  34 +(define (make-table)
  35 + (let ((local-table (list '*table* (list 0))))
  36 + (define tablekey car)
  37 + (define value cdr)
  38 + (define (lookup key)
  39 + (assoc #f key 'void (cadr local-table)))
  40 + (define (insert! key val)
  41 + (assoc #t key val (cadr local-table))
  42 + 'ok)
  43 + ;; For both reading and writing the value under a key
  44 + ;; in associative map organized as a binary tree:
  45 + (define (assoc write? key val tree)
  46 + (cond ((and (number? (car tree))
  47 + (zero? (car tree)))
  48 + (if write?
  49 + (begin (set-car! tree (cons key val))
  50 + (set-cdr! tree (list (list 0) (list 0))))
  51 + false))
  52 + ((same-key? key (tablekey (entry tree)))
  53 + (if write?
  54 + (set-cdr! (entry tree) val)
  55 + (value (entry tree))))
  56 + ((lt key (tablekey (entry tree)))
  57 + (assoc write? key val (left-branch tree)))
  58 + ((gt key (tablekey (entry tree)))
  59 + (assoc write? key val (right-branch tree)))
  60 + (else (error "This location should be unreachable."))))
  61 + (define (dispatch m)
  62 + (cond ((eq? m 'lookup) lookup)
  63 + ((eq? m 'insert!) insert!)
  64 + ((eq? m 'table) local-table)
  65 + ((eq? m 'tree) (cadr local-table))
  66 + (else (error "Unknown operation - TABLE" m))))
  67 + dispatch))
  68 +
  69 +(define (lookup key table)
  70 + ((table 'lookup) key))
  71 +
  72 +(define (insert! key val table)
  73 + ((table 'insert!) key val))
  74 +
  75 +(define (fib n)
  76 + (cond ((= n 0) 0)
  77 + ((= n 1) 1)
  78 + (else (+ (fib (- n 1))
  79 + (fib (- n 2))))))
  80 +
  81 +(define memo-fib
  82 + (memoize (lambda (n)
  83 + (cond ((= n 0) 0)
  84 + ((= n 1) 1)
  85 + (else (+ (memo-fib (- n 1))
  86 + (memo-fib (- n 2))))))))
  87 +
  88 +(define (memoize f)
  89 + (let ((table (make-table)))
  90 + (lambda (x)
  91 + (let ((previously-computed-result (lookup x table)))
  92 + (or previously-computed-result
  93 + (let ((result (f x)))
  94 + (insert! x result table)
  95 + result))))))
  96 +
  97 +(memo-fib 200) ; 280571172992510140037611932413038677189525
  98 +;; Takes less than a second, while (memo-fib 40) without memoization
  99 +;; takes several minutes.
  100 +
  101 +;; The order of growth is O(n) because the algorithm only performs
  102 +;; a constant number of operations per n. First, it steps down the
  103 +;; leftmost branch until depth n. There, reaching the base cases n = 1
  104 +;; or n = 0, it tabulates the values, and steps back up. Then it evaluates
  105 +;; the local right branch memo-fib expression. But its argument is one
  106 +;; less than left branch argument, which means the same result is already
  107 +;; computed and tabulated in the previous step down the tree. It simply
  108 +;; gets the value from table, adds it to the left branch value, and
  109 +;; returns the sum as the next result up the tree. So the algorithm
  110 +;; performs at most two lookups, one recursive call to memo-fib and
  111 +;; one insert! at each node of the leftmost branch. Number of nodes is n.
  112 +
  113 +
  114 +(define memo-fib (memoize fib))
  115 +
  116 +(memo-fib 30)
  117 +
  118 +;; No, it won't work, because fib will call itself instead of memo-fib.
  119 +;; After calling (f x), which invokes (fib x), it inserts just one
  120 +;; result into the table. But this is already the final result after
  121 +;; the whole tree recursive process is finished.

0 comments on commit 9f65721

Please sign in to comment.
Something went wrong with that request. Please try again.