[gsharp-cvs] CVS update: gsharp/gui.lisp

[Robert Strandh]

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

Modified Files:
	gui.lisp 
Log Message:
completions for staves, staff types, and clef types work better now
(should no longer fail on parse error). 

improved rename-staff command and made staff names unique. 


Date: Wed Jul 21 07:45:43 2004
Author: rstrandh

Index: gsharp/gui.lisp
diff -u gsharp/gui.lisp:1.13 gsharp/gui.lisp:1.14
--- gsharp/gui.lisp:1.13	Wed Jul 21 05:42:59 2004
+++ gsharp/gui.lisp	Wed Jul 21 07:45:43 2004
@@ -998,74 +998,113 @@
 ;;;
 ;;; Adding, deleting, and modifying staves
 
+(define-condition no-such-staff (gsharp-condition) ()
+  (:report
+   (lambda (condition stream)
+     (declare (ignore condition))
+     (format stream "No such staff"))))
+
+(define-presentation-method accept
+    ((type score-pane:staff) stream (view textual-view) &key)
+  (multiple-value-bind (staff success string)
+      (handler-case (complete-input stream
+				    (lambda (so-far mode)
+				      (complete-from-possibilities
+				       so-far
+				       (staves (buffer *gsharp-frame*))
+				       '()
+				       :action mode
+				       :predicate (lambda (obj) (declare (ignore obj)) t)
+				       :name-key #'name
+				       :value-key #'identity)))
+	(simple-parse-error () (error 'no-such-staff)))
+    (declare (ignore string))
+    (if success staff (error 'no-such-staff))))
+
 (define-presentation-method accept
     ((type fiveline-staff) stream (view textual-view) &key)
   (multiple-value-bind (staff success string)
-      (complete-input stream
-		      (lambda (so-far mode)
-			(complete-from-possibilities
-			 so-far
-			 (staves (buffer *gsharp-frame*))
-			 '()
-			 :action mode
-			 :predicate (lambda (obj) (typep obj 'fiveline-staff))
-			 :name-key #'name
-			 :value-key #'identity)))
+      (handler-case (complete-input stream
+				    (lambda (so-far mode)
+				      (complete-from-possibilities
+				       so-far
+				       (staves (buffer *gsharp-frame*))
+				       '()
+				       :action mode
+				       :predicate (lambda (obj) (typep obj 'fiveline-staff))
+				       :name-key #'name
+				       :value-key #'identity)))
+	(simple-parse-error () (error 'no-such-staff)))
     (declare (ignore string))
-    (if success
-	staff
-	(error "no such staff name")))) ; FIXME add a gsharp error here. 
+    (if success staff (error 'no-such-staff))))
 
 (defun symbol-name-lowcase (symbol)
   (string-downcase (symbol-name symbol)))
 
 (define-presentation-type staff-type ())
 
+(define-condition no-such-staff-type (gsharp-condition) ()
+  (:report
+   (lambda (condition stream)
+     (declare (ignore condition))
+     (format stream "No such staff type"))))
+
 (define-presentation-method accept
     ((type staff-type) stream (view textual-view) &key)
   (multiple-value-bind (type success string)
-      (complete-input stream
-		      (lambda (so-far mode)
-			(complete-from-possibilities
-			 so-far
-			 '(:fiveline)
-			 '()
-			 :action mode
-			 :predicate (lambda (obj) (declare (ignore obj)) t)
-			 :name-key #'symbol-name-lowcase
-			 :value-key #'identity)))
+      (handler-case (complete-input stream
+				    (lambda (so-far mode)
+				      (complete-from-possibilities
+				       so-far
+				       '(:fiveline)
+				       '()
+				       :action mode
+				       :predicate (lambda (obj) (declare (ignore obj)) t)
+				       :name-key #'symbol-name-lowcase
+				       :value-key #'identity)))
+	(simple-completion-error () (error 'no-such-staff-type)))
     (declare (ignore string))
-    (if success
-	type
-	(error "no such staff type"))))
+    (if success	type (error 'no-such-staff-type))))
 
 (define-presentation-type clef-type ())
 
 (define-presentation-method accept
     ((type clef-type) stream (view textual-view) &key)
   (multiple-value-bind (type success string)
-      (complete-input stream
-		      (lambda (so-far mode)
-			(complete-from-possibilities
-			 so-far
-			 '(:treble :bass :c :percussion)
-			 '()
-			 :action mode
-			 :predicate (lambda (obj) (declare (ignore obj)) t)
-			 :name-key #'symbol-name-lowcase
-			 :value-key #'identity)))
+      (handler-case (complete-input stream
+				    (lambda (so-far mode)
+				      (complete-from-possibilities
+				       so-far
+				       '(:treble :bass :c :percussion)
+				       '()
+				       :action mode
+				       :predicate (lambda (obj) (declare (ignore obj)) t)
+				       :name-key #'symbol-name-lowcase
+				       :value-key #'identity)))
+	(simple-completion-error () (error 'no-such-staff-type)))
     (declare (ignore string))
     (if success
 	type
 	(error "no such staff type"))))
 
+(define-condition staff-name-not-unique (gsharp-condition) ()
+  (:report
+   (lambda (condition stream)
+     (declare (ignore condition))
+     (format stream "Staff name already exists"))))
+
+(defun acquire-unique-staff-name ()
+  (let ((name (accept 'string :prompt "Staff name")))
+    (assert (not (member name (staves (buffer *gsharp-frame*)) :test #'string= :key #'name))
+	    () `staff-name-not-unique)
+    name))
+
 (defun acquire-new-staff ()
-  (let ((name (accept 'string :prompt "Staff name"))
-	(type (accept 'staff-type :prompt "Type")))
-    (ecase type
+  (let ((name (acquire-unique-staff-name)))
+    (ecase (accept 'staff-type :prompt "Type")
       (:fiveline (let ((clef (accept 'clef-type :prompt "Clef"))
 		       (line (accept 'integer :prompt "Line")))
-		   (make-fiveline-staff name (make-clef clef line)))))))	  
+		   (make-fiveline-staff name (make-clef clef line)))))))
 
 (define-gsharp-command (com-add-staff-before :name t) ()
   (add-staff-before-staff (accept 'score-pane:staff :prompt "Before staff")
@@ -1081,13 +1120,14 @@
   (remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff")
 			    (buffer *gsharp-frame*)))
 
-(define-gsharp-command (com-rename-staff :name t) ((name 'string))
-  (let ((buffer (buffer *gsharp-frame*))
-	(state (input-state *gsharp-frame*)))
-    (rename-staff name (staff state) buffer)))
+(define-gsharp-command (com-rename-staff :name t) ()
+  (let* ((staff (accept 'score-pane:staff :prompt "Staff"))
+	 (name (acquire-unique-staff-name))
+	 (buffer (buffer *gsharp-frame*)))
+    (rename-staff name staff buffer)))
 
-(define-gsharp-command (com-add-layer-staff :name t) ((name 'string))
-  (let ((staff (find-staff name (buffer *gsharp-frame*)))
+(define-gsharp-command (com-add-layer-staff :name t) ()
+  (let ((staff (accept 'score-pane:staff :prompt "Staff"))
 	(layer (layer (slice (bar (cursor *gsharp-frame*))))))
     (add-staff-to-layer staff layer)))