view implementations/gsharp/gsharp-import.lisp @ 190:725ce7ce77ba

remove DOS line endings in base/classes.lisp

darcs-hash:20090105150355-16a00-972232fbb3eb8030c3e0c6d3788ba6f389183d8c.gz

(in-package "AMUSE-GSHARP")

(defun last-bar-p (bar)
  ;; I know most of this file is cut-and-pasted, but this is a
  ;; particularly horrible example.
  (eq bar (car (last (gsharp-buffer:bars (gsharp-buffer:slice bar))))))

(defun find-next-note (note)
  (when (gsharp-buffer:tie-right note)
    (let ((bar (gsharp-buffer:bar (gsharp-buffer:cluster note)))
	  (cluster (gsharp-buffer:cluster note))
	  (next-element nil))
      (loop for (x y) on (gsharp-buffer:elements bar)
	    until (null y)
	    when (eq x cluster) do (setq next-element y))
      (cond
	(next-element)
	((last-bar-p bar) (return-from find-next-note nil))
	(t (let ((next-bar (gsharp-buffer:barno (gsharp-buffer:slice bar)
						(1+ (gsharp-numbering::number bar)))))
	     (if (gsharp-buffer:elements next-bar)
		 (setq next-element (car (gsharp-buffer:elements next-bar)))
		 (return-from find-next-note nil)))))
      ;; now NEXT-ELEMENT is the next element!
      (when (typep next-element 'gsharp-buffer:cluster)
	(loop for n in (gsharp-buffer:notes next-element)
	      if (and (gsharp-buffer:tie-left n)
		      (= (gsharp-buffer:pitch n) (gsharp-buffer:pitch note))
		      (eq (gsharp-buffer:staff n) (gsharp-buffer:staff note))
		      (eq (gsharp-buffer:accidentals n) (gsharp-buffer:accidentals note)))
	      return n)))))
		      
(defun compute-duration (note)
  (loop for n = note then (find-next-note n)
	while n
	sum (gsharp-buffer:duration (gsharp-buffer:cluster n))))

(defun events-from-element (element index time)
  (when (typep element 'gsharp-buffer:cluster)
    (mapcar (lambda (note)
	      (make-instance 'gsharp-pitched-event
			     :note note
                 :slice-index index
			     :number (gsharp-play::midi-pitch note)
			     :time time
			     :interval (* 4 (compute-duration note))))
	    (remove-if #'gsharp-buffer:tie-left (gsharp-buffer:notes element)))))

(defun events-from-bar (bar index time)
  (mapcan (lambda (element)
	    (prog1 (events-from-element element index time)
	      (incf time (* 4 (gsharp-buffer:duration element)))))
	  (gsharp-buffer:elements bar)))

(defun events-from-slice (slice index durations)
  (let ((time 0))
    (mapcan (lambda (bar duration)
	      (prog1 (events-from-bar bar index time)
		(incf time (* 4 duration))))
	    (gsharp-buffer:bars slice) durations)))

(defun segment-composition (segment)
  (let* ((slices (mapcar #'gsharp-buffer:body (gsharp-buffer::layers segment)))
	 (durations (gsharp-play::measure-durations slices))
         (gsharp-play::*tuning* (gsharp-buffer:tuning segment))
	 (events (loop for slice in slices
		       for i from 0
		       for events = (events-from-slice slice i durations)
		       then (merge 'list events (events-from-slice slice i durations) 'time<)
		       finally (return events))))
    (let* ((duration (* 4 (reduce #'+ durations)))
	   (result (make-instance 'gsharp-composition 
				  :buffer (gsharp-buffer:buffer segment)
				  ;; FIXME: this will break as soon as
				  ;; gsharp is made to have a sane
				  ;; divisions value in play.lisp
				  ;; instead of 25
				  :tempi (list (make-standard-tempo-period (* 128 (/ (* 4 25) (gsharp-buffer:tempo segment))) 0 duration))
				  :time 0
				  :interval duration)))
      (sequence:adjust-sequence result (length events)
				:initial-contents events))))

#|

(in-package :clim-user)

(define-command (com-amuse-play :name t :command-table gsharp::global-gsharp-table)
    ()
  (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
	 (composition (amuse-gsharp::segment-composition segment)))
    (amuse-utils::play composition)))
    
(define-command (com-infer-key :name t :command-table gsharp::global-gsharp-table)
    ()
  (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
	 (composition (amuse-gsharp::segment-composition segment))
    	 (result (amuse-harmony:krumhansl-key-finder composition composition))
	 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
	 (string (format nil "Key: ~A ~(~A~)" name (cadr result))))
    (esa:display-message string)))
    

(in-package :gsharp-measure)

(define-stealth-mixin snote () note
  ((misspeltp :initform nil :accessor misspeltp)))

(in-package :gsharp-drawing)

;;; patch DRAW-NOTE
(defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos)
  (score-pane:with-vertical-score-position (pane (staff-yoffset (staff note)))
    (cond
      ((gsharp-measure::misspeltp note)
       (with-output-as-presentation (pane note 'note)
         (score-pane:draw-notehead pane notehead x pos))
       (let ((ypos (score-pane:staff-step (- pos))))
         (draw-line* pane (- x 5) (+ ypos 3) (+ x 5) (+ ypos 3)
                     :line-thickness 3 :ink (make-rgb-color 0.8 0.1 0.1))))
      (t (score-pane:draw-notehead pane notehead x pos)))
    (when (final-accidental note)
      (score-pane:draw-accidental pane (final-accidental note) (final-absolute-accidental-xoffset note) pos))
    (draw-dots pane nb-dots x dot-xoffset dot-pos)))

(in-package :clim-user)

(defun ocp-list (composition)
  (flet ((sorter (x y)
           (or (amuse:time< x y)
               (and (amuse:time= x y)
                    (amuse:pitch< x y)))))
    (loop for e being each element of composition
          if (typep e 'amuse:pitched-event)
          collect (cons e (make-array 2 :initial-contents 
                                      (list (slot-value e 'amuse::time)
                                            (- (slot-value e 'amuse::number) 21)))) into result
          finally (return (sort result #'sorter :key #'car)))))

(let ((accidental-conversions
       '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
         ("f" . :flat) ("ff" . :double-flat))))
  (defun annotate-misspellings (composition)
    (do* ((ocp-list (ocp-list composition))
          (note-sequence (ps13:ps13-new-imp (map 'list #'cdr ocp-list) 10 42 nil nil nil))
          (list ocp-list (cdr list))
          (spellings note-sequence (cdr spellings)))
         ((null list))
      (let* ((event (caar list))
              (note (amuse-gsharp:note event))
             (accidental (elt (second (car spellings)) 1))
             (converted (cdr (assoc accidental accidental-conversions :test #'string=))))
        (unless (eq (gsharp-buffer:accidentals note) converted)
          ;; this pun is not to be preserved once we get into real
          ;; code.
          (setf (gsharp-measure::misspeltp note) (second (car spellings))))))))

(define-command (com-spellcheck :name t :command-table gsharp::global-gsharp-table)
    ()
  (let* ((segment (gsharp-cursor::segment (gsharp::current-cursor)))
	 (composition (amuse-gsharp::segment-composition segment)))
    (annotate-misspellings composition)
    #+nil
    (esa:display-message "~A" (first (ocp-list composition)))))

(let ((accidental-conversions
       '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
         ("f" . :flat) ("ff" . :double-flat))))
  (define-command (com-correct-misspelt-note :name t :command-table gsharp::global-gsharp-table)
      ((note 'gsharp::note))
    (let ((spelling (gsharp-measure::misspeltp note))
          (element (gsharp-buffer::cluster note))
          (staff (gsharp-buffer::staff note))
          (head (gsharp-buffer::head note))
          (dots (gsharp-buffer::dots note)))
      (let ((pitch (+ (mod (- (digit-char-p (char (elt spelling 0) 0) 17) 12) 7)
                      (* (parse-integer (elt spelling 2)) 7)))
            (accidentals (cdr (assoc (elt spelling 1) accidental-conversions :test #'string=))))
        (let ((new-note (gsharp-buffer::make-note pitch staff 
                                                  :head head
                                                  :dots dots
                                                  :accidentals accidentals)))
          (gsharp-buffer::remove-note note)
          (gsharp-buffer::add-note element new-note))))))

(define-presentation-to-command-translator correct-misspelt-note-translator
    (gsharp::note com-correct-misspelt-note gsharp::global-gsharp-table
          :gesture :select
          :tester ((object) (gsharp-measure::misspeltp object)))
  (object)
  (list object))

|#