1 USING: kernel words inspector slots quotations sequences assocs
2 math arrays inference effects shuffle continuations debugger
3 classes.tuple namespaces vectors bit-arrays byte-arrays strings
4 sbufs math.functions macros sequences.private combinators
5 mirrors combinators.lib combinators.short-circuit ;
9 : fail ( -- * ) \ fail new throw ;
10 M: fail summary drop "Unification failed" ;
12 : assure ( ? -- ) [ fail ] unless ;
14 : =/fail ( obj1 obj2 -- )
17 ! Inverse of a quotation
19 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
21 : define-math-inverse ( word quot1 quot2 -- )
22 pick 1quotation 3array "math-inverse" set-word-prop ;
24 : define-pop-inverse ( word n quot -- )
25 >r dupd "pop-length" set-word-prop r>
26 "pop-inverse" set-word-prop ;
28 TUPLE: no-inverse word ;
29 : no-inverse ( word -- * ) \ no-inverse new throw ;
31 drop "The word cannot be used in pattern matching" ;
33 : next ( revquot -- revquot* first )
35 [ "Badly formed math inverse" throw ]
38 : constant-word? ( word -- ? )
40 [ effect-out length 1 = ] keep
41 effect-in length 0 = and ;
43 : assure-constant ( constant -- quot )
44 dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
46 : swap-inverse ( math-inverse revquot -- revquot* quot )
47 next assure-constant rot second [ swap ] swap 3compose ;
49 : pull-inverse ( math-inverse revquot const -- revquot* quot )
50 assure-constant rot first compose ;
52 : ?word-prop ( word/object name -- value/f )
53 over word? [ word-prop ] [ 2drop f ] if ;
55 : undo-literal ( object -- quot )
58 PREDICATE: normal-inverse < word "inverse" word-prop ;
59 PREDICATE: math-inverse < word "math-inverse" word-prop ;
60 PREDICATE: pop-inverse < word "pop-length" word-prop ;
61 UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
63 : enough? ( stack word -- ? )
64 dup deferred? [ 2drop f ] [
65 [ >r length r> 1quotation infer effect-in >= ]
69 : fold-word ( stack word -- stack )
71 [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
73 : fold ( quot -- folded-quot )
74 [ { } swap [ fold-word ] each % ] [ ] make ;
76 : flattenable? ( object -- ? )
77 { [ word? ] [ primitive? not ] [
78 { "inverse" "math-inverse" "pop-inverse" }
79 [ word-prop ] with contains? not
82 : (flatten) ( quot -- )
83 [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ;
85 : retain-stack-overflow? ( error -- ? )
86 { "kernel-error" 14 f f } = ;
88 : flatten ( quot -- expanded )
89 [ [ (flatten) ] [ ] make ] [
90 dup retain-stack-overflow?
91 [ drop "No inverse defined on recursive word" ] when
95 GENERIC: inverse ( revquot word -- revquot* quot )
97 M: object inverse undo-literal ;
99 M: symbol inverse undo-literal ;
101 M: word inverse drop "Inverse is undefined" throw ;
103 M: normal-inverse inverse
104 "inverse" word-prop ;
106 M: math-inverse inverse
107 "math-inverse" word-prop
108 swap next dup \ swap =
109 [ drop swap-inverse ] [ pull-inverse ] if ;
111 M: pop-inverse inverse
112 [ "pop-length" word-prop cut-slice swap >quotation ] keep
113 "pop-inverse" word-prop compose call ;
115 : (undo) ( revquot -- )
117 [ unclip-slice inverse % (undo) ] if ;
119 : [undo] ( quot -- undo )
120 flatten fold reverse [ (undo) ] [ ] make ;
122 MACRO: undo ( quot -- ) [undo] ;
124 ! Inverse of selected words
126 \ swap [ swap ] define-inverse
127 \ dup [ [ =/fail ] keep ] define-inverse
128 \ 2dup [ over =/fail over =/fail ] define-inverse
129 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
130 \ pick [ >r pick r> =/fail ] define-inverse
131 \ tuck [ swapd [ =/fail ] keep ] define-inverse
133 \ >r [ r> ] define-inverse
134 \ r> [ >r ] define-inverse
136 \ tuple>array [ >tuple ] define-inverse
137 \ >tuple [ tuple>array ] define-inverse
138 \ reverse [ reverse ] define-inverse
140 \ undo 1 [ [ call ] curry ] define-pop-inverse
141 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
143 \ exp [ log ] define-inverse
144 \ log [ exp ] define-inverse
145 \ not [ not ] define-inverse
146 \ sq [ sqrt ] define-inverse
147 \ sqrt [ sq ] define-inverse
149 : assert-literal ( n -- n )
150 dup [ word? ] keep symbol? not and
151 [ "Literal missing in pattern matching" throw ] when ;
152 \ + [ - ] [ - ] define-math-inverse
153 \ - [ + ] [ - ] define-math-inverse
154 \ * [ / ] [ / ] define-math-inverse
155 \ / [ * ] [ / ] define-math-inverse
156 \ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
159 [ assert-literal ] bi@
160 [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
165 \ _ [ drop ] define-inverse
167 : both ( object object -- object )
169 \ both [ dup ] define-inverse
171 : assure-length ( seq length -- seq )
179 { >bit-array bit-array? }
181 { >byte-array byte-array? }
184 { >quotation quotation? }
185 } [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
187 ! These actually work on all seqs--should they?
188 \ 1array [ 1 assure-length first ] define-inverse
189 \ 2array [ 2 assure-length first2 ] define-inverse
190 \ 3array [ 3 assure-length first3 ] define-inverse
191 \ 4array [ 4 assure-length first4 ] define-inverse
193 \ first [ 1array ] define-inverse
194 \ first2 [ 2array ] define-inverse
195 \ first3 [ 3array ] define-inverse
196 \ first4 [ 4array ] define-inverse
198 \ prefix [ unclip ] define-inverse
199 \ unclip [ prefix ] define-inverse
200 \ suffix [ dup but-last swap peek ] define-inverse
202 ! Constructor inverse
203 : deconstruct-pred ( class -- quot )
204 "predicate" word-prop [ dupd call assure ] curry ;
206 : slot-readers ( class -- quot )
207 all-slots rest ! tail gets rid of delegate
208 [ slot-spec-reader 1quotation [ keep ] curry ] map concat
209 [ ] like [ drop ] compose ;
211 : ?wrapped ( object -- wrapped )
212 dup wrapper? [ wrapped ] when ;
214 : boa-inverse ( class -- quot )
215 [ deconstruct-pred ] keep slot-readers compose ;
217 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
219 : empty-inverse ( class -- quot )
221 [ tuple>array rest [ ] contains? [ fail ] when ]
224 \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
226 : writer>reader ( word -- word' )
227 [ "writing" word-prop "slots" word-prop ] keep
228 [ swap slot-spec-writer = ] curry find nip slot-spec-reader ;
230 : construct-inverse ( class setters -- quot )
231 >r deconstruct-pred r>
232 [ writer>reader ] map [ get-slots ] curry
235 \ construct 2 [ >r ?wrapped r> construct-inverse ] define-pop-inverse
237 ! More useful inverse-based combinators
239 : recover-fail ( try fail -- )
242 [ drop call ] [ nip throw ] if
245 : true-out ( quot effect -- quot' )
246 effect-out [ ndrop ] curry
249 : false-recover ( effect -- quot )
250 effect-in [ ndrop f ] curry [ recover-fail ] curry ;
252 : [matches?] ( quot -- undoes?-quot )
253 [undo] dup infer [ true-out ] keep false-recover curry ;
255 MACRO: matches? ( quot -- ? ) [matches?] ;
258 : no-match ( -- * ) \ no-match new throw ;
259 M: no-match summary drop "Fall through in switch" ;
261 : recover-chain ( seq -- quot )
262 [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
264 : [switch] ( quot-alist -- quot )
265 [ dup quotation? [ [ ] swap 2array ] when ] map
266 reverse [ >r [undo] r> compose ] { } assoc>map
269 MACRO: switch ( quot-alist -- ) [switch] ;