-
Notifications
You must be signed in to change notification settings - Fork 0
/
little-monad-4.rkt
128 lines (113 loc) · 3.44 KB
/
little-monad-4.rkt
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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
#lang racket
(define printf
(lambda l
(for-each (lambda (a) (display a) (display " "))
l)
(newline)))
(define rember/evensXcount/evens__2pass
(lambda (l)
(cons (rember/evens__direct l)
(count/evens__direct l))))
(define rember/evens__direct
(lambda (l)
(cond ((null? l)
'())
((pair? (car l))
(cons (rember/evens__direct (car l))
(rember/evens__direct (cdr l))))
((or (null? (car l))
(odd? (car l)))
(cons (car l)
(rember/evens__direct (cdr l))))
(else (rember/evens__direct (cdr l))))))
(define count/evens__direct
(lambda (l)
(cond ((null? l)
0)
((pair? (car l))
(+ (count/evens__direct (car l))
(count/evens__direct (cdr l))))
((or (null? (car l))
(odd? (car l)))
(count/evens__direct (cdr l)))
(else (add1 (count/evens__direct (cdr l)))))))
(define data '(2 3 (7 4 5 6) 8 (9) 2))
(rember/evensXcount/evens__2pass data)
(define rember/evensXcount/evens__cps
(lambda (l k)
(cond ((null? l)
(k '() 0))
((pair? (car l))
(rember/evensXcount/evens__cps
(car l)
(lambda (v1 c1)
(rember/evensXcount/evens__cps
(cdr l)
(lambda (v2 c2)
(printf "cps -- +" (+ c1 c2))
(k (cons v1 v2) (+ c1 c2)))))))
((or (null? (car l)) (odd? (car l)))
(rember/evensXcount/evens__cps
(cdr l)
(lambda (v c)
(k (cons (car l) v) c))))
(else
(rember/evensXcount/evens__cps
(cdr l)
(lambda (v c)
(printf "cps -- 1+" (add1 c))
(k v (add1 c))))))))
(rember/evensXcount/evens__cps
data
(lambda (x y) (cons x y)))
(define return
(lambda (v)
(lambda (s)
(cons v s))))
(define pipe
(lambda (m q)
(lambda (s)
(let ((pair (m s)))
(let ((w (q (car pair))))
(w (cdr pair)))))))
(define rember/evens
(lambda (l)
(cond ((null? l)
(return '()))
((pair? (car l))
(pipe (rember/evens (car l))
(lambda (a)
(pipe (rember/evens (cdr l))
(lambda (d)
(return (cons a d)))))))
((or (null? (car l))
(odd? (car l)))
(pipe (rember/evens (cdr l))
(lambda (d)
(return (cons (car l) d)))))
(else
(rember/evens (cdr l))))))
((rember/evens data) 0)
;; (rember/evens data)
(define rember/evensXcount/evens
(lambda (l)
(cond ((null? l)
(return '()))
((pair? (car l))
(pipe (rember/evensXcount/evens (car l))
(lambda (a)
(pipe (rember/evensXcount/evens (cdr l))
(lambda (d)
(return (cons a d)))))))
((or (null? (car l))
(odd? (car l)))
(pipe (rember/evensXcount/evens (cdr l))
(lambda (d)
(return (cons (car l) d)))))
(else
(pipe (lambda (s)
(printf "monad -- 1+" (add1 s))
(cons '_ (add1 s)))
(lambda (v)
(rember/evensXcount/evens (cdr l))))))))
((rember/evensXcount/evens data) 0)