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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
(define-module (util)
#:use-module (srfi srfi-1)
#:use-module ((sxml fold) #:select (fold-values))
#:export (destructure-lambda let-multi fold-lists catch-let
for-each-in
define-quick-record define-quick-record!
mod! sort* sort*!
find-min)
#:replace (let*)
)
(define-public upstring->symbol (compose string->symbol string-upcase))
(define-public symbol-upcase (compose string->symbol string-upcase symbol->string))
(define-public symbol-downcase (compose string->symbol string-downcase symbol->string))
(define-syntax destructure-lambda
(syntax-rules ()
((_ expr-list body ...)
(lambda (expr)
(apply (lambda expr-list body ...) expr)))))
(define-syntax catch-let
(syntax-rules ()
((_ thunk ((type handler) ...))
(catch #t thunk
(lambda (err . args)
(case err
((type) (apply handler err args)) ...
(else (format #t "Unhandled error type ~a, rethrowing ~%" err)
(apply throw err args))))))))
;;; For-each with arguments in reverse order.
(define-syntax-rule (for-each-in lst proc)
(for-each proc lst))
;;; Helper macros to make define-quick-record better
(define (class-name symb) (symbol-append '< symb '>))
(define (constructor symb) (symbol-append 'make- symb))
(define (pred symb) (symbol-append symb '?))
(define (getter name symb) (symbol-append 'get- name '- symb))
(define* (setter name symb #:optional bang?)
(symbol-append 'set- name '- symb (if bang? '! (symbol))))
(define (%define-quick-record internal-define bang? name fields)
(let ((symb (gensym)))
`((,internal-define ,(class-name name)
(,(constructor name) ,@fields)
,(pred name)
,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?)))
fields))
,@(map (lambda (f) `(define ,f (make-procedure-with-setter
,(getter f symb) ,(setter f symb bang?))))
fields))))
;;; Creates srfi-9 define{-immutable,}-record-type declations.
;;; Also creates srfi-17 accessor ((set! (access field) value))
;; (define (define-quick-record-templated define-proc name field))
(define-macro (define-quick-record name . fields)
(let ((public-fields (or (assoc-ref fields #:public) '()))
(private-fields (or (assoc-ref fields #:private) '())))
`(begin
,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type)
#f name
(append public-fields private-fields))
,@(map (lambda (field) `(export ,field))
public-fields))))
;; (define-quick-record-templated 'define-immutable-record-type name fields))
;; (define-macro (define-quick-record! name . fields)
;; (define-quick-record-templated 'define-record-type name fields))
;; Replace let* with a version that can bind from lists.
;; Also supports SRFI-71 (extended let-syntax for multiple values)
;; @lisp
;; (let* ([a b (values 1 2)] ; @r{SRFI-71}
;; [(c d) '(3 4)] ; @r{Let-list (mine)}
;; [e 5]) ; @r{Regular}
;; (list e d c b a))
;; ;; => (5 4 3 2 1)
;; @end lisp
(define-syntax let*
(syntax-rules ()
;; Base case
[(_ () body ...)
(begin body ...)]
;; (let (((a b) '(1 2))) (list b a)) => (2 1)
[(_ (((k k* ...) list-value) rest ...)
body ...)
(apply (lambda (k k* ...)
(let* (rest ...)
body ...))
list-value)]
;; "Regular" case
[(_ ((k value) rest ...) body ...)
(let ((k value))
(let* (rest ...)
body ...))]
;; SRFI-71 let-values
[(_ ((k k* ... values) rest ...) body ...)
(call-with-values (lambda () values)
(lambda (k k* ...)
(let* (rest ...)
body ...)))]
))
;; Like set!, but applies a transformer on the already present value.
(define-syntax-rule (mod! field transform-proc)
(set! field (transform-proc field)))
(define-public (concat lists)
(apply append lists))
;; This function borrowed from web-ics (calendar util)
(define* (sort* items comperator #:optional (get identity))
"A sort function more in line with how python's sorted works"
(sort items (lambda (a b)
(comperator (get a)
(get b)))))
;; Sorts the list @var{items}. @em{May} destroy the input list in the process
(define* (sort*! items comperator #:optional (get identity))
"A sort function more in line with how python's sorted works"
(sort! items (lambda (a b)
(comperator (get a)
(get b)))))
;; Finds the smallest element in @var{items}, compared with @var{<} after
;; applying @var{foo}. Returns 2 values. The smallest item in @var{items},
;; and the other items in some order.
(define (find-min < ac items)
(if (null? items)
;; Vad fan retunerar man här?
(values #f '())
(fold-values
(lambda (c min other)
(if (< (ac c) (ac min))
;; Current stream head is smaller that previous min
(values c (cons min other))
;; Previous min is still smallest
(values min (cons c other))))
(cdr items)
;; seeds:
(car items) '())))
;; TODO This might be utterly broken, do some real tests on it
;; (and then run equivalent tests on the stream variant)
(define-public (filter-sorted proc list)
(take-while
proc (drop-while
(negate proc) list)))
;; (define (!= a b) (not (= a b)))
(define-public != (negate =))
(define-public (take-to lst i)
"Like @var{take}, but might lists shorter than length."
(if (> i (length lst))
lst (take lst i)))
(define-public (as-string s)
(if (symbol? s) (symbol->string s) s))
(define-public (as-symb s)
(if (string? s) (string->symbol s) s))
|
