1 ! Copyright (C) 2007, 2009 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel locals words summary slots quotations
4 sequences assocs math arrays stack-checker effects continuations
5 classes.tuple namespaces make vectors bit-arrays byte-arrays
6 strings sbufs math.functions macros sequences.private
7 combinators mirrors splitting combinators.smart
8 combinators.short-circuit fry words.symbol generalizations
9 sequences.generalizations classes ;
13 M: fail summary drop "Matching failed" ;
15 : assure ( ? -- ) [ fail ] unless ; inline
17 : =/fail ( obj1 obj2 -- ) = assure ; inline
19 ! Inverse of a quotation
21 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
23 : define-dual ( word1 word2 -- )
24 2dup swap [ 1quotation define-inverse ] 2bi@ ;
26 : define-involution ( word -- ) dup 1quotation define-inverse ;
28 : define-math-inverse ( word quot1 quot2 -- )
29 pick 1quotation 3array "math-inverse" set-word-prop ;
31 : define-pop-inverse ( word n quot -- )
32 [ dupd "pop-length" set-word-prop ] dip
33 "pop-inverse" set-word-prop ;
35 ERROR: no-inverse word ;
37 drop "The word cannot be used in pattern matching" ;
39 ERROR: bad-math-inverse ;
41 : next ( revquot -- revquot* first )
43 [ unclip-slice ] if-empty ;
45 : constant-word? ( word -- ? )
48 [ in>> empty? ] bi and ;
50 : assure-constant ( constant -- quot )
51 dup word? [ bad-math-inverse ] when 1quotation ;
53 : swap-inverse ( math-inverse revquot -- revquot* quot )
54 next assure-constant rot second '[ @ swap @ ] ;
56 : pull-inverse ( math-inverse revquot const -- revquot* quot )
57 assure-constant rot first compose ;
59 : ?word-prop ( word/object name -- value/f )
60 over word? [ word-prop ] [ 2drop f ] if ;
62 : undo-literal ( object -- quot ) [ =/fail ] curry ;
64 PREDICATE: normal-inverse < word "inverse" word-prop ;
65 PREDICATE: math-inverse < word "math-inverse" word-prop ;
66 PREDICATE: pop-inverse < word "pop-length" word-prop ;
67 UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
69 : enough? ( stack word -- ? )
70 dup deferred? [ 2drop f ] [
71 [ [ length ] [ 1quotation inputs ] bi* >= ]
75 : fold-word ( stack word -- stack )
77 [ 1quotation with-datastack ]
78 [ [ [ literalize , ] each ] [ , ] bi* { } ]
81 : fold ( quot -- folded-quot )
82 [ { } [ fold-word ] reduce % ] [ ] make ;
84 ERROR: no-recursive-inverse ;
88 : flattenable? ( object -- ? )
89 { [ word? ] [ primitive? not ] [
90 { "inverse" "math-inverse" "pop-inverse" }
91 [ word-prop ] with any? not
94 : flatten ( quot -- expanded )
96 visited [ over suffix ] change
100 [ visited get member-eq? [ no-recursive-inverse ] when ]
107 ERROR: undefined-inverse ;
109 GENERIC: inverse ( revquot word -- revquot* quot )
111 M: object inverse undo-literal ;
113 M: symbol inverse undo-literal ;
115 M: word inverse undefined-inverse ;
117 M: normal-inverse inverse
118 "inverse" word-prop ;
120 M: math-inverse inverse
121 "math-inverse" word-prop
122 swap next dup \ swap =
123 [ drop swap-inverse ] [ pull-inverse ] if ;
125 M: pop-inverse inverse
126 [ "pop-length" word-prop cut-slice swap >quotation ]
127 [ "pop-inverse" word-prop ] bi compose call( -- quot ) ;
129 : (undo) ( revquot -- )
130 [ unclip-slice inverse % (undo) ] unless-empty ;
132 : [undo] ( quot -- undo )
133 flatten fold reverse [ (undo) ] [ ] make ;
135 MACRO: undo ( quot -- ) [undo] ;
137 ! Inverse of selected words
139 \ swap define-involution
140 \ dup [ [ =/fail ] keep ] define-inverse
141 \ 2dup [ over =/fail over =/fail ] define-inverse
142 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
143 \ pick [ [ pick ] dip =/fail ] define-inverse
145 \ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
146 \ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
147 \ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
148 \ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
150 \ not define-involution
151 \ >boolean [ dup { t f } member-eq? assure ] define-inverse
153 \ tuple>array \ >tuple define-dual
154 \ reverse define-involution
156 \ undo 1 [ ] define-pop-inverse
157 \ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
159 \ exp \ log define-dual
160 \ sq \ sqrt define-dual
162 ERROR: missing-literal ;
164 : assert-literal ( n -- n )
166 [ word? ] [ symbol? not ] bi and
167 [ missing-literal ] when ;
168 \ + [ - ] [ - ] define-math-inverse
169 \ - [ + ] [ - ] define-math-inverse
170 \ * [ / ] [ / ] define-math-inverse
171 \ / [ * ] [ / ] define-math-inverse
172 \ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse
175 [ assert-literal ] bi@
176 [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
181 \ __ [ drop ] define-inverse
183 : both ( object object -- object )
185 \ both [ dup ] define-inverse
192 { >bit-array bit-array? }
194 { >byte-array byte-array? }
197 { >quotation quotation? }
198 } [ '[ dup _ execute assure ] define-inverse ] assoc-each
200 : assure-length ( seq length -- )
201 swap length =/fail ; inline
203 : assure-array ( array -- array )
204 dup array? assure ; inline
206 : undo-narray ( array n -- ... )
208 [ assure-length ] [ firstn ] 2bi ; inline
210 \ 1array [ 1 undo-narray ] define-inverse
211 \ 2array [ 2 undo-narray ] define-inverse
212 \ 3array [ 3 undo-narray ] define-inverse
213 \ 4array [ 4 undo-narray ] define-inverse
214 \ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
216 \ first [ 1array ] define-inverse
217 \ first2 [ 2array ] define-inverse
218 \ first3 [ 3array ] define-inverse
219 \ first4 [ 4array ] define-inverse
221 \ prefix \ unclip define-dual
222 \ suffix [ dup but-last swap last ] define-inverse
224 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
225 \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
227 : assure-same-class ( obj1 obj2 -- )
228 [ class ] bi@ = assure ; inline
230 \ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
231 \ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
235 :: undo-if-empty ( result a b -- seq )
236 a call( -- b ) result = [ { } ] [ result b [undo] call( a -- b ) ] if ;
238 :: undo-if* ( result a b -- boolean )
239 b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ;
241 \ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse
243 \ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse
245 ! Constructor inverse
246 : deconstruct-pred ( class -- quot )
247 "predicate" word-prop [ dupd call assure ] curry ;
249 : slot-readers ( class -- quot )
250 all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
252 : ?wrapped ( object -- wrapped )
253 dup wrapper? [ wrapped>> ] when ;
255 : boa-inverse ( class -- quot )
256 [ deconstruct-pred ] [ slot-readers ] bi compose ;
258 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
260 : empty-inverse ( class -- quot )
262 [ tuple>array rest [ ] any? [ fail ] when ]
265 \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
267 ! More useful inverse-based combinators
269 : recover-fail ( try fail -- )
271 [ nip ] dip dup fail?
272 [ drop call ] [ nip throw ] if
275 : true-out ( quot effect -- quot' )
276 out>> length '[ @ _ ndrop t ] ;
278 : false-recover ( effect -- quot )
279 in>> length [ ndrop f ] curry [ recover-fail ] curry ;
281 : [matches?] ( quot -- undoes?-quot )
282 [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
284 MACRO: matches? ( quot -- ? ) [matches?] ;
287 M: no-match summary drop "Fall through in switch" ;
289 : recover-chain ( seq -- quot )
290 [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
292 : [switch] ( quot-alist -- quot )
293 [ dup quotation? [ [ ] swap 2array ] when ] map
294 reverse [ [ [undo] ] dip compose ] { } assoc>map
297 MACRO: switch ( quot-alist -- ) [switch] ;