blob: 44b64f046ba89ed8d95445775ead5ef743451d23 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BASE.plt - common routines that are shared by all other bzlib modules
;;
;; in a way, base.plt is the most fundamental module of the whole bzlib stack
;; and as such it also is the lowest level code. We are not likely to
;; fix the code any time soon, and hence any of the functions here are
;; explicitly likely to be obsoleted or moved elsewhere.
;;
;; Proceed with caution.
;;
;;
;; Bonzai Lab, LLC. All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; list.ss - basic functionalities that has to do with list processing.
;; yc 9/8/2009 - first version
;; yc 9/25/2009 - moved group from bzlib/dbd-memcached/dht to here; exported scheme/list
;; yc 2/10/2010 - move listof? from assert.ss (not sure why it was there) to list.ss
(require "base.ss" scheme/list scheme/contract)
(define (assoc/cdr key alist (default #f))
(if-it (assoc key alist)
(cdr it)
default))
(define (assoc/s key alist (default '()))
(let ((it (filter (lambda (kv)
(equal? (car kv) key))
alist)))
(if (null? it) default it)))
;; this function is a combo of member & assoc
;; it's useful when we have a malformed alist, where when the
;; pair has no value, the key is retained
;; (or when there is no key, the value is retained)
(define (assoc* key lst (default #f))
(define (helper rest)
(cond ((null? rest) default)
;; assoc behavior
((and (pair? (car rest))
(equal? key (caar rest)))
(car rest))
;; member behavior
((and (not (pair? (car rest)))
(equal? key (car rest)))
rest)
(else
(helper (cdr rest)))))
;; (trace helper)
(helper lst))
(define (assoc*/cdr key lst (default #f))
(if-it (assoc* key lst)
(cdr it)
default))
(define (group alist)
;; for each alist with the same key - group them together!!
(foldl (lambda (kv interim)
(if-it (assoc (car kv) interim) ;; the key already exists...
(cons (cons (car it) (cons (cdr kv) (cdr it)))
(filter (lambda (kv)
(not (equal? it kv))) interim))
(cons (list (car kv) (cdr kv)) interim)))
'()
alist))
(define (list->unique lst (equal? equal?))
(reverse (foldl (lambda (item interim)
(if (memf (lambda (item1)
(equal? item item1))
interim)
interim
(cons item interim)))
'()
lst)))
(define (listof? type?)
(lambda (args)
(and (list? args)
(andmap type? args))))
(provide/contract
(assoc/cdr (->* (any/c list?)
(any/c)
any))
(assoc/s (->* (any/c list?)
(any/c)
any))
(assoc* (->* (any/c list?)
(any/c)
any))
(assoc*/cdr (->* (any/c list?)
(any/c)
any))
(group (-> (or/c null? pair?) any))
(list->unique (->* (pair?)
(procedure?)
any))
(listof? (-> isa/c isa/c))
)
(provide (all-from-out scheme/list))
|
