1
; libctl: flexible Guile-based control files for scientific software
2
; Copyright (C) 1998, 1999, 2000, 2001, 2002, Steven G. Johnson
4
; This library is free software; you can redistribute it and/or
5
; modify it under the terms of the GNU Lesser General Public
6
; License as published by the Free Software Foundation; either
7
; version 2 of the License, or (at your option) any later version.
9
; This library is distributed in the hope that it will be useful,
10
; but WITHOUT ANY WARRANTY; without even the implied warranty of
11
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12
; Lesser General Public License for more details.
14
; You should have received a copy of the GNU Lesser General Public
15
; License along with this library; if not, write to the
16
; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17
; Boston, MA 02111-1307, USA.
19
; Steven G. Johnson can be contacted at stevenj@alum.mit.edu.
21
; ****************************************************************
22
; Replacements for MIT Scheme functions missing from Guile 1.2.
27
(define (list-transform-positive l pred)
31
(cons (car l) (list-transform-positive (cdr l) pred))
32
(list-transform-positive (cdr l) pred))))
34
(define (list-transform-negative l pred)
37
(if (not (pred (car l)))
38
(cons (car l) (list-transform-negative (cdr l) pred))
39
(list-transform-negative (cdr l) pred))))
41
(define (alist-copy al)
43
(cons (cons (caar al) (cdar al)) (alist-copy (cdr al)))))
45
(define (for-all? l pred)
49
(for-all? (cdr l) pred)
52
(define (first list) (list-ref list 0))
53
(define (second list) (list-ref list 1))
54
(define (third list) (list-ref list 2))
55
(define (fourth list) (list-ref list 3))
56
(define (fifth list) (list-ref list 4))
57
(define (sixth list) (list-ref list 5))
59
; fold-left and fold-right: combine elements of list using an operator
60
; op, with initial element init, associating from the right or from
61
; the left. These two are equivalent if op is associative.
63
(define (fold-left op init list)
66
(fold-left op (op init (car list)) (cdr list))))
68
(define (fold-right op init list)
69
(fold-left (lambda (x y) (op y x)) init (reverse list)))
71
; ****************************************************************
72
; Miscellaneous utility functions.
74
(define (compose f g) (lambda args (f (apply g args))))
76
(define (car-or-x p) (if (pair? p) (car p) p))
78
(define (sqr x) (* x x))
80
; complex conjugate of x:
81
(define (conj x) (make-rectangular (real-part x) (- (imag-part x))))
83
; combine 2 alists. returns a list containing all of the associations
84
; in a1 and any associations in a2 that are not in a1
85
(define (combine-alists a1 a2)
89
(if (assoc (caar a2) a1) a1 (cons (car a2) a1))
92
(define (vector-for-all? v pred) (for-all? (vector->list v) pred))
94
(define (vector-fold-right op init v)
95
(fold-right op init (vector->list v)))
97
(define (vector-fold-left op init v)
98
(fold-left op init (vector->list v)))
100
(define (vector-map func . v)
101
(list->vector (apply map (cons func (map vector->list v)))))
103
(define (indent indentby)
104
(print (make-string indentby #\space)))
106
(define print-ok? true) ; so that the user can disable output
108
(define (print . items)
109
(if print-ok? (for-each (lambda (item) (display item)) items)))
111
(define display-many print) ; backwards compatibility with earlier libctl
113
(define (make-initialized-list size init-func)
116
(cons (init-func i) (aux (+ i 1)))))
119
; ****************************************************************
121
; Some string utilities:
123
(define (string-find-next-char-in-list s l)
124
(define (aux index s)
127
(if (member (string-ref s 0) l)
129
(aux (+ index 1) (substring s 1 (string-length s))))))
132
(define (string-find-next-char-not-in-list s l)
133
(define (aux index s)
136
(if (not (member (string-ref s 0) l))
138
(aux (+ index 1) (substring s 1 (string-length s))))))
141
(define (string->positive-integer s)
142
(let ((non-blank (string-find-next-char-not-in-list
143
s '(#\space #\ht #\vt #\nl #\cr))))
144
(let ((s2 (if (eq? non-blank #f)
145
s (substring s non-blank (string-length s)))))
146
(let ((int-start (string-find-next-char-in-list
147
s2 (string->list "0123456789"))))
148
(if (eq? int-start 0)
149
(let ((int-end (string-find-next-char-not-in-list
150
(substring s2 1 (string-length s2))
151
(string->list "0123456789"))))
154
(if (string-find-next-char-not-in-list
155
(substring s2 (+ 1 int-end) (string-length s2))
156
'(#\space #\ht #\vt #\nl #\cr))
161
; ****************************************************************
165
; Display the message followed by the time t in minutes and seconds,
166
; returning t in seconds.
167
(define (display-time message t)
168
(let ((hours (quotient t 3600))
169
(minutes (remainder (quotient t 60) 60))
170
(seconds (remainder t 60)))
173
(print hours " hours, ")
175
(print hours " hour, ")))
177
(print minutes " minutes, ")
179
(print minutes " minute, ")))
180
(print seconds " seconds.\n"))
183
; (begin-time message ...statements...) works just like (begin
184
; ...statements...) except that it also displays 'message' followed by
185
; the elapsed time to execute the statements. Additionally, it returns
186
; the elapsed time in seconds, rather than the value of the last statement.
187
(defmacro-public begin-time (message . statements)
189
(let ((begin-time-start-t (current-time)))
191
(display-time ,message (- (current-time) begin-time-start-t)))))
193
; ****************************************************************
added
removed
base/utils.scm
