extra/combinators/extras/extras-tests.factor

   1 ! Copyright (C) 2013 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators.extras io.files kernel math
   4 modern.slices sequences splitting tools.test ;
   5 IN: combinators.extras.tests
   6
   7
   8 { "a b" }
   9 [ "a" "b" [ " " glue ] once ] unit-test
  10
  11 { "a b c" }
  12 [ "a" "b" "c" [ " " glue ] twice ] unit-test
  13
  14 { "a b c d" }
  15 [ "a" "b" "c" "d" [ " " glue ] thrice ] unit-test
  16
  17 { { "negative" 0 "positive" } } [
  18     { -1 0 1 } [
  19         {
  20            { [ 0 > ] [ "positive" ] }
  21            { [ 0 < ] [ "negative" ] }
  22            [ ]
  23         } cond-case
  24     ] map
  25 ] unit-test
  26
  27 { { 1 2 3 } } [ 1 { [ ] [ 1 + ] [ 2 + ] } cleave-array ] unit-test
  28
  29 { 2 15 } [ 1 2 3 4 5 6 [ - - ] [ + + ] 3bi* ] unit-test
  30
  31 { 2 5 } [ 1 2 3 4 5 6 [ - - ] 3bi@ ] unit-test
  32
  33 { 3 1 } [ 1 2 [ + ] keepd ] unit-test
  34
  35 { "1" "123" } [ "1" "123" [ length ] [ > ] swap-when ] unit-test
  36 { "123" "1" } [ "1" "123" [ length ] [ < ] swap-when ] unit-test
  37
  38
  39 { t } [ "resource:" [ file-exists? ] ?1arg >boolean ] unit-test
  40 { f } [ f [ file-exists? ] ?1arg ] unit-test
  41 { f } [ "/homeasdfasdf123123" [ file-exists? ] ?1arg ] unit-test
  42
  43 { "hi " "there" } [
  44     "hi there" {
  45         { [ "there" over subseq-start ] [ cut ] }
  46         [ f ]
  47     } cond*
  48 ] unit-test
  49
  50 { "hi " "there" } [
  51     "hi there" {
  52         { [ "foo" over subseq-start ] [ head f ] }
  53         { [ "there" over subseq-start ] [ cut ] }
  54         [ f ]
  55     } cond*
  56 ] unit-test
  57
  58 { "hi there" f } [
  59     "hi there" {
  60         { [ "foo" over subseq-start ] [ head f ] }
  61         { [ "bar" over subseq-start ] [ cut ] }
  62         [ f ]
  63     } cond*
  64 ] unit-test
  65
  66 { "hi " "there" } [
  67     "hi there" {
  68         { [ dup "there" subsequence-starts ] [ cut ] }
  69         [ f ]
  70     } cond*
  71 ] unit-test
  72
  73 { "hi " "there" } [
  74     "hi there" {
  75         { [ dup "foo" subsequence-starts ] [ head f ] }
  76         { [ dup "there" subsequence-starts ] [ cut ] }
  77         [ f ]
  78     } cond*
  79 ] unit-test
  80
  81 { "hi there" f } [
  82     "hi there" {
  83         { [ dup "foo" subsequence-starts ] [ head f ] }
  84         { [ dup "bar" subsequence-starts ] [ cut ] }
  85         [ f ]
  86     } cond*
  87 ] unit-test
  88
  89 { f } [ f { } chain ] unit-test
  90 { 3 } [ H{ { 1 H{ { 2 3 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
  91 { f } [ H{ { 1 H{ { 3 4 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
  92 { f } [ H{ { 2 H{ { 3 4 } } } } { [ 1 of ] [ 2 of ] } chain ] unit-test
  93 { 5 } [
  94     "hello factor!" { [ split-words ] [ first ] [ length ] } chain
  95 ] unit-test
  96
  97 {
  98     { 1 2 3 4 }
  99     { 1 2 3 4 }
 100     { 1 2 3 4 }
 101     { 1 2 3 4 }
 102 } [
 103     1 2 3 4
 104     [ 4array ] [ 4array ] [ 4array ] [ 4array ] 4quad
 105 ] unit-test
 106
 107 {
 108     { 1 2 3 4 }
 109     { 5 6 7 8 }
 110     { 9 10 11 12 }
 111 } [
 112     1 2 3 4  5 6 7 8  9 10 11 12
 113     [ 4array ] [ 4array ] [ 4array ] 4tri*
 114 ] unit-test
 115
 116 {
 117     { 1 2 3 4 }
 118     { 5 6 7 8 }
 119     { 9 10 11 12 }
 120 } [
 121     1 2 3 4  5 6 7 8  9 10 11 12
 122     [ 4array ] 4tri@
 123 ] unit-test
 124
 125 { 1 2 3 } [ 1 2 [ 3 ] dip-1up ] unit-test
 126 { 2 2 } [ 1 2 [ 1 + ] dip-1up ] unit-test
 127 { 20 11 } [ 10 20 [ 1 + ] dip-1up ] unit-test
 128
 129 { 0 10 20 30 40 50 60 80 71 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ]  dip-1up ] unit-test
 130 { 0 10 20 30 40 50 70 80 61 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] 2dip-1up ] unit-test
 131 { 0 10 20 30 40 60 70 80 51 } [ 0 10 20 30 40 50 60 70 80 [ 1 + ] 3dip-1up ] unit-test
 132
 133
 134 { 0 10 20 30 40 50 80 61 71 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ]  dip-2up ] unit-test
 135 { 0 10 20 30 40 70 80 51 61 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] 2dip-2up ] unit-test
 136 { 0 10 20 30 60 70 80 41 51 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] bi@ ] 3dip-2up ] unit-test
 137
 138 { 0 10 20 60 70 80 31 41 51 } [ 0 10 20 30 40 50 60 70 80 [ [ 1 + ] tri@ ] 3dip-3up ] unit-test
 139
 140 { 4 "abcd" 97 98 99 100 } [
 141     0 "abcd"
 142     [ [ CHAR: a = ] accept1 ]
 143     [ [ CHAR: b = ] accept1 ]
 144     [ [ CHAR: c = ] accept1 ]
 145     [ [ CHAR: d = ] accept1 ] 4craft-1up
 146 ] unit-test
 147
 148 { 20 30 2500 } [ 20 30 [ + sq ] 2keep-1up ] unit-test
 149
 150 { 10 1 } [ 10 [ drop 1 ] keep-1up ] unit-test
 151 { 10 20 1 } [ 10 20 [ 2drop 1 ] 2keep-1up ] unit-test
 152 { 10 20 30 1 } [ 10 20 30 [ 3drop 1 ] 3keep-1up ] unit-test
 153
 154
 155 { 10 1 } [ 10 [ drop 1 ] keep-1up ] unit-test
 156 { 10 20 1 } [ 10 20 [ 2drop 1 ] 2keep-1up ] unit-test
 157 { 10 20 30 1 } [ 10 20 30 [ 3drop 1 ] 3keep-1up ] unit-test
 158
 159 { 10 1 2 } [ 10 [ drop 1 2 ] keep-2up ] unit-test
 160 { 10 20 1 2 } [ 10 20 [ 2drop 1 2 ] 2keep-2up ] unit-test
 161 { 10 20 30 1 2 } [ 10 20 30 [ 3drop 1 2 ] 3keep-2up ] unit-test
 162
 163 { 10 1 2 3 } [ 10 [ drop 1 2 3 ] keep-3up ] unit-test
 164 { 10 20 1 2 3 } [ 10 20 [ 2drop 1 2 3 ] 2keep-3up ] unit-test
 165 { 10 20 30 1 2 3 } [ 10 20 30 [ 3drop 1 2 3 ] 3keep-3up ] unit-test
 166
 167 : test-keep-under ( -- a b c d e ) 1 [ [ 5 + ] call 10 20 30 ] keep-under ;
 168 : test-2keep-under ( -- a b c d e f g ) 1 2 [ [ 5 + ] bi@ 10 20 30 ] 2keep-under ;
 169 : test-3keep-under ( -- a b c d e f g h i ) 1 2 3 [ [ 5 + ] tri@ 10 20 30 ] 3keep-under ;
 170 : test-4keep-under ( -- a b c d e f g h i j k l ) 1 2 3 4 [ [ 5 + ] quad@ 10 20 30 40 ] 4keep-under ;
 171
 172 { 1 6 10 20 30 } [ test-keep-under ] unit-test
 173 { 1 2 6 7 10 20 30 } [ test-2keep-under ] unit-test
 174 { 1 2 3 6 7 8 10 20 30 } [ test-3keep-under ] unit-test
 175 { 1 2 3 4  6 7 8 9 10 20 30 40 } [ test-4keep-under ] unit-test
 176
 177 { 1 2 3 4 1 2 3 4 5 } [ 1 2 3 4 [ 5 ] 4keep-under ] unit-test
 178 { 1 2 3 4 1 2 3 4 5 6 7 8 9 10 } [ 1 2 3 4 [ 5 6 7 8 9 10 ] 4keep-under ] unit-test
 179
 180
 181 { 3 { 1 2 3 } }
 182 [ 0 { 1 2 3 } [ 1 + ] 1temp1d map ] unit-test
 183
 184 { 3 { { 1 1 } { 2 2 } { 3 3 } } }
 185 [ 0 { { 1 1 } { 2 2 } { 3 3 } } [ 1 + ] 1temp2d assoc-map ] unit-test
 186
 187 { 103 203 { { 1 1 } { 2 2 } { 3 3 } } }
 188 [ 100 200 { { 1 1 } { 2 2 } { 3 3 } } [ [ 1 + ] bi@ ] 2temp2d assoc-map ] unit-test
 189