[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp

Matthieu Villeneuve mvilleneuve at common-lisp.net
Sun Jan 23 10:21:11 UTC 2005


Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv20514

Modified Files:
	gui.lisp packages.lisp pane.lisp 
Log Message:
Added basic Isearch support
Date: Sun Jan 23 02:21:09 2005
Author: mvilleneuve

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.95 climacs/gui.lisp:1.96
--- climacs/gui.lisp:1.95	Sat Jan 22 07:20:44 2005
+++ climacs/gui.lisp	Sun Jan 23 02:21:08 2005
@@ -109,7 +109,7 @@
   (declare (ignore frame))
   (with-slots (climacs-pane) pane
      (let* ((buf (buffer climacs-pane))
-	    (name-info (format nil "   ~a   ~a   Syntax: ~a~a~a    ~a"
+	    (name-info (format nil "   ~a   ~a   Syntax: ~a~a~a~a    ~a"
 			       (if (needs-saving buf) "**" "--")
 			       (name buf)
 			       (name (syntax buf))
@@ -119,6 +119,9 @@
                                (if (auto-fill-mode climacs-pane)
                                    " Fill"
                                    "")
+                               (if (isearch-mode climacs-pane)
+                                   " Isearch"
+                                   "")
 			       (if (recordingp *application-frame*)
 				   "Def"
 				   ""))))
@@ -983,17 +986,102 @@
   (let ((size (accept 'integer :prompt "New kill ring size")))
     (setf (kill-ring-max-size *kill-ring*) size)))
 
-(define-named-command com-search-forward ()
-  (search-forward (point (current-window))
-		  (accept 'string :prompt "Search Forward")
-		  :test (lambda (a b)
-			  (and (characterp b) (char-equal a b)))))
-
-(define-named-command com-search-backward ()
-  (search-backward (point (current-window))
-		   (accept 'string :prompt "Search Backward")
-		   :test (lambda (a b)
-			   (and (characterp b) (char-equal a b)))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; Incremental search
+
+(define-named-command com-isearch-mode ()
+  (let* ((pane (current-window))
+         (point (point pane)))
+    (unless (endp (isearch-states pane))
+      (setf (isearch-previous-string pane)
+            (search-string (first (isearch-states pane)))))
+    (setf (isearch-mode pane) t)
+    (setf (isearch-states pane)
+          (list (make-instance 'isearch-state
+                               :search-string ""
+                               :search-mark (clone-mark point))))
+    (redisplay-frame-panes *application-frame*)
+    (loop while (isearch-mode pane)
+          as gesture = (climacs-read-gesture)
+          as item = (find-gestures (list gesture) 'isearch-climacs-table)
+          do (cond ((and item (eq (command-menu-item-type item) :command))
+                    (setf *current-gesture* gesture)
+                    (let ((command (command-menu-item-value item)))
+                      (unless (consp command)
+                        (setf command (list command)))
+                      (handler-case 
+                          (execute-frame-command *application-frame* command)
+                        (error (condition)
+                          (beep)
+                          (format *error-output* "~a~%" condition)))))
+                   (t
+                    (unread-gesture gesture)
+                    (setf (isearch-mode pane) nil)))
+             (redisplay-frame-panes *application-frame*))))
+
+(defun isearch-from-mark (pane mark string)
+  (let* ((point (point pane))
+         (mark2 (clone-mark mark)))
+    (when (search-forward mark2 string
+                          :test (lambda (x y)
+                                  (if (characterp x)
+                                      (and (characterp y) (char-equal x y))
+                                      (eql x y))))
+      (setf (offset point) (offset mark2))
+      (setf (offset mark) (- (offset mark2) (length string))))))
+
+(define-named-command com-isearch-append-char ()
+  (let* ((pane (current-window))
+         (point (point pane))
+         (states (isearch-states pane))
+         (string (concatenate 'string
+                              (search-string (first states))
+                              (string *current-gesture*)))
+         (mark (clone-mark (search-mark (first states))))
+         (previous-point-offset (offset point)))
+    (isearch-from-mark pane mark string)
+    (if (/= (offset point) previous-point-offset)
+        (push (make-instance 'isearch-state
+                             :search-string string
+                             :search-mark mark)
+              (isearch-states pane))
+        (beep))))
+
+(define-named-command com-isearch-delete-char ()
+  (let* ((pane (current-window)))
+    (cond ((null (second (isearch-states pane)))
+           (beep))
+          (t
+           (pop (isearch-states pane))
+           (let ((state (first (isearch-states pane))))
+             (setf (offset (point pane))
+                   (+ (offset (search-mark state))
+                      (length (search-string state)))))))))
+
+(define-named-command com-isearch-forward ()
+  (let* ((pane (current-window))
+         (point (point pane))
+         (states (isearch-states pane))
+         (string (if (null (second states))
+                     (isearch-previous-string pane)
+                     (search-string (first states))))
+         (mark (clone-mark point))
+         (previous-point-offset (offset point)))
+    (isearch-from-mark pane mark string)
+    (if (/= (offset point) previous-point-offset)
+        (push (make-instance 'isearch-state
+                             :search-string string
+                             :search-mark mark)
+              (isearch-states pane))
+        (beep))))
+
+(define-named-command com-isearch-exit ()
+  (setf (isearch-mode (current-window)) nil))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; Dynamic abbrevs
 
 (define-named-command com-dabbrev-expand ()
   (let* ((win (current-window))
@@ -1109,6 +1197,7 @@
 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
 (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
+(global-set-key '(#\s :control) 'com-isearch-mode)
 
 (global-set-key '(:up) 'com-previous-line)
 (global-set-key '(:down) 'com-next-line)
@@ -1316,3 +1405,21 @@
 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; Isearch command table
+
+(make-command-table 'isearch-climacs-table :errorp nil)
+
+(defun isearch-set-key (gesture command)
+  (add-command-to-command-table command 'isearch-climacs-table
+                                :keystroke gesture :errorp nil))
+
+(loop for code from (char-code #\Space) to (char-code #\~)
+      do (isearch-set-key (code-char code) 'com-isearch-append-char))
+
+(isearch-set-key '(#\Newline) 'com-isearch-exit)
+(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
+(isearch-set-key '(#\s :control) 'com-isearch-forward)
+


Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.37 climacs/packages.lisp:1.38
--- climacs/packages.lisp:1.37	Thu Jan 20 22:54:54 2005
+++ climacs/packages.lisp	Sun Jan 23 02:21:08 2005
@@ -98,6 +98,8 @@
            #:tab-space-count
            #:indent-tabs-mode
            #:auto-fill-mode #:auto-fill-column
+           #:isearch-state #:search-string #:search-mark
+           #:isearch-mode #:isearch-states #:isearch-previous-string
 	   #:url))
 
 (defpackage :climacs-gui


Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.10 climacs/pane.lisp:1.11
--- climacs/pane.lisp:1.10	Sat Jan 22 07:20:44 2005
+++ climacs/pane.lisp	Sun Jan 23 02:21:08 2005
@@ -44,6 +44,14 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
+;;; Isearch
+
+(defclass isearch-state ()
+  ((search-string :initarg :search-string :accessor search-string)
+   (search-mark :initarg :search-mark :accessor search-mark)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
 ;;; View
 
 (defclass climacs-textual-view (textual-view tabify-mixin)
@@ -75,6 +83,9 @@
    (tab-width :initform nil)
    (auto-fill-mode :initform t :accessor auto-fill-mode)
    (auto-fill-column :initform 70 :accessor auto-fill-column)
+   (isearch-mode :initform nil :accessor isearch-mode)
+   (isearch-states :initform '() :accessor isearch-states)
+   (isearch-previous-string :initform nil :accessor isearch-previous-string)
    (full-redisplay-p :initform nil :accessor full-redisplay-p)
    (cache :initform (let ((cache (make-instance 'standard-flexichain)))
 		      (insert* cache 0 nil)




More information about the Climacs-cvs mailing list