extra/shuffle/extras/extras.factor

   1 ! Copyright (C) 2022 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: generalizations kernel shuffle ;
   4 IN: shuffle.extras
   5
   6 : 6roll ( a b c d e f -- b c d e f a ) [ roll ] 2dip rot ; inline
   7
   8 : 7roll ( a b c d e f g -- b c d e f g a ) [ roll ] 3dip roll ; inline
   9
  10 : 8roll ( a b c d e f g h -- b c d e f g h a ) [ roll ] 4dip 5roll ; inline
  11
  12 : keep-1up ( quot -- quot ) keep swap ; inline
  13 : keep-2up ( quot -- quot ) keep rot rot ; inline
  14 : keep-3up ( quot -- quot ) keep roll roll roll ; inline
  15
  16 : 2keep-1up ( quot -- quot ) 2keep rot ; inline
  17 : 2keep-2up ( quot -- quot ) 2keep roll roll ; inline
  18 : 2keep-3up ( quot -- quot ) 2keep 5 nrot 5 nrot 5 nrot ; inline
  19
  20 : 3keep-1up ( quot -- quot ) 3keep roll ; inline
  21 : 3keep-2up ( quot -- quot ) 3keep 5 nrot 5 nrot ; inline
  22 : 3keep-3up ( quot -- quot ) 3keep 6 nrot 6 nrot 6 nrot ; inline
  23
  24 ! d is dummy, o is object to save notation space
  25 : dip-1up  ( ..a d quot: ( ..a -- ..b o d ) -- ..b d o )
  26     dip swap ; inline
  27 : dip-2up  ( ..a d quot: ( ..a -- ..b o1 o2 d ) -- ..b d o1 o2 )
  28     dip rot rot ; inline
  29
  30 : 2dip-1up ( ..a d1 d2 quot: ( ..a -- ..b o d1 d2 ) -- ..b d1 d2 o )
  31     2dip rot ; inline
  32 : 2dip-2up ( ..a d1 d2 quot: ( ..a -- ..b o1 o2 d1 d2 ) -- ..b d1 d2 o1 o2 )
  33     2dip roll roll ; inline
  34
  35 : 3dip-1up ( ..a d1 d2 d3 quot: ( ..a -- ..b o d1 d2 d3 ) -- ..b d1 d2 d3 o )
  36     3dip roll ; inline
  37 : 3dip-2up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 )
  38     3dip 5roll 5roll ; inline
  39 : 3dip-3up ( ..a d1 d2 d3 quot: ( ..a -- ..b o1 o2 o3 d1 d2 d3 ) -- ..b d1 d2 d3 o1 o2 o3 )
  40     3dip 6roll 6roll 6roll ; inline
  41
  42
  43 : 2craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) -- ..c o1 o2 )
  44     [ call ] dip [ dip-1up ] call ; inline
  45
  46 : 3craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) -- ..d o1 o2 o3 )
  47     [ call ] 2dip [ dip-1up ] dip [ 2dip-1up ] call ; inline
  48
  49 : 4craft-1up ( ..a quot1: ( ..a -- ..b o1 ) quot2: ( ..b -- ..c o2 ) quot3: ( ..c -- ..d o3 ) quot4: ( ..d -- ..e o4 ) -- ..e o1 o2 o3 o4 )
  50     [ call ] 3dip [ dip-1up ] 2dip [ 2dip-1up ] dip [ 3dip-1up ] call ; inline
  51
  52 : 3and ( a b c -- ? ) and and ; inline
  53 : 4and ( a b c d -- ? ) and and and ; inline
  54
  55 : 3or ( a b c -- ? ) or or ; inline
  56 : 4or ( a b c d -- ? ) or or or ; inline