unstable/list: added check-duplicate

svn: r17173

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)
+(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)))))))

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)
-}
+}
+
+
+@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)
+]
+}