(module lru-cache mzscheme
	(provide lru-cache
		 lru-cache?
		 empty-lru-cache!
		 lru-cache-empty?
		 lru-cache+
		 lru-cache-find)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;=head1 LRU Cache
;;;
;;;This module gives an implementation of a thread safe
;;;Least Recently Used Cache. It is setup using a cyclic
;;;vector, i.e. a vector that is assigned in a cyclic way.
;;;Each new element in the cache is considered the least
;;;recently used element. If the full cache of elements is
;;;in use, each new element will overwrite the oldest (i.e.
;;;least used) element.
;;;
;;;The LRU Cache is searched lineairly for elements in the
;;;cache. Older elements will be reached slower, because
;;;the search is larger. A full search on a fully used
;;;cache vector, will go exactly two times through the
;;;vector of cached elements. The search is done recusivly.
;;;If an element is found, it will bubble up to the front
;;;of the cache. If it is needed again soon, next time it
;;;is needed, it will be in one of the first positions
;;;of the cache.
;;;
;;;=head2 Supportive macros and functions
;;;
;;;This section provides some simple macros. No explanation
;;;is given.
;;;
;;;=verbatim scm,8
(define-struct %lru-cache (type size sem vect index inuse))

(define-syntax lru-cache-type
  (syntax-rules ()
    ((_ cache)
     (%lru-cache-type cache))))

(define-syntax lru-cache-eq-type?
  (syntax-rules ()
    ((_ cache)
     (eq? (lru-cache-type cache) 'eq))))

(define-syntax lru-cache-size
  (syntax-rules ()
    ((_ cache)
     (%lru-cache-size cache))))

(define-syntax protect
  (syntax-rules ()
    ((_ cache body)
     (begin
       (semaphore-wait (%lru-cache-sem cache))
       (let ((r body))
	 (semaphore-post (%lru-cache-sem cache))
	 r)))))
;;;=verbatim
;;;
;;;=head2 Interface
;;;
;;;=head3 C<(lru-cache size ['equal]) : lru-cache>
;;;
;;;Returns a new lru-cache of size C<size> elements.
;;;If C<'equal> is provided as an arguments, comparisions
;;;on the keys of the cache will be done using C<equal?> instead
;;;of C<eq?>.
;;;
;;;=verbatim scm,8
(define (lru-cache size . args)
  (let ((type (if (null? args)
		  'eq
		  (if (eq? (car args) 'eq)
		      'eq
		      (if (eq? (car args) 'equal)
			  'equal
			  (error "lru-cache: invalid argument"))))))
    (make-%lru-cache type size (make-semaphore 1) (make-vector size) (- size 1) 0)))
;;;=verbatim
;;;
;;;=head3 C<(lru-cache? obj) : boolean>
;;;
;;;Returns #t, if obj is a lru cache.
;;;
;;;=verbatim scm,8
(define (lru-cache? obj)
  (%lru-cache? obj))
;;;=verbatim
;;;
;;;=head3 C<(empty-lru-cache! cache) : lru-cache>
;;;
;;;Clears cache and returns cache. This function is
;;;thread safe.
;;;
;;;=verbatim scm,8
(define (empty-lru-cache! cache)
  (protect cache
	   (let ((sem (%lru-cache-sem cache)))  ;;;(vector-ref cache 2)))
	     (let ((c (lru-cache (lru-cache-size cache) (lru-cache-type cache))))
	       (set-%lru-cache-vect! cache (%lru-cache-vect c))
	       (set-%lru-cache-index! cache (%lru-cache-index c))
	       (set-%lru-cache-inuse! cache (%lru-cache-inuse c))
	       cache))))
;;;=verbatim
;;;
;;;=head3 C<(lru-cache-empty? cache) : boolean>
;;;
;;;Returns #t, if the cache has no elements, #f otherwise.
;;;This function is not thread safe. This is however not
;;;important, as it returns a snapshot in time of the
;;;state of the lru-cache, that will only be of value
;;;in a context where concurrent access is not of importance.
;;;
;;;=verbatim scm,8
(define (lru-cache-empty? cache)
  (= (%lru-cache-inuse cache) 0))
;;;=verbatim
;;;
;;;=head3 C<(lru-cache+ cache key element) : cache>
;;;
;;;Adds element to the cache under key C<key>. This
;;;function is thread safe. The cache is protected
;;;using a critical section.
;;;
;;;=verbatim scm,8
(define (lru-cache+ cache key element)
  (protect cache
   (let ((index (%lru-cache-index cache))
	 (vect (%lru-cache-vect cache))
	 (size (lru-cache-size cache))
	 (inuse (%lru-cache-inuse cache)))
     (set! index (if (= index 0)
		     (- size 1)
		     (- index 1)))
     (set! inuse (if (= inuse size)
		     size
		     (+ inuse 1)))
     (vector-set! vect index (cons key element))
     (set-%lru-cache-index! cache index)
     (set-%lru-cache-inuse! cache inuse)
     cache)))
;;;=verbatim
;;;
;;;=head3 C<(lru-cache-find cache key) : #f | found element>
;;;
;;;This function will search key in cache. If it
;;;finds key, it will return the associated element.
;;;If it doesn't find key, it will return #f.
;;;
;;;=verbatim scm,8
(define (lru-cache-find cache key)
  (protect cache
   (let ((index (%lru-cache-index cache))
	 (inuse (%lru-cache-inuse cache))
	 (size (- (lru-cache-size cache) 1))
	 (vect (%lru-cache-vect cache))
	 (found #f)
	 (cmp (if (lru-cache-eq-type? cache)
		  eq?
		  equal?)))
     
     (define (find-and-bubble i previous-i N)
       (if (<= N 0)
	   #f
	   (if (cmp (car (vector-ref vect i)) key)
	       (let ((elem (vector-ref vect i)))
		 (if (= previous-i -1) 
		     elem
		     (begin
		       (vector-set! vect i (vector-ref vect previous-i))
		       elem)))
	       (let ((r (find-and-bubble (if (= i size) 
					     0
					     (+ i 1))
					 i
					 (- N 1))))
		 (if (not (eq? r #f))
		     (if (= previous-i -1)
			 (vector-set! vect i r)
			 (vector-set! vect i (vector-ref vect previous-i))))
		 r))))

     (let ((r (find-and-bubble index -1 inuse)))
       (if (eq? r #f)
	   #f
	   (cdr r))))))
;;;=verbatim
;;;
;;;=head2 Info
;;;
;;;S<C<Author(s):>> Hans Oesterholt-Dijkema (hansatelementalprogrammingdotorgextension).E<lb>
;;;S<C<Copyright:>> (c) 2005.E<lb>
;;;S<C<License  :>> L<Elemental Programming License|http://www.elemental-programming.org/epwiki/ep_license.html>.E<lb>
;;;S<C<File     :>> fifo.scm $Revision: 1.2 $
;;;
;;;=cut

		  

)