1 ! Copyright (C) 2007, 2010 Slava Pestov, Daniel Ehrenberg.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs definitions effects hashtables
4 kernel kernel.private math sequences sequences.private words ;
9 ! We can't use n*quot, narray and firstn from generalizations because
10 ! they're macros, and macros use memoize!
11 : (n*quot) ( n quot -- quotquot )
12 <repetition> [ ] concat-as ;
14 : [nsequence] ( length exemplar -- quot )
15 [ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
16 [ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
19 : [firstn] ( length -- quot )
21 [ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot)
24 : packer ( seq -- quot )
26 [ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ]
27 [ { } [nsequence] ] if ;
29 : unpacker ( seq -- quot )
31 [ { [ drop ] [ ] [ first2-unsafe ] [ first3-unsafe ] [ first4-unsafe ] } nth ]
32 [ [firstn] ] if swap 1 >
33 [ [ { array } declare ] prepose ] when ;
35 : pack/unpack ( quot effect -- newquot )
36 [ in>> packer ] [ out>> unpacker ] bi surround ;
38 : unpack/pack ( quot effect -- newquot )
39 [ in>> unpacker ] [ out>> packer ] bi surround ;
41 : make/n ( table quot effect -- quot )
42 [ unpack/pack '[ _ _ cache ] ] keep pack/unpack ;
44 : make/0 ( table quot effect -- quot )
47 _ dup first-unsafe [ second-unsafe ] [
49 1 pick set-nth-unsafe t 0 rot set-nth-unsafe
53 ] keep unpacker compose ;
55 : make-memoizer ( table quot effect -- quot )
56 dup in>> length zero? [ make/0 ] [ make/n ] if ;
60 : (define-memoized) ( word quot effect hashtable -- )
61 [ [ drop "memo-quot" set-word-prop ] ] dip
62 '[ 2drop _ "memoize" set-word-prop ]
63 [ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ]
66 : define-memoized ( word quot effect -- )
67 dup in>> length zero? [ f f 2array ] [ H{ } clone ] if
70 : define-identity-memoized ( word quot effect -- )
71 dup in>> length zero? [ f f 2array ] [ IH{ } clone ] if
74 PREDICATE: memoized < word "memoize" word-prop >boolean ;
77 def>> 3 from-tail swap ?nth hashtable?
78 \ MEMO: \ IDENTITY-MEMO: ? \ ; ;
80 M: memoized definition "memo-quot" word-prop ;
82 M: memoized reset-word
84 [ { "memoize" "memo-quot" } remove-word-props ]
87 : memoize-quot ( quot effect -- memo-quot )
88 dup in>> length zero? [ f f 2array ] [ H{ } clone ] if
91 : reset-memoized ( word -- )
92 "memoize" word-prop dup sequence?
93 [ f swap set-first ] [ clear-assoc ] if ;
95 : invalidate-memoized ( inputs... word -- )
96 [ stack-effect in>> packer call ]
98 "memoize" word-prop dup sequence?
99 [ f swap set-first ] [ delete-at ] if
103 \ invalidate-memoized t "no-compile" set-word-prop