-
Notifications
You must be signed in to change notification settings - Fork 0
/
test-tools.scm
90 lines (85 loc) · 3.27 KB
/
test-tools.scm
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
;; Lilypond Harmony Rules tests harmony rules of Lilypond scores.
;; Copyright (C) 2021 Stéphane SOPPERA
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (test-tools)
#:use-module (lily)
#:use-module (oop goops)
#:use-module (harmony-rules)
#:export (test-pretty-print
make-note
timed-note
remove-length-and-origin))
(define (test-pretty-print obj indent)
"Pretty print the input object with INDENT as prefix of each line."
(define (rec obj indent)
(let ((strings '()))
(cond
((null? obj)
(set! strings (cons "'()" strings)))
((list? obj)
(set! strings (cons "(" strings))
(do ((head obj (cdr head))
(sub-indent (string-append indent " "))
(first-line #t #f))
((null? head))
(if (not first-line)
(begin
(set! strings (cons "\n" strings))
(set! strings (cons sub-indent strings))))
(set! strings
(cons (rec
(car head)
sub-indent)
strings)))
(set! strings (cons ")" strings)))
((pair? obj)
(set! strings
(cons (format "(~a . ~a)"
(rec (car obj) indent)
(rec (cdr obj) indent))
strings)))
((ly:music? obj)
(set! strings
(cons (format-music obj
'hidden-properties '(types)
'one-line #t)
strings)))
(#t (set! strings (cons (object->string obj) strings))))
(string-join (reverse strings) "")))
(string-append indent (rec obj indent)))
(define (make-note pitch duration)
(let ((duration (ly:make-duration duration)))
(make-music
'NoteEvent
'pitch pitch
'duration duration)))
(define (timed-note moment pitch duration)
(make <timed-note>
#:moment (ly:make-moment moment)
#:music (make-note pitch duration)))
(define (remove-length-and-origin music)
(music-map
(lambda (m)
(let ((new-m (ly:make-music (ly:prob-immutable-properties m)))
(props (sort (filter (lambda (pair)
(not (or (eq? (car pair) 'origin)
(eq? (car pair) 'length))))
(ly:music-mutable-properties m))
(lambda (a b) (string<? (symbol->string (car a))
(symbol->string (car b)))))))
(for-each (lambda (pair) (ly:music-set-property! new-m (car pair) (cdr pair)))
props)
new-m))
music))