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