[climacs-cvs] CVS update: climacs/ttcn3-syntax.lisp climacs/slidemacs.lisp climacs/prolog-syntax.lisp climacs/pane.lisp climacs/packages.lisp climacs/lisp-syntax.lisp climacs/html-syntax.lisp climacs/gui.lisp climacs/fundamental-syntax.lisp climacs/cl-syntax.lisp
Dave Murray
dmurray at common-lisp.net
Mon Aug 15 23:31:25 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv6402
Modified Files:
ttcn3-syntax.lisp slidemacs.lisp prolog-syntax.lisp pane.lisp
packages.lisp lisp-syntax.lisp html-syntax.lisp gui.lisp
fundamental-syntax.lisp cl-syntax.lisp
Log Message:
Factored out cursor display from syntaxes to a display-cursor
method on basic-syntax. Also added a display-mark method,
a mark-visible-p slot on climacs-pane, and a command
com-toggle-visible-mark to turn display of the mark on
and off - useful for developing marking commands.
Date: Tue Aug 16 01:31:22 2005
Author: dmurray
Index: climacs/ttcn3-syntax.lisp
diff -u climacs/ttcn3-syntax.lisp:1.2 climacs/ttcn3-syntax.lisp:1.3
--- climacs/ttcn3-syntax.lisp:1.2 Thu May 26 10:31:53 2005
+++ climacs/ttcn3-syntax.lisp Tue Aug 16 01:31:22 2005
@@ -442,15 +442,6 @@
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
(incf start-token-index))))))))
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (height (text-style-height (medium-text-style pane) pane))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column (column-number (point pane)))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p
- (make-rgb-color 0.7 0.7 0.7) +blue+))))))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p)))
Index: climacs/slidemacs.lisp
diff -u climacs/slidemacs.lisp:1.6 climacs/slidemacs.lisp:1.7
--- climacs/slidemacs.lisp:1.6 Tue Jun 21 18:51:05 2005
+++ climacs/slidemacs.lisp Tue Aug 16 01:31:22 2005
@@ -444,14 +444,5 @@
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
(incf start-token-index))))))))
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (height (text-style-height (medium-text-style pane) pane))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column (column-number (point pane)))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p
- (make-rgb-color 0.7 0.7 0.7) +blue+))))))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p)))
Index: climacs/prolog-syntax.lisp
diff -u climacs/prolog-syntax.lisp:1.21 climacs/prolog-syntax.lisp:1.22
--- climacs/prolog-syntax.lisp:1.21 Fri May 27 15:25:01 2005
+++ climacs/prolog-syntax.lisp Tue Aug 16 01:31:22 2005
@@ -1265,20 +1265,8 @@
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
(incf start-token-index))))))))
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (height (text-style-height (medium-text-style pane) pane))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column
- ;; FIXME: surely this should be more abstracted?
- (buffer-display-column
- (buffer (point pane)) (offset (point pane))
- (round (tab-width pane) (space-width pane))))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p +red+ +blue+))))))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p)))
#|
(climacs-gui::define-named-command com-inspect-lex ()
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.28 climacs/pane.lisp:1.29
--- climacs/pane.lisp:1.28 Mon Jul 18 00:40:37 2005
+++ climacs/pane.lisp Tue Aug 16 01:31:22 2005
@@ -231,6 +231,7 @@
(isearch-previous-string :initform nil :accessor isearch-previous-string)
(query-replace-mode :initform nil :accessor query-replace-mode)
(query-replace-state :initform nil :accessor query-replace-state)
+ (mark-visible-p :initform nil :accessor mark-visible-p)
(full-redisplay-p :initform nil :accessor full-redisplay-p)
(cache :initform (let ((cache (make-instance 'standard-flexichain)))
(insert* cache 0 nil)
@@ -460,37 +461,31 @@
(beginning-of-line (point pane))
(empty-cache cache)))))
-(defun display-cache (pane cursor-ink)
- (let* ((medium (sheet-medium pane))
- (style (medium-text-style medium))
- (height (text-style-height style medium)))
- (with-slots (top bot scan cache cursor-x cursor-y) pane
- (loop with start-offset = (offset top)
- for id from 0 below (nb-elements cache)
- do (setf scan start-offset)
- (updating-output
- (pane :unique-id (element* cache id)
- :cache-value (if (<= start-offset
- (offset (point pane))
- (+ start-offset (length (element* cache id))))
- (cons nil nil)
- (element* cache id))
- :cache-test #'eq)
- (display-line pane (element* cache id) start-offset
- (syntax (buffer pane)) (stream-default-view pane)))
- (incf start-offset (1+ (length (element* cache id)))))
- (when (mark= scan (point pane))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x x
- cursor-y y)))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink cursor-ink)))))
+(defun display-cache (pane)
+ (with-slots (top bot scan cache cursor-x cursor-y) pane
+ (loop with start-offset = (offset top)
+ for id from 0 below (nb-elements cache)
+ do (setf scan start-offset)
+ (updating-output
+ (pane :unique-id (element* cache id)
+ :cache-value (if (<= start-offset
+ (offset (point pane))
+ (+ start-offset (length (element* cache id))))
+ (cons nil nil)
+ (element* cache id))
+ :cache-test #'eq)
+ (display-line pane (element* cache id) start-offset
+ (syntax (buffer pane)) (stream-default-view pane)))
+ (incf start-offset (1+ (length (element* cache id)))))
+ (when (mark= scan (point pane))
+ (multiple-value-bind (x y) (stream-cursor-position pane)
+ (setf cursor-x x
+ cursor-y y)))))
(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p)
- (display-cache pane (if current-p +red+ +blue+)))
+ (display-cache pane)
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p))
(defgeneric redisplay-pane (pane current-p))
@@ -508,3 +503,47 @@
(defmethod full-redisplay ((pane climacs-pane))
(setf (full-redisplay-p pane) t))
+
+(defgeneric display-cursor (pane syntax current-p))
+
+(defmethod display-cursor ((pane climacs-pane) (syntax basic-syntax) current-p)
+ (with-slots (top) pane
+ (let* ((cursor-line (number-of-lines-in-region top (point pane)))
+ (style (medium-text-style pane))
+ (ascent (text-style-ascent style pane))
+ (descent (text-style-descent style pane))
+ (height (+ ascent descent))
+ (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
+ (cursor-column
+ (buffer-display-column
+ (buffer (point pane)) (offset (point pane))
+ (round (tab-width pane) (space-width pane))))
+ (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
+ (updating-output (pane :unique-id -1)
+ (draw-rectangle* pane
+ (1- cursor-x) cursor-y
+ (+ cursor-x 2) (+ cursor-y ascent descent)
+ :ink (if current-p +red+ +blue+))))))
+
+(defgeneric display-mark (pane syntax))
+
+(defmethod display-mark ((pane climacs-pane) (syntax basic-syntax))
+ (with-slots (top bot) pane
+ (let ((mark (mark pane)))
+ (when (< (offset top) (offset mark) (offset bot))
+ (let* ((mark-line (number-of-lines-in-region top mark))
+ (style (medium-text-style pane))
+ (ascent (text-style-ascent style pane))
+ (descent (text-style-descent style pane))
+ (height (+ ascent descent))
+ (mark-y (+ (* mark-line (+ height (stream-vertical-spacing pane)))))
+ (mark-column
+ (buffer-display-column
+ (buffer mark) (offset mark)
+ (round (tab-width pane) (space-width pane))))
+ (mark-x (* mark-column (text-style-width (medium-text-style pane) pane))))
+ (updating-output (pane :unique-id -2)
+ (draw-rectangle* pane
+ (1- mark-x) mark-y
+ (+ mark-x 2) (+ mark-y ascent descent)
+ :ink +green+)))))))
\ No newline at end of file
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.76 climacs/packages.lisp:1.77
--- climacs/packages.lisp:1.76 Sun Aug 14 20:09:42 2005
+++ climacs/packages.lisp Tue Aug 16 01:31:22 2005
@@ -141,6 +141,8 @@
(:export #:climacs-buffer #:needs-saving #:filepath
#:climacs-pane #:point #:mark
#:redisplay-pane #:full-redisplay
+ #:display-cursor
+ #:display-mark
#:page-down #:page-up
#:top #:bot
#:tab-space-count #:space-width #:tab-width
@@ -151,6 +153,7 @@
#:isearch-mode #:isearch-states #:isearch-previous-string
#:query-replace-state #:string1 #:string2
#:query-replace-mode
+ #:mark-visible-p
#:with-undo
#:url))
Index: climacs/lisp-syntax.lisp
diff -u climacs/lisp-syntax.lisp:1.31 climacs/lisp-syntax.lisp:1.32
--- climacs/lisp-syntax.lisp:1.31 Mon Aug 15 23:24:55 2005
+++ climacs/lisp-syntax.lisp Tue Aug 16 01:31:22 2005
@@ -1374,23 +1374,8 @@
(let ((*current-faces* *standard-faces*))
(with-slots (stack-top) syntax
(display-parse-tree stack-top syntax pane)))
- (with-slots (top) pane
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (style (medium-text-style pane))
- (ascent (text-style-ascent style pane))
- (descent (text-style-descent style pane))
- (height (+ ascent descent))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column
- (buffer-display-column
- (buffer (point pane)) (offset (point pane))
- (round (tab-width pane) (space-width pane))))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) cursor-y
- (+ cursor-x 2) (+ cursor-y ascent descent)
- :ink (if current-p +red+ +blue+))))))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.31 climacs/html-syntax.lisp:1.32
--- climacs/html-syntax.lisp:1.31 Thu May 26 10:31:53 2005
+++ climacs/html-syntax.lisp Tue Aug 16 01:31:22 2005
@@ -798,14 +798,6 @@
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
(incf start-token-index))))))))
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (height (text-style-height (medium-text-style pane) pane))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column (column-number (point pane)))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p +red+ +blue+))))))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p)))
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.176 climacs/gui.lisp:1.177
--- climacs/gui.lisp:1.176 Sun Aug 14 20:09:42 2005
+++ climacs/gui.lisp Tue Aug 16 01:31:22 2005
@@ -1640,6 +1640,9 @@
(define-named-command com-accept-lisp-string ()
(display-message (format nil "~s" (accept 'lisp-string))))
+(define-named-command com-toggle-visible-mark ()
+ (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Dead-escape command tables
Index: climacs/fundamental-syntax.lisp
diff -u climacs/fundamental-syntax.lisp:1.1 climacs/fundamental-syntax.lisp:1.2
--- climacs/fundamental-syntax.lisp:1.1 Tue Jul 19 12:02:02 2005
+++ climacs/fundamental-syntax.lisp Tue Aug 16 01:31:22 2005
@@ -108,23 +108,6 @@
pane (- tab-width (mod x tab-width)) 0))))
(incf start))))
-
-(defun display-cursor (pane current-p)
- (with-slots (top) pane
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (height (text-style-height (medium-text-style pane) pane))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column
- (buffer-display-column
- (buffer (point pane)) (offset (point pane))
- (round (tab-width pane) (space-width pane))))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p +red+ +blue+))))))
-
(defmethod display-line (pane mark)
(setf mark (clone-mark mark))
(let ((saved-offset nil)
@@ -202,7 +185,8 @@
:cache-value line
:cache-test #'eq)
(display-line pane (start-mark (element* lines i))))))))))
- (display-cursor pane current-p))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.14 climacs/cl-syntax.lisp:1.15
--- climacs/cl-syntax.lisp:1.14 Thu May 26 10:31:53 2005
+++ climacs/cl-syntax.lisp Tue Aug 16 01:31:22 2005
@@ -1125,17 +1125,8 @@
do (let ((token (lexeme lexer start-token-index)))
(display-parse-tree token syntax pane))
(incf start-token-index))))))))
- (let* ((cursor-line (number-of-lines-in-region top (point pane)))
- (height (text-style-height (medium-text-style pane) pane))
- (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
- (cursor-column (column-number (point pane)))
- (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
- (updating-output (pane :unique-id -1)
- (draw-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink (if current-p
- (make-rgb-color 0.7 0.7 0.7) +blue+))))))
+ (when (mark-visible-p pane) (display-mark pane syntax))
+ (display-cursor pane syntax current-p)))
More information about the Climacs-cvs
mailing list