This repository has been archived by the owner on Feb 25, 2021. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 0
/
sc-test-suite.lsp
19874 lines (18956 loc) · 832 KB
/
sc-test-suite.lsp
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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File: sc-test-suite.lsp
;;;
;;; Class Hierarchy: None
;;;
;;; Version: 1.0
;;;
;;; Project: slippery chicken (algorithmic composition)
;;;
;;; Purpose: Load the test suite and run tests of all documented
;;; methods and functions. Only FAIL feedback and desired
;;; warnings are printed. A message will be printed at the
;;; end of the run to indicate whether all tests passed or
;;; not.
;;;
;;; Author: Michael Edwards: [email protected]
;;;
;;; Creation date: 7th December 2011 (Edinburgh)
;;;
;;; $$ Last modified: 14:57:54 Sat Feb 6 2021 CET
;;;
;;; SVN ID: $Id: sc-test-suite.lsp 6249 2017-06-07 16:05:15Z medward2 $
;;;
;;; ****
;;; Licence: Copyright (c) 2010 Michael Edwards
;;;
;;; This file is part of slippery-chicken
;;;
;;; slippery-chicken 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 2 of the License, or (at your
;;; option) any later version.
;;;
;;; slippery-chicken 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 slippery-chicken; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place, Suite
;;; 330, Boston, MA 02111-1307 USA
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :sc)
(in-scale :quarter-tone)
;;; MDE Thu May 30 16:17:47 2013
(set-sc-config 'cmn-display-auto-open nil)
(set-sc-config 'midi-play-auto-open nil)
(set-sc-config 'default-dir "/tmp/")
;;; DJR Fri 30 Aug 2019 10:08:28 BST
(set-sc-config 'lp-display-auto-open nil)
;;; Thu Dec 15 10:01:31 GMT 2011 SAR: Changed intro
;;; Load this file in the Lisp prompt while in the slippery-chicken package.
(load-from-test-suite-dir "sc-test-suite-aux.lsp")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; assoc-list tests
(sc-deftest test-al-get-keys ()
(sc-test-check
(equal (get-keys (make-assoc-list 'test '((cat felix)
(dog fido)
(cow bessie))))
'(cat dog cow))
(equal (get-keys (make-assoc-list 'test '((cat felix)
(dog ((scottish terrier)
(german shepherd)
(irish wolfhound)))
(cow bessie))))
'(cat dog cow))))
(sc-deftest test-al-get-first ()
(let ((al (make-assoc-list 'test '((jim beam)
(four roses)
(wild turkey)))))
(sc-test-check
(named-object-p (get-first al))
(eq (id (get-first al)) 'jim)
(eq (data (get-first al)) 'beam))))
(sc-deftest test-al-get-last ()
(let ((al (make-assoc-list 'test '((jim beam)
(four roses)
(wild turkey)))))
(sc-test-check
(named-object-p (get-last al))
(eq (id (get-last al)) 'wild)
(eq (data (get-last al)) 'turkey))))
(sc-deftest test-al-get-position ()
(let ((al (make-assoc-list 'test '((jim beam)
(four roses)
(wild turkey)))))
(sc-test-check
(eq (get-position 'four al) 1)
(eq (get-position 'jack al) nil)
(eq (get-position 'jim al 1) nil))))
;; this one is supposed to produce a warning for the third EQ boolean
(sc-deftest test-al-get-data-data ()
(let ((al (make-assoc-list 'test '((jim beam)
(four roses)
(wild turkey)))))
(sc-test-check
(eq (get-data-data 'jim al) 'beam)
;; 8.12.11 ME: this was 'nil: removed quote
(eq (get-data-data 'jack al) nil))))
;; this one is supposed to produce warnings for the 3rd and 4th EQ booleans
(sc-deftest test-al-get-data ()
(let ((al (make-assoc-list 'al-test '((jim beam)
(four roses)
(wild turkey)))))
(sc-test-check
(named-object-p (get-data 'four al))
(eq (id (get-data 'four al)) 'four)
(eq (data (get-data 'four al)) 'roses)
(eq (get-data 'jack al) nil)
(eq (get-data 'jack al t) nil)
(eq (get-data 'jack al nil) nil))))
(sc-deftest test-al-add ()
(let ((al (make-assoc-list 'test '((jim beam)
(four roses)
(wild turkey)))))
(sc-test-check
(add '(makers mark) al)
(named-object-p (get-data 'makers al))
(eq (id (get-data 'makers al)) 'makers)
(eq (data (get-data 'makers al)) 'mark)
(eq (get-position 'makers al) 3)
(add '(knob creek) al)
(eq 4 (get-position 'knob al))
(add '(jack daniels) al t)
(eq 0 (get-position 'jack al))
(eq 5 (get-position 'knob al)))))
;; this one is supposed to produce a warning on the 3rd EQ boolean
(sc-deftest test-al-set-data ()
(let ((al (make-assoc-list 'test '((cat felix)
(dog fido)
(cow bessie)))))
(sc-test-check
(named-object-p (set-data 'dog '(dog spot) al))
(eq (id (set-data 'dog '(dog spot) al)) 'dog)
(eq (data (set-data 'dog '(dog spot) al)) 'spot)
(eq (set-data 'pig '(pig wilber) al) nil)
(eq (id (set-data 'dog '(pig wilbur) al)) 'pig)
(eq (get-data-data 'pig al) 'wilbur))))
(sc-deftest test-al-add-to-list-data ()
(let ((al (make-assoc-list 'test '((cat felix)
(dog (fido spot))
(cow bessie)))))
(sc-test-check
(named-object-p (add-to-list-data 'rover 'dog al))
(eq (id (get-data 'dog al)) 'dog)
(equal (get-data-data 'dog al) '(fido spot rover)))))
(sc-deftest test-al-add-to-list-data-force ()
(let ((al (make-assoc-list 'test '((cat felix)
(dog (fido spot))
(cow bessie)))))
(sc-test-check
(named-object-p (add-to-list-data-force 'rover 'dog al))
(eq (id (get-data 'dog al)) 'dog)
(equal (get-data-data 'dog al) '(fido spot rover))
(add-to-list-data-force 'wilber 'pig al)
(equal (get-keys al) '(cat dog cow pig)))))
;;; 08.12.11 SAR
(sc-deftest test-al-set-nth-of-data ()
(let ((al (make-assoc-list 'test '((cat felix)
(dog (fido spot rover))
(cow bessie)))))
(sc-test-check
(eq (set-nth-of-data 'dog 0 'snoopy al) 'snoopy)
(named-object-p (get-data 'dog al))
(equal (get-data-data 'dog al) '(snoopy spot rover)))))
;;; 08.12.11 SAR
(sc-deftest test-al-map-data ()
(let ((al (make-assoc-list 'test '((1 (2 3))
(2 (3 4))
(3 (5 6))))))
(sc-test-check
;; MDE Wed Aug 5 13:43:52 2015
(print-for-init al)
(equalp (map-data al #'(lambda (y)
(loop for i in y collect (* i 2))))
'((4 6) (6 8) (10 12)))
;; MDE Thu Nov 1 10:51:15 2018
(assoc-list-p (nmap-data al #'(lambda (l) (length l))))
;; (print-for-init al)
(equalp '(2 2 2) (mapcar #'data (data al))))))
;;; 08.12.11 SAR
(sc-deftest test-al-make-assoc-list ()
(let ((al (make-assoc-list 'test '((bugs bunny)
(daffy duck)
(porky pig)))))
(sc-test-check
(named-object-p al)
(equal (get-keys al) '(bugs daffy porky))
(eq (get-data-data 'daffy al) 'duck))))
;;; MDE Mon Feb 1 12:51:26 2016 - do this for the ral class too
(sc-deftest test-remove-data ()
(let ((al (make-assoc-list 'test '((bugs bunny)
(daffy duck)
(1 int)
(2.3 float)
("string" string)
(porky pig))))
(ral (make-ral 'mixed-bag
'((jim beam)
(wild turkey)
(four ((roses red) ; rm
(violets ((blue velvet)
(red ((dragon den)
("viper" nest) ; rm
(fox hole))) ; rm
(white ribbon))))))))) ; rm
(sc-test-check
(remove-data al 'daffy 1 2.3 "string")
(= 2 (sclist-length al))
(not (remove-data al))
(zerop (sclist-length al))
(= 8 (r-count-elements ral))
;; shouldn't work because it's a string
(remove-data ral '(four violets red viper))
(= 8 (r-count-elements ral))
(remove-data ral '(four violets red "viper"))
(= 7 (r-count-elements ral))
(remove-data ral 'jim '(four violets red fox))
(remove-data ral '(four violets white))
(remove-data ral '(four roses))
(= 3 (r-count-elements ral))
(eq 'turkey (get-data-data 'wild ral))
(remove-data ral 'wild) ; try another top-level element
(= 2 (r-count-elements ral))
(not (get-data '(four violets red fox) ral nil))
(eq 'den (get-data-data '(four violets red dragon) ral)))))
;; MDE Sat Sep 19 11:32:07 2020, Heidhausen
(sc-deftest test-assoc-list-ascending-ids? ()
(sc-test-check
(ascending-ids? (make-assoc-list 'test '((1 dog) (2 cat) (3 horse))))
;;; 3 is missing
(not (ascending-ids? (make-assoc-list 'test '((1 dog) (2 cat) (4 horse)))))
;; doesn't start at 2
(not (ascending-ids? (make-assoc-list 'test '((1 dog) (2 cat) (3 horse)))
2))
;; missing several integers
(not (ascending-ids? (make-assoc-list 'test '((4 dog) (2 cat) (7 horse)))
2))
(ascending-ids? (make-assoc-list 'test '((4 dog) (2 cat) (3 horse))) 2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; rthm-seq-bar tests
;;; MDE Sat Jun 6 15:15:09 2020, Heidhausen
(sc-deftest test-make-rsb-from-unit-multipliers ()
(let ((b1 (make-rsb-from-unit-multipliers 'e '(3 4 1 2)))
(b2 (make-rsb-from-unit-multipliers 's '(3)))
(b3 (make-rsb-from-unit-multipliers 'h '(2 1))))
(sc-test-check
(time-sig-equal b1 '(10 8))
(time-sig-equal b2 '(3 16))
(eq 'e. (data (get-nth-event 0 b2)))
(eq 'w (data (get-nth-event 0 b3)))
(eq 'h (data (get-nth-event 1 b1)))
(time-sig-equal b3 '(3 2)))))
;;; 09.12.11 SAR
;;; MDE Thu Aug 22 18:18:10 2013 -- made some changes for more detailed tests
(sc-deftest test-rsb-make-rthm-seq-bar ()
(let (bar)
(sc-test-check
(rthm-seq-bar-p (make-rthm-seq-bar '((2 4) q e s s)))
(equal (data (make-rthm-seq-bar '((2 4) q e s s))) '((2 4) q e s s))
(setf bar (make-rthm-seq-bar '((2 4) q e s s) 'test))
(= 4 (notes-needed bar))
(make-rthm-seq-bar '((2 4) 4 8 16 16))
(make-rthm-seq-bar '((2 4) q. e))
(make-rthm-seq-bar '((2 4) 4\. 8))
(make-rthm-seq-bar '((2 4) q +16.+32 e))
(make-rthm-seq-bar '((2 4) q +16\.+32 e))
;; MDE Thu Jun 4 09:44:28 2020, Heidhausen -- test the tuplet as rational
;; case
(= 7/6 (first
(first
(tuplets
(make-rthm-seq-bar '((3 4) { 7/6 (28/3) - 28/3 x 6 - }))))))
(setf bar (make-rthm-seq-bar '((2 4) q \+16\.+32 e)))
(= 2 (notes-needed bar))
(= 2 (bar-pos (get-nth-event 2 bar)))
(make-rthm-seq-bar '((2 4) 4+8 8))
(make-rthm-seq-bar '((2 4) 4.+8))
(make-rthm-seq-bar '((2 4) { 3 te te te } q)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-fill-with-rhythms ()
(let ((rsb (make-rthm-seq-bar '((3 4) q q q)))
(rsb2 (make-rthm-seq-bar '((4 4) q q q q))))
(sc-test-check
(rthm-seq-bar-p rsb)
(= 6 (fill-with-rhythms rsb (loop for r in '(e e e e e e)
collect (make-rhythm r))))
(equal (loop for r in (rhythms rsb) collect (data r)) '(e e e e e e))
(equal (id rsb) "rhythms-inserted-by-fill-with-rhythms")
(fill-with-rhythms rsb2 (loop for r in '(h q e s s)
for p in '(c4 dqs4 e4 gqf4 a4)
collect (make-event p r))
:transposition -14
;; MDE Sat May 19 20:47:39 2012 -- we need this!
:microtones-midi-channel 12
:midi-channel 11)
(equalp
(loop for e in (rhythms rsb2)
collect (data (pitch-or-chord e)))
'(C4 DQS4 E4 GQF4 A4))
(equalp
(loop for e in (rhythms rsb2)
collect (data (written-pitch-or-chord e)))
'(D5 EQS5 FS5 AQF5 B5))
;; MDE Sat May 19 20:53:33 2012 -- changed this to include 12
(every #'(lambda (x) (or (= x 12) (= x 11)))
(loop for e in (rhythms rsb2)
collect (midi-channel (pitch-or-chord e))))
;; MDE Fri May 13 14:26:50 2016 -- see if we can allow underfull bars
(= 5 (fill-with-rhythms rsb (loop for r in '(e e e e e q)
collect (make-rhythm r))
:is-full-error nil))
(equal (loop for r in (rhythms rsb) collect (data r)) '(e e e e e))
(= 5 (fill-with-rhythms rsb (loop for r in '(e e e e e)
collect (make-rhythm r))
:is-full-error nil))
(equal (loop for r in (rhythms rsb) collect (data r)) '(e e e e e))
)))
;;; 12.12.11 SAR
(sc-deftest test-rsb-all-rests? ()
(let ((rsb1 (make-rthm-seq-bar '((2 4) (q) (e) (s) (s))))
(rsb2 (make-rthm-seq-bar '((2 4) q e s s))))
(sc-test-check
(all-rests? rsb1)
(not (all-rests? rsb2)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-force-rest-bar ()
(let ((rsb (make-rthm-seq-bar '((2 4) q e s s))))
(sc-test-check
(force-rest-bar rsb)
(rthm-seq-bar-p rsb)
(is-rest-bar rsb)
(equal (loop for r in (rhythms rsb) collect (data r)) '(2))
(equal (loop for r in (rhythms rsb) collect (is-rest r)) '(T)))))
;;; MDE Wed Nov 7 16:50:45 2018
(sc-deftest test-rsb-force-all-rests ()
(let ((rsb (make-rthm-seq-bar '((2 4) q e s s))))
(sc-test-check
(rthm-seq-bar-p (force-all-rests rsb))
(rthm-seq-bar-p rsb)
;; (print rsb)
(not (is-rest-bar rsb))
(= 4 (num-rhythms rsb))
(= 4 (num-rests rsb)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-delete-beams ()
(let ((rbs (make-rthm-seq-bar '((2 4) - s s - s - s s s - s s))))
(sc-test-check
(delete-beams rbs)
(rthm-seq-bar-p rbs)
(not (beams rbs))
(equal (loop for r in (rhythms rbs) collect (beam r))
'(NIL NIL NIL NIL NIL NIL NIL NIL)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-auto-beam ()
(let ((rsb (make-rthm-seq-bar '((2 4) e e s s s s)))
;; MDE Thu Nov 29 18:56:24 2012
(rsb2 (make-rthm-seq-bar '((9 8) (e.) (e.) e. { 3 - te +te te - }
(16) (16) (16) e)))
(rsb3 (make-rthm-seq-bar '((2 2) { 3 te tq } { 3 tq te }
{ 5 fs fs fs fe } +q)))
(rsb4 (make-rthm-seq-bar '((9 8) s e s { 3 (te) te te } (q) e e e)))
rr)
(sc-test-check
(auto-beam rsb)
(rthm-seq-bar-p rsb)
(equal (loop for r in (rhythms rsb) collect (beam r))
'(1 0 1 NIL NIL 0))
(auto-beam rsb2 nil nil)
;; (not (beam (get-nth-event 2 rsb2)))
;; (= 1 (beam (get-nth-event 3 rsb2)))
;; (= 0 (beam (get-nth-event 5 rsb2)))
(auto-beam rsb3 nil nil)
(not (beams rsb3))
(auto-beam rsb4 nil nil)
;; (print (loop for r in (rhythms rsb4) collect (beam r)))
(auto-beam rsb 8)
(equal (loop for r in (rhythms rsb) collect (beam r))
'(NIL NIL 1 0 1 0))
;; MDE Fri Apr 28 18:45:30 2017
(replace-rhythms rsb3 5 4 (list (make-rhythm 'q)) t)
(equalp '(te tq tq te q "Q") (get-rhythm-symbols rsb3))
;; MDE Wed Apr 26 16:13:22 2017
;; (print (rhythms rsb4))
(setf rr (remove-rhythms rsb4 8 3))
(= 7 (length rr))
(equalp '(s e s te te te q) (get-rhythm-symbols rsb4))
)))
;;; 12.12.11 SAR
(sc-deftest test-rsb-get-nth-non-rest-rhythm ()
(let ((rsb (make-rthm-seq-bar '((2 4) e (e) s s (s) s))))
(sc-test-check
(rhythm-p (get-nth-non-rest-rhythm 0 rsb))
(eq (data (get-nth-non-rest-rhythm 0 rsb)) 'E)
(eq (data (get-nth-non-rest-rhythm 1 rsb)) 'S)
(not (get-nth-non-rest-rhythm 4 rsb nil)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-get-nth-rest ()
(let ((rsb (make-rthm-seq-bar '((3 4) e (e) s s (s) s (q)))))
(sc-test-check
(rhythm-p (get-nth-rest 0 rsb))
(eq (data (get-nth-rest 1 rsb)) 'S)
(eq (data (get-nth-rest 2 rsb)) 'Q)
(not (get-nth-rest 3 rsb nil)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-get-nth-attack ()
(let ((rsb (make-rthm-seq-bar '((3 4) q+e (e) s (s) e))))
(sc-test-check
(rhythm-p (get-nth-attack 0 rsb))
(eq (data (get-nth-attack 1 rsb)) 'S)
(eq (data (get-nth-attack 2 rsb)) 'E)
(not (get-nth-attack 3 rsb nil)))))
;;; MDE Fri Jul 24 11:39:49 2015
(sc-deftest test-rsb-get-nth-attack-with-tied ()
;; can't just make an rsb as that won't have proper tied-from info (that's
;; handled at rthm-seq level)
(let* ((rsb (first (bars (make-rthm-seq '(1 ((((5 4) q+e (e) s+s+e +s e s+e
(e)))))))))
(las1 (get-last-attacks rsb 3))
(las2 (get-last-attacks rsb 2))
(las3 (get-last-attacks rsb 15)))
(sc-test-check
(= 2 (length (get-nth-attack-with-tied 0 rsb)))
(= 4 (length (get-nth-attack-with-tied 1 rsb)))
(= 1 (length (get-nth-attack-with-tied 2 rsb)))
(= 2 (length (get-nth-attack-with-tied 3 rsb)))
(= 3 (length las1))
(= 2 (length las2))
(not las3)
(= 6 (bar-pos (fourth (first las1))))
(= 1 (length (first las2))))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-set-nth-attack ()
(let ((rsb (make-rthm-seq-bar '((2 4) q+e s s))))
(sc-test-check
(event-p (set-nth-attack 1 (make-event 'e4 'q) rsb))
(equal (loop for r in (rhythms rsb) collect (data r)) '("Q" "E" Q S))
(not (set-nth-attack 3 (make-event 'e4 'q) rsb nil)))))
;;; 12.12.11 SAR
(sc-deftest test-rsb-get-last-attack ()
(let ((rsb (make-rthm-seq-bar '((3 4) q+e (e) s (s) e)))
;; MDE Wed Sep 4 12:50:52 2013
(rsb2 (make-rthm-seq-bar '((3 4) q+e (e) s.+32+e))))
(sc-test-check
(rhythm-p (get-last-attack rsb2))
(= 3/8 (rq (get-last-attack rsb2)))
(rhythm-p (get-last-attack rsb))
(eq (data (get-last-attack rsb)) 'e))))
;;; 13.12.11 SAR
(sc-deftest test-rsb-get-time-sig ()
(let ((rsb (make-rthm-seq-bar '((2 4) q e s s))))
(sc-test-check
(time-sig-p (get-time-sig rsb))
(equal (data (get-time-sig rsb)) '(2 4)))))
;;; 13.12.11 SAR
(sc-deftest test-rsb-get-time-sig-as-list ()
(let ((rsb (make-rthm-seq-bar '((2 4) q e s s))))
(sc-test-check
(listp (get-time-sig-as-list rsb))
(equal (get-time-sig-as-list rsb) '(2 4)))))
;;; 13.12.11 SAR
(sc-deftest test-rsb-time-sig-equal ()
(let ((rsb1 (make-rthm-seq-bar '((2 4) q e s s)))
(rsb2 (make-rthm-seq-bar '((2 4) s s e q)))
(rsb3 (make-rthm-seq-bar '((3 4) q+e e s s s s))))
(sc-test-check
(time-sig-equal rsb1 rsb2)
(time-sig-equal rsb1 '(2 4))
(time-sig-equal rsb3 (make-time-sig '(3 4)))
(not (time-sig-equal rsb2 rsb3)))))
;;; 13.12.11 SAR
(sc-deftest test-rsb-make-rest-bar ()
(let ((rsb-rb-t (make-rest-bar '(2 4) t t))
(rsb-rb-nil (make-rest-bar '(2 4) nil nil)))
(sc-test-check
(rthm-seq-bar-p rsb-rb-t)
(equal (data (get-time-sig rsb-rb-t)) '(2 4))
(is-rest-bar rsb-rb-t)
(write-time-sig rsb-rb-t)
(show-rest rsb-rb-t)
(not (write-time-sig rsb-rb-nil))
(not (show-rest rsb-rb-nil)))))
;;; Wed Dec 14 14:03:13 GMT 2011 SAR
(sc-deftest test-rsb-delete-tuplets ()
(let ((rsb1 (make-rthm-seq-bar '((2 4) { 3 te te te } q)))
(rsb2 (make-rthm-seq-bar '((2 4) { 3 te te te } q))))
(delete-tuplets rsb2)
(sc-test-check
(tuplets rsb1)
(equal (loop for r in (rhythms rsb1) collect (bracket r))
'(((1 3)) (-1) (1) NIL))
(not (tuplets rsb2))
(equal (loop for r in (rhythms rsb2) collect (bracket r))
'(NIL NIL NIL NIL)))))
;;; SAR Thu Mar 1 13:22:02 GMT 2012: No further edits necessary
;;; Wed Dec 14 17:39:05 GMT 2011 SAR
(sc-deftest test-rsb-auto-put-tuplet-bracket-on-beats ()
(let ((rsb (make-rthm-seq-bar '((4 4) q { 3 te te te } q q))))
(sc-test-check
;; MDE Sun Jun 28 16:40:55 2015 -- these are no longer true because we
;; now require the { 3 in order to parse the rhythms and set slots
;; properly
;; (not (tuplets rsb))
;; (equal (loop for r in (rhythms rsb) collect (print (bracket r)))
;; '(NIL NIL NIL NIL NIL NIL))
(auto-put-tuplet-bracket-on-beats rsb 3)
(equal (tuplets rsb) '((3 1 3)))
(rthm-seq-bar-p (delete-tuplets rsb))
(auto-put-tuplet-bracket-on-beats rsb 3 nil 1)
(equal (tuplets rsb) '((3 1 3))))))
;;; Wed Dec 14 18:54:08 GMT 2011 SAR
(sc-deftest test-rsb-split ()
(let* ((rsb (make-rthm-seq-bar '((7 4) h. e e +e. e. e q)))
(rsb-splt (split rsb :min-beats 1 :max-beats 3)))
(sc-test-check
(listp rsb-splt)
(equal (loop for i in rsb-splt
collect (loop for r in (rhythms i)
collect (data r)))
'((H.) (E E) ("E." E. E) (Q)))
(not (split rsb :max-beats 1)))))
;;; MDE
(sc-deftest test-consolidate ()
(let ((rs (make-rthm-seq
'(7 ((((2 4) h)
((5 8) (e) e+q.)
((3 4) { 7 28+28+28 28+28+28+28 } +q { 5 fs+fs+fs+fs+fs })
;; MDE Sun Jun 28 16:42:41 2015 -- was repeated without
;; tuplet info but that's now required
({ 7 28+28+28 28+28+28+28 } q { 5 fs+fs+fs+fs+fs })
((2 4) { 3 te tq } +q)
(+q \+32 (32) s e)))))))
(sc-test-check
(consolidate-notes (second (bars rs)))
(consolidate-notes (third (bars rs)))
(consolidate-notes (fourth (bars rs)))
;; todo: add more tests here
(rhythm-equal (second (rhythms (second (bars rs)))) (make-rhythm 'h))
(rhythm-equal (first (rhythms (third (bars rs)))) (make-rhythm '14\.))
(rhythm-equal (fourth (rhythms (fourth (bars rs)))) (make-rhythm 'q)))))
;;; SAR Sun Dec 25 21:00:10 EST 2011
(sc-deftest test-rsb-get-nth-event ()
(let ((rsb (make-rthm-seq-bar '((2 4) q e s s))))
(sc-test-check
(rhythm-p (get-nth-event 0 rsb))
(equalp (data (get-nth-event 1 rsb)) 'e)
(not (get-nth-event 4 rsb nil)))))
;;; SAR Sun Dec 25 21:12:17 EST 2011
(sc-deftest test-rsb-get-last-event ()
(let ((rsb (make-rthm-seq-bar '((2 4) s s e q))))
(sc-test-check
(rhythm-p (get-last-event rsb))
(equalp (data (get-last-event rsb)) 'Q))))
;;; SAR Sun Dec 25 21:52:14 EST 2011
(sc-deftest test-rsb-transpose ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'c4 'e))))))
(sc-test-check
(rthm-seq-bar-p (transpose rsb 3))
(transpose rsb 3)
(equalp (loop for p in (rhythms rsb)
collect (data (pitch-or-chord p)))
'(C4 C4 C4))
(equalp (loop for p in (rhythms (transpose rsb 3))
collect (data (pitch-or-chord p)))
'(EF4 EF4 EF4))
(transpose rsb 3 :destructively t)
(equalp (loop for p in (rhythms rsb)
collect (data (pitch-or-chord p)))
'(EF4 EF4 EF4)))))
;;; SAR Mon Dec 26 12:26:58 EST 2011
(sc-deftest test-rsb-enharmonic ()
(let ((rsb1 (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e)))))
(rsb2 (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'c4 'e)))))
;; MDE Wed Apr 18 11:45:51 2012
(rsb3 (make-rthm-seq-bar
(make-rthm-seq-bar `((2 4)
,@(loop for e in
'((cs4 e) (ds4 e) (g4 e) (fs4 e))
collect (apply #'make-event e))))))
;; MDE Mon Apr 23 13:27:59 2012 -- test it works on chords too
(rsb4 (make-rthm-seq-bar
(make-rthm-seq-bar `((2 4)
,@(loop for e in
'((cs4 e) ((ds4 fs4) e) (g4 e)
(fs4 e))
collect (apply #'make-event e)))))))
(sc-test-check
;; MDE Wed Apr 18 11:48:10 2012 -- test whether the pitches keyword works
(enharmonic rsb3)
(equalp 'df4 (get-pitch-symbol (get-nth-event 0 rsb3)))
(equalp 'ef4 (get-pitch-symbol (get-nth-event 1 rsb3)))
(equalp 'g4 (get-pitch-symbol (get-nth-event 2 rsb3)))
(equalp 'gf4 (get-pitch-symbol (get-nth-event 3 rsb3)))
(enharmonic rsb3 :pitches '(df4 gf4))
(equalp 'cs4 (get-pitch-symbol (get-nth-event 0 rsb3)))
(equalp 'ef4 (get-pitch-symbol (get-nth-event 1 rsb3)))
(equalp 'fs4 (get-pitch-symbol (get-nth-event 3 rsb3)))
(enharmonic rsb4)
(equalp '(ef4 gf4) (get-pitch-symbol (get-nth-event 1 rsb4)))
(enharmonic rsb4 :pitches '(gf4))
(equalp '(ef4 fs4) (get-pitch-symbol (get-nth-event 1 rsb4)))
(enharmonic rsb1)
(equalp (loop for p in (rhythms rsb1)
collect (get-pitch-symbol p))
'(DF4 DF4 DF4))
(enharmonic rsb2)
(equalp (loop for p in (rhythms rsb2)
collect (get-pitch-symbol p))
'(C4 C4 C4))
(enharmonic rsb2 :force-naturals t)
(equalp (loop for p in (rhythms rsb2)
collect (get-pitch-symbol p))
'(BS3 BS3 BS3))
(set-written rsb1 -3)
(equalp (loop for p in (rhythms rsb1)
collect (get-pitch-symbol p))
'(BF3 BF3 BF3))
(enharmonic rsb1 :written t)
(equalp (loop for p in (rhythms rsb1)
collect (get-pitch-symbol p))
'(AS3 AS3 AS3)))))
;;; SAR Mon Dec 26 12:59:27 EST 2011
(sc-deftest test-rsb-set-written ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e))))))
(sc-test-check
(equalp (loop for p in (rhythms rsb)
collect (written-pitch-or-chord p))
'(NIL NIL NIL))
(set-written rsb -2)
(equalp (loop for p in (rhythms rsb)
collect (get-pitch-symbol p))
'(B3 B3 B3)))))
;;; SAR Tue Jan 17 21:28:29 GMT 2012: Optimized using notany and every
;;; SAR Mon Dec 26 14:28:18 EST 2011
(sc-deftest test-rsb-delete-written ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e))))))
(sc-test-check
(notany #'(lambda (x) (written-pitch-or-chord x))
(rhythms rsb))
(set-written rsb -2)
(every #'(lambda (x) (equalp (get-pitch-symbol x) 'B3))
(rhythms rsb))
(not (delete-written rsb))
(notany #'(lambda (x) (written-pitch-or-chord x))
(rhythms rsb)))))
;;; SAR Mon Dec 26 14:46:53 EST 2011
(sc-deftest test-rsb-set-midi-channel ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e))))))
(sc-test-check
(equalp (loop for p in (rhythms rsb)
collect (midi-channel (pitch-or-chord p)))
'(1 1 1))
(not (set-midi-channel rsb 13 14))
(equalp (loop for p in (rhythms rsb)
collect (midi-channel (pitch-or-chord p)))
'(13 13 13)))))
;;; SAR Mon Dec 26 20:01:02 EST 2011
(sc-deftest test-rsb-set-8va ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e))))))
(sc-test-check
(equalp (loop for e in (rhythms rsb) collect (8va e)) '(0 0 0))
(not (set-8va rsb 1))
(equalp (loop for e in (rhythms rsb) collect (8va e)) '(1 1 1)))))
;;; SAR Mon Dec 26 20:13:04 EST 2011
(sc-deftest test-rsb-reset-8va ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e))))))
(sc-test-check
(equalp (loop for e in (rhythms rsb) collect (8va e)) '(0 0 0))
(not (set-8va rsb 1))
(equalp (loop for e in (rhythms rsb) collect (8va e)) '(1 1 1))
(not (reset-8va rsb))
(equalp (loop for e in (rhythms rsb) collect (8va e)) '(0 0 0 )))))
;;; SAR Mon Dec 26 20:47:38 EST 2011
(sc-deftest test-rsb-delete-marks ()
(let ((rsb (make-rthm-seq-bar `((3 8) ,@(loop repeat 3
collect (make-event 'cs4 'e))))))
(sc-test-check
(equalp (loop for e in (rhythms rsb) collect (marks e))
'(NIL NIL NIL))
(not (loop for e in (rhythms rsb) do (add-mark-once e 's)))
(equalp (loop for e in (rhythms rsb) collect (marks e))
'((S) (S) (S)))
(not (delete-marks rsb))
(equalp (loop for e in (rhythms rsb) collect (marks e))
'(NIL NIL NIL)))))
;;; SAR Tue Jan 17 18:27:42 GMT 2012
(sc-deftest test-rsb-chop ()
(let* ((rsb1 (make-rthm-seq-bar '((2 4) q q)))
(rsb-chop1 (chop rsb1
'((1 1) (1 2) (1 3) (1 4) (2 2) (2 3) (2 4) (3 3)
(3 4) (4 4))
's))
(rsb2 (make-rthm-seq-bar '((2 4) q q)))
(rsb-chop2 (chop rsb2 '((1 2) (1 1) (2 2)) 'e))
(rsb3 (make-rthm-seq-bar '((4 4) - (s) (32) 32 (s) s - - +s+32 (32)
(e) - (q) (s) s (e))))
(rsb-chop3 (chop rsb3
'((1 4) (1 3) (1 2) (1 1) (2 4) (2 3) (2 2) (3 4)
(3 3) (4 4))
's))
(rsb4 (make-rthm-seq-bar '((4 4) - (s) (32) 32 (s) s - - +s+32 (32)
(e) - (q) (s) s (e))))
(rsb-chop4 (chop rsb4 '((1 2) (1 1) (2 2)) 'e))
(rsb5 (make-rthm-seq-bar '((2 4) { 3 te te te } e e)))
(rsb-chop5 (chop rsb5))
(rsb6 (make-rthm-seq-bar '((2 4) e { 3 te te te } e)))
(rsb-chop6 (chop rsb6)))
(sc-test-check
(listp rsb-chop1)
(every #'rthm-seq-bar-p rsb-chop1)
(equalp (loop for rsb-obj in rsb-chop1
collect (loop for r in (rhythms rsb-obj)
collect (data r)))
'((S) (E) (E.) (Q) (16) (8) (16/3) (16) (8) (16) (S) (E) (E.) (Q)
(16) (8) (16/3) (16) (8) (16)))
(equalp (loop for rsb-obj in rsb-chop1
collect (loop for r in (rhythms rsb-obj)
collect (is-rest r)))
'((NIL) (NIL) (NIL) (NIL) (T) (T) (T) (T) (T) (T) (NIL) (NIL)
(NIL) (NIL) (T) (T) (T) (T) (T) (T)))
(equalp (loop for rsb-obj in rsb-chop2
collect (loop for r in (rhythms rsb-obj)
collect (data r)))
'((Q) (E) (8) (Q) (E) (8)))
(equalp (loop for rsb-obj in rsb-chop2
collect (loop for r in (rhythms rsb-obj)
collect (is-rest r)))
'((NIL) (NIL) (T) (NIL) (NIL) (T)))
(equalp (loop for rsb-obj in rsb-chop3
collect (loop for r in (rhythms rsb-obj)
collect (data r)))
'((S 32 32 S S) (S 32 32 S) (S 32 32) (16) (32 32 S S) (32 32 S)
(32 32) (S S) (16) (S) (4) (16/3) (8) (16) (16/3) (8) (16) (8)
(16) (16) (4) (16/3) (8) (16) (16/3) (8) (16) (8) (16) (16)
(S S E)(S S S) (S S) (16) (S E) (S S) (S) (8) (16) (16)))
(equalp (loop for rsb-obj in rsb-chop3
collect (loop for r in (rhythms rsb-obj)
collect (is-rest r)))
'((T T NIL T NIL) (T T NIL T) (T T NIL) (T) (T NIL T NIL)
(T NIL T) (T NIL) (T NIL) (T) (NIL) (T) (T) (T) (T) (T) (T) (T)
(T) (T) (T) (T) (T) (T) (T) (T) (T) (T) (T) (T) (T) (T NIL T)
(T NIL T) (T NIL) (T) (NIL T) (NIL T) (NIL) (T) (T) (T)))
(equalp (loop for rsb-obj in rsb-chop4
collect (loop for r in (rhythms rsb-obj)
collect (data r)))
'((S 32 32 S S) (S 32 32) (S S) (4) (8) (8) (4) (8) (8) (S S E)
(S S) (8)))
(equalp (loop for rsb-obj in rsb-chop4
collect (loop for r in (rhythms rsb-obj)
collect (is-rest r)))
'((T T NIL T NIL) (T T NIL) (T NIL) (T) (T) (T) (T) (T) (T)
(T NIL T) (T NIL) (T)))
(equalp (loop for rsb-obj in rsb-chop5
collect (loop for r in (rhythms rsb-obj)
collect (rq r)))
'((1/3 1/3 1/3) (1/3 1/3 1/12) (1/3 1/6) (1/12 1/3 1/3)
(1/12 1/3 1/12) (1/6 1/3) (1/4) (1/12 1/6) (1/6 1/12) (1/4)
(1/2 1/2) (1/2 1/4) (1/2)
(1/4 1/2) (1/4 1/4) (1/2) (1/4) (1/4) (1/4) (1/4)))
(equalp (loop for rsb-obj in rsb-chop5
collect (loop for r in (rhythms rsb-obj)
collect (is-rest r)))
'((NIL NIL NIL) (NIL NIL NIL) (NIL NIL) (T NIL NIL) (T NIL NIL)
(T NIL) (NIL) (T NIL) (T NIL) (T) (NIL NIL) (NIL NIL) (NIL)
(T NIL) (T NIL) (NIL) (NIL) (T) (NIL) (T)))
(equalp (loop for rsb-obj in rsb-chop6
collect (loop for r in (rhythms rsb-obj)
collect (rq r)))
'((1/2 1/3 1/6) (1/2 1/4) (1/2) (1/4 1/3 1/6) (1/4 1/4)
(1/3 1/6) (1/4) (1/4) (1/4) (1/12 1/6) (1/6 1/3 1/2)
(1/6 1/3 1/4) (1/6 1/3) (1/4 1/2)
(1/4 1/4) (1/2) (1/6 1/12) (1/4) (1/4) (1/4)))
(equalp (loop for rsb-obj in rsb-chop6
collect (loop for r in (rhythms rsb-obj)
collect (is-rest r)))
;; MDE Mon Mar 19 18:19:28 2012 rationalize-if-necessary changed
#|
'((NIL NIL NIL) (NIL NIL) (NIL) (T NIL NIL) (T NIL) (NIL NIL)
(NIL) (T) (NIL) (T NIL) (T NIL NIL) (T NIL NIL) (T NIL) (T NIL)
(T NIL) (T) (T NIL) (T) (T) (T))))))
'((NIL NIL NIL) (NIL NIL) (NIL) (T NIL NIL) (T NIL) (NIL NIL)
(NIL) (T) (NIL) (T NIL) (T NIL NIL) (T NIL NIL) (T NIL)
(T NIL) (T NIL) (T) (T NIL) (T) (T) (T))))))
|#
'((NIL NIL NIL) (NIL NIL) (NIL) (T NIL NIL) (T NIL) (NIL NIL)
(NIL) (T) (NIL) (T NIL) (T NIL NIL) (T NIL NIL) (T NIL) (T NIL)
(T NIL) (NIL) (T NIL) (T) (NIL) (T))))))
;;; SAR Thu Mar 1 13:48:09 GMT 2012
(sc-deftest test-rsb-scale ()
(let ((rsb1 (make-rthm-seq-bar '((2 4) q e s s)))
(rsb2 (make-rthm-seq-bar '((6 8) q e q s s))))
(sc-test-check
(equalp
(loop for r in (rhythms (scale rsb1 3)) collect (data r))
'(H. Q. E. E.))
(equalp
(loop for r in (rhythms (scale rsb2 2 nil)) collect (data r))
'(H Q H E E))
(equalp (data (get-time-sig (scale rsb2 2 t))) '(6 4))
(equalp (data (get-time-sig (scale rsb2 2 nil))) '(12 8)))))
;;; MDE Thu Apr 19 11:12:15 2012. sounding-duration is a new slot
(sc-deftest test-rsb-sounding-duration ()
(let ((rsb (make-rthm-seq-bar '((3 4) q q q))))
(sc-test-check
(not (sounding-duration rsb))
(= 1 (set-sounding-duration rsb 1))
(= 1 (sounding-duration rsb))
;; resets sounding-duration to nil so it's calculated next time
(rhythms-to-events rsb)
(not (set-sounding-duration rsb nil))
;; (print (rhythms rsb))
(zerop (sounding-duration rsb)))))
;;; SAR Wed May 2 17:49:06 BST 2012
;;; This doesn't test the :min argument yet, since I can't get it to produce a
;;; different result.
(sc-deftest test-rsb-consolidate-rests ()
(let ((rsb1 (make-rthm-seq-bar '((4 4) (e) (e) (e) (e) (e) (s) (s) (s) e.)))
(rsb2 (make-rthm-seq-bar '((4 4) (e) (e) (e) (e) (e) (s) (s) (s) e.)))
(rsb3 (make-rthm-seq-bar '((2 2) (e) (e) (e) (e) (e) (s) (s) (s) e.)))
(rsb4 (make-rthm-seq-bar `((4 4) ,@(ml '(32) 16) (s) (s) e (e) (e))))
(rsb5 (make-rthm-seq-bar `((4 4) ,@(ml '(32) 16) (s) (s) e (e) (e))))
;; MDE Mon Aug 26 16:57:27 2013
(rsb6 (make-rthm-seq-bar '((4 4) (q) { 3 (te) (tq) }
{ 3 (tq) tq (tq) })))
;; MDE Sun Sep 7 18:27:38 2014
(rsb7 (make-rthm-seq-bar '((4 4) (h) (s) (e.) (s) e.)))
;; MDE Thu Sep 11 20:34:15 2014
(rsb8 (make-rthm-seq-bar '((4 4) (s) (q..) h))))
(sc-test-check
(consolidate-rests rsb1)
(equalp (loop for r in (rhythms rsb1) collect (data r))
'(4 4 4 S E.))
(consolidate-rests rsb2 :beat 2)
(equalp (loop for r in (rhythms rsb2) collect (data r))
'(2 E E S E.))
(consolidate-rests rsb3)
(equalp (loop for r in (rhythms rsb3) collect (data r))
'(2 E E S E.))
(consolidate-rests rsb3)
(consolidate-rests rsb4 :min nil)
(consolidate-rests rsb5 :min 'e)
;; (print (get-beats rsb6))
(consolidate-rests rsb6 :warn t)
;; (print-simple rsb6)
;; MDE Sun Sep 7 18:28:24 2014
(equalp '(h 4 s e.)
(loop for r in (rhythms (consolidate-rests rsb7))
collect (data r)))
;; MDE Thu Sep 11 20:34:55 2014
(equalp '(h h)
(loop for r in (rhythms (consolidate-rests rsb8))
collect (data r)))
(equalp (loop for r in (rhythms rsb4) collect (data r))
'(4 4 e e 4))
(equalp (loop for r in (rhythms rsb5) collect (data r))
'(4 4 s s e 4))
(equalp (loop for r in (rhythms rsb3) collect (data r))
'(2 Q S E.)))))
;;; SAR Wed May 2 18:05:34 BST 2012
;;; This just tests the core function, including :beats, but doesn't test :min
(sc-deftest test-rsb-consolidate-rests-max ()
(let ((rsb1 (make-rthm-seq-bar '((2 2) (e) (e) (e) (e) (e) (s) (s) (s) e.)))
(rsb2 (make-rthm-seq-bar '((2 2) (e) (e) (e) (e) (e) (s) (s) (s) e.)))
(rsb3 (make-rthm-seq-bar `((4 4) ,@(ml '(32) 16) (s) (s) e (e) (e))))
(rsb4 (make-rthm-seq-bar `((4 4) ,@(ml '(32) 16) (s) (s) e (e) (e)))))
(sc-test-check
(consolidate-rests rsb1)
(consolidate-rests rsb1)
(equalp (loop for r in (rhythms rsb1) collect (data r))
'(2 Q S E.))
(consolidate-rests-max rsb2)
(equalp (loop for r in (rhythms rsb2) collect (data r))
'(2 Q S E.))
(consolidate-rests-max rsb3 :min nil :beat 2)
(consolidate-rests-max rsb4 :min 'q :beat 2)
(equalp (get-rhythm-symbols rsb3) '(2 e e q))
(equalp (get-rhythm-symbols rsb4) '(2 s s e e e)))))
;;; SAR Wed May 2 19:17:24 BST 2012
(sc-deftest test-rsb-get-rhythm-symbols ()
(let ((rsb (make-rthm-seq-bar '((4 4) q e s s q. e))))
(sc-test-check
(equalp (get-rhythm-symbols rsb) '(Q E S S Q. E)))))
;;; MDE Mon May 7 17:07:00 2012
(sc-deftest test-rsb-auto-tuplets ()
(let ((b1 (make-rthm-seq-bar '((4 4) { 3 tq tq 18 18 18 } h )))
(b2 (make-rthm-seq-bar '((4 4) { 3 ts ts ts } e h.)))
(b3 (make-rthm-seq-bar '((4 4) { 6 ts x 6 } q { 5 fe x 5 })))
(b4 (make-rthm-seq-bar '((4 4) { 5 fe x 5 } { 6 ts x 6 } q))))
(flet ((recreate-test (rsb)
(let ((tups (copy-list (tuplets rsb))))
(equalp tups (recreate-tuplets rsb)))))
(sc-test-check
;; MDE Fri Apr 7 10:39:24 2017 -- before we delete let's test that
;; recreate-tuplets works
(recreate-test b1)
(recreate-test b2)
(recreate-test b3)
(recreate-test b4)
(delete-tuplets b1)
(delete-tuplets b2)
(delete-tuplets b3)
(delete-tuplets b4)
(not (tuplets b1))
(not (tuplets b2))
(not (tuplets b3))
(not (tuplets b4))
(not (bracket (get-nth-event 0 b1)))
(auto-tuplets b1)
(equalp '((3 0 4)) (tuplets b1))
(auto-tuplets b2)
(equalp '((3 0 2)) (tuplets b2))
;; (print 'here)
(auto-tuplets b3)
(equalp '((3 0 2) (3 3 5) (5 7 11)) (tuplets b3))
(auto-tuplets b4)
(equalp '((5 0 4) (3 5 7) (3 8 10)) (tuplets b4))))))
;;; SAR Sun May 20 16:02:01 EDT 2012
(sc-deftest test-rsb-check-tuplets ()
(let ((rsb (make-rthm-seq-bar '((4 4) { 3 te te te } q q q)))
(rsb2 (make-rthm-seq-bar '((2 4) { 3 tq x 3 }))))
(sc-test-check
(equalp (bracket (get-nth-event 2 rsb)) '(1))
(not (setf (bracket (get-nth-event 2 rsb)) nil))
(not (bracket (get-nth-event 2 rsb)))
(not (check-tuplets rsb #'warn))