basis/memoize/memoize.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel hashtables sequences arrays words namespaces make
   4 parser math assocs effects definitions quotations summary
   5 accessors fry ;
   6 IN: memoize
   7
   8 ERROR: too-many-arguments ;
   9
  10 M: too-many-arguments summary
  11     drop "There must be no more than 4 input and 4 output arguments" ;
  12
  13 <PRIVATE
  14
  15 : packer ( seq -- quot )
  16     length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
  17
  18 : unpacker ( seq -- quot )
  19     length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
  20
  21 : pack/unpack ( quot effect -- newquot )
  22     [ in>> packer ] [ out>> unpacker ] bi surround ;
  23
  24 : unpack/pack ( quot effect -- newquot )
  25     [ in>> unpacker ] [ out>> packer ] bi surround ;
  26
  27 : check-memoized ( effect -- )
  28     [ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ;
  29
  30 : make-memoizer ( table quot effect -- quot )
  31     [ check-memoized ] keep
  32     [ unpack/pack '[ _ _ cache ] ] keep
  33     pack/unpack ;
  34
  35 PRIVATE>
  36
  37 : define-memoized ( word quot -- )
  38     [ H{ } clone ] dip
  39     [ pick stack-effect make-memoizer define ]
  40     [ nip "memo-quot" set-word-prop ]
  41     [ drop "memoize" set-word-prop ]
  42     3tri ;
  43
  44 SYNTAX: MEMO: (:) define-memoized ;
  45
  46 PREDICATE: memoized < word "memoize" word-prop ;
  47
  48 M: memoized definer drop \ MEMO: \ ; ;
  49
  50 M: memoized definition "memo-quot" word-prop ;
  51
  52 M: memoized reset-word
  53     [ call-next-method ]
  54     [ { "memoize" "memo-quot" } reset-props ]
  55     bi ;
  56
  57 : memoize-quot ( quot effect -- memo-quot )
  58     [ H{ } clone ] 2dip make-memoizer ;
  59
  60 : reset-memoized ( word -- )
  61     "memoize" word-prop clear-assoc ;
  62
  63 : invalidate-memoized ( inputs... word -- )
  64     [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;