extra/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 ;
   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-compound ;
  41
  42 : MEMO:
  43     CREATE dup reset-generic parse-definition define-memoized ; parsing
  44
  45 PREDICATE: compound memoized "memoize" word-prop ;
  46
  47 M: memoized definer drop \ MEMO: \ ; ;
  48 M: memoized definition "memo-quot" word-prop ;