1#lang typed/racket/base
2
3;; Extra functions that can't be easily categorized
4
5(require racket/sequence racket/list racket/match)
6
7(provide (all-defined-out))
8
9(: in-cycle* (All (A) (-> (Sequenceof A) (Sequenceof A))))
10(define (in-cycle* s)
11  (define n (sequence-length s))
12  (if (zero? n) empty-sequence (in-cycle s)))
13
14(: sequence-take (All (A) (-> (Sequenceof A) Integer Integer (Listof A))))
15(define (sequence-take seq start end)
16  (for/list ([e  (sequence-tail seq start)]
17             [_  (in-range (- end start))])
18    e))
19
20(: sequence-head-vector (All (A) (-> Symbol (Sequenceof A) Integer (Vectorof A))))
21(define (sequence-head-vector name xs n)
22  (define vec (for/vector ([x  xs] [i  (in-range n)]) : A
23                x))
24  (unless (= n (vector-length vec))
25    (raise-argument-error name (format "sequence of length >= ~a" n) xs))
26  vec)
27
28(: sequence->listof-vector (All (A) (-> Symbol (Sequenceof (Sequenceof A)) Integer
29                                        (Listof (Vectorof A)))))
30(define (sequence->listof-vector name vs n)
31  (map (λ ([v : (Sequenceof A)])
32         (sequence-head-vector name v n))
33       (sequence->list vs)))
34
35(: cumulative-sum (-> (Listof Real) (Listof Real)))
36(define (cumulative-sum xs)
37  (reverse (foldl (λ ([x : Real] [xs : (Listof Real)])
38                    (cons (+ x (first xs)) xs))
39                  '(0)
40                  xs)))
41
42(: pair (All (A B) (-> A B (Pair A B))))
43(define pair cons)
44
45(: assoc-cons (All (A B) (-> (Listof (Pair A (Pair B (Listof B)))) A B
46                             (Listof (Pair A (Pair B (Listof B)))))))
47(define (assoc-cons hash key new-value)
48  (let loop ([hash  hash])
49    (cond [(empty? hash)  (list (pair key (list new-value)))]
50          [else
51           (define entry (first hash))
52           (cond [(equal? (car entry) key)  (cons (pair key (pair new-value (cdr entry)))
53                                                  (rest hash))]
54                 [else  (cons (first hash) (loop (rest hash)))])])))
55
56(: vector-find-index (All (A) (->* [(-> A Any) (Vectorof A)] [Integer Integer] (U Integer #f))))
57(define (vector-find-index pred? xs [start 0] [end (vector-length xs)])
58  (let/ec return : (U Integer #f)
59    (for ([i  (in-range start end)] #:when (pred? (vector-ref xs i)))
60      (return i))
61    #f))
62
63(: sorted-apply (All (A B) (-> (-> (Listof A) (Listof A))
64                               (-> (Listof A) (Listof B))
65                               (-> (Listof A) (Listof B)))))
66(define ((sorted-apply sort f) lst)
67  (define h
68    (let ([sorted-lst  (sort lst)])
69      (make-hash (map (inst pair A B) sorted-lst (f sorted-lst)))))
70  (map (λ ([e : A]) (hash-ref h e)) lst))
71
72(: transpose (All (A) (-> (Listof (Listof A))
73                          (Listof (Listof (U #f A))))))
74(define (transpose xss)
75  (cond [(andmap empty? xss)  empty]
76        [else  (cons (map (λ ([xs : (Listof A)]) (if (empty? xs) #f (first xs))) xss)
77                     (transpose (map (λ ([xs : (Listof A)]) (if (empty? xs) empty (rest xs)))
78                                     xss)))]))
79
80(: group-neighbors (All (A) (-> (Listof A) (-> A A Any) (Listof (Listof A)))))
81(define (group-neighbors lst equiv?)
82  (reverse
83   (map (inst reverse A)
84        (cond
85          [(empty? lst)  empty]
86          [else
87           (for/fold ([res : (Listof (Listof A))  (list (list (first lst)))])
88                     ([e  (in-list (rest lst))])
89             (if (andmap (λ ([e2 : A]) (equiv? e e2)) (first res))
90                 (cons (cons e (first res)) (rest res))
91                 (list* (list e) res)))]))))
92
93(: bin-samples (-> (Listof Real) (Listof Real) (Listof (Listof Real))))
94(define (bin-samples bin-bounds xs)
95  (let* ([bin-bounds  (filter (λ (x) (not (eqv? x +nan.0))) (remove-duplicates bin-bounds))]
96         [bin-bounds  (sort bin-bounds <)]
97         [x-min  (first bin-bounds)]
98         [x-max  (last bin-bounds)]
99         [xs  (filter (λ ([x : Real]) (<= x-min x x-max)) xs)]
100         [xs  (sort xs <)])
101    (define-values (res rest-xs)
102      (for/fold ([res : (Listof (Listof Real))  empty]
103                 [xs : (Listof Real)  xs])
104                ([x1  (in-list bin-bounds)]
105                 [x2  (in-list (rest bin-bounds))])
106        (: lst (Listof Real))
107        (: rest-xs (Listof Real))
108        (define-values (lst rest-xs)
109          (let loop ([lst : (Listof Real)  empty] [xs xs])
110            (if (and (not (empty? xs)) (<= x1 (first xs) x2))
111                (loop (cons (first xs) lst) (rest xs))
112                (values lst xs))))
113        (values (cons (reverse lst) res)
114                rest-xs)))
115    (reverse res)))
116
117(: make-raise-argument-error (-> Symbol Any * (-> String Natural Nothing)))
118(define ((make-raise-argument-error name . args) type n)
119  (apply raise-argument-error name type n args))
120
121(: raise-keyword-error (-> Symbol String Keyword Any Nothing))
122(define (raise-keyword-error fun-name type name value)
123  (raise-argument-error fun-name (format "~a for ~a" type name) value))
124
125(: make-raise-keyword-error (-> Symbol (-> String Keyword Any Nothing)))
126(define ((make-raise-keyword-error fun-name) type name value)
127  (raise-keyword-error fun-name type name value))
128