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)))