basis/inverse/inverse.factor

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