extra/combinators/cleave/cleave.factor

   1
   2 USING: kernel combinators words quotations arrays sequences locals macros
   3        shuffle combinators.lib generalizations fry ;
   4
   5 IN: combinators.cleave
   6
   7 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   8
   9 : >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
  10
  11 : >quots ( seq -- seq ) [ >quot ] map ;
  12
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14
  15 :: [ncleave] ( SEQ N -- quot )
  16    SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
  17
  18 MACRO: ncleave ( seq n -- quot ) [ncleave] ;
  19
  20 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  21 ! Cleave into array
  22 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23
  24 : [narr] ( seq n -- quot ) over length '[ , , ncleave , narray ] ;
  25
  26 MACRO: narr ( seq n -- array ) [narr] ;
  27
  28 MACRO: 0arr ( seq -- array ) 0 [narr] ;
  29 MACRO: 1arr ( seq -- array ) 1 [narr] ;
  30 MACRO: 2arr ( seq -- array ) 2 [narr] ;
  31 MACRO: 3arr ( seq -- array ) 3 [narr] ;
  32
  33 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  34
  35 MACRO: <arr> ( seq -- )
  36   [ >quots ] [ length ] bi
  37  '[ , cleave , narray ] ;
  38
  39 MACRO: <2arr> ( seq -- )
  40   [ >quots ] [ length ] bi
  41  '[ , 2cleave , narray ] ;
  42
  43 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  44
  45 : {1} ( x     -- {x}     ) 1array ; inline
  46 : {2} ( x y   -- {x,y}   ) 2array ; inline
  47 : {3} ( x y z -- {x,y,z} ) 3array ; inline
  48
  49 : {n} narray ;
  50
  51 : {bi}  ( x p q   -- {p(x),q(x)}      ) bi  {2} ; inline
  52
  53 : {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
  54
  55 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  56 ! Spread into array
  57 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  58
  59 MACRO: <arr*> ( seq -- )
  60   [ >quots ] [ length ] bi
  61  '[ , spread , narray ] ;
  62
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 : {bi*}  ( x y p q     -- {p(x),q(y)}      ) bi*  {2} ; inline
  66 : {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline