Changeset 39547 in project


Ignore:
Timestamp:
01/29/21 03:27:25 (5 weeks ago)
Author:
Kon Lovett
Message:

add unique, fix test

Location:
release/5/list-utils/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/list-utils/trunk/list-utils.egg

    r38846 r39547  
    1 ;;;; list-utils.egg  -*- Scheme -*-
     1;;;; list-utils.egg  -*- scheme -*-
    22;;;; Kon Lovett, Jul '18
    33
    44((synopsis "list-utils")
    5  (version "2.1.1")
     5 (version "2.2.0")
    66 (category data)
    7  (author "[[kon lovett]]")
     7 (author "Kon Lovett")
    88 (license "BSD")
    99 (dependencies srfi-1 check-errors)
     
    1212  (extension list-utils
    1313    (types-file)
    14     (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks")) ) )
     14    (csc-options
     15      "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks")) ) )
  • release/5/list-utils/trunk/list-utils.scm

    r38846 r39547  
    1 ;;;; list-utils.scm  -*- Scheme -*-
     1;;;; list-utils.scm  -*- scheme -*-
    22;;;; Kon Lovett, Mar '20
    33;;;; Kon Lovett, Jul '18
     
    99
    1010(;export
     11  list-unique/duplicates
     12  list-unique
    1113  skip+
    1214  split-at+
     
    2830  list-copy*)
    2931
    30 (import scheme)
    31 (import (chicken base))
    32 (import (only (chicken fixnum) most-positive-fixnum))
    33 (import (chicken type))
    34 (import (only (srfi 1)
    35   make-list cons*
    36   proper-list?
    37   reverse! append-reverse! append!
    38   take drop
    39   every
    40   split-at))
    41 (import (only type-checks
    42   check-list check-alist check-pair
    43   check-procedure
    44   check-fixnum check-positive-fixnum))
    45 (import (only type-errors error-alist define-error-type))
     32(import scheme
     33  (chicken base)
     34  (only (chicken fixnum) most-positive-fixnum)
     35  (chicken type)
     36  (only (srfi 1)
     37    first
     38    make-list cons*
     39    proper-list?
     40    reverse! append-reverse! append!
     41    take drop
     42    every
     43    split-at)
     44  (only type-checks
     45    check-list check-alist check-pair
     46    check-procedure
     47    check-fixnum check-positive-fixnum)
     48  (only type-errors error-alist define-error-type))
    4649
    4750;;;
    4851
    49 (define-type binary-predicate (* * --> boolean))
     52(define-type binary-test (* * -> boolean))
    5053
    5154(define-type alist (or null (list-of pair)))
     55
     56(: list-unique/duplicates (list #!optional procedure -> list list))
     57(: list-unique (list #!optional procedure -> list))
     58(: sort-alist (alist #!optional procedure -> alist))
     59(: sort-alist! (alist #!optional procedure -> void))
     60(: skip+ (list fixnum --> list fixnum))
     61(: split-at+ (list fixnum #!optional (or boolean list) --> list list))
     62(: section (list fixnum #!optional fixnum (or boolean list) --> list))
     63(: plist->alist (list --> alist))
     64(: alist->plist (alist --> list))
     65(: alist? (* -> boolean : alist))
     66(: alist-inverse-ref (* alist #!optional binary-test * --> *))
     67(: alist-delete-duplicates (* alist #!optional binary-test fixnum --> alist))
     68(: alist-delete-duplicates! (* alist #!optional binary-test fixnum --> alist))
     69(: zip-alist (list list --> alist))
     70(: unzip-alist (alist --> list list))
     71(: shift! (list #!optional * --> *))
     72(: unshift! (* list --> list))
     73(: andmap (procedure list #!rest list --> *))
     74(: ormap (procedure list #!rest list --> *))
     75(: pair-ref (list fixnum --> list))
     76(: list-set! (list fixnum * -> void))
     77(: list-copy* (list #!optional fixnum fixnum * --> list))
     78(: *skip+ (list fixnum --> list fixnum))
     79(: *split-at+ (list fixnum (or boolean list) --> list list))
     80(: *alist-delete-duplicates (symbol * alist binary-test fixnum --> alist))
     81(: *alist-delete-duplicates! (symbol * alist binary-test fixnum --> alist))
    5282
    5383;;
     
    6090(import (chicken sort))
    6191
    62 (: sort-alist (alist #!optional procedure -> alist))
    63 ;
    6492(define (sort-alist xs #!optional (lt? <))
    6593  (sort xs (lambda (a b) (lt? (car a) (car b)))) )
    6694
    67 (: sort-alist! (alist #!optional procedure -> void))
    68 ;
    6995(define (sort-alist! xs #!optional (lt? <))
    7096  (sort! xs (lambda (a b) (lt? (car a) (car b)))) )
     
    7399;;;
    74100
     101;; Unique sorted list
     102
     103;=> (values ls dups)
     104;
     105(define (list-unique/duplicates ls #!optional (eqal? equal?))
     106  (check-procedure 'list-unique/duplicates eqal? 'eqal?)
     107  (if (null? (check-list 'list-unique/duplicates ls))
     108    ls
     109    (let ((curr (first ls)))
     110      (let loop ((ils (cdr ls)) (ols (list curr)) (prev curr) (dups '()))
     111        (if (null? ils)
     112          (values (reverse! ols) (reverse! dups))
     113          (let ((curr (first ils)) (rst (cdr ils)))
     114            (if (eqal? prev curr)
     115              (loop rst ols prev (cons curr dups))
     116              (loop rst (cons curr ols) curr dups) ) ) ) ) ) ) )
     117
     118;=> ls
     119;
     120(define (list-unique ls #!optional (eqal? equal?))
     121  (check-procedure 'list-unique eqal? 'eqal?)
     122  (if (null? (check-list 'list-unique ls))
     123    ls
     124    (let ((curr (first ls)))
     125      (let loop ((ils (cdr ls)) (ols (list curr)) (prev curr))
     126        (if (null? ils)
     127          (reverse! ols)
     128          (let ((curr (first ils)) (rst (cdr ils)))
     129            (if (eqal? prev curr)
     130              (loop rst ols prev)
     131              (loop rst (cons curr ols) curr) ) ) ) ) ) ) )
     132
    75133;; Returns the original list starting at element n.
    76134
    77 (: skip+ (list fixnum --> list fixnum))
    78 ;
    79135(define (skip+ ls n)
    80136  (*skip+ (check-list 'skip+ ls 'ls) (check-fixnum 'skip+ n 'n)) )
     
    86142;; no padding & paritial section.
    87143
    88 (: split-at+ (list fixnum #!optional (or boolean list) --> list list))
    89 ;
    90144(define (split-at+ ls n #!optional pads)
    91145  (*split-at+
     
    103157;pads - remainder fill
    104158
    105 (: section (list fixnum #!optional fixnum (or boolean list) --> list))
    106 ;
    107159(define (section ls n #!optional (step n) (pads '()))
    108160  (cond
     
    147199(define-syntax shift!/set
    148200        (syntax-rules ()
     201          ;
    149202                ((shift!/set ?var)
    150203                  (shift!/set ?var #f) )
     204          ;
    151205                ((shift!/set ?var ?empval)
    152206      (if (not (pair? ?var))
     
    270324; (<key>1 <val>1 ... <key>n <val>n) -> ((<key>1 . <val>1) ... (<key>n . <val>n))
    271325
    272 (: plist->alist (list --> alist))
    273 ;
    274326(define (plist->alist pls)
    275327  (let loop ((pls (check-list 'plist->alist pls)) (als '()))
     
    285337; ((<key>1 . <val>1) ... (<key>n . <val>n)) -> (<key>1 <val>1 ... <key>n <val>n)
    286338
    287 (: alist->plist (alist --> list))
    288 ;
    289339(define (alist->plist als)
    290340  (let loop ((als (check-list 'alist->plist als)) (pls '()))
     
    298348;;
    299349
    300 (: alist? (* -> boolean : alist))
    301 ;
    302350(define (alist? obj)
    303351  (and
     
    307355;; Search the alist from back to front.
    308356
    309 (: alist-inverse-ref (* alist #!optional binary-predicate * --> *))
    310 ;
    311357(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
    312358  (let (
     
    322368;; Remove 1st N matching elements from the alist (functional)
    323369
    324 (: alist-delete-duplicates (* alist #!optional binary-predicate fixnum --> alist))
    325 ;
    326370(define (alist-delete-duplicates key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
    327371  (*alist-delete-duplicates 'alist-delete-duplicates key al cmp cnt) )
    328372
    329 (: alist-delete-duplicates! (* alist #!optional binary-predicate fixnum --> alist))
    330 ;
    331373(define (alist-delete-duplicates! key al #!optional (cmp eqv?) (cnt most-positive-fixnum))
    332374  (*alist-delete-duplicates! 'alist-delete-duplicates! key al cmp cnt) )
     
    336378
    337379; This works with any proper list, not just an alist.
    338 (: zip-alist (list list --> alist))
    339 ;
    340380(define (zip-alist keys vals)
    341381  (unless
     
    346386;; Split alist into (values keys vals)
    347387
    348 (: unzip-alist (alist --> list list))
    349 ;
    350388(define (unzip-alist al)
    351389  (let loop ((al (check-list 'unzip-alist al)) (keys '()) (vals '()))
     
    359397;;; Handy little things:
    360398
    361 (: shift! (list #!optional * --> *))
    362 ;
    363399(define (shift! ls #!optional def)
    364400  (check-list 'shift! ls)
     
    373409      x ) ) )
    374410
    375 (: unshift! (* list --> list))
    376 ;
    377411(define (unshift! x ls)
    378412  (check-pair 'unshift! ls)
     
    383417;;
    384418
    385 (: andmap (procedure list #!rest list --> *))
    386 ;
    387419(define (andmap func ls0 . rest)
    388420  (cond
     
    412444            (mapf (cdr ls0) (map cdr rest)))) ) ) ) )
    413445
    414 (: ormap (procedure list #!rest list --> *))
    415 ;
    416446(define (ormap func ls0 . rest)
    417447  (and
     
    422452        (apply ormap func (map cdr rest)) ) ) ) )
    423453
    424 (: pair-ref (list fixnum --> list))
    425 ;
    426454(define pair-ref drop)
    427455
    428 (: list-set! (list fixnum * -> void))
    429 ;
    430456(define (list-set! ls idx val)
    431457  (let ((ls (pair-ref ls idx)))
     
    434460      (set-car! ls val) ) ) )
    435461
    436 (: list-copy* (list #!optional fixnum fixnum * --> list))
    437 ;
    438462(define (list-copy* ls #!optional (start 0) (end (length ls)) (fill (void)))
    439463  (unless (<= start end)
     
    449473;;;
    450474
    451 (: *skip+ (list fixnum --> list fixnum))
    452 ;
    453475(define (*skip+ ls n)
    454476  (if (or (null? ls) (<= n 0))
     
    456478    (*skip+ (cdr ls) (- n 1))) )
    457479
    458 (: *split-at+ (list fixnum (or boolean list) --> list list))
    459 ;
    460480(define (*split-at+ ls n pads)
    461481  ;Do not attempt to padout when the primary list is empty.
     
    479499          (loop (cdr ls) (- n 1) (cons (car ls) part)) ) ) ) ) )
    480500
    481 (: *alist-delete-duplicates (symbol * alist binary-predicate fixnum --> alist))
    482 ;
    483501(define (*alist-delete-duplicates loc key al cmp cnt)
    484502  (check-procedure loc cmp)
     
    502520        (error-alist loc al) ) ) ) )
    503521
    504 (: *alist-delete-duplicates! (symbol * alist binary-predicate fixnum --> alist))
    505 ;
    506522(define (*alist-delete-duplicates! loc key al cmp cnt)
    507523  (check-procedure loc cmp)
  • release/5/list-utils/trunk/tests/list-utils-test.scm

    r38846 r39547  
    99
    1010(import list-utils)
     11
     12(test-group  "Unique"
     13  (test '((a b c d e) (a d)) (receive (list-unique/duplicates '(a a b c d d e))))
     14  (test '(a b c d e) (list-unique '(a a b c d d e)))
     15)
    1116
    1217(test-group  "Skip+"
     
    101106)
    102107
     108(import (chicken type))
     109
    103110(test-group  "Shift Set"
    104   (let ((lst '(1 2)))
     111  (let ((lst (the (or list false) '(1 2))))
    105112    (test 1 (shift!/set lst))
    106113    (test '(2) (identity lst))
Note: See TracChangeset for help on using the changeset viewer.