|
c@43
|
1 (in-package :amuse-tabcode)
|
|
c@43
|
2
|
|
c@43
|
3 (defun word-duration (word default)
|
|
c@43
|
4 (if (typep word 'tabcode::rhythmic-word)
|
|
c@43
|
5 (let ((flag (tabcode::flag word))
|
|
c@43
|
6 (dots (tabcode::dots word)))
|
|
c@43
|
7 (if flag
|
|
c@43
|
8 (* (car (rassoc flag tabcode::*rhythms*))
|
|
c@43
|
9 (if dots 3/2 1))
|
|
c@43
|
10 default))
|
|
c@43
|
11 0))
|
|
c@43
|
12
|
|
c@43
|
13 (defun word-causes-stop-p (word course)
|
|
c@43
|
14 (or (typep word 'tabcode::rest)
|
|
c@43
|
15 (typep word 'tabcode::barline)
|
|
c@43
|
16 (and (typep word 'tabcode::chord)
|
|
c@43
|
17 (member course (tabcode::playing word) :key #'tabcode::course))))
|
|
c@43
|
18
|
|
c@43
|
19 (defun duration-for-course (course buffer start initial-duration)
|
|
c@43
|
20 (let ((duration initial-duration)
|
|
c@43
|
21 (default-duration initial-duration))
|
|
c@43
|
22 (do ((i start (+ i 1)))
|
|
c@43
|
23 ((>= i (drei-buffer:size buffer)) duration)
|
|
c@43
|
24 (let* ((object (drei-buffer:buffer-object buffer i))
|
|
c@43
|
25 (word (tabcode-syntax::tabword-word object)))
|
|
c@43
|
26 (when (word-causes-stop-p word course)
|
|
c@43
|
27 (return-from duration-for-course duration))
|
|
c@43
|
28 (let ((word-duration (word-duration word default-duration)))
|
|
c@43
|
29 (incf duration word-duration)
|
|
c@43
|
30 (when (> word-duration 0)
|
|
c@43
|
31 (setf default-duration word-duration)))))))
|
|
c@43
|
32
|
|
c@43
|
33 ;;; FIXME: like GET-COURSE-TUNING/GET-TUNING only more hardcoded
|
|
c@43
|
34 (defun fret-to-number (char)
|
|
c@43
|
35 (let ((fret-num (- (char-code char) 97)))
|
|
c@43
|
36 (cond
|
|
c@43
|
37 ((> fret-num 20) (- fret-num 2))
|
|
c@43
|
38 ((> fret-num 8) (- fret-num 1))
|
|
c@43
|
39 (t fret-num))))
|
|
c@43
|
40 (defun midi-pitch-for-playing (course fret)
|
|
c@43
|
41 (let ((tuning #(67 62 57 53 48 43)))
|
|
c@43
|
42 (+ (aref tuning (1- course))
|
|
c@43
|
43 (fret-to-number fret))))
|
|
c@43
|
44
|
|
c@43
|
45 (defun make-tabcode-composition (tabword-buffer)
|
|
c@43
|
46 (let ((time 0)
|
|
c@43
|
47 (notes)
|
|
c@43
|
48 (result)
|
|
c@43
|
49 (current-duration 1))
|
|
c@43
|
50 (dotimes (i (drei-buffer:size tabword-buffer) (setq notes (nreverse result)))
|
|
c@43
|
51 (let* ((object (drei-buffer:buffer-object tabword-buffer i))
|
|
c@43
|
52 (tabword (tabcode-syntax::tabword-word object))
|
|
c@43
|
53 (duration (word-duration tabword current-duration)))
|
|
c@43
|
54 (when (typep tabword 'tabcode::rhythmic-word)
|
|
c@43
|
55 (setf current-duration duration))
|
|
c@43
|
56 (when (typep tabword 'tabcode::chord)
|
|
c@43
|
57 (dolist (playing (tabcode::playing tabword))
|
|
c@43
|
58 (let* ((course (tabcode::course playing))
|
|
c@43
|
59 (fret (tabcode::fret playing))
|
|
c@43
|
60 (note-duration (duration-for-course course tabword-buffer (1+ i) current-duration)))
|
|
c@43
|
61 (push (make-instance 'tabcode-pitched-event
|
|
c@43
|
62 :course course
|
|
c@43
|
63 :fret fret
|
|
c@43
|
64 :word tabword ; object?
|
|
c@43
|
65 :number (midi-pitch-for-playing course fret)
|
|
c@43
|
66 :time time
|
|
c@43
|
67 :interval note-duration)
|
|
c@43
|
68 result))))
|
|
c@43
|
69 (incf time duration)))
|
|
c@43
|
70 (let ((composition (make-instance 'tabcode-composition
|
|
c@43
|
71 :time 0
|
|
c@43
|
72 :interval time)))
|
|
c@43
|
73 (sequence:adjust-sequence composition (length notes)
|
|
c@43
|
74 :initial-contents notes))))
|
|
c@43
|
75
|
|
c@43
|
76 #|
|
|
c@43
|
77 (in-package :clim-user)
|
|
c@43
|
78
|
|
c@43
|
79 (defvar *composition*)
|
|
c@43
|
80
|
|
c@43
|
81 (define-command (com-set-amuse-composition
|
|
c@43
|
82 :name t :command-table tabcode-syntax::tabcode-table)
|
|
c@43
|
83 ()
|
|
c@43
|
84 (let* ((window (esa:current-window))
|
|
c@43
|
85 (buffer (drei-buffer:buffer window))
|
|
c@43
|
86 (syntax (climacs::syntax buffer))
|
|
c@43
|
87 (tabwords (slot-value syntax 'tabcode-syntax::tabwords)))
|
|
c@43
|
88 (setq *composition* (amuse-tabcode::make-tabcode-composition tabwords))))
|
|
csr21@58
|
89
|
|
csr21@58
|
90 (define-command (com-amuse-play
|
|
csr21@58
|
91 :name t :command-table tabcode-syntax::tabcode-table)
|
|
csr21@58
|
92 ()
|
|
csr21@58
|
93 (let* ((window (esa:current-window))
|
|
csr21@58
|
94 (buffer (drei-buffer:buffer window))
|
|
csr21@58
|
95 (syntax (climacs::syntax buffer))
|
|
csr21@58
|
96 (tabwords (slot-value syntax 'tabcode-syntax::tabwords))
|
|
csr21@58
|
97 (composition (amuse-tabcode::make-tabcode-composition tabwords)))
|
|
csr21@58
|
98 ;; HACK: emulate background playing.
|
|
csr21@58
|
99 (sb-thread:make-thread (lambda () (amuse-utils:play composition)))))
|
|
csr21@58
|
100
|
|
csr21@58
|
101 (define-command (com-infer-key
|
|
csr21@58
|
102 :name t :command-table tabcode-syntax::tabcode-table)
|
|
csr21@58
|
103 ()
|
|
csr21@58
|
104 (let* ((window (esa:current-window))
|
|
csr21@58
|
105 (buffer (drei-buffer:buffer window))
|
|
csr21@58
|
106 (syntax (climacs::syntax buffer))
|
|
csr21@58
|
107 (tabwords (slot-value syntax 'tabcode-syntax::tabwords))
|
|
csr21@58
|
108 (composition (amuse-tabcode::make-tabcode-composition tabwords))
|
|
csr21@58
|
109 (result (amuse-utils:krumhansl-key-finder composition composition))
|
|
csr21@58
|
110 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
|
|
csr21@58
|
111 (string (format nil "{<key>~A ~(~A~)</key>}~%" name (cadr result))))
|
|
csr21@58
|
112 (drei-buffer:insert-buffer-sequence buffer 0 string)))
|
|
csr21@55
|
113 |#
|
