diff --git a/collects/unstable/list.ss b/collects/unstable/list.ss index 697f100c98..661721467a 100644 --- a/collects/unstable/list.ss +++ b/collects/unstable/list.ss @@ -1,19 +1,15 @@ -#lang scheme +#lang scheme/base +(require scheme/contract + scheme/dict) -; list-prefix : list? list? -> (or/c list? false/c) -; Is l a prefix or r?, and what is that prefix? +; list-prefix : list? list? -> boolean? +; Is l a prefix or r? (define (list-prefix? ls rs) - (match ls - [(list) - #t] - [(list-rest l0 ls) - (match rs - [(list) - #f] - [(list-rest r0 rs) - (if (equal? l0 r0) - (list-prefix? ls rs) - #f)])])) + (or (null? ls) + (and (pair? rs) + (equal? (car ls) (car rs)) + (list-prefix? (cdr ls) (cdr rs))))) + ;; Eli: Is this some `match' obsession syndrom? The simple definition: ;; (define (list-prefix? ls rs) ;; (or (null? ls) (and (pair? rs) (equal? (car ls) (car rs)) @@ -25,6 +21,7 @@ ;; (Which can be useful for things like making a path relative to ;; another path.) A nice generalization is to make it get two or more ;; lists, and return a matching number of values. +;; ryanc: changed to use Eli's version (provide/contract [list-prefix? (list? list? . -> . boolean?)]) @@ -38,4 +35,52 @@ (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) -(provide filter-multiple extend) \ No newline at end of file +(provide filter-multiple extend) + +;; ryanc added: + +(provide/contract + [check-duplicate + (->* (list?) + (#:key (-> any/c any/c) + #:same? (or/c dict? (-> any/c any/c any/c))) + any)]) + +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl index ac5f7bf9ed..aedc04c1b5 100644 --- a/collects/unstable/scribblings/list.scrbl +++ b/collects/unstable/scribblings/list.scrbl @@ -3,9 +3,11 @@ scribble/manual scribble/eval "utils.ss" - (for-label unstable/list - scheme/contract - scheme/base)) + (for-label scheme/dict + unstable/list + syntax/id-table + scheme/contract + scheme/base)) @(define the-eval (make-base-eval)) @(the-eval '(require unstable/list)) @@ -40,4 +42,38 @@ Extends @scheme[l2] to be as long as @scheme[l1] by adding @scheme[(- @examples[#:eval the-eval] (extend '(1 2 3) '(a) 'b) -} \ No newline at end of file +} + + +@addition{Ryan Culpepper} + +@defproc[(check-duplicate [lst list?] + [#:key extract-key (-> any/c any/c) (lambda (x) x)] + [#:same? same? + (or/c (any/c any/c . -> . any/c) + dict?) + equal?]) + (or/c any/c #f)]{ + +Returns the first duplicate item in @scheme[lst]. More precisely, it +returns the first @scheme[_x] such that there was a previous +@scheme[_y] where @scheme[(same? (extract-key _x) (extract-key _y))]. + +The @scheme[same?] argument can either be an equivalence predicate +such as @scheme[equal?] or @scheme[eqv?] or a dictionary. In the +latter case, the elements of the list are mapped to @scheme[#t] in the +dictionary until an element is discovered that is already mapped to a +true value. The procedures @scheme[equal?], @scheme[eqv?], and +@scheme[eq?] automatically use a dictionary for speed. + +@(the-eval '(require syntax/id-table scheme/dict)) +@examples[#:eval the-eval +(check-duplicate '(1 2 3 4)) +(check-duplicate '(1 2 3 2 1)) +(check-duplicate '((a 1) (b 2) (a 3)) #:key car) +(define id-t (make-free-id-table)) +(check-duplicate (syntax->list #'(a b c d a b)) + #:same? id-t) +(dict-map id-t list) +] +}