extra/lru-cache/lru-cache.factor

   1 ! Copyright (C) 2017 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors assocs deques dlists fry kernel linked-assocs
   5 linked-assocs.private math sequences.private ;
   6
   7 IN: lru-cache
   8
   9 TUPLE: lru-cache < linked-assoc max-size ;
  10
  11 : <lru-cache> ( max-size exemplar -- assoc )
  12     dupd new-assoc <dlist> rot lru-cache boa ;
  13
  14 : <lru-hash> ( max-size -- assoc )
  15     H{ } <lru-cache> ;
  16
  17 M: lru-cache at*
  18     [ assoc>> at* ] [ dlist>> dup ] bi '[
  19         [
  20             [ _ delete-node ]
  21             [ _ push-node-back ]
  22             [ obj>> second-unsafe ] tri
  23         ] when
  24     ] keep ;
  25
  26 M: lru-cache set-at
  27     [ call-next-method ] keep dup max-size>> [
  28         over assoc>> assoc-size < [
  29             [ dlist>> pop-front first-unsafe ]
  30             [ assoc>> ]
  31             [ dlist>> ] tri (delete-at)
  32         ] [ drop ] if
  33     ] [ drop ] if* ;
  34
  35 TUPLE: fifo-cache < linked-assoc max-size ;
  36
  37 : <fifo-cache> ( max-size exemplar -- assoc )
  38     dupd new-assoc <dlist> rot fifo-cache boa ;
  39
  40 : <fifo-hash> ( max-size -- assoc )
  41     H{ } <fifo-cache> ;
  42
  43 M: fifo-cache set-at
  44     [ call-next-method ] keep dup max-size>> [
  45         over assoc>> assoc-size < [
  46             [ dlist>> pop-front first-unsafe ]
  47             [ assoc>> ]
  48             [ dlist>> ] tri (delete-at)
  49         ] [ drop ] if
  50     ] [ drop ] if* ;
  51
  52 TUPLE: lifo-cache < linked-assoc max-size ;
  53
  54 : <lifo-cache> ( max-size exemplar -- assoc )
  55     dupd new-assoc <dlist> rot lifo-cache boa ;
  56
  57 : <lifo-hash> ( max-size -- assoc )
  58     H{ } <lifo-cache> ;
  59
  60 M: lifo-cache set-at
  61     dup max-size>> [
  62         over assoc>> assoc-size <= [
  63             dup
  64             [ dlist>> pop-back first-unsafe ]
  65             [ assoc>> ]
  66             [ dlist>> ] tri (delete-at)
  67         ] when
  68     ] when* call-next-method ;