Move various common prefix functions from unstable/list to racket/list.

Make their interface consistent with the rest of racket/list.

pkgs/racket-doc/scribblings/reference/pairs.scrbl

@@ -1011,6 +1011,50 @@ Like @racket[takef], @racket[dropf], and @racket[splitf-at], but
 combined with the from-right functionality of @racket[take-right],
 @racket[drop-right], and @racket[split-at-right].}
 
+@defproc[(list-prefix? [l list?]
+                       [r list?]
+                       [same? (any/c any/c . -> . any/c) equal?])
+         boolean?]{
+ True if @racket[l] is a prefix of @racket[r].
+@examples[#:eval list-eval
+(list-prefix? '(1 2) '(1 2 3 4 5))
+]
+}
+
+@defproc[(take-common-prefix [l list?] [r list?]
+                             [same? (any/c any/c . -> . any/c) equal?])
+         list?]{
+
+  Returns the longest common prefix of @racket[l] and @racket[r].
+
+@examples[#:eval list-eval
+(take-common-prefix '(a b c d) '(a b x y z))
+]
+}
+
+@defproc[(drop-common-prefix [l list?] [r list?]
+                             [same? (any/c any/c . -> . any/c) equal?])
+         (values list? list?)]{
+
+  Returns the tails of @racket[l] and @racket[r] with the common
+  prefix removed.
+
+@examples[#:eval list-eval
+(drop-common-prefix '(a b c d) '(a b x y z))
+]
+}
+
+@defproc[(split-common-prefix [l list?] [r list?]
+                              [same? (any/c any/c . -> . any/c) equal?])
+         (values list? list? list?)]{
+
+  Returns the longest common prefix together with the tails of
+  @racket[l] and @racket[r] with the common prefix removed.
+
+@examples[#:eval list-eval
+(split-common-prefix '(a b c d) '(a b x y z))
+]
+}
 
 
 @defproc[(add-between [lst list?] [v any/c]

pkgs/racket-test-core/tests/racket/list.rktl

@@ -584,4 +584,36 @@
 (err/rt-test (list-set '(zero one two) -1 "two"))
 (err/rt-test (list-set '(zero one two) #f "two"))
 
+;; ---------- list prefix functions ----------
+
+(test #t list-prefix? '(1 2) '(1 2 3 4 5))
+(test #f list-prefix? '(2 1) '(1 2 3 4 5))
+(test #t list-prefix? '(1 2) '(1 2 3 4 5) =)
+(test #f list-prefix? '(2 1) '(1 2 3 4 5) =)
+(err/rt-test (list-prefix? #t '()))
+(err/rt-test (list-prefix? '() #t))
+(test '(a b) take-common-prefix '(a b c d) '(a b x y z))
+(test '() take-common-prefix '(1 a b c d) '(a b x y z))
+(test '(a b c d) take-common-prefix '(a b c d) '(a b c d))
+(test '(1 2) take-common-prefix '(1 2 3 4) '(1 2 4 3) =)
+(err/rt-test (take-common-prefix '() '() #f))
+(define (drop*-list xs ys [=? equal?])
+  (define-values (a b)
+    (drop-common-prefix xs ys =?))
+  (list a b))
+(test '((c d) (x y z)) drop*-list '(a b c d) '(a b x y z))
+(test '((1 a b c d) (a b x y z)) drop*-list '(1 a b c d) '(a b x y z))
+(test '(() ()) drop*-list '(a b c d) '(a b c d))
+(test '((3 4) (4 3)) drop*-list '(1 2 3 4) '(1 2 4 3) =)
+(err/rt-test (drop*-list '() '() #f))
+(define (split*-list xs ys [=? equal?])
+  (define-values (a b c)
+    (split-common-prefix xs ys =?))
+  (list a b c))
+(test '((a b) (c d) (x y z)) split*-list '(a b c d) '(a b x y z))
+(test '(() (1 a b c d) (a b x y z)) split*-list '(1 a b c d) '(a b x y z))
+(test '((a b c d) () ()) split*-list '(a b c d) '(a b c d))
+(test '((1 2) (3 4) (4 3)) split*-list '(1 2 3 4) '(1 2 4 3) =)
+(err/rt-test (split*-list '() '() #f))
+
 (report-errs)

racket/collects/racket/list.rkt

@@ -26,6 +26,11 @@
          dropf-right
          splitf-at-right
 
+         list-prefix?
+         split-common-prefix
+         take-common-prefix
+         drop-common-prefix
+
          append*
          flatten
          add-between
@@ -257,6 +262,51 @@
 (define (splitf-at-right list pred)
   (split-at list (count-from-right 'splitf-at-right list pred)))
 
+; list-prefix? : list? list? -> boolean?
+; Is l a prefix or r?
+(define (list-prefix? ls rs [same? equal?])
+  (unless (list? ls)
+    (raise-argument-error 'list-prefix? "list?" ls))
+  (unless (list? rs)
+    (raise-argument-error 'list-prefix? "list?" rs))
+  (unless (and (procedure? same?)
+               (procedure-arity-includes? same? 2))
+    (raise-argument-error 'list-prefix? "(any/c any/c . -> . any/c)" same?))
+  (or (null? ls)
+      (and (pair? rs)
+           (same? (car ls) (car rs))
+           (list-prefix? (cdr ls) (cdr rs)))))
+
+;; Eli: How about a version that removes the equal prefix from two lists
+;; and returns the tails -- this way you can tell if they're equal, or
+;; one is a prefix of the other, or if there was any equal prefix at
+;; all.  (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.
+
+(define (internal-split-common-prefix as bs same? keep-prefix? name)
+  (unless (and (procedure? same?)
+               (procedure-arity-includes? same? 2))
+    (raise-argument-error name "(any/c any/c . -> . any/c)" same?))
+  (let loop ([as as] [bs bs])
+    (if (and (pair? as) (pair? bs) (same? (car as) (car bs)))
+        (let-values ([(prefix atail btail) (loop (cdr as) (cdr bs))])
+          (values (and keep-prefix? (cons (car as) prefix)) atail btail))
+        (values null as bs))))
+
+(define (split-common-prefix as bs [same? equal?])
+  (internal-split-common-prefix as bs same? #t 'split-common-prefix))
+
+(define (take-common-prefix as bs [same? equal?])
+  (let-values ([(prefix atail btail)
+                (internal-split-common-prefix as bs same? #t 'take-common-prefix)])
+    prefix))
+
+(define (drop-common-prefix as bs [same? equal?])
+  (let-values ([(prefix atail btail)
+                (internal-split-common-prefix as bs same? #f 'drop-common-prefix)])
+    (values atail btail)))
+
 (define append*
   (case-lambda [(ls) (apply append ls)] ; optimize common case
                [(l1 l2) (apply append l1 l2)]