[climacs-cvs] CVS climacs

dmurray dmurray at common-lisp.net
Sat May 6 19:51:05 UTC 2006


Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv9866

Modified Files:
	cl-syntax.lisp fundamental-syntax.lisp html-syntax.lisp 
	lisp-syntax.lisp misc-commands.lisp packages.lisp pane.lisp 
	prolog-syntax.lisp slidemacs.lisp ttcn3-syntax.lisp 
Log Message:
Changed mark-visibility to region visibility. Turn it on
and off with Visible Region, for now.


--- /project/climacs/cvsroot/climacs/cl-syntax.lisp	2006/03/03 19:38:57	1.17
+++ /project/climacs/cvsroot/climacs/cl-syntax.lisp	2006/05/06 19:51:04	1.18
@@ -1141,7 +1141,7 @@
 		   do (let ((token (lexeme lexer start-token-index)))
 			(display-parse-tree token syntax pane))
 		     (incf start-token-index))))))))
-    (when (mark-visible-p pane) (display-mark pane syntax))
+    (when (region-visible-p pane) (display-region pane syntax))
     (display-cursor pane syntax current-p)))
 
 
--- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp	2005/08/15 23:31:22	1.2
+++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp	2006/05/06 19:51:04	1.3
@@ -185,7 +185,7 @@
 					     :cache-value line
 					     :cache-test #'eq)
 			(display-line pane (start-mark (element* lines i))))))))))
-  (when (mark-visible-p pane) (display-mark pane syntax))
+  (when (region-visible-p pane) (display-region pane syntax))
   (display-cursor pane syntax current-p))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/climacs/cvsroot/climacs/html-syntax.lisp	2005/08/15 23:31:22	1.32
+++ /project/climacs/cvsroot/climacs/html-syntax.lisp	2006/05/06 19:51:04	1.33
@@ -798,6 +798,6 @@
 			do (let ((token (lexeme lexer start-token-index)))
 			     (display-parse-tree token syntax pane))
 			   (incf start-token-index))))))))
-     (when (mark-visible-p pane) (display-mark pane syntax))
+     (when (region-visible-p pane) (display-region pane syntax))
      (display-cursor pane syntax current-p)))
 	    
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp	2006/05/06 17:23:33	1.65
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp	2006/05/06 19:51:04	1.66
@@ -1590,7 +1590,7 @@
   (let ((*current-faces* *standard-faces*))
     (with-slots (stack-top) syntax
       (display-parse-tree stack-top syntax pane)))
-  (when (mark-visible-p pane) (display-mark pane syntax))
+  (when (region-visible-p pane) (display-region pane syntax))
   (display-cursor pane syntax current-p))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/climacs/cvsroot/climacs/misc-commands.lisp	2006/05/06 15:38:42	1.10
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp	2006/05/06 19:51:04	1.11
@@ -1538,7 +1538,6 @@
 	 'marking-table
 	 '((#\h :control :meta)))
 
-(define-command (com-visible-mark :name t :command-table marking-table) ()
-  "Toggle the visibility of the mark in the current pane.
-This is particularly (only?) useful for experimenting with marking commands."
-  (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window)))))
+(define-command (com-visible-region :name t :command-table marking-table) ()
+  "Toggle the visibility of the region in the current pane."
+  (setf (region-visible-p (current-window)) (not (region-visible-p (current-window)))))
--- /project/climacs/cvsroot/climacs/packages.lisp	2006/05/06 06:27:14	1.92
+++ /project/climacs/cvsroot/climacs/packages.lisp	2006/05/06 19:51:04	1.93
@@ -152,7 +152,7 @@
            #:clear-cache
 	   #:redisplay-pane #:full-redisplay
 	   #:display-cursor
-	   #:display-mark
+	   #:display-region
 	   #:page-down #:page-up
 	   #:top #:bot
            #:tab-space-count #:space-width #:tab-width
@@ -163,7 +163,7 @@
            #:isearch-mode #:isearch-states #:isearch-previous-string
            #:query-replace-state #:string1 #:string2
            #:query-replace-mode
-	   #:mark-visible-p
+	   #:region-visible-p
 	   #:with-undo
 	   #:url
 	   #:climacs-textual-view #:+climacs-textual-view+))
--- /project/climacs/cvsroot/climacs/pane.lisp	2006/05/06 06:27:14	1.38
+++ /project/climacs/cvsroot/climacs/pane.lisp	2006/05/06 19:51:04	1.39
@@ -280,7 +280,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)
+   (region-visible-p :initform nil :accessor region-visible-p)
    (full-redisplay-p :initform nil :accessor full-redisplay-p)
    (cache :initform (let ((cache (make-instance 'standard-flexichain)))
 		      (insert* cache 0 nil)
@@ -564,7 +564,7 @@
 
 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p)
   (display-cache pane)
-  (when (mark-visible-p pane) (display-mark pane syntax))
+  (when (region-visible-p pane) (display-region pane syntax))
   (display-cursor pane syntax current-p))
 
 (defgeneric redisplay-pane (pane current-p))
@@ -589,43 +589,118 @@
 (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))))
+  (let ((point (point pane)))
+    (multiple-value-bind (cursor-x cursor-y line-height)
+	(offset-to-screen-position (offset point) pane)
       (updating-output (pane :unique-id -1)
 	(draw-rectangle* pane
 			 (1- cursor-x) cursor-y
-			 (+ cursor-x 2) (+ cursor-y ascent descent)
+			 (+ cursor-x 2) (+ cursor-y line-height)
 			 :ink (if current-p +red+ +blue+))))))
 
-(defgeneric display-mark (pane syntax))
+(defgeneric display-region (pane syntax))
 
-(defmethod display-mark ((pane climacs-pane) (syntax basic-syntax))
+(defmethod display-region ((pane climacs-pane) (syntax basic-syntax))
+  (multiple-value-bind (cursor-x cursor-y line-height)
+      (offset-to-screen-position (offset (point pane)) pane)
+    (multiple-value-bind (mark-x mark-y)
+	(offset-to-screen-position (offset (mark pane)) pane)
+      (cond
+	;; mark is above the top of the screen
+	((and (null mark-y) (null mark-x))
+	 (updating-output (pane :unique-id -3)
+	   (draw-rectangle* pane
+			    0 0
+			    (stream-text-margin pane) cursor-y
+			    :ink (compose-in +green+
+					     (make-opacity .1)))
+	   (draw-rectangle* pane
+			    0 cursor-y 
+			    cursor-x (+ cursor-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))))
+	;; mark is below the bottom of the screen
+	((and (null mark-y) mark-x)
+	 (updating-output (pane :unique-id -3)
+	   (draw-rectangle* pane
+			    0 (+ cursor-y line-height)
+			    (stream-text-margin pane) (bounding-rectangle-height
+						       (window-viewport pane))
+			    :ink (compose-in +green+
+					     (make-opacity .1)))
+	   (draw-rectangle* pane
+			    cursor-x cursor-y
+			    (stream-text-margin pane) (+ cursor-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))))
+	;; mark is at point
+	((and (= mark-x cursor-x) (= mark-y cursor-y))
+	 nil)
+	;; mark and point are on the same line
+	((= mark-y cursor-y)
+	 (updating-output (pane :unique-id -3)
+	   (draw-rectangle* pane
+			    mark-x mark-y
+			    cursor-x (+ cursor-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))))
+	;; mark and point are both visible, mark above point
+	((< mark-y cursor-y)
+	 (updating-output (pane :unique-id -3)
+	   (draw-rectangle* pane
+			    mark-x mark-y
+			    (stream-text-margin pane) (+ mark-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))
+	   (draw-rectangle* pane
+			    0 cursor-y
+			    cursor-x (+ cursor-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))
+	   (draw-rectangle* pane
+			    0 (+ mark-y line-height)
+			    (stream-text-margin pane) cursor-y
+			    :ink (compose-in +green+
+					     (make-opacity .1)))))
+	;; mark and point are both visible, point above mark
+	(t
+	 (updating-output (pane :unique-id -3)
+	   (draw-rectangle* pane
+			    cursor-x cursor-y
+			    (stream-text-margin pane) (+ cursor-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))
+	   (draw-rectangle* pane
+			    0 mark-y
+			    mark-x (+ mark-y line-height)
+			    :ink (compose-in +green+
+					     (make-opacity .1)))
+	   (draw-rectangle* pane
+			    0 (+ cursor-y line-height)
+			    (stream-text-margin pane) mark-y
+			    :ink (compose-in +green+
+					     (make-opacity .1)))))))))
+
+(defun offset-to-screen-position (offset pane)
+  "Returns the position of offset as a screen position.
+Returns X Y LINE-HEIGHT CHAR-WIDTH as values if offset is on the screen,
+NIL if offset is before the beginning of the screen,
+and T if offset is after the end of the screen."
   (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
+     (cond
+       ((< offset (offset top)) nil)
+       ((< (offset bot) offset) t)
+       (t
+	(let* ((line (number-of-lines-in-region top offset))
+	       (style (medium-text-style pane))
+	       (style-width (text-style-width style pane))
+	       (ascent (text-style-ascent style pane))
+	       (descent (text-style-descent style pane))
+	       (height (+ ascent descent))
+	       (y (+ (* line (+ height (stream-vertical-spacing pane)))))
+	       (column 
+		(buffer-display-column
+		 (buffer pane) offset
+		 (round (tab-width pane) (space-width pane))))
+	       (x (* column style-width)))
+	  (values x y height style-width))))))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/prolog-syntax.lisp	2006/03/03 19:38:57	1.26
+++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp	2006/05/06 19:51:04	1.27
@@ -1310,7 +1310,7 @@
 			do (let ((token (lexeme lexer start-token-index)))
 			     (display-parse-tree token syntax pane))
 			   (incf start-token-index))))))))
-     (when (mark-visible-p pane) (display-mark pane syntax))
+     (when (region-visible-p pane) (display-region pane syntax))
      (display-cursor pane syntax current-p)))
 
 #|
--- /project/climacs/cvsroot/climacs/slidemacs.lisp	2006/03/03 19:38:57	1.8
+++ /project/climacs/cvsroot/climacs/slidemacs.lisp	2006/05/06 19:51:04	1.9
@@ -454,5 +454,5 @@
 		   do (let ((token (lexeme lexer start-token-index)))
 			(display-parse-tree token syntax pane))
 		     (incf start-token-index))))))))
-    (when (mark-visible-p pane) (display-mark pane syntax))
+    (when (region-visible-p pane) (display-region pane syntax))
     (display-cursor pane syntax current-p)))
--- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp	2006/03/03 19:38:57	1.4
+++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp	2006/05/06 19:51:04	1.5
@@ -452,6 +452,6 @@
 		   do (let ((token (lexeme lexer start-token-index)))
 			(display-parse-tree token syntax pane))
 		     (incf start-token-index))))))))
-    (when (mark-visible-p pane) (display-mark pane syntax))
+    (when (region-visible-p pane) (display-region pane syntax))
     (display-cursor pane syntax current-p)))
 




More information about the Climacs-cvs mailing list