[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Tue Jan 16 05:17:42 UTC 2007
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv19540
Modified Files:
gui.lisp
Log Message:
Replaced (current-buffer *application-frame*) by (current-buffer) as
required by ESA now.
Also, untabified to make editing with Climacs easier.
--- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/11/16 12:58:23 1.73
+++ /project/gsharp/cvsroot/gsharp/gui.lisp 2007/01/16 05:17:40 1.74
@@ -2,9 +2,9 @@
(defun make-initial-cursor (buffer)
(let* ((segment (segmentno buffer 0))
- (layer (layerno segment 0))
- (slice (body layer))
- (bar (barno slice 0)))
+ (layer (layerno segment 0))
+ (slice (body layer))
+ (bar (barno slice 0)))
(make-cursor bar 0)))
(defclass gsharp-minibuffer-pane (minibuffer-pane)
@@ -30,7 +30,7 @@
(defclass gsharp-pane-mixin () ())
(defclass gsharp-pane (score-pane:score-pane gsharp-pane-mixin)
- ((view :initarg :view :accessor view)))
+ ((view :initarg :view :accessor view)))
(defvar *info-bg-color* +gray85+)
(defvar *info-fg-color* +black+)
@@ -45,82 +45,82 @@
(defun display-info (frame pane)
(declare (ignore frame))
(let* ((master-pane (master-pane pane))
- (view (view master-pane))
- (buffer (buffer view)))
+ (view (view master-pane))
+ (buffer (buffer view)))
(princ " " pane)
(princ (cond ((and (needs-saving buffer)
- (read-only-p buffer)
- "%*"))
- ((needs-saving buffer) "**")
- ((read-only-p buffer) "%%")
- (t "--"))
- pane)
+ (read-only-p buffer)
+ "%*"))
+ ((needs-saving buffer) "**")
+ ((read-only-p buffer) "%%")
+ (t "--"))
+ pane)
(princ " " pane)
(with-text-face (pane :bold)
(format pane "~25A" (name buffer)))
(princ " " pane)
(format pane "[~a/~a]"
- (score-pane:current-page-number view)
- (score-pane:number-of-pages view))
+ (score-pane:current-page-number view)
+ (score-pane:number-of-pages view))
(princ " " pane)
(with-text-family (pane :sans-serif)
(princ (if (recordingp *application-frame*)
- "Def"
- "")
- pane))))
+ "Def"
+ "")
+ pane))))
(define-application-frame gsharp (esa-frame-mixin
- standard-application-frame)
+ standard-application-frame)
((views :initarg :views :initform '() :accessor views)
(input-state :initarg :input-state :accessor input-state))
(:menu-bar menubar-command-table :height 25)
(:pointer-documentation t)
(:panes
(score (let* ((win (make-pane 'gsharp-pane
- :width 400 :height 500
- :name "score"
- ;; :incremental-redisplay t
- :double-buffering t
- :display-function 'display-score
- :command-table 'total-melody-table))
- (info (make-pane 'gsharp-info-pane
- :master-pane win
- :background *info-bg-color*
- :foreground *info-fg-color*)))
- (setf (windows *application-frame*) (list win))
- (setf (view win) (car (views *application-frame*)))
- (vertically ()
- (scrolling (:width 750 :height 500
- :min-height 400 :max-height 20000)
- win)
- info)))
+ :width 400 :height 500
+ :name "score"
+ ;; :incremental-redisplay t
+ :double-buffering t
+ :display-function 'display-score
+ :command-table 'total-melody-table))
+ (info (make-pane 'gsharp-info-pane
+ :master-pane win
+ :background *info-bg-color*
+ :foreground *info-fg-color*)))
+ (setf (windows *application-frame*) (list win))
+ (setf (view win) (car (views *application-frame*)))
+ (vertically ()
+ (scrolling (:width 750 :height 500
+ :min-height 400 :max-height 20000)
+ win)
+ info)))
(state (make-pane 'score-pane:score-pane
- :width 50 :height 200
- :name "state"
- :display-function 'display-state))
+ :width 50 :height 200
+ :name "state"
+ :display-function 'display-state))
(element (make-pane 'score-pane:score-pane
- :width 50 :height 300
- :min-height 100 :max-height 20000
- :name "element"
- :display-function 'display-element))
+ :width 50 :height 300
+ :min-height 100 :max-height 20000
+ :name "element"
+ :display-function 'display-element))
(interactor (make-pane 'gsharp-minibuffer-pane :width 900)))
(:layouts
(default
(vertically ()
(horizontally ()
score
- (vertically ()
- (scrolling (:width 80 :height 200) state)
- (scrolling (:width 80 :height 300
- :min-height 300 :max-height 20000)
- element)))
+ (vertically ()
+ (scrolling (:width 80 :height 200) state)
+ (scrolling (:width 80 :height 300
+ :min-height 300 :max-height 20000)
+ element)))
interactor)))
(:top-level (esa-top-level)))
(defmethod buffers ((application-frame gsharp))
(remove-duplicates (mapcar (lambda (window) (buffer (view window)))
- (windows application-frame))
- :test #'eq))
+ (windows application-frame))
+ :test #'eq))
(defmethod frame-current-buffer ((application-frame gsharp))
(buffer (view (car (windows application-frame)))))
@@ -136,56 +136,56 @@
(let ((state (input-state *application-frame*)))
(score-pane:with-score-pane pane
(score-pane:with-staff-size 10
- (score-pane:with-vertical-score-position (pane 100)
- (let ((xpos 30))
- (score-pane:draw-notehead pane (notehead state) xpos 4)
- (when (not (eq (notehead state) :whole))
- (when (or (eq (stem-direction state) :auto)
- (eq (stem-direction state) :down))
- (when (eq (notehead state) :filled)
- (score-pane:with-notehead-left-offsets (left down)
- (declare (ignore down))
- (let ((x (+ xpos left)))
- (loop repeat (rbeams state)
- for staff-step from -4 by 2 do
- (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
- (loop repeat (lbeams state)
- for staff-step from -4 by 2 do
- (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
- (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4))))
- (when (or (eq (stem-direction state) :auto)
- (eq (stem-direction state) :up))
- (when (eq (notehead state) :filled)
- (score-pane:with-notehead-right-offsets (right up)
- (declare (ignore up))
- (let ((x (+ xpos right)))
- (loop repeat (rbeams state)
- for staff-step downfrom 12 by 2 do
- (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
- (loop repeat (lbeams state)
- for staff-step downfrom 12 by 2 do
- (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
- (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12)))))
- (score-pane:with-notehead-right-offsets (right up)
- (declare (ignore up))
- (loop repeat (dots state)
- for dx from (+ right 5) by 5 do
- (score-pane:draw-dot pane (+ xpos dx) 4)))))))))
+ (score-pane:with-vertical-score-position (pane 100)
+ (let ((xpos 30))
+ (score-pane:draw-notehead pane (notehead state) xpos 4)
+ (when (not (eq (notehead state) :whole))
+ (when (or (eq (stem-direction state) :auto)
+ (eq (stem-direction state) :down))
+ (when (eq (notehead state) :filled)
+ (score-pane:with-notehead-left-offsets (left down)
+ (declare (ignore down))
+ (let ((x (+ xpos left)))
+ (loop repeat (rbeams state)
+ for staff-step from -4 by 2 do
+ (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
+ (loop repeat (lbeams state)
+ for staff-step from -4 by 2 do
+ (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
+ (score-pane:draw-left-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step -4))))
+ (when (or (eq (stem-direction state) :auto)
+ (eq (stem-direction state) :up))
+ (when (eq (notehead state) :filled)
+ (score-pane:with-notehead-right-offsets (right up)
+ (declare (ignore up))
+ (let ((x (+ xpos right)))
+ (loop repeat (rbeams state)
+ for staff-step downfrom 12 by 2 do
+ (score-pane:draw-beam pane x staff-step 0 (+ x 10) staff-step 0))
+ (loop repeat (lbeams state)
+ for staff-step downfrom 12 by 2 do
+ (score-pane:draw-beam pane (- x 10) staff-step 0 x staff-step 0)))))
+ (score-pane:draw-right-stem pane xpos (- (score-pane:staff-step 4)) (- (score-pane:staff-step 12)))))
+ (score-pane:with-notehead-right-offsets (right up)
+ (declare (ignore up))
+ (loop repeat (dots state)
+ for dx from (+ right 5) by 5 do
+ (score-pane:draw-dot pane (+ xpos dx) 4)))))))))
(defun update-page-numbers (frame)
(loop for window in (windows frame)
- do (let ((page-number 0)
- (view (view window)))
- (gsharp-measure::new-map-over-obseq-subsequences
- (lambda (all-measures)
- (incf page-number)
- (when (member-if (lambda (measure) (member (bar (cursor view))
- (measure-bars measure)
- :test #'eq))
- all-measures)
- (setf (score-pane:current-page-number view) page-number)))
- (buffer view))
- (setf (score-pane:number-of-pages view) page-number))))
+ do (let ((page-number 0)
+ (view (view window)))
+ (gsharp-measure::new-map-over-obseq-subsequences
+ (lambda (all-measures)
+ (incf page-number)
+ (when (member-if (lambda (measure) (member (bar (cursor view))
+ (measure-bars measure)
+ :test #'eq))
+ all-measures)
+ (setf (score-pane:current-page-number view) page-number)))
+ (buffer view))
+ (setf (score-pane:number-of-pages view) page-number))))
;;; I tried making this a :before method on redisplay-frame-panes,
;;; but it turns out that McCLIM calls redisplay-frame-pane from
@@ -199,7 +199,7 @@
(let* ((buffer (buffer (view pane))))
(score-pane:with-score-pane pane
(draw-buffer pane buffer (current-cursor)
- (left-margin buffer) 100)
+ (left-margin buffer) 100)
(gsharp-drawing::draw-the-cursor pane (current-cursor) (cursor-element (current-cursor)) (last-note (input-state *application-frame*)))
(multiple-value-bind (minx miny maxx maxy)
(bounding-rectangle* pane)
@@ -224,30 +224,30 @@
(defmethod display-element ((frame gsharp) pane)
(when (handler-case (cur-cluster)
- (gsharp-condition () nil))
+ (gsharp-condition () nil))
(score-pane:with-score-pane pane
(score-pane:with-staff-size 10
- (score-pane:with-vertical-score-position (pane 500)
- (let* ((xpos 30)
- (cluster (cur-cluster))
- (notehead (notehead cluster))
- (rbeams (rbeams cluster))
- (lbeams (lbeams cluster))
- (dots (dots cluster))
- (notes (notes cluster))
- (stem-direction (stem-direction cluster)))
- (declare (ignore stem-direction notehead lbeams rbeams dots))
- (loop for note in notes do
- (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7)
- (score-pane:draw-accidental pane (accidentals note)
- (- xpos (if (oddp (note-position note)) 15 25))
- (* 3 (note-position note))))
- (when notes
- (draw-ellipse* pane xpos (* 15 (note-position (cur-note)))
- 7 0 0 7 :ink +red+))
- (loop for s from 0 by 30
- repeat 5 do
- (draw-line* pane (- xpos 25) s (+ xpos 25) s))))))))
+ (score-pane:with-vertical-score-position (pane 500)
+ (let* ((xpos 30)
+ (cluster (cur-cluster))
+ (notehead (notehead cluster))
+ (rbeams (rbeams cluster))
+ (lbeams (lbeams cluster))
+ (dots (dots cluster))
+ (notes (notes cluster))
+ (stem-direction (stem-direction cluster)))
+ (declare (ignore stem-direction notehead lbeams rbeams dots))
+ (loop for note in notes do
+ (draw-ellipse* pane xpos (* 15 (note-position note)) 7 0 0 7)
+ (score-pane:draw-accidental pane (accidentals note)
+ (- xpos (if (oddp (note-position note)) 15 25))
+ (* 3 (note-position note))))
+ (when notes
+ (draw-ellipse* pane xpos (* 15 (note-position (cur-note)))
+ 7 0 0 7 :ink +red+))
+ (loop for s from 0 by 30
+ repeat 5 do
+ (draw-line* pane (- xpos 25) s (+ xpos 25) s))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -265,15 +265,15 @@
'menubar-command-table
:errorp nil
:menu '(("File" :menu file-command-table)
- ("Buffer" :menu buffer-command-table)
- ("Stuff" :menu segment-command-table)
- ("Segment" :menu segment-command-table)
- ("Layer" :menu layer-command-table)
- ("Slice" :menu slice-command-table)
- ("Measure" :menu measure-command-table)
- ("Modes" :menu modes-command-table)
- ("Staves" :menu staves-command-table)
- ("Play" :menu play-command-table)))
+ ("Buffer" :menu buffer-command-table)
+ ("Stuff" :menu segment-command-table)
+ ("Segment" :menu segment-command-table)
+ ("Layer" :menu layer-command-table)
+ ("Slice" :menu slice-command-table)
+ ("Measure" :menu measure-command-table)
+ ("Modes" :menu modes-command-table)
+ ("Staves" :menu staves-command-table)
+ ("Play" :menu play-command-table)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -283,34 +283,34 @@
'file-command-table
:errorp nil
:menu `(("Find" :command (esa-io::com-find-file ,esa::*unsupplied-argument-marker*))
- ("Save" :command esa-io::com-save-buffer)
- ("Save as" :command (esa-io::com-write-buffer ,esa::*unsupplied-argument-marker*))
- ("Quit" :command com-quit)))
+ ("Save" :command esa-io::com-save-buffer)
+ ("Save as" :command (esa-io::com-write-buffer ,esa::*unsupplied-argument-marker*))
+ ("Quit" :command com-quit)))
(define-gsharp-command (com-new-buffer :name t) ()
(let* ((buffer (make-instance 'buffer))
- (cursor (make-initial-cursor buffer))
- (staff (car (staves buffer)))
- (input-state (make-input-state))
- (view (make-instance 'orchestra-view
- :buffer buffer
- :cursor cursor)))
+ (cursor (make-initial-cursor buffer))
+ (staff (car (staves buffer)))
+ (input-state (make-input-state))
+ (view (make-instance 'orchestra-view
+ :buffer buffer
+ :cursor cursor)))
(push view (views *application-frame*))
(setf (view (car (windows *application-frame*))) view)
(setf (input-state *application-frame*) input-state
- (staves (car (layers (car (segments buffer))))) (list staff))))
+ (staves (car (layers (car (segments buffer))))) (list staff))))
(defmethod frame-find-file :around ((application-frame gsharp) filepath)
(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)))
+ (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)
+ (input-state *application-frame*) input-state
+ (filepath buffer) filepath)
(select-layer cursor (car (layers (segment (current-cursor)))))))
(define-gsharp-command (com-quit :name t) ()
@@ -324,7 +324,7 @@
'buffer-command-table
:errorp nil
:menu '(("Play" :command com-play-buffer)
- ("Delete Current" :command com-delete-buffer)))
[928 lines skipped]
More information about the Gsharp-cvs
mailing list