blob: ca4469af5a321a22ab74da8cb0d86e57c0b0708d (
plain) (
blame)
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
|
#| Copyright 2024 Peter McGoron
|
| Licensed under the Apache License, Version 2.0 (the "License");
|
| you may not use this file except in compliance with the License.
| You may obtain a copy of the License at
|
| http://www.apache.org/licenses/LICENSE-2.0
|
| Unless required by applicable law or agreed to in writing, software
| distributed under the License is distributed on an "AS IS" BASIS,
| WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
| See the License for the specific language governing permissions and
| limitations under the License.
|#
(define-syntax cond-values
(syntax-rules (else)
((cond-values clauses ... (else body ...))
(cond-thunk clauses ... (else body ...)))
((cond-values clauses ...)
(cond-thunk clauses ... (else (values))))))
(define-syntax after
(syntax-rules (when let =>)
((after ((when conditional) clauses ...) body ...)
(if conditional
(after (clauses ...) body ...)
#f))
((after ((let value => formal) clauses ...) body ...)
(case-receive value
(() #f)
(formal (after (clauses ...) body ...))))
((after () body ...)
(lambda () body ...))))
(define-syntax apply-after
(syntax-rules ()
((apply-after producer consumer)
(after ((let producer => formal))
(apply consumer formal)))))
(define (pair=> x)
(cond-values
(after ((when (pair? x)))
(values (car x) (cdr x)))))
(define (list-length-destructor whole-list num final-call)
(cond-thunk
(when-ct (not (integer? num))
(error "must be integer" num))
(when-ct (not (positive? num))
(error "must be positive" num))
(else
(let loop ((iterator whole-list)
(collected '())
(num num))
(cond-values
(after ((when (= num 0)))
(final-call collected iterator))
(after ((let (pair=> iterator) => (head rest)))
(loop (cdr rest) (cons head collected) (- num 1))))))))
(define (length-at-least=> whole-list num)
(list-length-destructor whole-list num
(lambda (reverse-seen rest)
(when-ct (or (null? rest) (pair? rest))
(apply values
(reverse (cons rest reverse-seen)))))))
(define (length=> whole-list num)
(list-length-destructor whole-list num
(lambda (_ rest)
(when-ct (null? rest)
(apply values whole-list)))))
|
