Initial import

private/lru-cache.rkt

@@ -0,0 +1,171 @@
+#lang racket/base
+
+(require racket/contract)
+
+(provide make-lru
+         lru?
+         lru-max-count
+         set-lru-max-count!
+         lru-expires?
+         lru-expire
+         set-lru-expire!
+         lru-has?
+         lru-add!
+         lru-count
+         lru->list
+         lru-clear
+         )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Struct
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-struct lru*
+  (cache
+   compare
+   [max-count #:mutable]
+   [expire-in-seconds #:mutable]
+   )
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Supporting functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (max-count? c)
+  (and (integer? c) (> c 0)))
+
+(define (larger-equal0? c)
+  (and (integer? c) (>= c 0)))
+
+(define (cmp-procedure? cmp-f)
+  (procedure? cmp-f))
+
+(define (expire? e)
+  (or (eq? e #f) (max-count? e)))
+
+(define (find-and-bubble count max-count e cache cmp expire-s current-s el)
+  (if (or (null? cache)
+          (>= count max-count))
+      '()
+      (let ((front (car cache)))
+        (if (and (not (eq? expire-s #f))
+                 (< (cadr front) expire-s))
+            (find-and-bubble count max-count e (cdr cache) cmp expire-s current-s el)
+            (if (cmp e (car front))
+                (find-and-bubble count max-count e (cdr cache) cmp expire-s current-s (car front))
+                (cons front
+                      (find-and-bubble (+ count 1) max-count
+                                       e (cdr cache) cmp expire-s current-s el))
+                )
+            )
+        )
+      )
+  )
+
+(define (find cache cmp-f el)
+  (if (null? cache)
+      #f
+      (if (cmp-f el (caar cache))
+          #t
+          (find (cdr cache) cmp-f el)
+          )
+      )
+  )
+
+(define (cleanup-expired lru)
+  (if (eq? (lru*-expire-in-seconds lru) #f)
+      'done
+      (let ((expire-s (- (current-seconds) (lru*-expire-in-seconds lru)))
+            (lcache (unbox (lru*-cache lru))))
+        (letrec ((f (λ (cache)
+                      (if (null? cache)
+                          '()
+                          (if (< (cadar cache) expire-s)
+                              (f (cdr cache))
+                              (cons (car cache) (f (cdr cache))))))))
+          (set-box! (lru*-cache lru) (f lcache)))
+        'cleaned)))
+
+(define (find-and/or-add lru el)
+  (let ((ncache (find-and-bubble
+                 1 (lru*-max-count lru)
+                 el (unbox (lru*-cache lru))
+                 (lru*-compare lru)
+                 (if (eq? (lru*-expire-in-seconds lru) #f)
+                     #f
+                     (- (current-seconds) (lru*-expire-in-seconds lru)))
+                 (current-seconds)
+                 #f)))
+    (set-box! (lru*-cache lru) (cons (list el (current-seconds)) ncache)))
+  lru)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Supporting functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define/contract (make-lru max-count #:cmp [compare equal?] #:expire [expire-in-seconds #f])
+  (->* (max-count?) (#:cmp cmp-procedure? #:expire expire?) lru*?)
+  (make-lru* (box '()) compare max-count expire-in-seconds))
+
+(define/contract (lru-has? lru el)
+  (-> lru*? any/c boolean?)
+  (cleanup-expired lru)
+  (find (unbox (lru*-cache lru)) (lru*-compare lru) el)
+  )
+
+(define/contract (lru-add! lru el)
+  (-> lru*? any/c lru*?)
+  (find-and/or-add lru el)
+  lru)
+
+(define/contract (lru-clear lru)
+  (-> lru*? lru*?)
+  (set-box! (lru*-cache lru) '())
+  lru)
+
+(define/contract (lru->list lru #:with-expire [we #f])
+  (->* (lru*?) (#:with-expire boolean?) list?)
+  (cleanup-expired lru)
+  (let ((c (current-seconds)))
+    (map (λ (e)
+           (if we
+               (list (car e) (- c (cadr e)))
+               (car e))) (unbox (lru*-cache lru))))
+  )
+
+(define/contract (lru-count lru)
+  (-> lru*? larger-equal0?)
+  (cleanup-expired lru)
+  (length (unbox (lru*-cache lru))))
+
+(define (lru? l)
+  (lru*? l))
+
+(define/contract (lru-max-count l)
+  (-> lru*? max-count?)
+  (lru*-max-count l))
+
+(define/contract (lru-expire l)
+  (-> lru*? expire?)
+  (lru*-expire-in-seconds l))
+
+(define/contract (set-lru-max-count! l c)
+  (-> lru*? max-count? lru*?)
+  (set-lru*-max-count! l c)
+  l)
+
+(define/contract (set-lru-expire! l e)
+  (-> lru*? expire? lru*?)
+  (set-lru*-expire-in-seconds! l e)
+  l)
+
+(define/contract (lru-expires? l)
+  (-> lru*? boolean?)
+  (let ((e (lru*-expire-in-seconds l)))
+    (if e
+        (and (integer? e) (> e 0))
+        #f)))
+   
+   
+