basis/memoize/memoize.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel hashtables sequences sequences.private arrays
   4 words namespaces make parser effects.parser math assocs effects
   5 definitions quotations summary accessors fry hashtables.identity ;
   6 IN: memoize
   7
   8 <PRIVATE
   9
  10 ! We can't use n*quot, narray and firstn from generalizations because
  11 ! they're macros, and macros use memoize!
  12 : (n*quot) ( n quot -- quotquot )
  13     <repetition> [ ] concat-as ;
  14
  15 : [nsequence] ( length exemplar -- quot )
  16     [ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
  17     [ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
  18     [ nip ] 3append ;
  19
  20 : [firstn] ( length -- quot )
  21     [ 0 swap ] swap
  22     [ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot)
  23     [ 2drop ] 3append ;
  24
  25 : packer ( seq -- quot )
  26     length dup 4 <=
  27     [ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ]
  28     [ { } [nsequence] ] if ;
  29
  30 : unpacker ( seq -- quot )
  31     length dup 4 <=
  32     [ { [ drop ] [ ] [ first2-unsafe ] [ first3-unsafe ] [ first4-unsafe ] } nth ]
  33     [ [firstn] ] if ;
  34
  35 : pack/unpack ( quot effect -- newquot )
  36     [ in>> packer ] [ out>> unpacker ] bi surround ;
  37
  38 : unpack/pack ( quot effect -- newquot )
  39     [ in>> unpacker ] [ out>> packer ] bi surround ;
  40
  41 : make/n ( table quot effect -- quot )
  42     [ unpack/pack '[ _ _ cache ] ] keep pack/unpack ;
  43
  44 : make/0 ( table quot effect -- quot )
  45     out>> [
  46         packer '[
  47             _ dup first-unsafe
  48             [ nip ] [ @ @ [ 0 rot set-nth-unsafe ] keep ] if*
  49         ]
  50     ] keep unpacker compose ;
  51
  52 : make-memoizer ( table quot effect -- quot )
  53     dup in>> length zero? [ make/0 ] [ make/n ] if ;
  54
  55 PRIVATE>
  56
  57 : (define-memoized) ( word quot effect hashtable -- )
  58     [ [ drop "memo-quot" set-word-prop ] ] dip
  59     '[ 2drop _ "memoize" set-word-prop ]
  60     [ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ]
  61     3tri ;
  62
  63 : define-memoized ( word quot effect -- )
  64     dup in>> length zero? [ f 1array ] [ H{ } clone ] if
  65     (define-memoized) ;
  66
  67 : define-identity-memoized ( word quot effect -- )
  68     dup in>> length zero? [ f 1array ] [ IH{ } clone ] if
  69     (define-memoized) ;
  70
  71 SYNTAX: MEMO: (:) define-memoized ;
  72
  73 SYNTAX: IDENTITY-MEMO: (:) define-identity-memoized ;
  74
  75 PREDICATE: memoized < word "memoize" word-prop >boolean ;
  76
  77 M: memoized definer drop \ MEMO: \ ; ;
  78
  79 M: memoized definition "memo-quot" word-prop ;
  80
  81 M: memoized reset-word
  82     [ call-next-method ]
  83     [ { "memoize" "memo-quot" } reset-props ]
  84     bi ;
  85
  86 : memoize-quot ( quot effect -- memo-quot )
  87     [ H{ } clone ] 2dip make-memoizer ;
  88
  89 : reset-memoized ( word -- )
  90     "memoize" word-prop dup sequence?
  91     [ f swap set-first ] [ clear-assoc ] if ;
  92
  93 : invalidate-memoized ( inputs... word -- )
  94     [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
  95
  96 \ invalidate-memoized t "no-compile" set-word-prop