extra/combinators/extras/extras-tests.factor

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