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 inspector slots quotations
   4 sequences assocs math arrays inference effects shuffle
   5 continuations debugger classes.tuple namespaces vectors
   6 bit-arrays byte-arrays strings sbufs math.functions macros
   7 sequences.private combinators mirrors combinators.lib
   8 combinators.short-circuit ;
   9 IN: inverse
  10
  11 TUPLE: fail ;
  12 : fail ( -- * ) \ fail new throw ;
  13 M: fail summary drop "Unification failed" ;
  14
  15 : assure ( ? -- ) [ fail ] unless ;
  16
  17 : =/fail ( obj1 obj2 -- )
  18     = assure ;
  19
  20 ! Inverse of a quotation
  21
  22 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
  23
  24 : define-math-inverse ( word quot1 quot2 -- )
  25     pick 1quotation 3array "math-inverse" set-word-prop ;
  26
  27 : define-pop-inverse ( word n quot -- )
  28     >r dupd "pop-length" set-word-prop r>
  29     "pop-inverse" set-word-prop ;
  30
  31 TUPLE: no-inverse word ;
  32 : no-inverse ( word -- * ) \ no-inverse new throw ;
  33 M: no-inverse summary
  34     drop "The word cannot be used in pattern matching" ;
  35
  36 : next ( revquot -- revquot* first )
  37     dup empty?
  38     [ "Badly formed math inverse" throw ]
  39     [ unclip-slice ] if ;
  40
  41 : constant-word? ( word -- ? )
  42     stack-effect
  43     [ effect-out length 1 = ] keep
  44     effect-in length 0 = and ;
  45
  46 : assure-constant ( constant -- quot )
  47     dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
  48
  49 : swap-inverse ( math-inverse revquot -- revquot* quot )
  50     next assure-constant rot second [ swap ] swap 3compose ;
  51
  52 : pull-inverse ( math-inverse revquot const -- revquot* quot )
  53     assure-constant rot first compose ;
  54
  55 : ?word-prop ( word/object name -- value/f )
  56     over word? [ word-prop ] [ 2drop f ] if ;
  57
  58 : undo-literal ( object -- quot )
  59     [ =/fail ] curry ;
  60
  61 PREDICATE: normal-inverse < word "inverse" word-prop ;
  62 PREDICATE: math-inverse < word "math-inverse" word-prop ;
  63 PREDICATE: pop-inverse < word "pop-length" word-prop ;
  64 UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
  65
  66 : enough? ( stack word -- ? )
  67     dup deferred? [ 2drop f ] [
  68         [ >r length r> 1quotation infer effect-in >= ]
  69         [ 3drop f ] recover
  70     ] if ;
  71
  72 : fold-word ( stack word -- stack )
  73     2dup enough?
  74     [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
  75
  76 : fold ( quot -- folded-quot )
  77     [ { } swap [ fold-word ] each % ] [ ] make ;
  78
  79 : flattenable? ( object -- ? )
  80     { [ word? ] [ primitive? not ] [
  81         { "inverse" "math-inverse" "pop-inverse" }
  82         [ word-prop ] with contains? not
  83     ] } 1&& ;
  84
  85 : (flatten) ( quot -- )
  86     [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ;
  87
  88  : retain-stack-overflow? ( error -- ? )
  89     { "kernel-error" 14 f f } = ;
  90
  91 : flatten ( quot -- expanded )
  92     [ [ (flatten) ] [ ] make ] [
  93         dup retain-stack-overflow?
  94         [ drop "No inverse defined on recursive word" ] when
  95         throw
  96     ] recover ;
  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 drop "Inverse is undefined" throw ;
 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 ] keep
 116     "pop-inverse" word-prop compose call ;
 117
 118 : (undo) ( revquot -- )
 119     dup empty? [ drop ]
 120     [ unclip-slice inverse % (undo) ] if ;
 121
 122 : [undo] ( quot -- undo )
 123     flatten fold reverse [ (undo) ] [ ] make ;
 124
 125 MACRO: undo ( quot -- ) [undo] ;
 126
 127 ! Inverse of selected words
 128
 129 \ swap [ swap ] define-inverse
 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 [ >r pick r> =/fail ] define-inverse
 134 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 135
 136 \ >r [ r> ] define-inverse
 137 \ r> [ >r ] define-inverse
 138
 139 \ tuple>array [ >tuple ] define-inverse
 140 \ >tuple [ tuple>array ] define-inverse
 141 \ reverse [ reverse ] define-inverse
 142
 143 \ undo 1 [ [ call ] curry ] define-pop-inverse
 144 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
 145
 146 \ exp [ log ] define-inverse
 147 \ log [ exp ] define-inverse
 148 \ not [ not ] define-inverse
 149 \ sq [ sqrt ] define-inverse
 150 \ sqrt [ sq ] define-inverse
 151
 152 : assert-literal ( n -- n )
 153     dup [ word? ] keep symbol? not and
 154     [ "Literal missing in pattern matching" throw ] when ;
 155 \ + [ - ] [ - ] define-math-inverse
 156 \ - [ + ] [ - ] define-math-inverse
 157 \ * [ / ] [ / ] define-math-inverse
 158 \ / [ * ] [ / ] define-math-inverse
 159 \ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
 160
 161 \ ? 2 [
 162     [ assert-literal ] bi@
 163     [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
 164     2curry
 165 ] define-pop-inverse
 166
 167 DEFER: _
 168 \ _ [ drop ] define-inverse
 169
 170 : both ( object object -- object )
 171     dupd assert= ;
 172 \ both [ dup ] define-inverse
 173
 174 : assure-length ( seq length -- seq )
 175     over length =/fail ;
 176
 177 {
 178     { >array array? }
 179     { >vector vector? }
 180     { >fixnum fixnum? }
 181     { >bignum bignum? }
 182     { >bit-array bit-array? }
 183     { >float float? }
 184     { >byte-array byte-array? }
 185     { >string string? }
 186     { >sbuf sbuf? }
 187     { >quotation quotation? }
 188 } [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
 189
 190 ! These actually work on all seqs--should they?
 191 \ 1array [ 1 assure-length first ] define-inverse
 192 \ 2array [ 2 assure-length first2 ] define-inverse
 193 \ 3array [ 3 assure-length first3 ] define-inverse
 194 \ 4array [ 4 assure-length first4 ] define-inverse
 195
 196 \ first [ 1array ] define-inverse
 197 \ first2 [ 2array ] define-inverse
 198 \ first3 [ 3array ] define-inverse
 199 \ first4 [ 4array ] define-inverse
 200
 201 \ prefix [ unclip ] define-inverse
 202 \ unclip [ prefix ] define-inverse
 203 \ suffix [ dup but-last swap peek ] define-inverse
 204
 205 ! Constructor inverse
 206 : deconstruct-pred ( class -- quot )
 207     "predicate" word-prop [ dupd call assure ] curry ;
 208
 209 : slot-readers ( class -- quot )
 210     all-slots rest ! tail gets rid of delegate
 211     [ slot-spec-reader 1quotation [ keep ] curry ] map concat
 212     [ ] like [ drop ] compose ;
 213
 214 : ?wrapped ( object -- wrapped )
 215     dup wrapper? [ wrapped>> ] when ;
 216
 217 : boa-inverse ( class -- quot )
 218     [ deconstruct-pred ] keep slot-readers compose ;
 219
 220 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 221
 222 : empty-inverse ( class -- quot )
 223     deconstruct-pred
 224     [ tuple>array rest [ ] contains? [ fail ] when ]
 225     compose ;
 226
 227 \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
 228
 229 : writer>reader ( word -- word' )
 230     [ "writing" word-prop "slots" word-prop ] keep
 231     [ swap slot-spec-writer = ] curry find nip slot-spec-reader ;
 232
 233 : construct-inverse ( class setters -- quot )
 234     >r deconstruct-pred r>
 235     [ writer>reader ] map [ get-slots ] curry
 236     compose ;
 237
 238 \ construct 2 [ >r ?wrapped r> construct-inverse ] define-pop-inverse
 239
 240 ! More useful inverse-based combinators
 241
 242 : recover-fail ( try fail -- )
 243     [ drop call ] [
 244         >r nip r> dup fail?
 245         [ drop call ] [ nip throw ] if
 246     ] recover ; inline
 247
 248 : true-out ( quot effect -- quot' )
 249     effect-out [ ndrop ] curry
 250     [ t ] 3compose ;
 251
 252 : false-recover ( effect -- quot )
 253     effect-in [ ndrop f ] curry [ recover-fail ] curry ;
 254
 255 : [matches?] ( quot -- undoes?-quot )
 256     [undo] dup infer [ true-out ] keep false-recover curry ;
 257
 258 MACRO: matches? ( quot -- ? ) [matches?] ;
 259
 260 TUPLE: no-match ;
 261 : no-match ( -- * ) \ no-match new throw ;
 262 M: no-match summary drop "Fall through in switch" ;
 263
 264 : recover-chain ( seq -- quot )
 265     [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
 266
 267 : [switch]  ( quot-alist -- quot )
 268     [ dup quotation? [ [ ] swap 2array ] when ] map
 269     reverse [ >r [undo] r> compose ] { } assoc>map
 270     recover-chain ;
 271
 272 MACRO: switch ( quot-alist -- ) [switch] ;