1#lang lazy/base
2
3(require
4  (prefix-in ! racket/list)
5  (except-in
6   racket/list
7   first second third fourth fifth sixth seventh eighth
8   rest last-pair
9   make-list
10   take drop split-at takef dropf splitf-at
11   take-right drop-right split-at-right takef-right dropf-right splitf-at-right
12   add-between
13   append*
14   flatten
15   remove-duplicates
16   filter-map count partition
17   range
18   append-map
19   filter-not
20   argmin argmax))
21
22(provide (all-from-out racket/list)
23         last-pair
24         take drop split-at takef dropf splitf-at
25         take-right drop-right split-at-right takef-right dropf-right splitf-at-right
26         add-between
27         append*
28         flatten
29         remove-duplicates
30         filter-map count partition
31         range
32         append-map
33         filter-not
34         argmin argmax)
35
36;; lazy versions of exports from racket/list
37;; ---------------------------------------------------------------------------------------------------
38
39(define (last-pair p)
40  (let ([p (! p)])
41    (unless (pair? p)
42      (raise-argument-error 'last-pair "pair?" p))
43    (let loop ([p p])
44      (define next (! (cdr p)))
45      (if (pair? next) (loop next) p))))
46
47(define (make-list n v)
48  (let ([n (! n)])
49    (unless (exact-nonnegative-integer? n)
50      (raise-argument-error 'make-list "exact-nonnegative-integer?" 0 n v))
51    (let loop ([n n]
52               [acc '()])
53      (if (zero? n) acc
54          (loop (sub1 n) (cons v acc))))))
55
56(define (take l n)
57  (let ([n (! n)])
58    (unless (exact-nonnegative-integer? n)
59      (raise-argument-error 'take "exact-nonnegative-integer?" 1 l n))
60    (let loop ([n n] [l l])
61      (if (zero? n)
62          '()
63          (let ([l (! l)])
64            (cond [(null? l)
65                   ;; it would be fine to force the whole list (since we now
66                   ;; know it's finite), but doing so means keeping a reference
67                   ;; to its head, which can lead to memory leaks.
68                   (raise-arguments-error 'take
69                                          "index is too large for input list"
70                                          "index" n)]
71                  [(pair? l) (cons (car l) (loop (sub1 n) (! (cdr l))))]
72                  [else (raise-argument-error 'take "list?" l)]))))))
73
74(define (split-at l n)
75  (let ([n (! n)])
76    (unless (exact-nonnegative-integer? n)
77      (raise-argument-error 'split-at "exact-nonnegative-integer?" 1 l n))
78    (let loop ([n n] [l l])
79      (if (zero? n)
80          (values '() l)
81          (let ([l (! l)])
82            (cond [(null? l)
83                   ;; see comment for `take`
84                   (raise-arguments-error 'split-at
85                                          "index is too large for input list"
86                                          "index" n)]
87                  [(pair? l)
88                   (define-values (a b) (loop (sub1 n) (! (cdr l))))
89                   (values (cons (car l) a) b)]
90                  [else (raise-argument-error 'split-at "list?" l)]))))))
91
92(define (drop lst pos)
93  (list-tail lst pos))
94
95(define (takef lst pred)
96  (let ([pred (! pred)])
97    (unless (procedure? pred)
98      (raise-argument-error 'takef "procedure?" 1 lst pred))
99    (let loop ([lst (! lst)])
100      (cond
101        [(and (pair? lst) (! (pred (car lst))))
102         (cons (car lst) (loop (cdr lst)))]
103        [else '()]))))
104
105(define (dropf lst pred)
106  (let ([pred (! pred)])
107    (unless (procedure? pred)
108      (raise-argument-error 'takef "procedure?" 1 lst pred))
109    (let loop ([lst (! lst)])
110      (cond
111        [(and (pair? lst) (! (pred (car lst))))
112         (loop (cdr lst))]
113        [else lst]))))
114
115(define (splitf-at lst pred)
116  (let ([pred (! pred)])
117    (unless (procedure? pred)
118      (raise-argument-error 'takef "procedure?" 1 lst pred))
119    (let loop ([lst (! lst)])
120      (cond
121        [(and (pair? lst) (! (pred (car lst))))
122         (define-values (a b) (loop (cdr lst)))
123         (values (cons (car lst) a) b)]
124        [else (values '() lst)]))))
125
126(define (take-right l n)
127  (drop l (- (improper-length l) n)))
128
129(define (drop-right l n)
130  (take l (- (improper-length l) n)))
131
132(define (split-at-right l n)
133  (split-at l (- (improper-length l) n)))
134
135(define (takef-right l pred)
136  (improper-reverse (takef (improper-reverse l) pred)))
137
138(define (dropf-right l pred)
139  (improper-reverse (dropf (improper-reverse l) pred)))
140
141(define (splitf-at-right l pred)
142  (improper-reverse (splitf-at (improper-reverse l) pred)))
143
144;; keyword arguments currently do not work to due Lazy Racket limitations
145(define (add-between lst v
146                     #:before-first [before-first '()]
147                     #:before-last [before-last v]
148                     #:after-last [after-last '()]
149                     #:splice? [splice? #f])
150  (define middle
151    (let ([lst (!list lst)])
152      (cons (car lst)
153            (let loop ([lst (cdr lst)])
154              (cond
155                [(null? lst) '()]
156                [else ((if splice? append list*)
157                       (if (null? (cdr lst)) before-last v)
158                       (if splice? (list (car lst)) (car lst))
159                       (loop (cdr lst)))])))))
160  (if splice?
161      (append before-first middle after-last)
162      middle))
163
164(define (append* . args)
165  (define-values (head tail) (split-at-right args 1))
166  (apply append (append head (apply append tail))))
167
168(define (flatten v)
169  (let ([v (! v)])
170    (cond
171      [(pair? v) (append (flatten (car v)) (flatten (cdr v)))]
172      [(null? v) '()]
173      [else (list v)])))
174
175(define (remove-duplicates lst [same? equal?] #:key [extract-key (λ (x) x)])
176  (let loop ([lst (!list lst)])
177    (if (null? lst) '()
178        (cons (car lst) (loop (remove* (list (car lst)) lst
179                                       (λ (a b) (same? (extract-key a) (extract-key b)))))))))
180
181(define (filter-map proc lst . lsts)
182  (let loop ([lsts (cons lst lsts)])
183    (cond
184      [(null? (! (car lsts))) '()]
185      [else
186       (define result (apply proc (map car lsts)))
187       (if result
188           (cons result (loop (map cdr lsts)))
189           (loop (map cdr lsts)))])))
190
191(define (count proc lst . lsts)
192  (let loop ([lsts (cons lst lsts)]
193             [acc 0])
194    (cond
195      [(null? (! (car lsts))) acc]
196      [else
197       (define result (apply proc (map car lsts)))
198       (loop (map cdr lsts) (if result (add1 acc) acc))])))
199
200(define (partition pred lst)
201  (let loop ([lst (!list lst)])
202    (cond
203      [(null? lst) (values '() '())]
204      [else
205       (define-values (a b) (loop (cdr lst)))
206       (if (pred (car lst))
207           (values (cons (car lst) a) b)
208           (values a (cons (car lst) b)))])))
209
210(define range
211  (case-lambda
212    [(end) (range 0 end)]
213    [(start end) (range start end 1)]
214    [(start end step)
215     (let loop ([n start])
216       (cond
217         [(if (positive? step)
218              (n . >= . end)
219              (n . <= . end)) '()]
220         [else
221          (cons n (loop (+ n step)))]))]))
222
223(define (append-map proc lst . lsts)
224  (append* (apply map proc lst lsts)))
225
226(define (filter-not pred lst)
227  (filter (λ (x) (not (pred x))) lst))
228
229(define (argmin proc lst)
230  (!argmin proc (!list lst)))
231
232(define (argmax proc lst)
233  (!argmax proc (!list lst)))
234
235;; internal utility functions
236;; ---------------------------------------------------------------------------------------------------
237
238(define (improper-length lst)
239  (let loop ([n 0] [lst (! lst)])
240    (cond
241      [(pair? lst) (loop (add1 n) (! (cdr lst)))]
242      [else n])))
243
244(define (improper-reverse lst)
245  (let loop ([lst (! lst)]
246             [acc '()])
247    (cond
248      [(pair? lst) (loop (! (cdr lst)) (cons (car lst) acc))]
249      [else acc])))
250