www

commit 84c6dad33e3c7042d49e3e4ea8102c1a6d096a21
parent 95bb2cfbb0a1334cd4a1ba146ba498055af76968
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Sun, 15 Nov 2009 07:00:44 +0000

unstable/syntax: changed format-id to autoconvert identifiers
unstable/struct: changed struct->list, more options
added unstable/find

svn: r16774

original commit: 4517f379424d204ddff7576f45144812f9fec520

Diffstat:
A
collects/unstable/find.ss
 | 
69
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A
collects/unstable/scribblings/find.scrbl
 | 
74
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

2 files changed, 143 insertions(+), 0 deletions(-)
diff --git a/collects/unstable/find.ss b/collects/unstable/find.ss
@@ -0,0 +1,69 @@
+#lang scheme/base
+(require scheme/contract
+         unstable/struct)
+
+(provide/contract
+ [find
+  (->* ((-> any/c any/c)
+        any/c)
+       (#:stop-on-found? any/c
+        #:stop (or/c #f (-> any/c any/c))
+        #:get-children (or/c #f (-> any/c (or/c #f list?))))
+       list?)]
+ [find-first
+  (->* ((-> any/c any/c)
+        any/c)
+       (#:stop (or/c #f (-> any/c any/c))
+        #:get-children (or/c #f (-> any/c (or/c #f list?)))
+        #:default any/c)
+       any/c)])
+
+(define (find pred x
+              #:stop-on-found? [stop-on-found? #f]
+              #:stop [stop #f]
+              #:get-children [get-children #f])
+  (define (loop x acc)
+    (cond [(pred x)
+           (let ([acc (cons x acc)])
+             (if stop-on-found?
+                 acc
+                 (loop/nf x acc)))]
+          [else
+           (loop/nf x acc)]))
+  ;; loop/nt: x is "not found"; look in its children
+  (define (loop/nf x acc)
+    (cond [(and stop (stop x))
+           acc]
+          [(and get-children (get-children x))
+           => (lambda (children) (loop* children acc))]
+          [(pair? x)
+           (let ([acc (loop (car x) acc)])
+             (loop (cdr x) acc))]
+          [(vector? x)
+           (for/fold ([acc acc]) ([elem (in-vector x)])
+             (loop elem acc))]
+          [(box? x)
+           (loop (unbox x) acc)]
+          [(struct->list x #:on-opaque 'skip)
+           => (lambda (elems)
+                (loop* elems acc))]
+          ;; unreachable, since
+          ;; (struct->list X #:on-opaque 'skip) always returns a list
+          [else acc]))
+  (define (loop* xs acc)
+    (for/fold ([acc acc]) ([elem (in-list xs)])
+      (loop elem acc)))
+  (reverse (loop x null)))
+
+
+(define (find-first pred x
+                    #:stop [stop #f]
+                    #:get-children [get-children #f]
+                    #:default [default #f])
+  (let/ec return
+    (define (pred* x)
+      (and (pred x) (return x)))
+    (find pred* x #:stop stop #:get-children get-children)
+    (if (procedure? default)
+        (default)
+        default)))
diff --git a/collects/unstable/scribblings/find.scrbl b/collects/unstable/scribblings/find.scrbl
@@ -0,0 +1,74 @@
+#lang scribble/manual
+@(require scribble/eval
+          (for-label unstable/find
+                     scheme/contract
+                     scheme/shared
+                     scheme/base))
+
+@title[#:tag "find"]{Find}
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require unstable/find))
+@(the-eval '(require scheme/shared))
+
+@defmodule[unstable/find]
+
+@defproc[(find [pred (-> any/c any/c)]
+               [x any/c]
+               [#:stop-on-found? stop-on-found? any/c #f]
+               [#:stop stop (or/c #f (-> any/c any/c)) #f]
+               [#:get-children get-children (or/c #f (-> any/c (or/c #f list?))) #f])
+         list?]{
+
+Returns a list of all values satisfying @scheme[pred] contained in
+@scheme[x] (possibly including @scheme[x] itself). 
+
+If @scheme[stop-on-found?] is true, the children of values satisfying
+@scheme[pred] are not examined. If @scheme[stop] is a procedure, then
+the children of values for which @scheme[stop] returns true are not
+examined (but the values themselves are; @scheme[stop] is applied
+after @scheme[pred]). Only the current branch of the search is
+stopped, not the whole search.
+
+The search recurs through pairs, vectors, boxes, and the accessible
+fields of structures. If @scheme[get-children] is a procedure, it can
+override the default notion of a value's children by returning a list
+(if it returns false, the default notion of children is used).
+
+No cycle detection is done, so @scheme[find] on a cyclic graph may
+diverge. To do cycle checking yourself, use @scheme[stop] and a
+mutable table.
+
+@examples[#:eval the-eval
+(find symbol? '((all work) and (no play)))
+(find list? '#((all work) and (no play)) #:stop-on-found? #t)
+(find negative? 100 
+      #:stop-on-found? #t
+      #:get-children (lambda (n) (list (- n 12))))
+(find symbol? (shared ([x (cons 'a x)]) x)
+      #:stop (let ([table (make-hasheq)])
+               (lambda (x)
+                 (begin0 (hash-ref table x #f)
+                         (hash-set! table x #t)))))
+]
+}
+
+@defproc[(find-first [pred (-> any/c any/c)]
+                     [x any/c]
+                     [#:stop stop (or/c #f (-> any/c any/c)) #f]
+                     [#:get-children get-children (or/c #f (-> any/c (or/c #f list?))) #f]
+                     [#:default default any/c (lambda () (error ....))])
+         any/c]{
+
+Like @scheme[find-first], but only returns the first match. If no
+matches are found, @scheme[default] is applied as a thunk if it is a
+procedure or returned otherwise.
+
+@examples[#:eval the-eval
+(find-first symbol? '((all work) and (no play)))
+(find-first list? '#((all work) and (no play)))
+(find-first negative? 100 
+            #:get-children (lambda (n) (list (- n 12))))
+(find-first symbol? (shared ([x (cons 'a x)]) x))
+]
+}