subr.l - picolisp - Unnamed repository; edit this file to name it for gitweb.

subr.l (10494B)
      1 # 23jul13abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 ### c[ad]*r ###
      5 (let L '(1 2 3 4 5)
      6    (test 1 (car L))
      7    (test (2 3 4 5) (cdr L))
      8    (test 2 (cadr L))
      9    (test (3 4 5) (cddr L))
     10    (test 3 (caddr L))
     11    (test (4 5) (cdddr L))
     12    (test 4 (cadddr L))
     13    (test (5) (cddddr L)) )
     14 (let L '((1 2 3) (4 5))
     15    (test 1 (caar L))
     16    (test (2 3) (cdar L))
     17    (test 2 (cadar L))
     18    (test (3) (cddar L))
     19    (test 4 (caadr L))
     20    (test (5) (cdadr L)) )
     21 (let L '(((1 2)))
     22    (test 1 (caaar L))
     23    (test (2) (cdaar L)) )
     24 
     25 
     26 ### nth ###
     27 (test '(b c d) (nth '(a b c d) 2))
     28 (test '(c) (nth '(a (b c) d) 2 2))
     29 
     30 
     31 ### con ###
     32 (let C (1 . a)
     33    (test '(b c d) (con C '(b c d)))
     34    (test (1 b c d) C) )
     35 
     36 
     37 ### cons ###
     38 (test (1 . 2) (cons 1 2))
     39 (test '(a b c d) (cons 'a '(b c d)))
     40 (test '((a b) c d) (cons '(a b) '(c d)))
     41 (test '(a b c . d) (cons 'a 'b 'c 'd))
     42 
     43 
     44 ### conc ###
     45 (let (A (1 2 3)  B '(a b c))
     46    (test (1 2 3 a b c) (conc A B))
     47    (test (1 2 3 a b c) A) )
     48 
     49 (test (1 2 3 4 5 6)
     50    (conc (1 2 3) NIL (4 5 6)) )
     51 
     52 
     53 ### circ ###
     54 (let C (circ 'a 'b 'c)
     55    (test '(a b c . @) C)
     56    (test T (== C (cdddr C))) )
     57 
     58 
     59 ### rot ###
     60 (test (4 1 2 3) (rot (1 2 3 4)))
     61 (test (3 1 2 4 5 6) (rot (1 2 3 4 5 6) 3))
     62 (test (3 1 2 . @Z) (rot (1 2 3 .)))
     63 
     64 
     65 ### list ###
     66 (test (1 2 3 4) (list 1 2 3 4))
     67 (test '(a (2 3) "OK") (list 'a (2 3) "OK"))
     68 
     69 
     70 ### need ###
     71 (test '(NIL NIL NIL NIL NIL) (need 5))
     72 (test '(NIL NIL a b c) (need 5 '(a b c)))
     73 (test '(a b c NIL NIL) (need -5 '(a b c)))
     74 (test '(" " " " a b c) (need 5 '(a b c) " "))
     75 (test (0 0 0) (need 3 0))
     76 
     77 
     78 ### range ###
     79 (test (1 2 3 4 5 6) (range 1 6))
     80 (test (1 2 3 4 5 6) (range 1 6))
     81 (test (6 5 4 3 2 1) (range 6 1))
     82 (test (-3 -2 -1 0 1 2 3) (range -3 3))
     83 (test (3 1 -1 -3) (range 3 -3 2))
     84 (test (-3 -2 -1) (range -3 -1))
     85 
     86 
     87 ### full ###
     88 (test T (full (1 2 3)))
     89 (test NIL (full (1 NIL 3)))
     90 (test T (full 123))
     91 
     92 
     93 ### make made chain link yoke ###
     94 (let (A 'a I 'i)
     95    (test '(x y z z a)
     96       (make
     97          (link (for A '(x y z) (link A)))
     98          (link A) ) )
     99    (test (-1 0 1 x 2 y 3 z i a)
    100       (make
    101          (made (cons 0 (box)))
    102          (for (I . A) '(x y z) (link I A))
    103          (test (0 1 x 2 y 3 z) (made))
    104          (made (cons -1 (made)))
    105          (link I A) ) )
    106    (test (1 2 3 4 5 6 7 8 9)
    107       (make (chain (1 2 3)) (chain (4 5 6) (7 8 9))) )
    108    (test '(a b c)
    109       (make (yoke 'b) (link 'c) (yoke 'a)) )
    110    (test '((x y z) (y z) (z) (z) a)
    111       (make (link (for (A '(x y z) A (cdr A)) (link A))) (link A)) )
    112    (test (1 (x y z) 2 (y z) 3 (z) (z) i a)
    113       (make (link (for ((I . A) '(x y z) A (cdr A)) (link I A))) (link I A)) ) )
    114 
    115 
    116 ### copy ###
    117 (test T (=T (copy T)))
    118 (let L (1 2 3)
    119    (test T (== L L))
    120    (test NIL (== L (copy L)))
    121    (test T (= L (copy L)))
    122    (test T (= (1 2 3) (copy L))) )
    123 
    124 
    125 ### mix ###
    126 (test '(c d a b) (mix '(a b c d) 3 4 1 2))
    127 (test '(a A d D) (mix '(a b c d) 1 'A 4 'D))
    128 
    129 
    130 ### append ###
    131 (test '(a b c 1 2 3) (append '(a b c) (1 2 3)))
    132 (test (1 2 3 . 4) (append (1) (2) (3) 4))
    133 
    134 
    135 ### delete ###
    136 (test (1 3) (delete 2 (1 2 3)))
    137 (test '((1 2) (5 6) (3 4)) (delete (3 4) '((1 2) (3 4) (5 6) (3 4))))
    138 
    139 
    140 ### delq ###
    141 (test '(a c) (delq 'b '(a b c)))
    142 (test (1 (2) 3) (delq (2) (1 (2) 3)))
    143 
    144 
    145 ### replace ###
    146 (test '(A b b A) (replace '(a b b a) 'a 'A))
    147 (test '(a B B a) (replace '(a b b a) 'b 'B))
    148 (test '(B A A B) (replace '(a b b a) 'a 'B 'b 'A))
    149 
    150 
    151 ### strip ###
    152 (test 123 (strip 123))
    153 (test '(a) (strip '''(a)))
    154 (test '(a b c) (strip (quote quote a b c)))
    155 
    156 
    157 ### split ###
    158 (test '((1) (2 b) (c 4 d 5) (6))
    159    (split (1 a 2 b 3 c 4 d 5 e 6) 'e 3 'a) )
    160 (test '("The" "quick" "brown" "fox")
    161    (mapcar pack (split (chop "The quick brown fox") " ")) )
    162 
    163 
    164 ### reverse ###
    165 (test (4 3 2 1) (reverse (1 2 3 4)))
    166 (test NIL (reverse NIL))
    167 
    168 
    169 ### flip ###
    170 (test (4 3 2 1) (flip (1 2 3 4)))
    171 (test (3 2 1 4 5 6) (flip (1 2 3 4 5 6) 3))
    172 (test NIL (flip NIL))
    173 
    174 
    175 ### trim ###
    176 (test (1 NIL 2) (trim (1 NIL 2 NIL NIL)))
    177 (test '(a b) (trim '(a b " " " ")))
    178 
    179 
    180 ### clip ###
    181 (test (1 NIL 2) (clip '(NIL 1 NIL 2 NIL)))
    182 (test '(a " " b) (clip '(" " a " " b " ")))
    183 
    184 
    185 ### head ###
    186 (test '(a b c) (head 3 '(a b c d e f)))
    187 (test NIL (head NIL '(a b c d e f)))
    188 (test NIL (head 0 '(a b c d e f)))
    189 (test '(a b c d e f) (head 10 '(a b c d e f)))
    190 (test '(a b c d) (head -2 '(a b c d e f)))
    191 (test '(a b c) (head '(a b c) '(a b c d e f)))
    192 
    193 
    194 ### tail ###
    195 (test '(d e f) (tail 3 '(a b c d e f)))
    196 (test '(c d e f) (tail -2 '(a b c d e f)))
    197 (test NIL (tail NIL '(a b c d e f)))
    198 (test NIL (tail 0 '(a b c d e f)))
    199 (test '(a b c d e f) (tail 10 '(a b c d e f)))
    200 (test '(d e f) (tail '(d e f) '(a b c d e f)))
    201 
    202 
    203 ### stem ###
    204 (test '("g" "h" "i") (stem (chop "abc/def\\ghi") "/" "\\"))
    205 (test '("g" "h" "i") (stem (chop "abc/def\\ghi") "\\" "/"))
    206 
    207 
    208 ### fin ###
    209 (test 'a (fin 'a))
    210 (test 'b (fin '(a . b)))
    211 (test 'c (fin '(a b . c)))
    212 (test NIL (fin '(a b c)))
    213 
    214 
    215 ### last ###
    216 (test 4 (last (1 2 3 4)))
    217 (test '(d e f) (last '((a b) c (d e f))))
    218 
    219 
    220 ### == ###
    221 (test T (== 'a 'a))
    222 (test T (== 'NIL NIL (val NIL) (car NIL) (cdr NIL)))
    223 (test NIL (== (1 2 3) (1 2 3)))
    224 
    225 
    226 ### n== ###
    227 (test NIL (n== 'a 'a))
    228 (test T (n== (1) (1)))
    229 
    230 
    231 ### = ###
    232 (test T (= 6 (* 1 2 3)))
    233 (test T (= "a" "a"))
    234 (test T (== "a" "a"))
    235 (test T (= (1 (2) 3) (1 (2) 3)))
    236 (test T (= (1 . (2 3 .)) (1 . (2 3 .))))
    237 
    238 
    239 ### <> ###
    240 (test T (<> 'a 'b))
    241 (test T (<> 'a 'b 'b))
    242 (test NIL (<> 'a 'a 'a))
    243 
    244 
    245 ### =0 ###
    246 (test 0 (=0 (- 6 3 2 1)))
    247 (test NIL (=0 'a))
    248 
    249 
    250 ### =T ###
    251 (test NIL (=T 0))
    252 (test NIL (=T "T"))
    253 (test T (=T T))
    254 
    255 
    256 ### n0 ###
    257 (test NIL (n0 (- 6 3 2 1)))
    258 (test T (n0 'a))
    259 
    260 
    261 ### nT ###
    262 (test T (nT 0))
    263 (test T (nT "T"))
    264 (test NIL (nT T))
    265 
    266 
    267 ### < ###
    268 (test T (< 3 4))
    269 (test T (< 'a 'b 'c))
    270 (test T (< 999 'a))
    271 (test T (< NIL 7 'x (1) T))
    272 
    273 
    274 ### <= ###
    275 (test T (<= 3 3))
    276 (test T (<= 1 2 3))
    277 (test T (<= "abc" "abc" "def"))
    278 
    279 
    280 ### > ###
    281 (test T (> 4 3))
    282 (test T (> 'A 999))
    283 (test T (> T (1) 'x 7 NIL))
    284 
    285 
    286 ### >= ###
    287 (test T (>= 'A 999))
    288 (test T (>= 3 2 2 1))
    289 
    290 
    291 ### max ###
    292 (test 'z (max 2 'a 'z 9))
    293 (test (5) (max (5) (2 3) 'X))
    294 
    295 
    296 ### min ###
    297 (test 2 (min 2 'a 'z 9))
    298 (test 'X (min (5) (2 3) 'X))
    299 
    300 
    301 ### atom ###
    302 (test T (atom 123))
    303 (test T (atom 'a))
    304 (test T (atom NIL))
    305 (test NIL (atom (123)))
    306 
    307 
    308 ### pair ###
    309 (test NIL (pair NIL))
    310 (test (1 . 2) (pair (1 . 2)))
    311 (test (1 2 3) (pair (1 2 3)))
    312 
    313 
    314 ### circ? ###
    315 (test NIL (circ? 'a))
    316 (test NIL (circ? (1 2 3)))
    317 (test (2 3 . @) (circ? (1 . (2 3 .))))
    318 
    319 
    320 ### lst? ###
    321 (test T (lst? NIL))
    322 (test NIL (lst? T))
    323 (test T (lst? (1 . 2)))
    324 (test T (lst? (1 2 3)))
    325 
    326 
    327 ### num? ###
    328 (test 123 (num? 123))
    329 (test NIL (num? 'abc))
    330 (test NIL (num? (1 2 3)))
    331 
    332 
    333 ### sym? ###
    334 (test T (sym? 'a))
    335 (test T (sym? NIL))
    336 (test NIL (sym? 123))
    337 (test NIL (sym? '(a b)))
    338 
    339 
    340 ### flg? ###
    341 (test T (flg? T))
    342 (test T (flg? NIL))
    343 (test NIL (flg? 0))
    344 (test T (flg? (= 3 3)))
    345 (test T (flg? (= 3 4)))
    346 (test NIL (flg? (+ 3 4)))
    347 
    348 
    349 ### member ###
    350 (test (3 4 5 6) (member 3 (1 2 3 4 5 6)))
    351 (test NIL (member 9 (1 2 3 4 5 6)))
    352 (test '((d e f) (g h i))
    353    (member '(d e f) '((a b c) (d e f) (g h i))) )
    354 
    355 
    356 ### memq ###
    357 (test '(c d e f) (memq 'c '(a b c d e f)))
    358 (test NIL (memq (2) '((1) (2) (3))))
    359 (test 'c (memq 'c '(a b . c)))
    360 (test '(b c a . @Z) (memq 'b '(a b c .)))
    361 (test NIL (memq 'd '(a b c .)))
    362 
    363 
    364 ### mmeq ###
    365 (test NIL (mmeq '(a b c) '(d e f)))
    366 (test '(b x) (mmeq '(a b c) '(d b x)))
    367 
    368 
    369 ### sect ###
    370 (test (3 4) (sect (1 2 3 4) (3 4 5 6)))
    371 (test (1 2 3) (sect (1 2 3) (1 2 3)))
    372 (test NIL (sect (1 2 3) (4 5 6)))
    373 
    374 
    375 ### diff ###
    376 (test (1 3 5) (diff (1 2 3 4 5) (2 4)))
    377 (test (1 2 3) (diff (1 2 3) NIL))
    378 (test NIL (diff (1 2 3) (1 2 3)))
    379 
    380 
    381 ### index ###
    382 (test 3 (index 'c '(a b c d e f)))
    383 (test NIL (index 'z '(a b c d e f)))
    384 (test 3 (index '(5 6) '((1 2) (3 4) (5 6) (7 8))))
    385 
    386 
    387 ### offset ###
    388 (test 3 (offset '(c d e f) '(a b c d e f)))
    389 (test NIL (offset '(c d e) '(a b c d e f)))
    390 
    391 
    392 ### prior ###
    393 (let (L (1 2 3 4 5 6)  X (cdddr L))
    394    (test NIL (prior L L))
    395    (test (3 4 5 6) (prior X L)) )
    396 
    397 
    398 ### length ###
    399 (test 3 (length "abc"))
    400 (test 3 (length "äbc"))
    401 (test 3 (length 123))
    402 (test 3 (length (1 (2) 3)))
    403 (test T (length (1 2 3 .)))
    404 (test T (length (1 . (2 3 .))))
    405 
    406 
    407 ### size ###
    408 (test 3 (size "abc"))
    409 (test 4 (size "äbc"))
    410 (test 1 (size 127))
    411 (test 2 (size 128))
    412 (test 4 (size (1 (2) 3)))
    413 (test 3 (size (1 2 3 .)))
    414 (test 8 (size '((1 2 3) (4 5 6))))
    415 (test 6 (size '((1 2 .) (4 5 .))))
    416 (test 3 (size (1 . (2 3 .))))
    417 
    418 
    419 ### bytes ###
    420 (test 4 (bytes "abc"))
    421 (test 5 (bytes "äbc"))
    422 (test 2 (bytes 127))
    423 (test 3 (bytes 128))
    424 (test 10 (bytes (101 (102) 103)))
    425 (test 9 (bytes (101 102 103 .)))
    426 (let (L (7 "abc" (1 2 3) 'a)  F (tmp "bytes"))
    427    (out F (pr L))
    428    (test (bytes L) (car (info F))) )
    429 
    430 
    431 ### assoc ###
    432 (test '("b" . 7)
    433    (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
    434 (test (999 1 2 3)
    435    (assoc 999 '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
    436 (test NIL
    437    (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) )
    438 
    439 
    440 ### asoq ###
    441 (test NIL
    442    (asoq (9) '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) )
    443 (test '(b . 7)
    444    (asoq 'b '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) )
    445 
    446 
    447 ### rank ###
    448 (test NIL
    449    (rank 0 '((1 . a) (100 . b) (1000 . c))) )
    450 (test (1 . a)
    451    (rank 50 '((1 . a) (100 . b) (1000 . c))) )
    452 (test (100 . b)
    453    (rank 100 '((1 . a) (100 . b) (1000 . c))) )
    454 (test (100 . b)
    455    (rank 300 '((1 . a) (100 . b) (1000 . c))) )
    456 (test (1000 . c)
    457    (rank 9999 '((1 . a) (100 . b) (1000 . c))) )
    458 (test (100 . b)
    459    (rank 50 '((1000 . a) (100 . b) (1 . c)) T) )
    460 
    461 
    462 ### match ###
    463 (use (@A @B @X @Y @Z)
    464    (test T
    465       (match '(@A is @B) '(This is a test)) )
    466    (test '(This) @A)
    467    (test '(a test) @B)
    468    (test T
    469       (match '(@X (d @Y) @Z) '((a b c) (d (e f) g) h i)) )
    470    (test '((a b c)) @X)
    471    (test '((e f) g) @Y)
    472    (test '(h i) @Z) )
    473 
    474 
    475 ### fill ###
    476 (let (@X 1234  @Y (1 2 3 4))
    477    (test 1234 (fill '@X))
    478    (test '(a b (c 1234) (((1 2 3 4) . d) e))
    479       (fill '(a b (c @X) ((@Y . d) e))) ) )
    480 (test (1 a b c 9)
    481    (fill (1 ^ (list 'a 'b 'c) 9)) )
    482 (test (1 9)
    483    (fill (1 ^ 7 9)) )
    484 (let X 2 (test (1 2 3) (fill (1 X 3) 'X)))
    485 (let X 2 (test (1 2 3) (fill (1 X 3) '(X))))
    486 
    487 
    488 ### prove ###
    489 (test T
    490    (prove (goal '((equal 3 3)))) )
    491 (test '((@X . 3))
    492    (prove (goal '((equal 3 @X)))) )
    493 (test NIL
    494    (prove (goal '((equal 3 4)))) )
    495 
    496 
    497 ### -> ###
    498 (test '((@A . 3) (@B . 7))
    499    (prove (goal '(@A 3 (^ @B (+ 4 (-> @A)))))) )
    500 
    501 
    502 ### unify ###
    503 (test '((@A ((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T))
    504    (prove (goal '((^ @A (unify '(@B @C)))))) )
    505 
    506 
    507 ### sort ###
    508 (test '(NIL 1 2 3 4 a b c d (1 2 3) (a b c) (x y z) T)
    509    (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2)) )
    510 (test '(T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL)
    511    (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2) >) )
    512 
    513 # vi:et:ts=3:sw=3
	picolisp Unnamed repository; edit this file to name it for gitweb.
	git clone https://logand.com/git/picolisp.git/
	Log \| Files \| Refs \| README \| LICENSE