Changeset 20949 in project


Ignore:
Timestamp:
10/23/10 04:23:07 (11 years ago)
Author:
Kon Lovett
Message:

Added section (sorta like clojure partition) & support routines skip+ & split-at+ (by default a srfi-1 split-at workalike).

Location:
release/4/list-utils
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/list-utils/tags/1.1.0/list-utils.scm

    r19232 r20949  
    55
    66  (;export
     7    skip+
     8    split-at+
     9    section
    710    length=0?
    811    length=1?
     
    3538      rassoc)
    3639    (only srfi-1
    37       cons* reverse!)
     40      cons* reverse! append-reverse!)
    3841    (only type-checks
    39       check-list check-pair check-integer check-procedure)
     42      check-list check-pair check-procedure
     43      check-fixnum check-positive-fixnum)
    4044    (only type-errors
    4145      error-alist define-error-type))
    4246
    43   (require-library srfi-1 type-checks type-errors)
     47  (require-library
     48    srfi-1 type-checks type-errors)
     49
     50;; Returns the original list starting at element n.
     51
     52(define (skip+ ls n)
     53  (if (or (null? ls) (<= n 0)) (values ls n)
     54    (skip+ (cdr ls) (sub1 n))) )
     55
     56;; Returns new list with all elements [0 n-1] and original list from n.
     57;; The new list is padded upto n elements from pads, when supplied.
     58;; Returns partial split when fewer than n elements are available,
     59;; either from the primary or pad list, or no split when pads is #f. Default is
     60;; no padding & paritial section.
     61
     62(define (split-at+ ls n #!optional (pads '()))
     63  ;Do not attempt to padout when the primary list is empty.
     64  (if (null? ls) (values '() '())
     65    (let loop ((ls ls) (n n) (part '()))
     66      (cond
     67        ((<= n 0)
     68          (values (reverse! part) ls) )
     69        ((null? ls)
     70          (cond
     71            ;Unless padding is desired throw away the section
     72            ((not pads)   (values '() '()) )
     73            ((null? pads) (values (reverse! part) '()) )
     74            (else         (values (append-reverse! part (split-at+ pads n)) '()) ) ) )
     75        (else
     76          (loop (cdr ls) (sub1 n) (cons (car ls) part)) ) ) ) ) )
     77
     78;; Returns sublists of length n from the list, the last sublist padded, if
     79;; necessary and possible, from pads. The sublists are constructed starting
     80;; at every step element.
     81
     82;ls - list
     83;n - elements per section
     84;step - elements between section
     85;pads - remainder fill
     86
     87(define (section ls n #!optional (step n) (pads '()))
     88  (check-positive-fixnum 'section n 'size)
     89  (check-positive-fixnum 'section step 'step)
     90  (cond
     91    ;Do not attempt to section the padding list when
     92    ;the primary list is empty.
     93    ((null? ls)   '() )
     94    (else
     95      ;Remaining elements between sections
     96      (let ((inc (- step n)))
     97        (let loop ((ls ls) (parts '()))
     98          ;Get this section
     99          #;(assert (not (null? ls)))
     100          (let-values (((part nls) (split-at+ ls n pads)))
     101            (cond
     102              ((null? nls)
     103                ;Possible empty section when no padding.
     104                ;otherwise complete with this, the last,
     105                ;section
     106                (if (null? part) (reverse! parts)
     107                  (reverse! (cons part parts)) ) )
     108              (else
     109                ;Skip over "between" elements and
     110                ;continue sectioning the list.
     111                (let ((ls (cond
     112                            ;step = n
     113                            ((zero? inc)      nls )
     114                            ;step < n so skip from starting this section element
     115                            ((negative? inc)  (skip+ ls (+ n inc)) )
     116                            ;step > n so skip remaining elements in between
     117                            (else             (skip+ nls inc) ) ) ) )
     118                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )
    44119
    45120;;
     
    195270(define (*alist-delete/count loc key al cmp cnt)
    196271  (check-procedure loc cmp)
    197   (let loop ((cal al) (cnt (check-integer loc cnt)) (oal '()))
     272  (let loop ((cal al) (cnt (check-fixnum loc cnt)) (oal '()))
    198273    (cond
    199274      ((null? cal)
     
    221296  (check-procedure loc cmp)
    222297  (let ((ral al))
    223     (let loop ((cal al) (pal #f) (cnt (check-integer loc cnt)))
     298    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
    224299      (cond
    225300        ((or (null? cal) (not (positive? cnt)))
  • release/4/list-utils/tags/1.1.0/list-utils.setup

    r20292 r20949  
    55(verify-extension-name "list-utils")
    66
    7 (setup-shared-extension-module 'list-utils (extension-version "1.0.0")
     7(setup-shared-extension-module 'list-utils (extension-version "1.1.0")
    88  #:compile-options '(
    99    -scrutinize
  • release/4/list-utils/tags/1.1.0/tests/run.scm

    r19232 r20949  
    1 (use list-utils test data-structures)
     1(use test)
     2(use data-structures)
     3(use list-utils)
    24
    3 (test-group  "Lists"
     5(test-group  "Skip+"
     6  (test '(() -1) (receive (skip+ '() -1)))
     7  (test '(() 0) (receive (skip+ '() 0)))
     8  (test '(() 1) (receive (skip+ '() 1)))
     9  (test '((1) -1) (receive (skip+ '(1) -1)))
     10  (test '((1) 0) (receive (skip+ '(1) 0)))
     11  (test '(() 0) (receive (skip+ '(1) 1)))
     12  (test '(() 1) (receive (skip+ '(1) 2)))
     13  (test '((1 2) -1) (receive (skip+ '(1 2) -1)))
     14  (test '((1 2) 0) (receive (skip+ '(1 2) 0)))
     15  (test '((2) 0) (receive (skip+ '(1 2) 1)))
     16  (test '(() 0) (receive (skip+ '(1 2) 2)))
     17)
    418
    5   (define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
    6   (define alst2 '((a . 1) (b . 2) (b . 3) (c . 4) (b . 5) (a . 6) (d . 7)))
     19(test-group  "Split-at+"
     20  (test '(() ()) (receive (split-at+ '() -1 #f)))
     21  (test '(() ()) (receive (split-at+ '() 0 #f)))
     22  (test '(() ()) (receive (split-at+ '() 1 #f)))
     23  (test '(() ()) (receive (split-at+ '() -1 '())))
     24  (test '(() ()) (receive (split-at+ '() 0 '())))
     25  (test '(() ()) (receive (split-at+ '() 1 '())))
     26  (test '(() ()) (receive (split-at+ '() -1 '(1))))
     27  (test '(() ()) (receive (split-at+ '() 0 '(1))))
     28  (test '(() ()) (receive (split-at+ '() 1 '(1))))
     29  (test '(() (1)) (receive (split-at+ '(1) -1 #f)))
     30  (test '(() (1)) (receive (split-at+ '(1) 0 #f)))
     31  (test '((1) ()) (receive (split-at+ '(1) 1 #f)))
     32  (test '(() ()) (receive (split-at+ '(1) 2 #f)))
     33  (test '(() (1)) (receive (split-at+ '(1) -1 '())))
     34  (test '(() (1)) (receive (split-at+ '(1) 0 '())))
     35  (test '((1) ()) (receive (split-at+ '(1) 1 '())))
     36  (test '((1) ()) (receive (split-at+ '(1) 2 '())))
     37  (test '(() (1)) (receive (split-at+ '(1) -1 '(2))))
     38  (test '(() (1)) (receive (split-at+ '(1) 0 '(2))))
     39  (test '((1) ()) (receive (split-at+ '(1) 1 '(2))))
     40  (test '((1 2) ()) (receive (split-at+ '(1) 2 '(2))))
     41)
    742
     43(test-group  "Section"
     44  ;(section LIST SIZE [STEP [PADS]])
     45  ;Needs more tests
     46
     47  (test-error "size <= 0" (section '(1 2) -1 1 #f))
     48  (test-error "size <= 0" (section '(1 2) 0 1 #f))
     49  (test-error "step <= 0" (section '(1 2) 1 -1 #f))
     50  (test-error "step <= 0" (section '(1 2) 1 0 #f))
     51
     52  (test "null primary" '() (section '() 1 1 #f))
     53  (test "size > length primary & no pad" '() (section '(1) 2 2 #f))
     54
     55  (test '((1) (2)) (section '(1 2) 1 1 #f))
     56  (test '((1 2)) (section '(1 2) 2 2 #f))
     57  (test "size > length primary & clip" '((1 2)) (section '(1 2) 3 3 '()))
     58  (test "size > length primary & pad" '((1 2 3)) (section '(1 2) 3 3 '(3 4 5)))
     59
     60  (test "size > step" '((1 2) (2 3)) (section '(1 2 3) 2 1))
     61  (test "size < step" '((1) (3)) (section '(1 2 3) 1 2))
     62
     63  (test '((1 2) (2 3)) (section '(1 2 3) 2 1 '(a b c)))
     64  (test '((1 2 a)) (section '(1 2) 3 3 '(a b c)))
     65  (test '((1 2) (3 a)) (section '(1 2 3) 2 2 '(a b c)))
     66  (test '((1 2) (3)) (section '(1 2 3) 2 2))
     67)
     68
     69(define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
     70(define alst2 '((a . 1) (b . 2) (b . 3) (c . 4) (b . 5) (a . 6) (d . 7)))
     71
     72(test-group  "Length"
    873        (test-assert (length=0? '()))
    974        (test-assert (not (length=0? '(1))))
     
    1883        (test-assert (not (length>1? '())))
    1984        (test-assert (not (length>1? '(1))))
     85)
    2086
     87(test-group  "Null Stuff"
    2188  (test '(1) (ensure-list '(1)))
    2289  (test '(1) (ensure-list 1))
     
    2491  (test '(1) (not-null? '(1)))
    2592  (test-assert (not (not-null? '())))
     93)
    2694
     95(test-group  "Shift Set"
    2796  (let ((lst '(1 2)))
    2897    (test 1 (shift!/set lst))
     
    33102    (test '() (identity lst))
    34103  )
     104)
    35105
     106(test-group  "Alist Zip"
    36107  (test '((a b) ((1) (2))) (receive (unzip-alist '((a 1) (b 2)))))
    37108  (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
    38109  (test '((a 1) (b 2)) (zip-alist '(a b) '((1) (2))))
    39110  (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
     111)
    40112
     113(test-group  "Plist <-> Alist"
    41114  (test '(a (1) b (2) b (3) c (4) b (5) a (6) d (7)) (alist->plist alst1))
    42115  (test '(a 1 b 2 b 3 c 4 b 5 a 6 d 7) (alist->plist alst2))
    43116  (test alst1 (plist->alist '(a (1) b (2) b (3) c (4) b (5) a (6) d (7))))
    44117  (test alst2 (plist->alist '(a 1 b 2 b 3 c 4 b 5 a 6 d 7)))
     118)
    45119
     120(test-group  "Alist Delete"
    46121  (test '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete/count 'b alst1 eq? 2))
    47122  (test '((a 1) (c 4) (a 6) (d 7)) (alist-delete/count 'b alst1 eq?))
  • release/4/list-utils/trunk/list-utils.scm

    r19232 r20949  
    55
    66  (;export
     7    skip+
     8    split-at+
     9    section
    710    length=0?
    811    length=1?
     
    3538      rassoc)
    3639    (only srfi-1
    37       cons* reverse!)
     40      cons* reverse! append-reverse!)
    3841    (only type-checks
    39       check-list check-pair check-integer check-procedure)
     42      check-list check-pair check-procedure
     43      check-fixnum check-positive-fixnum)
    4044    (only type-errors
    4145      error-alist define-error-type))
    4246
    43   (require-library srfi-1 type-checks type-errors)
     47  (require-library
     48    srfi-1 type-checks type-errors)
     49
     50;; Returns the original list starting at element n.
     51
     52(define (skip+ ls n)
     53  (if (or (null? ls) (<= n 0)) (values ls n)
     54    (skip+ (cdr ls) (sub1 n))) )
     55
     56;; Returns new list with all elements [0 n-1] and original list from n.
     57;; The new list is padded upto n elements from pads, when supplied.
     58;; Returns partial split when fewer than n elements are available,
     59;; either from the primary or pad list, or no split when pads is #f. Default is
     60;; no padding & paritial section.
     61
     62(define (split-at+ ls n #!optional (pads '()))
     63  ;Do not attempt to padout when the primary list is empty.
     64  (if (null? ls) (values '() '())
     65    (let loop ((ls ls) (n n) (part '()))
     66      (cond
     67        ((<= n 0)
     68          (values (reverse! part) ls) )
     69        ((null? ls)
     70          (cond
     71            ;Unless padding is desired throw away the section
     72            ((not pads)   (values '() '()) )
     73            ((null? pads) (values (reverse! part) '()) )
     74            (else         (values (append-reverse! part (split-at+ pads n)) '()) ) ) )
     75        (else
     76          (loop (cdr ls) (sub1 n) (cons (car ls) part)) ) ) ) ) )
     77
     78;; Returns sublists of length n from the list, the last sublist padded, if
     79;; necessary and possible, from pads. The sublists are constructed starting
     80;; at every step element.
     81
     82;ls - list
     83;n - elements per section
     84;step - elements between section
     85;pads - remainder fill
     86
     87(define (section ls n #!optional (step n) (pads '()))
     88  (check-positive-fixnum 'section n 'size)
     89  (check-positive-fixnum 'section step 'step)
     90  (cond
     91    ;Do not attempt to section the padding list when
     92    ;the primary list is empty.
     93    ((null? ls)   '() )
     94    (else
     95      ;Remaining elements between sections
     96      (let ((inc (- step n)))
     97        (let loop ((ls ls) (parts '()))
     98          ;Get this section
     99          #;(assert (not (null? ls)))
     100          (let-values (((part nls) (split-at+ ls n pads)))
     101            (cond
     102              ((null? nls)
     103                ;Possible empty section when no padding.
     104                ;otherwise complete with this, the last,
     105                ;section
     106                (if (null? part) (reverse! parts)
     107                  (reverse! (cons part parts)) ) )
     108              (else
     109                ;Skip over "between" elements and
     110                ;continue sectioning the list.
     111                (let ((ls (cond
     112                            ;step = n
     113                            ((zero? inc)      nls )
     114                            ;step < n so skip from starting this section element
     115                            ((negative? inc)  (skip+ ls (+ n inc)) )
     116                            ;step > n so skip remaining elements in between
     117                            (else             (skip+ nls inc) ) ) ) )
     118                  (loop ls (cons part parts)) ) ) ) ) ) ) ) ) )
    44119
    45120;;
     
    195270(define (*alist-delete/count loc key al cmp cnt)
    196271  (check-procedure loc cmp)
    197   (let loop ((cal al) (cnt (check-integer loc cnt)) (oal '()))
     272  (let loop ((cal al) (cnt (check-fixnum loc cnt)) (oal '()))
    198273    (cond
    199274      ((null? cal)
     
    221296  (check-procedure loc cmp)
    222297  (let ((ral al))
    223     (let loop ((cal al) (pal #f) (cnt (check-integer loc cnt)))
     298    (let loop ((cal al) (pal #f) (cnt (check-fixnum loc cnt)))
    224299      (cond
    225300        ((or (null? cal) (not (positive? cnt)))
  • release/4/list-utils/trunk/list-utils.setup

    r20292 r20949  
    55(verify-extension-name "list-utils")
    66
    7 (setup-shared-extension-module 'list-utils (extension-version "1.0.0")
     7(setup-shared-extension-module 'list-utils (extension-version "1.1.0")
    88  #:compile-options '(
    99    -scrutinize
  • release/4/list-utils/trunk/tests/run.scm

    r19232 r20949  
    1 (use list-utils test data-structures)
     1(use test)
     2(use data-structures)
     3(use list-utils)
    24
    3 (test-group  "Lists"
     5(test-group  "Skip+"
     6  (test '(() -1) (receive (skip+ '() -1)))
     7  (test '(() 0) (receive (skip+ '() 0)))
     8  (test '(() 1) (receive (skip+ '() 1)))
     9  (test '((1) -1) (receive (skip+ '(1) -1)))
     10  (test '((1) 0) (receive (skip+ '(1) 0)))
     11  (test '(() 0) (receive (skip+ '(1) 1)))
     12  (test '(() 1) (receive (skip+ '(1) 2)))
     13  (test '((1 2) -1) (receive (skip+ '(1 2) -1)))
     14  (test '((1 2) 0) (receive (skip+ '(1 2) 0)))
     15  (test '((2) 0) (receive (skip+ '(1 2) 1)))
     16  (test '(() 0) (receive (skip+ '(1 2) 2)))
     17)
    418
    5   (define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
    6   (define alst2 '((a . 1) (b . 2) (b . 3) (c . 4) (b . 5) (a . 6) (d . 7)))
     19(test-group  "Split-at+"
     20  (test '(() ()) (receive (split-at+ '() -1 #f)))
     21  (test '(() ()) (receive (split-at+ '() 0 #f)))
     22  (test '(() ()) (receive (split-at+ '() 1 #f)))
     23  (test '(() ()) (receive (split-at+ '() -1 '())))
     24  (test '(() ()) (receive (split-at+ '() 0 '())))
     25  (test '(() ()) (receive (split-at+ '() 1 '())))
     26  (test '(() ()) (receive (split-at+ '() -1 '(1))))
     27  (test '(() ()) (receive (split-at+ '() 0 '(1))))
     28  (test '(() ()) (receive (split-at+ '() 1 '(1))))
     29  (test '(() (1)) (receive (split-at+ '(1) -1 #f)))
     30  (test '(() (1)) (receive (split-at+ '(1) 0 #f)))
     31  (test '((1) ()) (receive (split-at+ '(1) 1 #f)))
     32  (test '(() ()) (receive (split-at+ '(1) 2 #f)))
     33  (test '(() (1)) (receive (split-at+ '(1) -1 '())))
     34  (test '(() (1)) (receive (split-at+ '(1) 0 '())))
     35  (test '((1) ()) (receive (split-at+ '(1) 1 '())))
     36  (test '((1) ()) (receive (split-at+ '(1) 2 '())))
     37  (test '(() (1)) (receive (split-at+ '(1) -1 '(2))))
     38  (test '(() (1)) (receive (split-at+ '(1) 0 '(2))))
     39  (test '((1) ()) (receive (split-at+ '(1) 1 '(2))))
     40  (test '((1 2) ()) (receive (split-at+ '(1) 2 '(2))))
     41)
    742
     43(test-group  "Section"
     44  ;(section LIST SIZE [STEP [PADS]])
     45  ;Needs more tests
     46
     47  (test-error "size <= 0" (section '(1 2) -1 1 #f))
     48  (test-error "size <= 0" (section '(1 2) 0 1 #f))
     49  (test-error "step <= 0" (section '(1 2) 1 -1 #f))
     50  (test-error "step <= 0" (section '(1 2) 1 0 #f))
     51
     52  (test "null primary" '() (section '() 1 1 #f))
     53  (test "size > length primary & no pad" '() (section '(1) 2 2 #f))
     54
     55  (test '((1) (2)) (section '(1 2) 1 1 #f))
     56  (test '((1 2)) (section '(1 2) 2 2 #f))
     57  (test "size > length primary & clip" '((1 2)) (section '(1 2) 3 3 '()))
     58  (test "size > length primary & pad" '((1 2 3)) (section '(1 2) 3 3 '(3 4 5)))
     59
     60  (test "size > step" '((1 2) (2 3)) (section '(1 2 3) 2 1))
     61  (test "size < step" '((1) (3)) (section '(1 2 3) 1 2))
     62
     63  (test '((1 2) (2 3)) (section '(1 2 3) 2 1 '(a b c)))
     64  (test '((1 2 a)) (section '(1 2) 3 3 '(a b c)))
     65  (test '((1 2) (3 a)) (section '(1 2 3) 2 2 '(a b c)))
     66  (test '((1 2) (3)) (section '(1 2 3) 2 2))
     67)
     68
     69(define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
     70(define alst2 '((a . 1) (b . 2) (b . 3) (c . 4) (b . 5) (a . 6) (d . 7)))
     71
     72(test-group  "Length"
    873        (test-assert (length=0? '()))
    974        (test-assert (not (length=0? '(1))))
     
    1883        (test-assert (not (length>1? '())))
    1984        (test-assert (not (length>1? '(1))))
     85)
    2086
     87(test-group  "Null Stuff"
    2188  (test '(1) (ensure-list '(1)))
    2289  (test '(1) (ensure-list 1))
     
    2491  (test '(1) (not-null? '(1)))
    2592  (test-assert (not (not-null? '())))
     93)
    2694
     95(test-group  "Shift Set"
    2796  (let ((lst '(1 2)))
    2897    (test 1 (shift!/set lst))
     
    33102    (test '() (identity lst))
    34103  )
     104)
    35105
     106(test-group  "Alist Zip"
    36107  (test '((a b) ((1) (2))) (receive (unzip-alist '((a 1) (b 2)))))
    37108  (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
    38109  (test '((a 1) (b 2)) (zip-alist '(a b) '((1) (2))))
    39110  (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
     111)
    40112
     113(test-group  "Plist <-> Alist"
    41114  (test '(a (1) b (2) b (3) c (4) b (5) a (6) d (7)) (alist->plist alst1))
    42115  (test '(a 1 b 2 b 3 c 4 b 5 a 6 d 7) (alist->plist alst2))
    43116  (test alst1 (plist->alist '(a (1) b (2) b (3) c (4) b (5) a (6) d (7))))
    44117  (test alst2 (plist->alist '(a 1 b 2 b 3 c 4 b 5 a 6 d 7)))
     118)
    45119
     120(test-group  "Alist Delete"
    46121  (test '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete/count 'b alst1 eq? 2))
    47122  (test '((a 1) (c 4) (a 6) (d 7)) (alist-delete/count 'b alst1 eq?))
Note: See TracChangeset for help on using the changeset viewer.