basis/inverse/inverse.factor

   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
   5 continuations debugger classes.tuple namespaces make vectors
   6 bit-arrays byte-arrays strings sbufs math.functions macros
   7 sequences.private combinators mirrors splitting combinators.smart
   8 combinators.short-circuit fry words.symbol generalizations
   9 classes ;
  10 IN: inverse
  11
  12 ERROR: fail ;
  13 M: fail summary drop "Matching failed" ;
  14
  15 : assure ( ? -- ) [ fail ] unless ; inline
  16
  17 : =/fail ( obj1 obj2 -- ) = assure ; inline
  18
  19 ! Inverse of a quotation
  20
  21 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
  22
  23 : define-dual ( word1 word2 -- )
  24     2dup swap [ 1quotation define-inverse ] 2bi@ ;
  25
  26 : define-involution ( word -- ) dup 1quotation define-inverse ;
  27
  28 : define-math-inverse ( word quot1 quot2 -- )
  29     pick 1quotation 3array "math-inverse" set-word-prop ;
  30
  31 : define-pop-inverse ( word n quot -- )
  32     [ dupd "pop-length" set-word-prop ] dip
  33     "pop-inverse" set-word-prop ;
  34
  35 ERROR: no-inverse word ;
  36 M: no-inverse summary
  37     drop "The word cannot be used in pattern matching" ;
  38
  39 ERROR: bad-math-inverse ;
  40
  41 : next ( revquot -- revquot* first )
  42     [ bad-math-inverse ]
  43     [ unclip-slice ] if-empty ;
  44
  45 : constant-word? ( word -- ? )
  46     stack-effect
  47     [ out>> length 1 = ]
  48     [ in>> empty? ] bi and ;
  49
  50 : assure-constant ( constant -- quot )
  51     dup word? [ bad-math-inverse ] when 1quotation ;
  52
  53 : swap-inverse ( math-inverse revquot -- revquot* quot )
  54     next assure-constant rot second '[ @ swap @ ] ;
  55
  56 : pull-inverse ( math-inverse revquot const -- revquot* quot )
  57     assure-constant rot first compose ;
  58
  59 : ?word-prop ( word/object name -- value/f )
  60     over word? [ word-prop ] [ 2drop f ] if ;
  61
  62 : undo-literal ( object -- quot ) [ =/fail ] curry ;
  63
  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 ;
  68
  69 : enough? ( stack word -- ? )
  70     dup deferred? [ 2drop f ] [
  71         [ [ length ] [ 1quotation infer in>> ] bi* >= ]
  72         [ 3drop f ] recover
  73     ] if ;
  74
  75 : fold-word ( stack word -- stack )
  76     2dup enough?
  77     [ 1quotation with-datastack ]
  78     [ [ [ literalize , ] each ] [ , ] bi* { } ]
  79     if ;
  80
  81 : fold ( quot -- folded-quot )
  82     [ { } [ fold-word ] reduce % ] [ ] make ;
  83
  84 ERROR: no-recursive-inverse ;
  85
  86 SYMBOL: visited
  87
  88 : flattenable? ( object -- ? )
  89     { [ word? ] [ primitive? not ] [
  90         { "inverse" "math-inverse" "pop-inverse" }
  91         [ word-prop ] with any? not
  92     ] } 1&& ;
  93
  94 : flatten ( quot -- expanded )
  95     [
  96         visited [ over suffix ] change
  97         [
  98             dup flattenable? [
  99                 def>>
 100                 [ visited get memq? [ no-recursive-inverse ] when ]
 101                 [ flatten ]
 102                 bi
 103             ] [ 1quotation ] if
 104         ] map concat
 105     ] with-scope ;
 106
 107 ERROR: undefined-inverse ;
 108
 109 GENERIC: inverse ( revquot word -- revquot* quot )
 110
 111 M: object inverse undo-literal ;
 112
 113 M: symbol inverse undo-literal ;
 114
 115 M: word inverse undefined-inverse ;
 116
 117 M: normal-inverse inverse
 118     "inverse" word-prop ;
 119
 120 M: math-inverse inverse
 121     "math-inverse" word-prop
 122     swap next dup \ swap =
 123     [ drop swap-inverse ] [ pull-inverse ] if ;
 124
 125 M: pop-inverse inverse
 126     [ "pop-length" word-prop cut-slice swap >quotation ]
 127     [ "pop-inverse" word-prop ] bi compose call( -- quot ) ;
 128
 129 : (undo) ( revquot -- )
 130     [ unclip-slice inverse % (undo) ] unless-empty ;
 131
 132 : [undo] ( quot -- undo )
 133     flatten fold reverse [ (undo) ] [ ] make ;
 134
 135 MACRO: undo ( quot -- ) [undo] ;
 136
 137 ! Inverse of selected words
 138
 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
 144 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 145
 146 \ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
 147 \ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
 148 \ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
 149 \ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
 150
 151 \ not define-involution
 152 \ >boolean [ dup { t f } memq? assure ] define-inverse
 153
 154 \ tuple>array \ >tuple define-dual
 155 \ reverse define-involution
 156
 157 \ undo 1 [ ] define-pop-inverse
 158 \ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
 159
 160 \ exp \ log define-dual
 161 \ sq \ sqrt define-dual
 162
 163 ERROR: missing-literal ;
 164
 165 : assert-literal ( n -- n )
 166     dup
 167     [ word? ] [ symbol? not ] bi and
 168     [ missing-literal ] when ;
 169 \ + [ - ] [ - ] define-math-inverse
 170 \ - [ + ] [ - ] define-math-inverse
 171 \ * [ / ] [ / ] define-math-inverse
 172 \ / [ * ] [ / ] define-math-inverse
 173 \ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse
 174
 175 \ ? 2 [
 176     [ assert-literal ] bi@
 177     [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
 178     2curry
 179 ] define-pop-inverse
 180
 181 DEFER: __
 182 \ __ [ drop ] define-inverse
 183
 184 : both ( object object -- object )
 185     dupd assert= ;
 186 \ both [ dup ] define-inverse
 187
 188 {
 189     { >array array? }
 190     { >vector vector? }
 191     { >fixnum fixnum? }
 192     { >bignum bignum? }
 193     { >bit-array bit-array? }
 194     { >float float? }
 195     { >byte-array byte-array? }
 196     { >string string? }
 197     { >sbuf sbuf? }
 198     { >quotation quotation? }
 199 } [ '[ dup _ execute assure ] define-inverse ] assoc-each
 200
 201 : assure-length ( seq length -- )
 202     swap length =/fail ; inline
 203
 204 : assure-array ( array -- array )
 205     dup array? assure ; inline
 206
 207 : undo-narray ( array n -- ... )
 208     [ assure-array ] dip
 209     [ assure-length ] [ firstn ] 2bi ; inline
 210
 211 \ 1array [ 1 undo-narray ] define-inverse
 212 \ 2array [ 2 undo-narray ] define-inverse
 213 \ 3array [ 3 undo-narray ] define-inverse
 214 \ 4array [ 4 undo-narray ] define-inverse
 215 \ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
 216
 217 \ first [ 1array ] define-inverse
 218 \ first2 [ 2array ] define-inverse
 219 \ first3 [ 3array ] define-inverse
 220 \ first4 [ 4array ] define-inverse
 221
 222 \ prefix \ unclip define-dual
 223 \ suffix [ dup but-last swap last ] define-inverse
 224
 225 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
 226 \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
 227
 228 : assure-same-class ( obj1 obj2 -- )
 229     [ class ] bi@ = assure ; inline
 230
 231 \ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
 232 \ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
 233
 234 ! conditionals
 235
 236 :: undo-if-empty ( result a b -- seq )
 237    a call( -- b ) result = [ { } ] [ result b [undo] call( a -- b ) ] if ;
 238
 239 :: undo-if* ( result a b -- boolean )
 240    b call( -- b ) result = [ f ] [ result a [undo] call( a -- b ) ] if ;
 241
 242 \ if-empty 2 [ swap [ undo-if-empty ] 2curry ] define-pop-inverse
 243
 244 \ if* 2 [ swap [ undo-if* ] 2curry ] define-pop-inverse
 245
 246 ! Constructor inverse
 247 : deconstruct-pred ( class -- quot )
 248     "predicate" word-prop [ dupd call assure ] curry ;
 249
 250 : slot-readers ( class -- quot )
 251     class-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
 252
 253 : ?wrapped ( object -- wrapped )
 254     dup wrapper? [ wrapped>> ] when ;
 255
 256 : boa-inverse ( class -- quot )
 257     [ deconstruct-pred ] [ slot-readers ] bi compose ;
 258
 259 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 260
 261 : empty-inverse ( class -- quot )
 262     deconstruct-pred
 263     [ tuple>array rest [ ] any? [ fail ] when ]
 264     compose ;
 265
 266 \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
 267
 268 ! More useful inverse-based combinators
 269
 270 : recover-fail ( try fail -- )
 271     [ drop call ] [
 272         [ nip ] dip dup fail?
 273         [ drop call ] [ nip throw ] if
 274     ] recover ; inline
 275
 276 : true-out ( quot effect -- quot' )
 277     out>> '[ @ _ ndrop t ] ;
 278
 279 : false-recover ( effect -- quot )
 280     in>> [ ndrop f ] curry [ recover-fail ] curry ;
 281
 282 : [matches?] ( quot -- undoes?-quot )
 283     [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
 284
 285 MACRO: matches? ( quot -- ? ) [matches?] ;
 286
 287 ERROR: no-match ;
 288 M: no-match summary drop "Fall through in switch" ;
 289
 290 : recover-chain ( seq -- quot )
 291     [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
 292
 293 : [switch]  ( quot-alist -- quot )
 294     [ dup quotation? [ [ ] swap 2array ] when ] map
 295     reverse [ [ [undo] ] dip compose ] { } assoc>map
 296     recover-chain ;
 297
 298 MACRO: switch ( quot-alist -- ) [switch] ;