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

[Robert Strandh]

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

Modified Files:
	gui.lisp 
Log Message:
Patch from Christophe Rhodes implementing transpose-objects and
transpose-words.  Thank you. 


Date: Sat Jan  1 20:58:40 2005
Author: rstrandh

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.42 climacs/gui.lisp:1.43
--- climacs/gui.lisp:1.42	Sat Jan  1 14:25:19 2005
+++ climacs/gui.lisp	Sat Jan  1 20:58:40 2005
@@ -212,12 +212,6 @@
     (possibly-expand-abbrev (point (win *application-frame*))))
   (insert-object (point (win *application-frame*)) *current-gesture*))
 
-(define-named-command com-backward-object ()
-  (decf (offset (point (win *application-frame*)))))
-
-(define-named-command com-forward-object ()
-  (incf (offset (point (win *application-frame*)))))
-
 (define-named-command com-beginning-of-line ()
   (beginning-of-line (point (win *application-frame*))))
 
@@ -234,12 +228,52 @@
   (let* ((point (point (win *application-frame*))))
     (unless (beginning-of-buffer-p point)
       (when (end-of-line-p point)
-	(decf (offset point)))
-      (let ((object (object-after point)))
-	(delete-range point)
-	(decf (offset point))
-	(insert-object point object)
-	(incf (offset point))))))
+       (backward-object point))
+       (let ((object (object-after point)))
+        (delete-range point)
+       (backward-object point)
+       (insert-object point object)
+       (forward-object point)))))
+
+(defgeneric backward-object (mark &optional count))
+(defmethod backward-object ((mark climacs-buffer::mark-mixin)
+                            &optional (count 1))
+  (decf (offset mark) count))
+
+(defgeneric forward-object (mark &optional count))
+(defmethod forward-object ((mark climacs-buffer::mark-mixin)
+                           &optional (count 1))
+  (incf (offset mark) count))
+
+(define-named-command com-backward-object ()
+  (backward-object (point (win *application-frame*))))
+
+(define-named-command com-forward-object ()
+  (forward-object (point (win *application-frame*))))
+
+(define-named-command com-transpose-words ()
+  (let* ((point (point (win *application-frame*))))
+    (let (bw1 bw2 ew1 ew2)
+      (backward-word point)
+      (setf bw1 (offset point))
+      (forward-word point)
+      (setf ew1 (offset point))
+      (forward-word point)
+      (when (= (offset point) ew1)
+        ;; this is emacs' message in the minibuffer
+        (error "Don't have two things to transpose"))
+      (setf ew2 (offset point))
+      (backward-word point)
+      (setf bw2 (offset point))
+      (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
+            (w1 (buffer-sequence (buffer point) bw1 ew1)))
+        (delete-word point)
+        (insert-sequence point w1)
+        (backward-word point)
+        (backward-word point)
+        (delete-word point)
+        (insert-sequence point w2)
+        (forward-word point)))))
 
 (define-named-command com-previous-line ()
   (previous-line (point (win *application-frame*))))
@@ -520,6 +554,7 @@
 (global-set-key '(#\w :control) 'com-cut-out)
 (global-set-key '(#\f :meta) 'com-forward-word)
 (global-set-key '(#\b :meta) 'com-backward-word)
+(global-set-key '(#\t :meta) 'com-transpose-words)
 (global-set-key '(#\x :meta) 'com-extended-command)
 (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only
 (global-set-key '(#\w :meta) 'com-copy-out)