1 ! Copyright (C) 2007, 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel words summary slots quotations
4 sequences assocs math arrays stack-checker effects generalizations
5 continuations debugger classes.tuple namespaces make vectors
6 bit-arrays byte-arrays strings sbufs math.functions macros
7 sequences.private combinators mirrors
8 combinators.short-circuit fry ;
13 M: fail summary drop "Unification failed" ;
15 : assure ( ? -- ) [ fail ] unless ;
17 : =/fail ( obj1 obj2 -- ) = assure ;
19 ! Inverse of a quotation
21 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
23 : define-math-inverse ( word quot1 quot2 -- )
24 pick 1quotation 3array "math-inverse" set-word-prop ;
26 : define-pop-inverse ( word n quot -- )
27 [ dupd "pop-length" set-word-prop ] dip
28 "pop-inverse" set-word-prop ;
30 ERROR: no-inverse word ;
32 drop "The word cannot be used in pattern matching" ;
34 ERROR: bad-math-inverse ;
36 : next ( revquot -- revquot* first )
38 [ unclip-slice ] if-empty ;
40 : constant-word? ( word -- ? )
43 [ in>> empty? ] bi and ;
45 : assure-constant ( constant -- quot )
46 dup word? [ bad-math-inverse ] when 1quotation ;
48 : swap-inverse ( math-inverse revquot -- revquot* quot )
49 next assure-constant rot second '[ @ swap @ ] ;
51 : pull-inverse ( math-inverse revquot const -- revquot* quot )
52 assure-constant rot first compose ;
54 : ?word-prop ( word/object name -- value/f )
55 over word? [ word-prop ] [ 2drop f ] if ;
57 : undo-literal ( object -- quot ) [ =/fail ] curry ;
59 PREDICATE: normal-inverse < word "inverse" word-prop ;
60 PREDICATE: math-inverse < word "math-inverse" word-prop ;
61 PREDICATE: pop-inverse < word "pop-length" word-prop ;
62 UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
64 : enough? ( stack word -- ? )
65 dup deferred? [ 2drop f ] [
66 [ [ length ] dip 1quotation infer in>> >= ]
70 : fold-word ( stack word -- stack )
72 [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
74 : fold ( quot -- folded-quot )
75 [ { } swap [ fold-word ] each % ] [ ] make ;
77 : flattenable? ( object -- ? )
78 { [ word? ] [ primitive? not ] [
79 { "inverse" "math-inverse" "pop-inverse" }
80 [ word-prop ] with contains? not
83 : (flatten) ( quot -- )
84 [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ;
86 : retain-stack-overflow? ( error -- ? )
87 { "kernel-error" 14 f f } = ;
89 : flatten ( quot -- expanded )
90 [ [ (flatten) ] [ ] make ] [
91 dup retain-stack-overflow?
92 [ drop "No inverse defined on recursive word" ] when
96 ERROR: undefined-inverse ;
98 GENERIC: inverse ( revquot word -- revquot* quot )
100 M: object inverse undo-literal ;
102 M: symbol inverse undo-literal ;
104 M: word inverse undefined-inverse ;
106 M: normal-inverse inverse
107 "inverse" word-prop ;
109 M: math-inverse inverse
110 "math-inverse" word-prop
111 swap next dup \ swap =
112 [ drop swap-inverse ] [ pull-inverse ] if ;
114 M: pop-inverse inverse
115 [ "pop-length" word-prop cut-slice swap >quotation ]
116 [ "pop-inverse" word-prop ] bi compose call ;
118 : (undo) ( revquot -- )
119 [ unclip-slice inverse % (undo) ] unless-empty ;
121 : [undo] ( quot -- undo )
122 flatten fold reverse [ (undo) ] [ ] make ;
124 MACRO: undo ( quot -- ) [undo] ;
126 ! Inverse of selected words
128 \ swap [ swap ] define-inverse
129 \ dup [ [ =/fail ] keep ] define-inverse
130 \ 2dup [ over =/fail over =/fail ] define-inverse
131 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
132 \ pick [ [ pick ] dip =/fail ] define-inverse
133 \ tuck [ swapd [ =/fail ] keep ] define-inverse
135 \ not [ not ] define-inverse
136 \ >boolean [ { t f } memq? assure ] define-inverse
138 \ >r [ r> ] define-inverse
139 \ r> [ >r ] define-inverse
141 \ tuple>array [ >tuple ] define-inverse
142 \ >tuple [ tuple>array ] define-inverse
143 \ reverse [ reverse ] define-inverse
145 \ undo 1 [ [ call ] curry ] define-pop-inverse
146 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
148 \ exp [ log ] define-inverse
149 \ log [ exp ] define-inverse
150 \ not [ not ] define-inverse
151 \ sq [ sqrt ] define-inverse
152 \ sqrt [ sq ] define-inverse
154 ERROR: missing-literal ;
156 : assert-literal ( n -- n )
158 [ word? ] [ symbol? not ] bi and
159 [ missing-literal ] when ;
160 \ + [ - ] [ - ] define-math-inverse
161 \ - [ + ] [ - ] define-math-inverse
162 \ * [ / ] [ / ] define-math-inverse
163 \ / [ * ] [ / ] define-math-inverse
164 \ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
167 [ assert-literal ] bi@
168 [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
173 \ _ [ drop ] define-inverse
175 : both ( object object -- object )
177 \ both [ dup ] define-inverse
179 : assure-length ( seq length -- seq )
187 { >bit-array bit-array? }
189 { >byte-array byte-array? }
192 { >quotation quotation? }
193 } [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
195 ! These actually work on all seqs--should they?
196 \ 1array [ 1 assure-length first ] define-inverse
197 \ 2array [ 2 assure-length first2 ] define-inverse
198 \ 3array [ 3 assure-length first3 ] define-inverse
199 \ 4array [ 4 assure-length first4 ] define-inverse
201 \ first [ 1array ] define-inverse
202 \ first2 [ 2array ] define-inverse
203 \ first3 [ 3array ] define-inverse
204 \ first4 [ 4array ] define-inverse
206 \ prefix [ unclip ] define-inverse
207 \ unclip [ prefix ] define-inverse
208 \ suffix [ dup but-last swap peek ] define-inverse
210 ! Constructor inverse
211 : deconstruct-pred ( class -- quot )
212 "predicate" word-prop [ dupd call assure ] curry ;
214 : slot-readers ( class -- quot )
216 [ name>> reader-word 1quotation [ keep ] curry ] map concat
217 [ ] like [ drop ] compose ;
219 : ?wrapped ( object -- wrapped )
220 dup wrapper? [ wrapped>> ] when ;
222 : boa-inverse ( class -- quot )
223 [ deconstruct-pred ] [ slot-readers ] bi compose ;
225 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
227 : empty-inverse ( class -- quot )
229 [ tuple>array rest [ ] contains? [ fail ] when ]
232 \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
234 ! More useful inverse-based combinators
236 : recover-fail ( try fail -- )
238 [ nip ] dip dup fail?
239 [ drop call ] [ nip throw ] if
242 : true-out ( quot effect -- quot' )
243 out>> '[ @ __ ndrop t ] ;
245 : false-recover ( effect -- quot )
246 in>> [ ndrop f ] curry [ recover-fail ] curry ;
248 : [matches?] ( quot -- undoes?-quot )
249 [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
251 MACRO: matches? ( quot -- ? ) [matches?] ;
254 M: no-match summary drop "Fall through in switch" ;
256 : recover-chain ( seq -- quot )
257 [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
259 : [switch] ( quot-alist -- quot )
260 [ dup quotation? [ [ ] swap 2array ] when ] map
261 reverse [ [ [undo] ] dip compose ] { } assoc>map
264 MACRO: switch ( quot-alist -- ) [switch] ;