[gsharp-cvs] CVS update: gsharp/play.lisp gsharp/buffer.lisp gsharp/drawing.lisp gsharp/gui.lisp gsharp/packages.lisp gsharp/system.lisp

Robert Strandh rstrandh at common-lisp.net
Mon Oct 31 01:41:15 UTC 2005


Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp.net:/tmp/cvs-serv27994

Modified Files:
	buffer.lisp drawing.lisp gui.lisp packages.lisp system.lisp 
Added Files:
	play.lisp 
Log Message:
Extracted midi-related computations to a new file: play.lisp

Renamed notehead-duration to undotted-duration, which better reflects
the intention.


Date: Mon Oct 31 02:41:13 2005
Author: rstrandh



Index: gsharp/buffer.lisp
diff -u gsharp/buffer.lisp:1.9 gsharp/buffer.lisp:1.10
--- gsharp/buffer.lisp:1.9	Thu Aug  5 08:31:57 2004
+++ gsharp/buffer.lisp	Mon Oct 31 02:41:13 2005
@@ -237,7 +237,7 @@
 	    ":notehead ~W :rbeams ~W :lbeams ~W :dots ~W :xoffset ~W "
 	    notehead rbeams lbeams dots xoffset)))
 
-(defmethod notehead-duration ((element element))
+(defmethod undotted-duration ((element element))
   (ecase (notehead element)
     (:whole 1)
     (:half 1/2)
@@ -245,7 +245,7 @@
 				  (lbeams element))))))))
 
 (defmethod element-duration ((element element))
-  (let ((duration (notehead-duration element)))
+  (let ((duration (undotted-duration element)))
     (do ((dot-duration (/ duration 2) (/ dot-duration 2))
 	 (nb-dots (dots element) (1- nb-dots)))
 	((zerop nb-dots))


Index: gsharp/drawing.lisp
diff -u gsharp/drawing.lisp:1.11 gsharp/drawing.lisp:1.12
--- gsharp/drawing.lisp:1.11	Fri Sep  2 18:10:03 2005
+++ gsharp/drawing.lisp	Mon Oct 31 02:41:13 2005
@@ -633,7 +633,7 @@
 (defmethod draw-element (pane (element rest) x &optional (flags t))
   (declare (ignore flags))
   (score-pane:with-vertical-score-position (pane (staff-yoffset (staff element)))
-    (score-pane:draw-rest pane (notehead-duration element) x (staff-pos element))
+    (score-pane:draw-rest pane (undotted-duration element) x (staff-pos element))
     (draw-dots pane (dots element) x (1+ (staff-pos element)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


Index: gsharp/gui.lisp
diff -u gsharp/gui.lisp:1.26 gsharp/gui.lisp:1.27
--- gsharp/gui.lisp:1.26	Fri Oct 28 19:20:19 2005
+++ gsharp/gui.lisp	Mon Oct 31 02:41:13 2005
@@ -528,86 +528,15 @@
  :menu '(("Buffer" :command com-play-buffer)
 	 ("Segment" :command com-play-segment)))
 
-(defun midi-pitch (note)
-  (+ (* 12 (+ (floor (pitch note) 7) 1))
-     (ecase (mod (pitch note) 7) (0 0) (1 2) (2 4) (3 5) (4 7) (5 9) (6 11))
-     (ecase (accidentals note)
-       (:double-flat -2) (:flat -1) (:natural 0) (:sharp 1) (:double-sharp 2))))
-
-(defun measure-durations (slices)
-  (let ((durations (mapcar (lambda (slice)
-			     (mapcar (lambda (bar)
-				       (reduce #'+ (elements bar)
-					       :key #'element-duration))
-				     (bars slice)))
-			   slices)))
-    (loop while durations
-	  collect (reduce #'max (mapcar #'car durations))
-	  do (setf durations (remove nil (mapcar #'cdr durations))))))
-
-(defun events-from-element (element time channel)
-  (when (typep element 'cluster)
-    (append (mapcar (lambda (note)
-		      (make-instance 'note-on-message
-				     :time time
-				     :status (+ #x90 channel)
-				     :key (midi-pitch note) :velocity 100))
-		    (notes element))
-	    (mapcar (lambda (note)
-		      (make-instance 'note-off-message
-				     :time (+ time (* 128 (element-duration element)))
-				     :status (+ #x80 channel)
-				     :key (midi-pitch note) :velocity 100))
-		    (notes element)))))
-
-(defun events-from-bar (bar time channel)
-  (mapcan (lambda (element)
-	    (prog1 (events-from-element element time channel)
-	      (incf time (* 128 (element-duration element)))))
-	  (elements bar)))
-
-(defun track-from-slice (slice channel durations)
-  (cons (make-instance 'program-change-message
-	  :time 0 :status  (+ #xc0 channel) :program 0)
-	(let ((time 0))
-	  (mapcan (lambda (bar duration)
-		    (prog1 (events-from-bar bar time channel)
-		      (incf time (* 128 duration))))
-		  (bars slice) durations))))
-
 (define-gsharp-command (com-play-segment :name t) ()
-  (let* ((slices (mapcar #'body (layers (car (segments (buffer *application-frame*))))))
-	 (durations (measure-durations slices))
-	 (tracks (loop for slice in slices
-		       for i from 0
-		       collect (track-from-slice slice i durations)))
-	 (midifile (make-instance 'midifile
-		     :format 1
-		     :division 25
-		     :tracks tracks)))
-    (write-midi-file midifile "test.mid")
-    #+cmu
-    (ext:run-program "timidity" '("test.mid"))
-    #+sbcl
-    (sb-ext:run-program "timidity" '("test.mid") :search t)
-    #-(or cmu sbcl)
-    (error "write compatibility layer for RUN-PROGRAM")))
+  (play-segment (segment (cursor *application-frame*))))
 
 (define-gsharp-command (com-play-layer :name t) ()
-  (let* ((slice (body (layer (cursor *application-frame*))))
-	 (durations (measure-durations (list slice)))
-	 (tracks (list (track-from-slice slice 0 durations)))
-	 (midifile (make-instance 'midifile
-		     :format 1
-		     :division 25
-		     :tracks tracks)))
-    (write-midi-file midifile "test.mid")
-    #+cmu
-    (ext:run-program "timidity" '("test.mid"))
-    #+sbcl
-    (sb-ext:run-program "timidity" '("test.mid") :search t)
-    #-(or cmu sbcl)
-    (error "write compatibility layer for RUN-PROGRAM")))
+  (play-layer (layer (cursor *application-frame*))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; main entry point
 
 (defun run-gsharp (&key (width 900) (height 600))
   (let* ((buffer (make-initialized-buffer))
@@ -621,21 +550,6 @@
 						  :width width :height height)))
       (setf (staves (car (layers (car (segments buffer))))) (list staff))
       (run-frame-top-level *application-frame*))))
-
-;; (defun run-gsharp ()
-;;  (loop for port in climi::*all-ports*
-;; 	do (destroy-port port))
-;;  (setq climi::*all-ports* nil)
-;;   (let* ((buffer (make-initialized-buffer))
-;; 	 (staff (car (staves buffer)))
-;; 	 (input-state (make-input-state))
-;; 	 (cursor (make-initial-cursor buffer)))
-;;     (setf *application-frame* (make-application-frame 'gsharp
-;; 						 :buffer buffer
-;; 						 :input-state input-state
-;; 						 :cursor cursor)
-;; 	  (staves (car (layers (car (segments buffer))))) (list staff)))
-;;   (run-frame-top-level *application-frame*))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;


Index: gsharp/packages.lisp
diff -u gsharp/packages.lisp:1.11 gsharp/packages.lisp:1.12
--- gsharp/packages.lisp:1.11	Thu Oct 13 11:05:04 2005
+++ gsharp/packages.lisp	Mon Oct 31 02:41:13 2005
@@ -66,7 +66,7 @@
 	   #:rename-staff
 	   #:add-staff-to-layer
 	   #:remove-staff-from-layer
-	   #:stem-direction #:stem-length #:notehead-duration #:element-duration
+	   #:stem-direction #:stem-length #:undotted-duration #:element-duration
 	   #:clef #:keysig #:staff-pos #:xoffset #:read-everything #:save-buffer-to-stream
 	   #:line-width #:min-width #:spacing-style #:right-edge #:left-offset
 	   #:left-margin #:text #:append-char #:erase-char
@@ -202,10 +202,18 @@
 	   #:header #:header-type
 	   #:unknown-event #:status #:data-byte))
 
+(defpackage :gsharp-play
+  (:use :common-lisp :midi :gsharp-buffer)
+  (:shadowing-import-from :gsharp-buffer #:rest)
+  (:export #:play-layer
+	   #:play-segment
+	   #:play-buffer))
+
 (defpackage :gsharp
   (:use :clim :clim-lisp :gsharp-utilities :esa
 	:gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering
-	:gsharp-measure :sdl :midi)
+	:gsharp-measure :sdl :midi
+	:gsharp-play)
   (:shadowing-import-from :gsharp-numbering #:number)
   (:shadowing-import-from :gsharp-buffer #:rest))
 


Index: gsharp/system.lisp
diff -u gsharp/system.lisp:1.7 gsharp/system.lisp:1.8
--- gsharp/system.lisp:1.7	Mon Jul 25 13:14:38 2005
+++ gsharp/system.lisp	Mon Oct 31 02:41:13 2005
@@ -40,4 +40,5 @@
    "input-state"
    "midi"
    "modes"
+   "play"
    "gui")




More information about the Gsharp-cvs mailing list