[mcclim-cvs] CVS mcclim/Goatee

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Goatee
In directory clnet:/tmp/cvs-serv18682/Goatee

Modified Files:
	presentation-history.lisp 
Log Message:
Now Goatee has Drei-like presentation history commands.


--- /project/mcclim/cvsroot/mcclim/Goatee/presentation-history.lisp	2004/01/20 16:07:26	1.1
+++ /project/mcclim/cvsroot/mcclim/Goatee/presentation-history.lisp	2007/01/07 19:36:06	1.2
@@ -30,67 +30,40 @@
 (defun insert-ptype-history (object type)
   (multiple-value-bind (line pos)
       (point* *buffer*)
-    (setf *insert-extent* (make-instance 'extent
-					 :start-line line
-					 :start-pos pos))
     (multiple-value-bind (printed-rep accept-object)
 	(present-acceptably-to-string object type
 				      +textual-view+ ; XXX
 				      type)
-      (format *trace-output* "insert-ptype-history: ~S, ~S~%"
-	      (pos (bp-start *insert-extent*))
-	      (pos (bp-end *insert-extent*)))
       ;; XXX accept-object
-      (insert *buffer* printed-rep :line line :pos pos)
-      (format *trace-output* "insert-ptype-history:: ~S, ~S~%"
-	      (pos (bp-start *insert-extent*))
-	      (pos (bp-end *insert-extent*))))))
+      (insert *buffer* printed-rep :line line :pos pos))))
 
 
-(defun cmd-presentation-history-yank (&key &allow-other-keys)
+(defun cmd-history-yank-next (&key &allow-other-keys)
   (let* ((accepting-type climi::*active-history-type*)
-	 (history (and accepting-type
-		       (climi::presentation-type-history accepting-type))))
-    (setq *last-history-type* accepting-type
-	  *last-history* history)
+         (history (and accepting-type
+                       (presentation-type-history accepting-type))))
     (when history
       (multiple-value-bind (object type)
-	  (climi::presentation-history-head history accepting-type)
-	(if type
-	    (insert-ptype-history object type))))))
+          (climi::presentation-history-next history accepting-type)
+        (when type
+          (clear-buffer *buffer*)
+          (insert-ptype-history object type))))))
 
-(defun cmd-presentation-history-yank-next (&key &allow-other-keys)
-  (when (and *last-history-type* *last-history*)
+(defun cmd-history-yank-previous (&key &allow-other-keys)
+  (let* ((accepting-type climi::*active-history-type*)
+         (history (and accepting-type
+                       (presentation-type-history accepting-type))))
+    (when history
       (multiple-value-bind (object type)
-	  (climi::presentation-history-next *last-history* *last-history-type*)
-	(when type
-	  (delete-region *buffer*
-			 (bp-start *insert-extent*)
-			 (bp-end *insert-extent*))
-	  (insert-ptype-history object type)))))
-
-
-(defun goatee-next (&key &allow-other-keys)
-  (cond ((or (eq *last-command* 'cmd-presentation-history-yank)
-	     (and (eq *last-command* 'goatee-next)
-		  (or (eq *last-yank-command* 'cmd-presentation-history-yank-next) 
-		      (eq *last-yank-command*
-			  'cmd-presentation-history-yank-prev)))) 
-	 (funcall #'cmd-presentation-history-yank-next)
-	 (setq *last-yank-command* 'cmd-presentation-history-yank-next))
-	((or (eq *last-command* 'cmd-yank)
-	     (eq *last-command* 'cmd-yank-prev)
-	     (and (eq *last-command* 'goatee-next)
-		  (or (eq *last-yank-command* 'cmd-yank-next) 
-		      (eq *last-yank-command* 'cmd-yank-prev))))
-	 (funcall #'cmd-yank-next)
-	 (setq *last-yank-command* 'cmd-yank-next))
-	(t (beep))))
-
-(add-gesture-command-to-table '(#\y :control :meta)
-			      'cmd-presentation-history-yank
-			      *simple-area-gesture-table*)
-
-(add-gesture-command-to-table '(#\y :meta)
-			      'goatee-next
-			      *simple-area-gesture-table*)
+          (climi::presentation-history-previous history accepting-type)
+        (when type
+          (clear-buffer *buffer*)
+          (insert-ptype-history object type))))))
+
+(add-gesture-command-to-table '(#\p :meta)
+                              'cmd-history-yank-previous
+                              *simple-area-gesture-table*)
+
+(add-gesture-command-to-table '(#\n :meta)
+                              'cmd-history-yank-next
+                              *simple-area-gesture-table*)