scheme-pearls/factc.rkt at main · evalwhen/scheme-pearls · GitHub

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
#lang racket

(require data/queue)

(define (cop op)
  (lambda (a b k)
    (k (op a b))))

(define addC
  (lambda (a b k)
    ;; (k (+ a b))
    (addTask (lambda ()
               (k (+ a b))))
    ))

(define multC
  (lambda (a b k)
    ;; (k (* a b))
    (addTask (lambda ()
               (k (* a b))))
    ))

(define subC
  (lambda (a b k)
    ;; (k (- a b))
    (addTask (lambda ()
               (k (- a b))))
    ))

(define fact
  (lambda (n)
    (if (= n 1)
        1
        (* n (fact (- n 1))))))

(define factC
  (lambda (n k)
    (if (= n 1)
        (k 1)
        (subC n 1 (lambda (subRes)
                    (factC subRes (lambda (factN1)
                                    (multC n factN1 (lambda (multRes)
                                                      (k multRes))))))))))
;; (module+ test
;;   (factC 10 (lambda (x) (println x))))

(define fib
  (lambda (n)
    (if (<= n 1)
        n
        (+ (fib (- n 1))
           (fib (- n 2))))))

(define fibC
  (lambda (n k)
    (if (<= n 1)
        (k n)
        (subC n 1
              (lambda (subRes)
                (fibC subRes
                      (lambda (fibn1)
                        (subC n 2
                              (lambda (subn2)
                                (fibC subn2
                                      (lambda (fibn2)
                                        (addC fibn1 fibn2
                                              (lambda (addRes)
                                                (k addRes))))))))))))))

;; (module+ test
;;   (fibC 8 (lambda (x) (println x))))

;; concurrency

(define tasks (make-queue))

(define (addTask t)
  (enqueue! tasks t))

(define (run)
  (let loop ()
    (if (queue-empty? tasks)
        'done
        (begin
          ;; (println (queue-length tasks))
          ((dequeue! tasks))
          (loop)))))

(fibC 8 (lambda (x) (println x)))
(factC 233 (lambda (x) (println x)))
(run)