csr21@59: (in-package "AMUSE-GSHARP")
csr21@59: 
csr21@59: (defun last-bar-p (bar)
csr21@59:   ;; I know most of this file is cut-and-pasted, but this is a
csr21@59:   ;; particularly horrible example.
csr21@59:   (eq bar (car (last (gsharp-buffer:bars (gsharp-buffer:slice bar))))))
csr21@59: 
csr21@59: (defun find-next-note (note)
csr21@59:   (when (gsharp-buffer:tie-right note)
csr21@59:     (let ((bar (gsharp-buffer:bar (gsharp-buffer:cluster note)))
csr21@59: 	  (cluster (gsharp-buffer:cluster note))
csr21@59: 	  (next-element nil))
csr21@59:       (loop for (x y) on (gsharp-buffer:elements bar)
csr21@59: 	    until (null y)
csr21@59: 	    when (eq x cluster) do (setq next-element y))
csr21@59:       (cond
csr21@59: 	(next-element)
csr21@59: 	((last-bar-p bar) (return-from find-next-note nil))
csr21@59: 	(t (let ((next-bar (gsharp-buffer:barno (gsharp-buffer:slice bar)
csr21@59: 						(1+ (gsharp-numbering::number bar)))))
csr21@59: 	     (if (gsharp-buffer:elements next-bar)
csr21@59: 		 (setq next-element (car (gsharp-buffer:elements next-bar)))
csr21@59: 		 (return-from find-next-note nil)))))
csr21@59:       ;; now NEXT-ELEMENT is the next element!
csr21@59:       (when (typep next-element 'gsharp-buffer:cluster)
csr21@59: 	(loop for n in (gsharp-buffer:notes next-element)
csr21@59: 	      if (and (gsharp-buffer:tie-left n)
csr21@59: 		      (= (gsharp-buffer:pitch n) (gsharp-buffer:pitch note))
csr21@59: 		      (eq (gsharp-buffer:staff n) (gsharp-buffer:staff note))
csr21@59: 		      (eq (gsharp-buffer:accidentals n) (gsharp-buffer:accidentals note)))
csr21@59: 	      return n)))))
csr21@59: 		      
csr21@59: (defun compute-duration (note)
csr21@59:   (loop for n = note then (find-next-note n)
csr21@59: 	while n
csr21@59: 	sum (gsharp-buffer:duration (gsharp-buffer:cluster n))))
csr21@59: 
c@61: (defun events-from-element (element index time)
csr21@59:   (when (typep element 'gsharp-buffer:cluster)
csr21@59:     (mapcar (lambda (note)
csr21@59: 	      (make-instance 'gsharp-pitched-event
csr21@59: 			     :note note
d@166:                  :slice-index index
csr21@59: 			     :number (gsharp-play::midi-pitch note)
csr21@59: 			     :time time
csr21@59: 			     :interval (* 4 (compute-duration note))))
csr21@59: 	    (remove-if #'gsharp-buffer:tie-left (gsharp-buffer:notes element)))))
csr21@59: 
c@61: (defun events-from-bar (bar index time)
csr21@59:   (mapcan (lambda (element)
c@61: 	    (prog1 (events-from-element element index time)
csr21@59: 	      (incf time (* 4 (gsharp-buffer:duration element)))))
csr21@59: 	  (gsharp-buffer:elements bar)))
csr21@59: 
c@61: (defun events-from-slice (slice index durations)
csr21@59:   (let ((time 0))
csr21@59:     (mapcan (lambda (bar duration)
c@61: 	      (prog1 (events-from-bar bar index time)
csr21@59: 		(incf time (* 4 duration))))
csr21@59: 	    (gsharp-buffer:bars slice) durations)))
csr21@59: 
csr21@59: (defun segment-composition (segment)
csr21@59:   (let* ((slices (mapcar #'gsharp-buffer:body (gsharp-buffer::layers segment)))
csr21@59: 	 (durations (gsharp-play::measure-durations slices))
csr21@59:          (gsharp-play::*tuning* (gsharp-buffer:tuning segment))
csr21@59: 	 (events (loop for slice in slices
csr21@59: 		       for i from 0
csr21@59: 		       for events = (events-from-slice slice i durations)
csr21@59: 		       then (merge 'list events (events-from-slice slice i durations) 'time<)
csr21@59: 		       finally (return events))))
csr21@59:     (let* ((duration (* 4 (reduce #'+ durations)))
csr21@59: 	   (result (make-instance 'gsharp-composition 
csr21@59: 				  :buffer (gsharp-buffer:buffer segment)
csr21@59: 				  ;; FIXME: this will break as soon as
csr21@59: 				  ;; gsharp is made to have a sane
csr21@59: 				  ;; divisions value in play.lisp
csr21@59: 				  ;; instead of 25
c@150: 				  :tempi (list (make-standard-tempo-period (* 128 (/ (* 4 25) (gsharp-buffer:tempo segment))) 0 duration))
csr21@59: 				  :time 0
csr21@59: 				  :interval duration)))
csr21@59:       (sequence:adjust-sequence result (length events)
csr21@59: 				:initial-contents events))))
csr21@59: 
csr21@59: #|
csr21@59: 
csr21@59: (in-package :clim-user)
csr21@59: 
c@60: (define-command (com-amuse-play :name t :command-table gsharp::global-gsharp-table)
csr21@59:     ()
csr21@59:   (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
csr21@59: 	 (composition (amuse-gsharp::segment-composition segment)))
csr21@59:     (amuse-utils::play composition)))
csr21@59:     
c@60: (define-command (com-infer-key :name t :command-table gsharp::global-gsharp-table)
csr21@59:     ()
csr21@59:   (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
csr21@59: 	 (composition (amuse-gsharp::segment-composition segment))
c@94:     	 (result (amuse-harmony:krumhansl-key-finder composition composition))
csr21@59: 	 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
csr21@59: 	 (string (format nil "Key: ~A ~(~A~)" name (cadr result))))
c@91:     (esa:display-message string)))
csr21@59:     
csr21@59: 
c@60: (in-package :gsharp-measure)
c@60: 
c@92: (define-stealth-mixin snote () note
c@60:   ((misspeltp :initform nil :accessor misspeltp)))
c@60: 
c@60: (in-package :gsharp-drawing)
c@60: 
c@60: ;;; patch DRAW-NOTE
c@60: (defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos)
c@60:   (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note)))
c@61:     (cond
c@61:       ((gsharp-measure::misspeltp note)
c@61:        (with-output-as-presentation (pane note 'note)
c@61:          (score-pane:draw-notehead pane notehead x pos))
c@61:        (let ((ypos (score-pane:staff-step (- pos))))
c@61:          (draw-line* pane (- x 5) (+ ypos 3) (+ x 5) (+ ypos 3)
c@61:                      :line-thickness 3 :ink (make-rgb-color 0.8 0.1 0.1))))
c@61:       (t (score-pane:draw-notehead pane notehead x pos)))
c@60:     (when (final-accidental note)
c@60:       (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos))
c@60:     (draw-dots pane nb-dots x dot-xoffset dot-pos)))
c@60: 
c@60: (in-package :clim-user)
c@60: 
c@60: (defun ocp-list (composition)
c@60:   (flet ((sorter (x y)
c@60:            (or (amuse:time< x y)
c@60:                (and (amuse:time= x y)
c@60:                     (amuse:pitch< x y)))))
c@60:     (loop for e being each element of composition
c@60:           if (typep e 'amuse:pitched-event)
c@60:           collect (cons e (make-array 2 :initial-contents 
c@60:                                       (list (slot-value e 'amuse::time)
c@60:                                             (- (slot-value e 'amuse::number) 21)))) into result
c@60:           finally (return (sort result #'sorter :key #'car)))))
c@60: 
c@60: (let ((accidental-conversions
c@60:        '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
c@60:          ("f" . :flat) ("ff" . :double-flat))))
c@60:   (defun annotate-misspellings (composition)
c@60:     (do* ((ocp-list (ocp-list composition))
c@93:           (note-sequence (ps13:ps13-new-imp (map 'list #'cdr ocp-list) 10 42 nil nil nil))
c@60:           (list ocp-list (cdr list))
c@60:           (spellings note-sequence (cdr spellings)))
c@60:          ((null list))
c@60:       (let* ((event (caar list))
csr21@62:               (note (amuse-gsharp:note event))
c@61:              (accidental (elt (second (car spellings)) 1))
c@61:              (converted (cdr (assoc accidental accidental-conversions :test #'string=))))
c@61:         (unless (eq (gsharp-buffer:accidentals note) converted)
c@61:           ;; this pun is not to be preserved once we get into real
c@61:           ;; code.
c@61:           (setf (gsharp-measure::misspeltp note) (second (car spellings))))))))
c@60: 
c@60: (define-command (com-spellcheck :name t :command-table gsharp::global-gsharp-table)
c@60:     ()
c@60:   (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
c@60: 	 (composition (amuse-gsharp::segment-composition segment)))
c@60:     (annotate-misspellings composition)
c@60:     #+nil
c@60:     (esa:display-message "~A" (first (ocp-list composition)))))
c@61: 
c@61: (let ((accidental-conversions
c@61:        '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
c@61:          ("f" . :flat) ("ff" . :double-flat))))
c@61:   (define-command (com-correct-misspelt-note :name t :command-table gsharp::global-gsharp-table)
c@61:       ((note 'gsharp::note))
c@61:     (let ((spelling (gsharp-measure::misspeltp note))
c@61:           (element (gsharp-buffer::cluster note))
c@61:           (staff (gsharp-buffer::staff note))
c@61:           (head (gsharp-buffer::head note))
c@61:           (dots (gsharp-buffer::dots note)))
c@61:       (let ((pitch (+ (mod (- (digit-char-p (char (elt spelling 0) 0) 17) 12) 7)
c@61:                       (* (parse-integer (elt spelling 2)) 7)))
c@61:             (accidentals (cdr (assoc (elt spelling 1) accidental-conversions :test #'string=))))
c@61:         (let ((new-note (gsharp-buffer::make-note pitch staff 
c@61:                                                   :head head
c@61:                                                   :dots dots
c@61:                                                   :accidentals accidentals)))
c@61:           (gsharp-buffer::remove-note note)
c@61:           (gsharp-buffer::add-note element new-note))))))
c@61: 
c@61: (define-presentation-to-command-translator correct-misspelt-note-translator
c@61:     (gsharp::note com-correct-misspelt-note gsharp::global-gsharp-table
c@61:           :gesture :select
c@61:           :tester ((object) (gsharp-measure::misspeltp object)))
c@61:   (object)
c@61:   (list object))
c@60: 
csr21@59: |#