add shrink-path-wrt

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

@@ -549,6 +549,8 @@ machine and volume names become path elements.
 @;------------------------------------------------------------------------
 @section{More Path Utilities}
 
+@(define path-eval (make-base-eval `(require racket/path)))
+
 @note-lib[racket/path]
 
 @defproc[(file-name-from-path [path (or/c path-string? path-for-some-system?)])
@@ -652,6 +654,26 @@ Use this function when working with paths for a different system
 (whose encoding of pathnames might be unrelated to the current
 locale's encoding) and when starting and ending with strings.}
 
+@defproc[(shrink-path-wrt [pth path?] [other-pths (listof path?)]) (or/c #f path?)]{
+  Returns a suffix of @racket[pth] that shares nothing
+  in common with the suffixes of @racket[other-pths], or
+  @racket[pth], if not possible (e.g. when @racket[other-pths]
+  is empty or contains only paths with the same elements as @racket[pth]).
+  
+  @examples[#:eval path-eval
+                   (shrink-path-wrt (build-path "racket" "list.rkt")
+                                    (list (build-path "racket" "list.rkt")
+                                          (build-path "racket" "base.rkt")))
+                   
+                   (shrink-path-wrt (build-path "racket" "list.rkt")
+                                    (list (build-path "racket" "list.rkt")
+                                          (build-path "racket" "private" "list.rkt")
+                                          (build-path "racket" "base.rkt")))]
+
+}
+
+@close-eval[path-eval]
+
 @;------------------------------------------------------------------------
 @include-section["unix-paths.scrbl"]
 @include-section["windows-paths.scrbl"]

pkgs/racket-pkgs/racket-test/tests/racket/pathlib.rktl

@@ -86,4 +86,31 @@
 
 ;; ----------------------------------------
 
+(test #f shrink-path-wrt (build-path "x.rkt") '())
+(test #f shrink-path-wrt (build-path "x.rkt") (list (build-path "x.rkt")))
+(test (build-path "x.rkt") shrink-path-wrt (build-path "x.rkt") (list (build-path "x.rkt")
+                                                                      (build-path "y.rkt")))
+(test (build-path "a" "x.rkt") shrink-path-wrt
+      (build-path "a" "x.rkt")
+      (list (build-path "a" "x.rkt")
+            (build-path "b" "x.rkt")))
+
+(test (build-path "d" "a" "x.rkt") shrink-path-wrt
+      (build-path "d" "a" "x.rkt")
+      (list (build-path "b" "x.rkt")
+            (build-path "c" "a" "x.rkt")
+            (build-path "d" "a" "x.rkt")))
+
+(test (build-path "d" "a" "x.rkt") shrink-path-wrt
+      (build-path "d" "a" "x.rkt")
+      (list (build-path "b" "x.rkt")
+            (build-path "p" "c" "a" "x.rkt")
+            (build-path "p" "d" "a" "x.rkt")))
+
+(test #f shrink-path-wrt
+      (build-path "d" "a" "x.rkt")
+      (list (build-path "d" "a" "x.rkt")
+            (build-path "d" "a" "x.rkt")))
+
+
 (report-errs)

racket/collects/racket/path.rkt

@@ -8,7 +8,8 @@
          path-only
          some-system-path->string
          string->some-system-path
-         path-element?)
+         path-element?
+         shrink-path-wrt)
 
 (define (simple-form-path p)
   (unless (path-string? p)
@@ -184,3 +185,55 @@
   (and (path-for-some-system? path)
        (let-values ([(base name d?) (split-path path)])
          (eq? base 'relative))))
+
+
+
+(define (shrink-path-wrt fn other-fns)
+  (unless (path? fn)
+    (raise-argument-error
+     'shrink-path-wrt
+     "path?"
+     0 fn other-fns))
+  (unless (and (list? other-fns) (andmap path? other-fns))
+    (raise-argument-error
+     'shrink-path-wrt
+     "(listof path?)"
+     1 fn other-fns))
+  (define exp (reverse (explode-path fn)))
+  (define other-exps
+    (filter
+     (λ (x) (not (equal? exp x)))
+     (map (λ (fn) (reverse (explode-path fn)))
+          other-fns)))
+  (cond
+    [(null? other-exps) #f]
+    [else
+     (define size
+       (let loop ([other-exps other-exps]
+                  [size 1])
+         (cond
+           [(null? other-exps) size]
+           [else (let ([new-size (find-exp-diff (car other-exps) exp)])
+                   (loop (cdr other-exps)
+                         (max new-size size)))])))
+     (apply build-path (reverse (take-n size exp)))]))
+  
+(define (take-n n lst)
+  (let loop ([n n]
+             [lst lst])
+    (cond
+      [(zero? n) null]
+      [(null? lst) null]
+      [else (cons (car lst) (loop (- n 1) (cdr lst)))])))
+
+(define (find-exp-diff p1 p2)
+  (let loop ([p1 p1]
+             [p2 p2]
+             [i 1])
+    (cond
+      [(or (null? p1) (null? p2)) i]
+      [else (let ([f1 (car p1)]
+                  [f2 (car p2)])
+              (if (equal? f1 f2)
+                  (loop (cdr p1) (cdr p2) (+ i 1))
+                  i))])))