basis/memoize/memoize.factor

   1 ! Copyright (C) 2007 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 ;
   6 IN: memoize
   7
   8 : packer ( n -- quot )
   9     { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
  10
  11 : unpacker ( n -- quot )
  12     { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
  13
  14 : #in ( word -- n )
  15     stack-effect in>> length ;
  16
  17 : #out ( word -- n )
  18     stack-effect out>> length ;
  19
  20 : pack/unpack ( quot word -- newquot )
  21     [ dup #in unpacker % swap % #out packer % ] [ ] make ;
  22
  23 : make-memoizer ( quot word -- quot )
  24     [
  25         [ #in packer % ] keep
  26         [ "memoize" word-prop , ] keep
  27         [ pack/unpack , ] keep
  28         \ cache ,
  29         #out unpacker %
  30     ] [ ] make ;
  31
  32 ERROR: too-many-arguments ;
  33
  34 M: too-many-arguments summary
  35     drop "There must be no more than 4 input and 4 output arguments" ;
  36
  37 : check-memoized ( word -- )
  38     dup #in 4 > swap #out 4 > or [ too-many-arguments ] when ;
  39
  40 : define-memoized ( word quot -- )
  41     over check-memoized
  42     2dup "memo-quot" set-word-prop
  43     over H{ } clone "memoize" set-word-prop
  44     over make-memoizer define ;
  45
  46 : MEMO: (:) define-memoized ; parsing
  47
  48 PREDICATE: memoized < word "memoize" word-prop ;
  49
  50 M: memoized definer drop \ MEMO: \ ; ;
  51
  52 M: memoized definition "memo-quot" word-prop ;
  53
  54 M: memoized reset-word
  55     [ call-next-method ]
  56     [ { "memoize" "memo-quot" } reset-props ]
  57     bi ;
  58
  59 : memoize-quot ( quot effect -- memo-quot )
  60     gensym swap dupd "declared-effect" set-word-prop
  61     dup rot define-memoized 1quotation ;
  62
  63 : reset-memoized ( word -- )
  64     "memoize" word-prop clear-assoc ;
  65
  66 : invalidate-memoized ( inputs... word -- )
  67     [ #in packer call ] [ "memoize" word-prop delete-at ] bi ;