[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Wed Feb 15 02:54:28 UTC 2006
Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp:/tmp/cvs-serv24313
Modified Files:
buffer.lisp gsharp.asd gui.lisp modes.lisp packages.lisp
Added Files:
esa-buffer.lisp esa-io.lisp
Log Message:
Added a new package and a new file ESA-BUFFER allowing buffers to be
named, to be associated with a file name, and to have a `needs-saving'
and a `read-only' flag.
Added a new package and a new file ESA-IO containing
application-independent functionality to create buffers from files,
and to save buffers to files. This package also supplies filename
completion. Most of the code was adapted from Climacs.
Abstracted out all Gsharp-specific I/O to ESA-IO. In particular, this
means that we now have commands such as C-x C-s, and C-x C-w, which we
didn't before.
The old I/O code is still there. Cleanup is next.
--- /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/13 23:51:34 1.33
+++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2006/02/15 02:54:26 1.34
@@ -1042,7 +1042,7 @@
(defvar *default-left-offset* 30)
(defvar *default-left-margin* 20)
-(defclass buffer (gsharp-object)
+(defclass buffer (gsharp-object esa-buffer-mixin)
((print-character :allocation :class :initform #\B)
(segments :initform '() :initarg :segments :accessor segments)
(staves :initform (list (make-fiveline-staff))
@@ -1214,7 +1214,15 @@
(*readtable* readtable))
(read stream)))))
-(defun save-buffer-to-stream (buffer stream)
+(defun read-buffer-from-stream (stream)
+ (let* ((version (read-line stream))
+ (readtable (cdr (assoc version *readtables* :test #'string=))))
+ (assert readtable () 'unknown-file-version)
+ (let ((*read-eval* nil)
+ (*readtable* readtable))
+ (read stream))))
+
+(defmethod save-buffer-to-stream ((buffer buffer) stream)
(let ((*print-circle* t)
(*package* (find-package :keyword)))
;; (format stream "G#V3~%")
--- /project/gsharp/cvsroot/gsharp/gsharp.asd 2005/12/07 03:38:27 1.5
+++ /project/gsharp/cvsroot/gsharp/gsharp.asd 2006/02/15 02:54:26 1.6
@@ -24,6 +24,8 @@
"packages"
"clim-patches"
"esa"
+ "esa-buffer"
+ "esa-io"
"utilities"
"gf"
"sdl"
--- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/13 23:51:34 1.53
+++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/02/15 02:54:26 1.54
@@ -68,8 +68,11 @@
interactor)))
(:top-level (esa-top-level)))
-(defun current-buffer ()
- (buffer (view (car (windows *application-frame*)))))
+(defmethod buffers ((application-frame gsharp))
+ (remove-duplicates (mapcar #'buffer (views application-frame)) :test #'eq))
+
+(defmethod current-buffer ((application-frame gsharp))
+ (buffer (view (car (windows application-frame)))))
(defun current-cursor ()
(cursor (view (car (windows *application-frame*)))))
@@ -308,13 +311,26 @@
(setf (input-state *application-frame*) input-state)
(select-layer cursor (car (layers (segment (current-cursor)))))))
+(defmethod find-file :around (filepath (application-frame gsharp))
+ (declare (ignore filepath))
+ (let* ((buffer (call-next-method))
+ (input-state (make-input-state))
+ (cursor (make-initial-cursor buffer))
+ (view (make-instance 'orchestra-view
+ :buffer buffer
+ :cursor cursor)))
+ (setf (view (car (windows *application-frame*))) view
+ (input-state *application-frame*) input-state
+ (filepath buffer) filepath)
+ (select-layer cursor (car (layers (segment (current-cursor)))))))
+
(define-gsharp-command (com-save-buffer-as :name t) ()
(let* ((stream (frame-standard-input *application-frame*))
(filename (handler-case (accept 'completable-pathname :stream stream
:prompt "File Name")
(simple-parse-error () (error 'file-not-found)))))
(with-open-file (stream filename :direction :output)
- (save-buffer-to-stream (current-buffer) stream)
+ (save-buffer-to-stream (current-buffer *application-frame*) stream)
(message "Saved buffer to ~A~%" filename))))
(define-gsharp-command (com-quit :name t) ()
@@ -354,13 +370,13 @@
(define-gsharp-command (com-insert-segment-before :name t) ()
(let ((cursor (current-cursor)))
- (insert-segment-before (make-instance 'segment :staff (car (staves (current-buffer))))
+ (insert-segment-before (make-instance 'segment :staff (car (staves (current-buffer *application-frame*))))
cursor)
(backward-segment cursor)))
(define-gsharp-command (com-insert-segment-after :name t) ()
(let ((cursor (current-cursor)))
- (insert-segment-after (make-instance 'segment :staff (car (staves (current-buffer))))
+ (insert-segment-after (make-instance 'segment :staff (car (staves (current-buffer *application-frame*))))
cursor)
(forward-segment cursor)))
@@ -996,7 +1012,7 @@
(lambda (so-far mode)
(complete-from-possibilities
so-far
- (staves (current-buffer))
+ (staves (current-buffer *application-frame*))
'()
:action mode
:predicate (constantly t)
@@ -1013,7 +1029,7 @@
(lambda (so-far mode)
(complete-from-possibilities
so-far
- (staves (current-buffer))
+ (staves (current-buffer *application-frame*))
'()
:action mode
:predicate (lambda (obj) (typep obj 'fiveline-staff))
@@ -1080,7 +1096,7 @@
(defun acquire-unique-staff-name (prompt)
(let ((name (accept 'string :prompt prompt)))
- (assert (not (member name (staves (current-buffer)) :test #'string= :key #'name))
+ (assert (not (member name (staves (current-buffer *application-frame*)) :test #'string= :key #'name))
() `staff-name-not-unique)
name))
@@ -1096,21 +1112,21 @@
(define-gsharp-command (com-insert-staff-before :name t) ()
(add-staff-before-staff (accept 'score-pane:staff :prompt "Insert staff before staff")
(acquire-new-staff)
- (current-buffer)))
+ (current-buffer *application-frame*)))
(define-gsharp-command (com-insert-staff-after :name t) ()
(add-staff-after-staff (accept 'score-pane:staff :prompt "Insert staff after staff")
(acquire-new-staff)
- (current-buffer)))
+ (current-buffer *application-frame*)))
(define-gsharp-command (com-delete-staff :name t) ()
(remove-staff-from-buffer (accept 'score-pane:staff :prompt "Staff")
- (current-buffer)))
+ (current-buffer *application-frame*)))
(define-gsharp-command (com-rename-staff :name t) ()
(let* ((staff (accept 'score-pane:staff :prompt "Rename staff"))
(name (acquire-unique-staff-name "New name of staff"))
- (buffer (current-buffer)))
+ (buffer (current-buffer *application-frame*)))
(rename-staff name staff buffer)))
(define-gsharp-command (com-add-staff-to-layer :name t) ()
@@ -1145,3 +1161,13 @@
(insert-element element cursor)
(forward-element cursor)
element))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; I/O
+
+(defmethod make-buffer-from-stream (stream (frame gsharp))
+ (read-buffer-from-stream stream))
+
+(defmethod make-new-buffer ((frame gsharp))
+ (make-instance 'buffer))
\ No newline at end of file
--- /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/13 23:51:34 1.8
+++ /project/gsharp/cvsroot/gsharp/modes.lisp 2006/02/15 02:54:26 1.9
@@ -1,7 +1,7 @@
(in-package :gsharp)
(define-command-table global-gsharp-table
- :inherit-from (global-esa-table keyboard-macro-table))
+ :inherit-from (global-esa-table esa-io-table keyboard-macro-table))
(set-key `(com-forward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\f :control)))
(set-key `(com-backward-element ,*numeric-argument-marker*) 'global-gsharp-table '((#\b :control)))
@@ -13,7 +13,7 @@
(set-key 'com-left 'global-gsharp-table '((#\l :meta)))
(set-key 'com-right 'global-gsharp-table '((#\r :meta)))
(set-key 'com-rotate-notehead 'global-gsharp-table '((#\r :control)))
-(set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control)))
+;;; (set-key 'com-load-file 'global-gsharp-table '((#\x :control) (#\f :control)))
(set-key 'com-istate-more-dots 'global-gsharp-table '((#\i) (#\.)))
(set-key 'com-istate-more-lbeams 'global-gsharp-table '((#\i) (#\[)))
(set-key 'com-istate-more-rbeams 'global-gsharp-table '((#\i) (#\])))
--- /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/14 03:00:52 1.44
+++ /project/gsharp/cvsroot/gsharp/packages.lisp 2006/02/15 02:54:27 1.45
@@ -11,6 +11,22 @@
#:set-key
#:find-applicable-command-table))
+(defpackage :esa-buffer
+ (:use :clim-lisp :clim :esa)
+ (:export #:make-buffer-from-stream #:save-buffer-to-stream
+ #:filepath #:name #:needs-saving
+ #:esa-buffer-mixin
+ #:make-new-buffer
+ #:read-only-p))
+
+(defpackage :esa-io
+ (:use :clim-lisp :clim :esa :esa-buffer)
+ (:export #:buffers #:current-buffer
+ #:find-file #:find-file-read-only
+ #:set-visited-filename
+ #:save-buffer #:write-buffer
+ #:esa-io-table))
+
(defpackage :gsharp-utilities
(:shadow built-in-class)
(:use :clim-lisp :clim-mop)
@@ -64,7 +80,7 @@
#:score-view))
(defpackage :gsharp-buffer
- (:use :common-lisp :gsharp-utilities)
+ (:use :common-lisp :gsharp-utilities :esa-buffer)
(:shadow #:rest)
(:export #:clef #:name #:lineno #:make-clef
#:staff #:fiveline-staff #:make-fiveline-staff
@@ -100,12 +116,13 @@
#:add-staff-to-layer
#:remove-staff-from-layer
#:stem-direction #:undotted-duration #:duration
- #:clef #:keysig #:staff-pos #:xoffset #:read-everything #:save-buffer-to-stream
+ #:clef #:keysig #:staff-pos #:xoffset #:read-everything
+ #:read-buffer-from-stream
#:key-signature #:alterations #:more-sharps #:more-flats
#:line-width #:min-width #:spacing-style #:right-edge #:left-offset
#:left-margin #:text #:append-char #:erase-char
#:tie-right #:tie-left
- ))
+ #:needs-saving))
(defpackage :gsharp-numbering
(:use :gsharp-utilities :gsharp-buffer :clim-lisp)
@@ -226,7 +243,7 @@
#:play-buffer))
(defpackage :gsharp
- (:use :clim :clim-lisp :gsharp-utilities :esa
+ (:use :clim :clim-lisp :gsharp-utilities :esa :esa-buffer :esa-io
:gsharp-buffer :gsharp-cursor :gsharp-drawing :gsharp-numbering
:gsharp-measure :sdl :midi
:gsharp-play)
--- /project/gsharp/cvsroot/gsharp/esa-buffer.lisp 2006/02/15 02:54:28 NONE
+++ /project/gsharp/cvsroot/gsharp/esa-buffer.lisp 2006/02/15 02:54:28 1.1
;;; -*- Mode: Lisp; Package: ESA-IO -*-
;;; (c) copyright 2006 by
;;; Robert Strandh (strandh at labri.fr)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :esa-buffer)
(defgeneric make-buffer-from-stream (stream application-frame)
(:documentation "Create a fresh buffer by reading the external
representation from STREAM"))
(defgeneric make-new-buffer (application-frame)
(:documentation "Create a empty buffer for the application frame"))
(defgeneric save-buffer-to-stream (buffer stream)
(:documentation "Save the entire BUFFER to STREAM in the appropriate
external representation"))
(defgeneric filepath (buffer))
(defgeneric (setf filepath) (filepath buffer))
(defgeneric name (buffer))
(defgeneric (setf name) (name buffer))
(defgeneric needs-saving (buffer))
(defgeneric (setf needs-saving) (needs-saving buffer))
(defclass esa-buffer-mixin ()
((%filepath :initform nil :accessor filepath)
(%name :initarg :name :initform "*scratch*" :accessor name)
(%needs-saving :initform nil :accessor needs-saving)
(%read-only-p :initform nil :accessor read-only-p)))
--- /project/gsharp/cvsroot/gsharp/esa-io.lisp 2006/02/15 02:54:28 NONE
+++ /project/gsharp/cvsroot/gsharp/esa-io.lisp 2006/02/15 02:54:28 1.1
;;; -*- Mode: Lisp; Package: ESA-IO -*-
;;; (c) copyright 2006 by
;;; Robert Strandh (strandh at labri.fr)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :esa-io)
(defgeneric buffers (application-frame)
(:documentation "Return a list of all the buffers of the application"))
(defgeneric current-buffer (application-frame)
(:documentation "Return the current buffer of APPLICATION-FRAME"))
(defgeneric find-file (file-path application-frame))
(defgeneric find-file-read-only (file-path application-frame))
(defgeneric set-visited-filename (filepath buffer application-frame))
(defgeneric save-buffer (buffer application-frame))
(defgeneric write-buffer (buffer filepath application-frame))
(make-command-table 'esa-io-table :errorp nil)
(defgeneric find-file (file-path application-frame)
(:documentation "if a buffer with the file-path already exists, return it,
else if a file with the right name exists, return a fresh buffer created from
the file, else return a new empty buffer having the associated file name."))
(defun filename-completer (so-far mode)
(flet ((remove-trail (s)
(subseq s 0 (let ((pos (position #\/ s :from-end t)))
(if pos (1+ pos) 0)))))
(let* ((directory-prefix
(if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
""
(namestring #+sbcl *default-pathname-defaults*
#+cmu (ext:default-directory)
#-(or sbcl cmu) *default-pathname-defaults*)))
(full-so-far (concatenate 'string directory-prefix so-far))
(pathnames
(loop with length = (length full-so-far)
and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
for path in
#+(or sbcl cmu lispworks) (directory wildcard)
#+openmcl (directory wildcard :directories t)
#+allegro (directory wildcard :directories-are-files nil)
#+cormanlisp (nconc (directory wildcard)
(cl::directory-subdirs dirname))
#-(or sbcl cmu lispworks openmcl allegro cormanlisp)
(directory wildcard)
when (let ((mismatch (mismatch (namestring path) full-so-far)))
(or (null mismatch) (= mismatch length)))
collect path))
(strings (mapcar #'namestring pathnames))
(first-string (car strings))
(length-common-prefix nil)
(completed-string nil)
(full-completed-string nil))
(unless (null pathnames)
(setf length-common-prefix
(loop with length = (length first-string)
for string in (cdr strings)
do (setf length (min length (or (mismatch string first-string) length)))
finally (return length))))
(unless (null pathnames)
(setf completed-string
(subseq first-string (length directory-prefix)
(if (null (cdr pathnames)) nil length-common-prefix)))
(setf full-completed-string
(concatenate 'string directory-prefix completed-string)))
(case mode
((:complete-limited :complete-maximal)
(cond ((null pathnames)
(values so-far nil nil 0 nil))
((null (cdr pathnames))
(values completed-string t (car pathnames) 1 nil))
(t
(values completed-string nil nil (length pathnames) nil))))
(:complete
(cond ((null pathnames)
(values so-far t so-far 1 nil))
((null (cdr pathnames))
(values completed-string t (car pathnames) 1 nil))
((find full-completed-string strings :test #'string-equal)
(let ((pos (position full-completed-string strings :test #'string-equal)))
(values completed-string
t (elt pathnames pos) (length pathnames) nil)))
(t
(values completed-string nil nil (length pathnames) nil))))
(:possibilities
(values nil nil nil (length pathnames)
(loop with length = (length directory-prefix)
for name in pathnames
collect (list (subseq (namestring name) length nil)
name))))))))
(define-presentation-method present (object (type pathname)
stream (view textual-view) &key)
(princ (namestring object) stream))
(define-presentation-method accept ((type pathname) stream (view textual-view)
&key (default nil defaultp) (default-type type))
(multiple-value-bind (pathname success string)
(complete-input stream
#'filename-completer
:allow-any-input t)
(cond (success
(values pathname type))
((and (zerop (length string))
defaultp)
(values default default-type))
(t (values string 'string)))))
;;; Adapted from cl-fad/PCL
(defun directory-pathname-p (pathspec)
"Returns NIL if PATHSPEC does not designate a directory."
(let ((name (pathname-name pathspec))
(type (pathname-type pathspec)))
(and (or (null name) (eql name :unspecific))
(or (null type) (eql type :unspecific)))))
(defun filepath-filename (pathname)
(if (null (pathname-type pathname))
(pathname-name pathname)
(concatenate 'string (pathname-name pathname)
"." (pathname-type pathname))))
(defmethod find-file (filepath application-frame)
(cond ((null filepath)
(display-message "No file name given.")
(beep))
((directory-pathname-p filepath)
(display-message "~A is a directory name." filepath)
(beep))
(t
(or (find filepath (buffers *application-frame*)
:key #'filepath :test #'equal)
(let ((buffer (if (probe-file filepath)
(with-open-file (stream filepath :direction :input)
(make-buffer-from-stream stream *application-frame*))
(make-new-buffer *application-frame*))))
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath)
(needs-saving buffer) nil)
buffer)))))
(define-command (com-find-file :name t :command-table esa-io-table) ()
(let* ((filepath (accept 'pathname :prompt "Find File")))
(find-file filepath *application-frame*)))
(set-key 'com-find-file 'esa-io-table '((#\x :control) (#\f :control)))
(defmethod find-file-read-only (filepath application-frame)
(cond ((null filepath)
(display-message "No file name given.")
(beep))
((directory-pathname-p filepath)
(display-message "~A is a directory name." filepath)
(beep))
(t
(or (find filepath (buffers *application-frame*)
:key #'filepath :test #'equal)
(if (probe-file filepath)
(with-open-file (stream filepath :direction :input)
(let ((buffer (make-buffer-from-stream stream *application-frame*)))
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath)
(read-only-p buffer) t
(needs-saving buffer) nil)))
(progn
(display-message "No such file: ~A" filepath)
(beep)
nil))))))
(define-command (com-find-file-read-only :name t :command-table esa-io-table) ()
(let ((filepath (accept 'pathname :Prompt "Find file read only")))
(find-file-read-only filepath *application-frame*)))
(set-key 'com-find-file-read-only 'esa-io-table '((#\x :control) (#\r :control)))
(define-command (com-read-only :name t :command-table esa-io-table) ()
(let ((buffer (current-buffer *application-frame*)))
(setf (read-only-p buffer) (not (read-only-p buffer)))))
(set-key 'com-read-only 'esa-io-table '((#\x :control) (#\q :control)))
(defmethod set-visited-file-name (filename buffer application-frame)
(setf (filepath buffer) filename
(name buffer) (filepath-filename filename)
(needs-saving buffer) t))
(define-command (com-set-visited-file-name :name t :command-table esa-io-table) ()
(let ((filename (accept 'pathname :prompt "New file name")))
(set-visited-file-name filename (current-buffer *application-frame*) *application-frame*)))
(defmethod save-buffer (buffer application-frame)
(let ((filepath (or (filepath buffer)
(accept 'pathname :prompt "Save Buffer to File"))))
(cond
((directory-pathname-p filepath)
(display-message "~A is a directory." filepath)
(beep))
(t
(when (probe-file filepath)
(let ((backup-name (pathname-name filepath))
(backup-type (concatenate 'string (pathname-type filepath) "~")))
(rename-file filepath (make-pathname :name backup-name
:type backup-type))))
(with-open-file (stream filepath :direction :output :if-exists :supersede)
(save-buffer-to-stream buffer stream))
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath))
(display-message "Wrote: ~a" (filepath buffer))
(setf (needs-saving buffer) nil)))))
(define-command (com-save-buffer :name t :command-table esa-io-table) ()
(let ((buffer (current-buffer *application-frame*)))
(if (or (null (filepath buffer))
(needs-saving buffer))
(save-buffer buffer *application-frame*)
(display-message "No changes need to be saved from ~a" (name buffer)))))
(set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control)))
(defmethod write-buffer (buffer filepath application-frame)
(cond
((directory-pathname-p filepath)
(display-message "~A is a directory name." filepath))
(t
(with-open-file (stream filepath :direction :output :if-exists :supersede)
(save-buffer-to-stream buffer stream))
(setf (filepath buffer) filepath
(name buffer) (filepath-filename filepath)
(needs-saving buffer) nil)
(display-message "Wrote: ~a" (filepath buffer)))))
(define-command (com-write-buffer :name t :command-table esa-io-table) ()
(let ((filepath (accept 'pathname :prompt "Write Buffer to File"))
(buffer (current-buffer *application-frame*)))
(write-buffer buffer filepath *application-frame*)))
(set-key 'com-write-buffer 'esa-io-table '((#\x :control) (#\w :control)))
More information about the Gsharp-cvs
mailing list