extra/inverse/inverse.factor

   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 qualified ;
   9 RENAME: _ fry => __
  10 IN: inverse
  11
  12 ERROR: fail ;
  13 M: fail summary drop "Unification failed" ;
  14
  15 : assure ( ? -- ) [ fail ] unless ;
  16
  17 : =/fail ( obj1 obj2 -- ) = assure ;
  18
  19 ! Inverse of a quotation
  20
  21 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
  22
  23 : define-math-inverse ( word quot1 quot2 -- )
  24     pick 1quotation 3array "math-inverse" set-word-prop ;
  25
  26 : define-pop-inverse ( word n quot -- )
  27     [ dupd "pop-length" set-word-prop ] dip
  28     "pop-inverse" set-word-prop ;
  29
  30 ERROR: no-inverse word ;
  31 M: no-inverse summary
  32     drop "The word cannot be used in pattern matching" ;
  33
  34 ERROR: bad-math-inverse ;
  35
  36 : next ( revquot -- revquot* first )
  37     [ bad-math-inverse ]
  38     [ unclip-slice ] if-empty ;
  39
  40 : constant-word? ( word -- ? )
  41     stack-effect
  42     [ out>> length 1 = ]
  43     [ in>> empty? ] bi and ;
  44
  45 : assure-constant ( constant -- quot )
  46     dup word? [ bad-math-inverse ] when 1quotation ;
  47
  48 : swap-inverse ( math-inverse revquot -- revquot* quot )
  49     next assure-constant rot second '[ @ swap @ ] ;
  50
  51 : pull-inverse ( math-inverse revquot const -- revquot* quot )
  52     assure-constant rot first compose ;
  53
  54 : ?word-prop ( word/object name -- value/f )
  55     over word? [ word-prop ] [ 2drop f ] if ;
  56
  57 : undo-literal ( object -- quot ) [ =/fail ] curry ;
  58
  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 ;
  63
  64 : enough? ( stack word -- ? )
  65     dup deferred? [ 2drop f ] [
  66         [ [ length ] dip 1quotation infer in>> >= ]
  67         [ 3drop f ] recover
  68     ] if ;
  69
  70 : fold-word ( stack word -- stack )
  71     2dup enough?
  72     [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
  73
  74 : fold ( quot -- folded-quot )
  75     [ { } swap [ fold-word ] each % ] [ ] make ;
  76
  77 : flattenable? ( object -- ? )
  78     { [ word? ] [ primitive? not ] [
  79         { "inverse" "math-inverse" "pop-inverse" }
  80         [ word-prop ] with contains? not
  81     ] } 1&& ;
  82
  83 : (flatten) ( quot -- )
  84     [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ;
  85
  86  : retain-stack-overflow? ( error -- ? )
  87     { "kernel-error" 14 f f } = ;
  88
  89 : flatten ( quot -- expanded )
  90     [ [ (flatten) ] [ ] make ] [
  91         dup retain-stack-overflow?
  92         [ drop "No inverse defined on recursive word" ] when
  93         throw
  94     ] recover ;
  95
  96 ERROR: undefined-inverse ;
  97
  98 GENERIC: inverse ( revquot word -- revquot* quot )
  99
 100 M: object inverse undo-literal ;
 101
 102 M: symbol inverse undo-literal ;
 103
 104 M: word inverse undefined-inverse ;
 105
 106 M: normal-inverse inverse
 107     "inverse" word-prop ;
 108
 109 M: math-inverse inverse
 110     "math-inverse" word-prop
 111     swap next dup \ swap =
 112     [ drop swap-inverse ] [ pull-inverse ] if ;
 113
 114 M: pop-inverse inverse
 115     [ "pop-length" word-prop cut-slice swap >quotation ]
 116     [ "pop-inverse" word-prop ] bi compose call ;
 117
 118 : (undo) ( revquot -- )
 119     [ unclip-slice inverse % (undo) ] unless-empty ;
 120
 121 : [undo] ( quot -- undo )
 122     flatten fold reverse [ (undo) ] [ ] make ;
 123
 124 MACRO: undo ( quot -- ) [undo] ;
 125
 126 ! Inverse of selected words
 127
 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
 134
 135 \ not [ not ] define-inverse
 136 \ >boolean [ { t f } memq? assure ] define-inverse
 137
 138 \ >r [ r> ] define-inverse
 139 \ r> [ >r ] define-inverse
 140
 141 \ tuple>array [ >tuple ] define-inverse
 142 \ >tuple [ tuple>array ] define-inverse
 143 \ reverse [ reverse ] define-inverse
 144
 145 \ undo 1 [ [ call ] curry ] define-pop-inverse
 146 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
 147
 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
 153
 154 ERROR: missing-literal ;
 155
 156 : assert-literal ( n -- n )
 157     dup
 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
 165
 166 \ ? 2 [
 167     [ assert-literal ] bi@
 168     [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
 169     2curry
 170 ] define-pop-inverse
 171
 172 DEFER: _
 173 \ _ [ drop ] define-inverse
 174
 175 : both ( object object -- object )
 176     dupd assert= ;
 177 \ both [ dup ] define-inverse
 178
 179 : assure-length ( seq length -- seq )
 180     over length =/fail ;
 181
 182 {
 183     { >array array? }
 184     { >vector vector? }
 185     { >fixnum fixnum? }
 186     { >bignum bignum? }
 187     { >bit-array bit-array? }
 188     { >float float? }
 189     { >byte-array byte-array? }
 190     { >string string? }
 191     { >sbuf sbuf? }
 192     { >quotation quotation? }
 193 } [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
 194
 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
 200
 201 \ first [ 1array ] define-inverse
 202 \ first2 [ 2array ] define-inverse
 203 \ first3 [ 3array ] define-inverse
 204 \ first4 [ 4array ] define-inverse
 205
 206 \ prefix [ unclip ] define-inverse
 207 \ unclip [ prefix ] define-inverse
 208 \ suffix [ dup but-last swap peek ] define-inverse
 209
 210 ! Constructor inverse
 211 : deconstruct-pred ( class -- quot )
 212     "predicate" word-prop [ dupd call assure ] curry ;
 213
 214 : slot-readers ( class -- quot )
 215     all-slots
 216     [ name>> reader-word 1quotation [ keep ] curry ] map concat
 217     [ ] like [ drop ] compose ;
 218
 219 : ?wrapped ( object -- wrapped )
 220     dup wrapper? [ wrapped>> ] when ;
 221
 222 : boa-inverse ( class -- quot )
 223     [ deconstruct-pred ] [ slot-readers ] bi compose ;
 224
 225 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 226
 227 : empty-inverse ( class -- quot )
 228     deconstruct-pred
 229     [ tuple>array rest [ ] contains? [ fail ] when ]
 230     compose ;
 231
 232 \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
 233
 234 ! More useful inverse-based combinators
 235
 236 : recover-fail ( try fail -- )
 237     [ drop call ] [
 238         [ nip ] dip dup fail?
 239         [ drop call ] [ nip throw ] if
 240     ] recover ; inline
 241
 242 : true-out ( quot effect -- quot' )
 243     out>> '[ @ __ ndrop t ] ;
 244
 245 : false-recover ( effect -- quot )
 246     in>> [ ndrop f ] curry [ recover-fail ] curry ;
 247
 248 : [matches?] ( quot -- undoes?-quot )
 249     [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
 250
 251 MACRO: matches? ( quot -- ? ) [matches?] ;
 252
 253 ERROR: no-match ;
 254 M: no-match summary drop "Fall through in switch" ;
 255
 256 : recover-chain ( seq -- quot )
 257     [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
 258
 259 : [switch]  ( quot-alist -- quot )
 260     [ dup quotation? [ [ ] swap 2array ] when ] map
 261     reverse [ [ [undo] ] dip compose ] { } assoc>map
 262     recover-chain ;
 263
 264 MACRO: switch ( quot-alist -- ) [switch] ;