unmaintained/isequences/base/base.factor

   1 ! Copyright (C) 2007 Robbert van Dalen.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4
   5 IN: isequences.base
   6 USING: generic kernel math math.functions sequences
   7 isequences.interface shuffle ;
   8
   9 : index-error ( -- * )
  10     "index out of bounds" throw ; foldable
  11
  12 : traversal-error ( -- * )
  13     "traversal error" throw ; foldable
  14
  15 : to-sequence ( s -- s )
  16     dup i-length 0 <
  17     [ -- to-sequence reverse ]
  18     [ dup [ swap i-at ] swap add* swap i-length swap map ]
  19     if ; inline
  20
  21 : neg? ( s -- ? ) i-length 0 < ; foldable
  22
  23 : is-atom? ( seq -- ? )
  24     dup 0 i-at eq? ;
  25
  26 : twice ( n -- n )
  27     dup + ; inline
  28
  29 : 2size ( s1 s2 -- s1 s2 size1 size2 )
  30     2dup [ i-length ] 2apply ; inline
  31
  32 : rindex ( s n -- s n )
  33     swap dup i-length rot - ; inline
  34
  35 : left-right ( s -- left right )
  36     [ ileft ] keep iright ; inline
  37
  38 : (i-at) ( s i -- v )
  39     i-length swap dup ileft dup i-length roll 2dup <=
  40     [ swap - rot iright swap ]
  41     [ nip ]
  42     if i-at nip ; inline
  43
  44 : (ihead2) ( s i -- h )
  45     swap dup ileft dup i-length roll 2dup =
  46     [ 2drop nip ]
  47     [ 2dup < [ swap - rot iright swap ihead ++ ] [ nip ihead nip ] if ]
  48     if ; inline
  49
  50 : (ihead) ( s i -- h )
  51     dup pick i-length = [ drop ] [ (ihead2) ] if ; inline
  52
  53 : (itail3) ( s i -- h )
  54     swap left-right swap dup i-length roll 2dup =
  55     [ 3drop ]
  56     [ 2dup < [ swap - nip itail ] [ nip itail swap ++ ] if ]
  57     if ; inline
  58
  59 : (itail2) ( s sl i -- t )
  60     tuck = [ 2drop 0 ] [ (itail3) ] if ; inline
  61
  62 : (itail) ( s i -- t )
  63     over i-length dup >r 1 =
  64     [ r> drop 1 = [ drop 0 ] when ] [ r> swap (itail2) ] if ;
  65
  66
  67 : PRIME1 ( -- prime1 ) HEX: 58ea12c9 ; foldable
  68 : PRIME2 ( -- prime2 ) HEX: 79af7bc3 ; foldable
  69
  70 : hh ( fixnum-h -- fixnum-h )
  71     PRIME1 * PRIME2 + >fixnum ; inline
  72
  73 : quick-hash ( fixnum-h1 fixnum-h2 -- fixnum-h )
  74     [ hh ] 2apply bitxor hh ; inline
  75
  76 : ($$) ( s -- hash )
  77     left-right [ $$ ] 2apply quick-hash ; inline
  78
  79 : (ig1) ( s1 s2 -- s )
  80     >r left-right 2size <
  81     [ dup >r ileft ipair r> iright r> ++ ipair ]
  82     [ r> ++ ipair ] if ; inline
  83
  84 : (ig2) ( s1 s2 -- s )
  85     left-right 2size >
  86     [ >r dup >r ileft ++ r> iright r> ipair ipair ]
  87     [ >r ++ r> ipair ] if ; inline
  88
  89 : (ig3) ( s1 s2 size1 size2 -- s )
  90     2dup twice >=
  91     [ 2drop (ig1) ]
  92     [ swap twice >= [ (ig2) ] [ ipair ] if ] if ; inline
  93
  94 : ++g++ ( s1 s2 -- s )
  95     dup i-length dup zero?
  96     [ 2drop ]
  97     [ pick i-length dup zero? [ 2drop nip ] [ swap (ig3) ] if ] if ; inline
  98
  99 : ++g+- ( s1 s2 -- s )
 100     2size + dup 0 <
 101     [ neg swap -- swap rindex itail -- nip ]
 102     [ nip ihead ]
 103     if ; inline
 104
 105 : ++g-+ ( s1 s2 -- s )
 106     2size + dup 0 <
 107     [ nip swap -- swap neg ihead -- ]
 108     [ rindex itail nip ]
 109     if ; inline
 110
 111 : ++g-- ( s1 s2 -- s )
 112     -- swap -- swap ++ -- ; inline
 113
 114 : ++g ( s1 s2 -- s )
 115     2dup [ neg? ] 2apply
 116     [ [ ++g-- ] [ ++g+- ] if ] [ [ ++g-+ ] [ ++g++ ] if ] if ;
 117
 118
 119 ! #### lazy negative isequence ####
 120 !
 121 TUPLE: ineg sequence ;
 122
 123 M: ineg -- ineg-sequence ;
 124 M: ineg i-length ineg-sequence i-length neg ;
 125 M: ineg i-at i-length dup 0 <= [ neg swap -- swap i-at ] [ index-error ] if ;
 126 M: ineg ileft -- iright -- ;
 127 M: ineg iright -- ileft -- ;
 128 M: ineg ihead [ -- ] 2apply ihead -- ;
 129 M: ineg itail [ -- ] 2apply itail -- ;
 130 M: ineg $$ ineg-sequence $$ neg ;
 131
 132 TUPLE: irev sequence ;
 133
 134 : <i-rev>
 135     dup i-length 1 > [ <irev> ] when ; inline
 136
 137 M: irev i-at swap irev-sequence swap i-length over i-length - 1+ neg i-at ;
 138 M: irev i-length irev-sequence i-length ;
 139 M: irev ileft irev-sequence iright `` ;
 140 M: irev iright irev-sequence ileft `` ;
 141 M: irev ihead >r irev-sequence r> rindex itail `` ;
 142 M: irev itail >r irev-sequence r> rindex ihead `` ;
 143 M: irev $$ irev-sequence neg hh ;
 144
 145 M: irev descending? irev-sequence ascending? ;
 146 M: irev ascending? irev-sequence descending? ;
 147
 148 M: object `` <i-rev> ;
 149 M: ineg `` -- `` -- ;
 150 M: integer `` ;
 151 M: irev `` irev-sequence ;
 152
 153 ! #### composite isequence (size-balanced binary tree) ####
 154 !
 155 TUPLE: ibranch left right size ;
 156
 157 : <isequence> ( s1 s2 -- s )
 158     2size + <ibranch> ; inline
 159
 160 M: ibranch i-length ibranch-size ;
 161 M: ibranch i-at (i-at) ;
 162 M: ibranch iright ibranch-right ;
 163 M: ibranch ileft ibranch-left ;
 164 M: ibranch ihead (ihead) ;
 165 M: ibranch itail (itail) ;
 166 M: ibranch $$ ($$) ;
 167
 168
 169 ! #### object isequence ####
 170 !
 171 GENERIC: object/++ ( s1 s2 -- s )
 172 GENERIC: object/ipair ( s1 s2 -- s )
 173
 174 M: object object/++ swap ++g ;
 175 M: object object/ipair swap <isequence> ;
 176 M: object ++ swap object/++ ;
 177 M: object ipair swap object/ipair ;
 178
 179 M: object i-length drop 1 ;
 180 M: object -- <ineg> ;
 181 M: object i-at i-length zero? [ index-error ] unless ;
 182 M: object ileft drop 0 ;
 183 M: object iright drop 0 ;
 184 M: object ihead dup zero? [ 2drop 0 ] [ 1 = [ index-error ] unless ] if ;
 185 M: object itail dup zero? [ drop ] [ 1 = [ drop 0 ] [ index-error ] if ] if ;
 186
 187
 188 ! #### single element isequence ####
 189 !
 190 TUPLE: ileaf value ;
 191
 192 : <i> ( v -- s ) <ileaf> ; inline
 193
 194 M: ileaf i-at i-length zero? [ ileaf-value ] [ index-error ] if ;
 195 M: ileaf $$ 0 i-at $$ ;
 196
 197
 198 ! #### integer isequence ####
 199 !
 200
 201 GENERIC: integer/++ ( s1 s2 -- v )
 202 M: object integer/++ object/++ ;
 203 M: integer ++ swap integer/++ ;
 204
 205 GENERIC: integer/ipair ( s1 s2 -- s )
 206 M: object integer/ipair swap <isequence> ;
 207 M: integer ipair swap integer/ipair ;
 208
 209 M: integer integer/++ + ;
 210 M: integer integer/ipair + ;
 211
 212 M: integer i-length ;
 213 M: integer -- neg ;
 214 M: integer i-at i-length dup 0 >= [ > [ 0 ] [ index-error ] if ] [ index-error ] if ;
 215 M: integer ileft
 216     dup zero? [ traversal-error ] [ 2/ ] if ;
 217 M: integer iright
 218     dup zero? [ traversal-error ] [ 1+ 2/ ] if ;
 219 M: integer ihead swap drop ;
 220 M: integer itail - ;
 221 M: integer $$ >fixnum ;
 222
 223
 224 ! #### negative integers ####
 225 !
 226 PREDICATE: integer ninteger 0 < ;
 227
 228 M: ninteger i-at i-length dup 0 <= [ < [ 0 ] [ index-error ] if ] [ index-error ] if ;
 229
 230
 231 ! #### sequence -> isequence ####
 232 !
 233
 234 : chk-index dup zero? [ traversal-error ] [ 2/ ] if ; inline
 235
 236 M: sequence i-length length ;
 237 M: sequence i-at i-length swap nth ;
 238 M: sequence ileft dup length chk-index head ;
 239 M: sequence iright dup length chk-index tail ;
 240 M: sequence ihead head ;
 241 M: sequence itail tail ;
 242 M: sequence $$ [ $$ ] map unclip [ quick-hash ] reduce ;
 243
 244
 245 ! #### (natural) compare/ordering ####
 246
 247 DEFER: (i-eq?)
 248
 249 : (i-eq4?) ( s1 s2 -- ? )
 250    2dup [ is-atom? ] 2apply
 251    [ [ = ] [ 2drop f ] if ]
 252    [ [ 2drop f ] [ [ 0 i-at ] 2apply (i-eq?) ] if ] if ;
 253
 254 : (i-eq3?) ( s1 s2 -- ? )
 255     dup ileft pick over i-length tuck ihead rot (i-eq?)
 256     [ itail swap iright swap (i-eq?) ]
 257     [ 3drop f ]
 258     if ;
 259
 260 : (i-eq2?) ( s1 s2 sl -- ? )
 261     dup zero? [ 3drop 0 ]
 262     [ 1 = [ (i-eq4?) ] [ (i-eq3?) ] if ]
 263     if ; inline
 264
 265 : (i-eq?) ( s1 s2 -- ? )
 266     2dup eq? [ 2drop t ]
 267     [ 2dup [ i-length ] 2apply tuck = [ (i-eq2?) ] [ 3drop f ] if ]
 268     if ; inline
 269
 270 : (i-cmp5) ( s1 s2 -- i )
 271     dup ileft pick over i-length tuck ihead rot i-cmp dup zero?
 272     [ drop itail swap iright swap i-cmp ]
 273     [ -roll 3drop ] if ; inline
 274
 275 : (i-cmp4) ( s1 s2 s -- i )
 276     dup zero? [ 3drop 0 ]
 277     [ 1 = [ [ 0 i-at ] 2apply i-cmp ] [ (i-cmp5) ] if ]
 278     if ; inline
 279
 280 : (i-cmp3) ( s1 s2 ls1 ls2 -- i )
 281     2dup = [ drop (i-cmp4) ]
 282     [ min dup >r ihead r> (i-cmp4) dup zero? [ drop -1 ] when ]
 283     if ; inline
 284
 285 : (i-cmp2) ( s1 s2 ls1 ls2 -- i )
 286      2dup > [ swap 2swap swap 2swap (i-cmp2) neg ] [ (i-cmp3) ] if ; inline
 287
 288 : cmp-g++ ( s1 s2 -- i )
 289       2dup (i-eq?) [ 2drop 0 ]
 290       [ 2dup [ i-length ] 2apply (i-cmp2) ] if ; inline
 291
 292 : cmp-g-- ( s1 s2 -- i )
 293     [ -- ] 2apply swap cmp-g++ ; inline
 294
 295 : cmp-g+- ( s1 s2 -- i ) 2drop 1 ; inline
 296
 297 : cmp-g-+ ( s1 s2 -- i ) 2drop -1 ; inline
 298
 299 : cmp-gg ( s1 s2 -- i )
 300   2dup [ neg? ] 2apply [ [ cmp-g-- ] [ cmp-g+- ] if ]
 301   [ [ cmp-g-+ ] [ cmp-g++ ] if ] if ;
 302
 303
 304 GENERIC: object/i-cmp ( s2 s1 -- s )
 305 M: object object/i-cmp swap cmp-gg ;
 306 M: object i-cmp swap object/i-cmp ;
 307
 308 : ifirst ( s1 -- v )
 309     dup i-length 1 = [ 0 i-at ] [ ileft ifirst ] if ; inline
 310
 311 : ilast ( s1 -- v )
 312     dup i-length 1 = [ 0 i-at ] [ iright ilast ] if ; inline
 313
 314 : (ascending2?) ( s1 s2 -- ? )
 315     ifirst swap ilast i-cmp 0 >= ;
 316
 317 : (ascending?) ( s -- ? )
 318     dup i-length 1 <=
 319     [ drop t ]
 320     [ left-right 2dup [ ascending? ] both? [ (ascending2?) ] [ 2drop f ] if ]
 321     if ;
 322
 323 : (descending2?) ( s1 s2 -- ? )
 324     ifirst swap ilast i-cmp 0 <= ;
 325
 326 : (descending?) ( s -- ? )
 327     dup i-length 1 <=
 328     [ drop t ]
 329     [ left-right 2dup [ descending? ] both? [ (descending2?) ] [ 2drop f ] if ]
 330     if ;
 331
 332 M: object ascending? (ascending?) ;
 333 M: object descending? (descending?) ;
 334 M: integer ascending? drop t ;
 335 M: integer descending? drop t ;
 336
 337
 338 ! **** dual-sided isequences ****
 339 !
 340
 341 TUPLE: iturned sequence ;
 342 TUPLE: iright-sided value ;
 343 TUPLE: idual-sided left right ;
 344
 345 M: iturned i-length iturned-sequence i-length ;
 346 M: iturned i-at >r iturned-sequence r> i-at :v: ;
 347 M: iturned ileft iturned-sequence ileft <iturned> ;
 348 M: iturned iright iturned-sequence iright <iturned> ;
 349 M: iturned ihead >r iturned-sequence r> ihead <iturned> ;
 350 M: iturned itail >r iturned-sequence r> itail <iturned> ;
 351 M: iturned $$ iturned-sequence dup -- [ $$ ] 2apply quick-hash ;
 352
 353 : <i-right-sided> ( v -- lv )
 354     dup i-length zero? [ drop 0 ] [ <iright-sided> ] if ; inline
 355
 356 : <i-dual-sided> ( v1 v2 -- dv )
 357     2dup [ i-length ] 2apply zero?
 358     [ zero? [ 2drop 0 ] [ drop ] if ]
 359     [ zero? [ nip <i-right-sided> ] [ <idual-sided> ] if ]
 360     if ;
 361
 362 : i-cmp-left-right ( s1 s2 -- i )
 363     2dup [ left-side ] 2apply i-cmp dup zero?
 364     [ drop [ right-side ] 2apply i-cmp ]
 365     [ -rot 2drop ]
 366     if ; inline
 367
 368 : ::g ( s -- s )
 369     dup i-length 0 < [ -- <iturned> -- ] [ <iturned> ] if ; inline
 370
 371 M: object :: ::g ;
 372 M: iturned :: iturned-sequence ;
 373 M: integer :: ;
 374
 375 GENERIC: iright-sided/i-cmp ( s1 s2 -- i )
 376 GENERIC: idual-sided/i-cmp ( s1 s2 -- i )
 377
 378 M: object iright-sided/i-cmp swap i-cmp-left-right ;
 379 M: object idual-sided/i-cmp swap i-cmp-left-right ;
 380 M: iright-sided object/i-cmp swap i-cmp-left-right ;
 381 M: idual-sided object/i-cmp swap i-cmp-left-right ;
 382 M: iright-sided i-cmp swap iright-sided/i-cmp ;
 383 M: idual-sided i-cmp swap idual-sided/i-cmp ;
 384
 385
 386 M: object left-side ;
 387 M: object right-side drop 0 ;
 388 M: iright-sided left-side drop 0 ;
 389 M: iright-sided right-side iright-sided-value ;
 390 M: idual-sided left-side idual-sided-left ;
 391 M: idual-sided right-side idual-sided-right ;
 392 M: object :v: <i-right-sided> ;
 393 M: idual-sided :v: dup idual-sided-right swap idual-sided-left <i-dual-sided> ;
 394 M: iright-sided :v: iright-sided-value ;
 395
 396 : dual++ ( v2 v1 -- v ) swap 0 <i-dual-sided> ++ ; inline
 397
 398 M: iright-sided object/++ iright-sided-value swap <i-dual-sided> ;
 399 M: idual-sided object/++ dual++ ;
 400 M: iright-sided integer/++ iright-sided-value swap <i-dual-sided> ;
 401 M: idual-sided integer/++ dual++ ;
 402
 403 GENERIC: iright-sided/++ ( s1 s2 -- s )
 404 GENERIC: idual-sided/++ ( s1 s2 -- s )
 405
 406 M: iright-sided idual-sided/++
 407     swap dup idual-sided-left swap idual-sided-right
 408     rot iright-sided-value ++ <i-dual-sided> ;
 409
 410 M: iright-sided iright-sided/++
 411     swap [ iright-sided-value ] 2apply ++ <i-right-sided> ;
 412
 413 M: idual-sided iright-sided/++
 414     dup idual-sided-left swap idual-sided-right
 415     rot iright-sided-value swap ++ <i-dual-sided> ;
 416
 417 M: idual-sided idual-sided/++
 418         swap 2dup [ idual-sided-left ] 2apply ++
 419         >r [ idual-sided-right ] 2apply ++ r> <i-dual-sided> ;
 420
 421 M: iright-sided ++ swap iright-sided/++ ;
 422 M: idual-sided ++ swap idual-sided/++ ;
 423
 424 M: object iright-sided/++
 425     >r iright-sided-value r> swap <i-dual-sided> ;
 426 M: object idual-sided/++
 427     >r dup idual-sided-left swap idual-sided-right r> ++ <i-dual-sided> ;
 428
 429
 430 ! **** lazy left product of an isequence ****
 431 !
 432
 433 TUPLE: imul sequence multiplier ;
 434
 435 : <i-muls> ( seq mul -- imul ) <imul> ; foldable
 436
 437 : *_g++ ( s n -- s ) i-length dup zero? [ nip ] [ <i-muls> ] if ; inline
 438
 439 : *_g+- ( s n -- s ) -- *_ ; inline
 440
 441 : *_g-+ ( s n -- s ) swap -- swap *_ -- ; inline
 442
 443 : *_g-- ( s n -- s ) [ -- ] 2apply *_ ; inline
 444
 445
 446 : imul-unpack ( imul -- m s )
 447     dup imul-multiplier swap imul-sequence ; inline
 448
 449 : imul-ileft ( imul -- imul )
 450     imul-unpack dup i-length 1 =
 451     [ swap ileft *_ ]
 452     [ ileft swap *_ ]
 453     if ; inline
 454
 455 : imul-iright ( imul -- imul )
 456     imul-unpack dup i-length 1 =
 457     [ swap iright *_ ]
 458     [ iright swap *_ ]
 459     if ; inline
 460
 461 : check-bounds ( s i -- s i )
 462     2dup swap i-length >= [ index-error ] when ; inline
 463
 464 : imul-i-at ( imul i -- v  )
 465     i-length check-bounds swap dup imul-multiplier swap imul-sequence
 466     -rot /i i-at ; inline
 467
 468 : *_g ( s n -- s )
 469     2dup [ neg? ] 2apply [ [ *_g-- ] [ *_g+- ] if ]
 470     [ [ *_g-+ ] [ *_g++ ] if ] if ; inline
 471
 472 M: object *_ *_g ;
 473
 474 M: integer *_ i-length abs * ;
 475 M: imul i-at imul-i-at ;
 476 M: imul i-length imul-unpack i-length swap * ;
 477 M: imul ileft imul-ileft ;
 478 M: imul iright imul-iright ;
 479 M: imul ihead (ihead) ;
 480 M: imul itail (itail) ;
 481 M: imul $$ imul-unpack [ $$ 2/ ] 2apply quick-hash ;
 482
 483 M: imul ascending? imul-sequence ascending? ;
 484 M: imul descending? imul-sequence descending? ;
 485
 486
 487 ! **** sort, union, intersect and diff ****
 488 !
 489
 490 DEFER: (ifind2)
 491
 492 : (ifind3) ( s1 v s e -- i )
 493     2dup >r >r + 2/ pick swap i-at over i-cmp 0 <
 494     [ r> r> swap over + 1+ 2/ swap (ifind2) ]
 495     [ r> r> over + 2/ (ifind2) ]
 496     if ; inline
 497
 498 : (ifind2) ( s1 v s e -- i )
 499     2dup = [ -roll 3drop ] [ (ifind3) ] if ; inline
 500
 501 : ifind ( s1 v -- i )
 502     over i-length 0 swap (ifind2) ; inline
 503
 504 : icontains? ( s1 v -- ? )
 505     2dup ifind pick i-length dupd <
 506     [ rot swap i-at i-cmp zero? ] [ 3drop f ] if ; inline
 507
 508 : icut ( s v -- s2 s2 )
 509      dupd ifind 2dup ihead -rot itail ; inline
 510
 511 DEFER: (union)
 512
 513 : (union6) ( s1 s2 -- s )
 514     2dup [ 0 i-at ] 2apply i-cmp 0 >
 515     [ swap ] when ++ ; inline
 516
 517 : (union5) ( s1 s2 -- s )
 518     over ileft i-length pick swap i-at icut rot left-right
 519     swap roll (union) -rot swap (union) ++ ;
 520
 521 : (union4) ( s1 s2 -- s )
 522     2dup ifirst swap ilast i-cmp 0 >= [ ++ ] [ (union5) ] if ; inline
 523
 524 : (union3) ( s1 s2 ls1 ls2 -- s )
 525     1 =
 526     [ 1 = [ (union6) ] [ (union4) ] if ]
 527     [ 1 = [ swap ] when (union4) ] if ; inline
 528
 529 : (union2) ( s1 s2 -- s )
 530     2dup [ i-length ] 2apply 2dup zero?
 531     [ 3drop drop ] [ zero? [ 2drop nip ] [ (union3) ] if ] if ; inline
 532
 533 : (union) ( s1 s2 -- s )
 534     2dup eq? [ drop 2 *_ ] [ (union2) ] if ; inline
 535
 536 DEFER: i-sort
 537
 538 : (i-sort) ( s -- s )
 539     dup i-length 1 >
 540     [ left-right [ i-sort ] 2apply (union) ]
 541     when ; inline
 542
 543 DEFER: (diff)
 544
 545 : (diff7) ( s1 s2 -- s )
 546     dupd swap 0 i-at icontains? [ drop 0 ] when ; inline
 547
 548 : (diff6) ( s1 s2 -- s )
 549     2dup [ 0 i-at ] 2apply i-cmp zero?
 550     [ 2drop 0 ] [ drop ] if ; inline
 551
 552 : (diff5) ( s1 s2 -- s )
 553     over ileft i-length pick swap i-at icut rot left-right
 554     swap roll (diff) -rot swap (diff) ++ ; inline
 555
 556 : (diff4) ( s1 s2 -- s )
 557     2dup [ i-length ] 2apply 1 =
 558     [ 1 = [ (diff6) ] [ (diff5) ] if ]
 559     [ 1 = [ (diff7) ] [ (diff5) ] if ] if ; inline
 560
 561 : (diff3) ( s1 s2 -- s )
 562     2dup ifirst swap ilast i-cmp 0 >
 563     [ drop ] [ (diff4) ] if ; inline
 564
 565 : (diff2) ( s1 s2 -- s )
 566     2dup [ i-length zero? ] either?
 567     [ drop ] [ (diff3) ] if ; inline
 568
 569 : (diff) ( s1 s2 -- s )
 570     2dup eq? [ 2drop 0 ] [ (diff2) ] if ; inline
 571
 572
 573 ! **** sort, diff, union and intersect assumes positive isequences ****
 574
 575 : i-sort ( s -- s )
 576     dup ascending? [ dup descending? [ `` ] [ (i-sort) ] if ] unless ;
 577
 578 : i-diff ( s1 s2 -- s )
 579    [ i-sort ] 2apply (diff) ; inline
 580
 581 : i-union ( s1 s2 -- s )
 582     [ i-sort ] 2apply (union) ; inline
 583
 584 : i-intersect ( s1 s2 -- s )
 585     [ i-sort ] 2apply over -rot i-diff i-diff ;
 586