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 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 M: lru-cache clone
  36     [ assoc>> clone ] [ dlist>> clone ] [ max-size>> ] tri
  37     lru-cache boa ;
  38
  39 TUPLE: fifo-cache < linked-assoc max-size ;
  40
  41 : <fifo-cache> ( max-size exemplar -- assoc )
  42     dupd new-assoc <dlist> rot fifo-cache boa ;
  43
  44 : <fifo-hash> ( max-size -- assoc )
  45     H{ } <fifo-cache> ;
  46
  47 M: fifo-cache set-at
  48     [ call-next-method ] keep dup max-size>> [
  49         over assoc>> assoc-size < [
  50             [ dlist>> pop-front first-unsafe ]
  51             [ assoc>> ]
  52             [ dlist>> ] tri (delete-at)
  53         ] [ drop ] if
  54     ] [ drop ] if* ;
  55
  56 M: fifo-cache clone
  57     [ assoc>> clone ] [ dlist>> clone ] [ max-size>> ] tri
  58     fifo-cache boa ;
  59
  60 TUPLE: lifo-cache < linked-assoc max-size ;
  61
  62 : <lifo-cache> ( max-size exemplar -- assoc )
  63     dupd new-assoc <dlist> rot lifo-cache boa ;
  64
  65 : <lifo-hash> ( max-size -- assoc )
  66     H{ } <lifo-cache> ;
  67
  68 M: lifo-cache set-at
  69     dup max-size>> [
  70         over assoc>> assoc-size <= [
  71             dup
  72             [ dlist>> pop-back first-unsafe ]
  73             [ assoc>> ]
  74             [ dlist>> ] tri (delete-at)
  75         ] when
  76     ] when* call-next-method ;
  77
  78 M: lifo-cache clone
  79     [ assoc>> clone ] [ dlist>> clone ] [ max-size>> ] tri
  80     lifo-cache boa ;