- climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS update: climacs/kill-ring.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp
by ejohnson＠common-lisp.net 29 Dec '04

29 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv15124 Modified Files: climacs.asd gui.lisp packages.lisp Added Files: kill-ring.lisp Log Message: adding in kill ring material Date: Wed Dec 29 06:45:38 2004 Author: ejohnson Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.5 climacs/climacs.asd:1.6 --- climacs/climacs.asd:1.5 Sat Dec 25 00:14:40 2004 +++ climacs/climacs.asd Wed Dec 29 06:45:37 2004 @@ -55,4 +55,5 @@ "io" "abbrev" "syntax" + "kill-ring" "gui") Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.24 climacs/gui.lisp:1.25 --- climacs/gui.lisp:1.24 Wed Dec 29 05:55:20 2004 +++ climacs/gui.lisp Wed Dec 29 06:45:37 2004 @@ -34,14 +34,18 @@ (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) (point :initform nil :initarg :point :reader point) - (syntax :initarg :syntax :accessor syntax))) + (syntax :initarg :syntax :accessor syntax) + (mark :initform nil :initarg :mark :reader mark))) (defmethod initialize-instance :after ((pane climacs-pane) &rest args) (declare (ignore args)) - (with-slots (buffer point syntax) pane + (with-slots (buffer point syntax mark) pane (when (null point) (setf point (make-instance 'standard-right-sticky-mark :buffer buffer))) + (when (null mark) + (setf mark (make-instance 'standard-right-sticky-mark + :buffer buffer))) (setf syntax (make-instance 'texinfo-syntax :pane pane)))) (define-application-frame climacs () @@ -96,6 +100,7 @@ (setf table (command-menu-item-value item))) finally (return item))) +(defvar *kill-ring* (initialize-kill-ring 7)) (defparameter *current-gesture* nil) (defun climacs-top-level (frame &key @@ -331,6 +336,49 @@ (define-command com-browse-url () (accept 'url :prompt "Browse URL")) +(define-command com-set-mark () + (with-slots (point mark) (win *application-frame*) + (setf mark (clone-mark point)))) + +;;;;;;;;;;;;;;;;;;;; +;; Kill ring commands + +;; The naming may sound odd here, but think of electronic wireing: +;; outputs to inputs and inputs to outputs. Copying into a buffer +;; first requires coping out of the kill ring. + +(define-command com-copy-in () + (kr-copy-out (point (win *application-frame*)) *kill-ring*)) + +(define-command com-cut-in () + (kr-cut-out (point (win *application-frame*)) *kill-ring*)) + +(define-command com-cut-out () + (with-slots (buffer point mark)(win *application-frame*) + (let ((off1 (offset point)) + (off2 (offset mark))) + (if (< off1 off2) + (kr-cut-in buffer *kill-ring* off1 off2) + (kr-cut-in buffer *kill-ring* off2 off1))))) + +(define-command com-copy-out () + (with-slots (buffer point mark)(win *application-frame*) + (let ((off1 (offset point)) + (off2 (offset mark))) + (if (< off1 off2) + (kr-copy-in buffer *kill-ring* off1 off2) + (kr-copy-in buffer *kill-ring* off2 off1))))) + +;; Needs adjustment to be like emacs M-y +(define-command com-kr-rotate () + (kr-rotate *kill-ring* -1)) + +;; Not bound to a key yet +(define-command com-kr-resize () + (let ((size (accept 'fixnum :prompt "New kill ring size: "))) + (kr-resize *kill-ring* size))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global command table @@ -355,11 +403,16 @@ (global-set-key '(#\n :control) 'com-next-line) (global-set-key '(#\o :control) 'com-open-line) (global-set-key '(#\k :control) 'com-kill-line) +(global-set-key '(#\Space :control) 'com-set-mark) +(global-set-key '(#\y :control) 'com-copy-in) +(global-set-key '(#\w :control) 'com-cut-in) (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\a :meta) 'com-insert-weird-stuff) (global-set-key '(#\c :meta) 'com-insert-reversed-string) +(global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only +(global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\u :meta) 'com-browse-url) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.11 climacs/packages.lisp:1.12 --- climacs/packages.lisp:1.11 Sun Dec 26 08:18:01 2004 +++ climacs/packages.lisp Wed Dec 29 06:45:37 2004 @@ -60,6 +60,12 @@ #:redisplay-pane #:redisplay-with-syntax #:full-redisplay #:url)) +(defpackage :climacs-kill-ring + (:use :clim-lisp :climacs-buffer :flexichain) + (:export #:initialize-kill-ring #:kr-length #:kr-resize + #:kr-rotate #:kr-copy-in #:kr-cut-in #:kr-copy-out + #:kr-cut-out)) + (defpackage :climacs-gui - (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax)) + (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by abridgewater＠common-lisp.net 29 Dec '04

29 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12180 Modified Files: gui.lisp Log Message: First cut at getting M-x extended commands to work. Covers Quit and Find File. Date: Wed Dec 29 05:55:20 2004 Author: abridgewater Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.23 climacs/gui.lisp:1.24 --- climacs/gui.lisp:1.23 Tue Dec 28 18:32:18 2004 +++ climacs/gui.lisp Wed Dec 29 05:55:20 2004 @@ -137,7 +137,7 @@ (t nil)))) (redisplay-frame-panes frame)))) -(define-command com-quit () +(define-command (com-quit :name "Quit" :command-table climacs) () (frame-exit *application-frame*)) (define-command com-self-insert () @@ -193,7 +193,9 @@ 'default))) (define-command com-extended-command () - (accept 'command :prompt "Extended Command")) + (let ((item (accept 'command :prompt "Extended Command"))) + (window-clear *standard-input*) + (execute-frame-command *application-frame* item))) (defclass weird () () (:documentation "An open ended class.")) @@ -286,7 +288,7 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) -(define-command com-find-file () +(define-command (com-find-file :name "Find File" :command-table climacs) () (let ((filename (accept 'completable-pathname :prompt "Find File"))) (with-slots (buffer point syntax) (win *application-frame*)

1 0

[climacs-cvs] CVS update: climacs/syntax.lisp
by abridgewater＠common-lisp.net 28 Dec '04

28 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25376 Modified Files: syntax.lisp Log Message: Changed redisplay to not create output records for #\Space characters. Date: Tue Dec 28 23:41:15 2004 Author: abridgewater Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.10 climacs/syntax.lisp:1.11 --- climacs/syntax.lisp:1.10 Mon Dec 27 18:43:08 2004 +++ climacs/syntax.lisp Tue Dec 28 23:41:14 2004 @@ -106,7 +106,8 @@ until (eql (buffer-object (buffer pane) scan) #\Newline) do (let ((obj (buffer-object (buffer pane) scan))) (cond ((eql obj #\Space) - (output-word (princ obj pane))) + (output-word) + (stream-increment-cursor-position pane space-width 0)) ((eql obj #\Tab) (output-word) (let ((x (stream-cursor-position pane)))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 28 Dec '04

28 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9146 Modified Files: gui.lisp Log Message: Better buffer name. Save-buffer now sets the filename and the name of the buffer. Date: Tue Dec 28 18:32:20 2004 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.22 climacs/gui.lisp:1.23 --- climacs/gui.lisp:1.22 Tue Dec 28 17:57:26 2004 +++ climacs/gui.lisp Tue Dec 28 18:32:18 2004 @@ -280,6 +280,12 @@ (declare (ignore success)) (or pathname string))) +(defun pathname-filename (pathname) + (if (null (pathname-type pathname)) + (pathname-name pathname) + (concatenate 'string (pathname-name pathname) + "." (pathname-type pathname)))) + (define-command com-find-file () (let ((filename (accept 'completable-pathname :prompt "Find File"))) @@ -290,7 +296,7 @@ (with-open-file (stream filename :direction :input :if-does-not-exist :create) (input-from-stream stream buffer 0)) (setf (filename buffer) filename - (name buffer) (pathname-name filename)) + (name buffer) (pathname-filename filename)) (beginning-of-buffer point)))) (define-command com-save-buffer () @@ -300,6 +306,8 @@ (buffer (buffer (win *application-frame*)))) (with-open-file (stream filename :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) + (setf (filename buffer) filename + (name buffer) (pathname-filename filename)) (setf (modified-p (buffer (win *application-frame*))) nil))) (define-command com-write-buffer () @@ -309,7 +317,7 @@ (with-open-file (stream filename :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) (setf (filename buffer) filename - (name buffer) (pathname-name filename)) + (name buffer) (pathname-filename filename)) (setf (modified-p (buffer (win *application-frame*))) nil))) (define-command com-beginning-of-buffer ()

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 28 Dec '04

28 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7032 Modified Files: gui.lisp Log Message: Nicer layout. Buffer name and buffer modification flag shown on new status line. write-buffer command. Date: Tue Dec 28 17:57:26 2004 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.21 climacs/gui.lisp:1.22 --- climacs/gui.lisp:1.21 Mon Dec 27 17:47:45 2004 +++ climacs/gui.lisp Tue Dec 28 17:57:26 2004 @@ -27,7 +27,9 @@ (defclass filename-mixin () ((filename :initform nil :accessor filename))) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin) ()) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin) + ((name :initform "*scratch*" :accessor name) + (modified :initform nil :accessor modified-p))) (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) @@ -50,11 +52,19 @@ :name 'win :incremental-redisplay t :display-function 'display-win)) - (int :interactor :width 900 :height 50 :max-height 50)) + (info :application + :width 900 :height 20 :max-height 20 + :name 'info :background +light-gray+ + :scroll-bars nil + :incremental-redisplay t + :display-function 'display-info) + (int :application :width 900 :height 20 :max-height 20 + :scroll-bars nil)) (:layouts (default - (vertically () + (vertically (:scroll-bars nil) (scrolling (:width 900 :height 400) win) + info int))) (:top-level (climacs-top-level))) @@ -63,6 +73,14 @@ (let ((frame (make-application-frame 'climacs))) (run-frame-top-level frame))) +(defun display-info (frame pane) + (let* ((win (win frame)) + (buf (buffer win)) + (name-info (format nil " ~a ~a" + (if (modified-p buf) "**" "--") + (name buf)))) + (princ name-info pane))) + (defun display-win (frame pane) "The display function used by the climacs application frame." (declare (ignore frame)) @@ -85,8 +103,10 @@ partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (setf (slot-value frame 'win) (find-pane-named frame 'win)) - (let ((*standard-output* (frame-standard-output frame)) - (*standard-input* (frame-standard-input frame)) +;; (let ((*standard-output* (frame-standard-output frame)) +;; (*standard-input* (frame-standard-input frame)) + (let ((*standard-output* (find-pane-named frame 'win)) + (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) @@ -123,7 +143,8 @@ (define-command com-self-insert () (unless (constituentp *current-gesture*) (possibly-expand-abbrev (point (win *application-frame*)))) - (insert-object (point (win *application-frame*)) *current-gesture*)) + (insert-object (point (win *application-frame*)) *current-gesture*) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-command com-backward-object () (decf (offset (point (win *application-frame*))))) @@ -138,10 +159,12 @@ (end-of-line (point (win *application-frame*)))) (define-command com-delete-object () - (delete-range (point (win *application-frame*)))) + (delete-range (point (win *application-frame*))) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-command com-backward-delete-object () - (delete-range (point (win *application-frame*)) -1)) + (delete-range (point (win *application-frame*)) -1) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -150,10 +173,12 @@ (next-line (point (win *application-frame*)))) (define-command com-open-line () - (open-line (point (win *application-frame*)))) + (open-line (point (win *application-frame*))) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-command com-kill-line () - (kill-line (point (win *application-frame*)))) + (kill-line (point (win *application-frame*))) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -174,11 +199,13 @@ (:documentation "An open ended class.")) (define-command com-insert-weird-stuff () - (insert-object (point (win *application-frame*)) (make-instance 'weird))) + (insert-object (point (win *application-frame*)) (make-instance 'weird)) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-command com-insert-reversed-string () (insert-sequence (point (win *application-frame*)) - (reverse (accept 'string)))) + (reverse (accept 'string))) + (setf (modified-p (buffer (win *application-frame*))) t)) (define-presentation-type completable-pathname () :inherit-from 'pathname) @@ -227,7 +254,7 @@ (values completed-string nil nil (length pathnames) nil)))) (:complete (cond ((null pathnames) - (values so-far nil nil 0 nil)) + (values so-far t so-far 1 nil)) ((null (cdr pathnames)) (values completed-string t (car pathnames) 1 nil)) ((find full-completed-string strings :test #'string-equal) @@ -259,10 +286,11 @@ (with-slots (buffer point syntax) (win *application-frame*) (setf buffer (make-instance 'climacs-buffer) point (make-instance 'standard-right-sticky-mark :buffer buffer) - syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)) - (filename buffer) filename) - (with-open-file (stream filename :direction :input) + syntax (make-instance 'texinfo-syntax :pane (win *application-frame*))) + (with-open-file (stream filename :direction :input :if-does-not-exist :create) (input-from-stream stream buffer 0)) + (setf (filename buffer) filename + (name buffer) (pathname-name filename)) (beginning-of-buffer point)))) (define-command com-save-buffer () @@ -271,7 +299,18 @@ :prompt "Save Buffer to File"))) (buffer (buffer (win *application-frame*)))) (with-open-file (stream filename :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))))) + (output-to-stream stream buffer 0 (size buffer))) + (setf (modified-p (buffer (win *application-frame*))) nil))) + +(define-command com-write-buffer () + (let ((filename (accept 'completable-pathname + :prompt "Write Buffer to File")) + (buffer (buffer (win *application-frame*)))) + (with-open-file (stream filename :direction :output :if-exists :supersede) + (output-to-stream stream buffer 0 (size buffer))) + (setf (filename buffer) filename + (name buffer) (pathname-name filename)) + (setf (modified-p (buffer (win *application-frame*))) nil))) (define-command com-beginning-of-buffer () (beginning-of-buffer (point (win *application-frame*)))) @@ -345,3 +384,4 @@ (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\s :control) 'com-save-buffer) +(c-x-set-key '(#\w :control) 'com-write-buffer)

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp climacs/io.lisp
by rstrandh＠common-lisp.net 28 Dec '04

28 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7130 Modified Files: buffer.lisp io.lisp Log Message: Improved performance of loading a file by employing an new addition to the Flexichain library. You will have to update your Flexichain directory from CVS in order for this to work. Date: Tue Dec 28 07:58:36 2004 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.11 climacs/buffer.lisp:1.12 --- climacs/buffer.lisp:1.11 Fri Dec 24 09:21:34 2004 +++ climacs/buffer.lisp Tue Dec 28 07:58:36 2004 @@ -327,9 +327,7 @@ sequence.")) (defmethod insert-buffer-sequence ((buffer standard-buffer) offset sequence) - (loop for elem across sequence - do (insert-buffer-object buffer offset elem) - (incf offset))) + (insert-vector* (slot-value buffer 'contents) offset sequence)) (defgeneric insert-object (mark object) (:documentation "Insert the object at the mark. This function simply calls Index: climacs/io.lisp diff -u climacs/io.lisp:1.2 climacs/io.lisp:1.3 --- climacs/io.lisp:1.2 Thu Dec 23 09:00:33 2004 +++ climacs/io.lisp Tue Dec 28 07:58:36 2004 @@ -23,11 +23,14 @@ (in-package :climacs-base) (defun input-from-stream (stream buffer offset) - (let ((eof-object (cons nil nil))) - (loop for obj = (read-char stream nil eof-object) - until (eq obj eof-object) - do (insert-buffer-object buffer offset obj) - (incf offset)))) + (loop with vec = (make-array 10000 :element-type 'character) + for count = (read-sequence vec stream) + while (plusp count) + do (if (= count (length vec)) + (insert-buffer-sequence buffer offset vec) + (insert-buffer-sequence buffer offset + (subseq vec 0 count))) + (incf offset count))) (defun output-to-stream (stream buffer offset1 offset2) (loop for offset from offset1 below offset2

1 0

[climacs-cvs] CVS update: climacs/syntax.lisp
by rstrandh＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29501 Modified Files: syntax.lisp Log Message: Improved cursor redisplay. Thanks to Alastair Bridgewater Date: Mon Dec 27 18:43:09 2004 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.9 climacs/syntax.lisp:1.10 --- climacs/syntax.lisp:1.9 Mon Dec 27 17:47:45 2004 +++ climacs/syntax.lisp Mon Dec 27 18:43:08 2004 @@ -163,10 +163,13 @@ (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x x cursor-y y))) - (draw-line* pane - cursor-x (- cursor-y (* 0.2 height)) - cursor-x (+ cursor-y (* 0.8 height)) - :ink +red+)))))) + (maybe-updating-output (pane :all-new t :fixed-position t) + (draw-line* pane + ;; cursors with odd x-positions were invisible + ;; so we strip off the low bit to make them even. + (logand -2 cursor-x) (- cursor-y (* 0.2 height)) + (logand -2 cursor-x) (+ cursor-y (* 0.8 height)) + :ink +red+))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv26651 Modified Files: gui.lisp syntax.lisp Log Message: Patch to get incremental redisplay to work. There is still a small problem with the cursor disappearing. Thanks to Alastair Bridgewater. Date: Mon Dec 27 17:47:46 2004 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.20 climacs/gui.lisp:1.21 --- climacs/gui.lisp:1.20 Mon Dec 27 12:32:46 2004 +++ climacs/gui.lisp Mon Dec 27 17:47:45 2004 @@ -48,7 +48,7 @@ (win (make-pane 'climacs-pane :width 900 :height 400 :name 'win -;;; :incremental-redisplay t + :incremental-redisplay t :display-function 'display-win)) (int :interactor :width 900 :height 50 :max-height 50)) (:layouts Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.8 climacs/syntax.lisp:1.9 --- climacs/syntax.lisp:1.8 Mon Dec 27 12:32:46 2004 +++ climacs/syntax.lisp Mon Dec 27 17:47:45 2004 @@ -66,11 +66,11 @@ 'string) :stream pane))) -(defmacro maybe-updating-output (stuff &body body) - `(progn ,@body)) +;;(defmacro maybe-updating-output (stuff &body body) +;; `(progn ,@body)) -;; (defmacro maybe-updating-output (stuff &body body) -;; `(updating-output ,stuff ,@body)) + (defmacro maybe-updating-output (stuff &body body) + `(updating-output ,stuff ,@body)) (defmethod display-line (pane (syntax basic-syntax)) (with-slots (saved-offset bot scan cursor-x cursor-y space-width tab-width) syntax @@ -81,12 +81,18 @@ (macrolet ((output-word (&body body) `(let ((contents (compute-contents))) (if (null contents) - (progn ,@body) + ,(if body + `(maybe-updating-output (pane :unique-id (incf id)) + ,@body) + `(progn)) + (progn (maybe-updating-output (pane :unique-id (incf id) :cache-value contents :cache-test #'string=) - (present-contents contents pane syntax) - ,@body))))) + (present-contents contents pane syntax)) + ,(when body + `(maybe-updating-output (pane :unique-id (incf id)) + ,@body))))))) (loop with id = 0 when (mark= scan (point pane)) do (multiple-value-bind (x y) (stream-cursor-position pane)

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11024 Modified Files: base.lisp gui.lisp syntax.lisp Log Message: performance improvements. Date: Mon Dec 27 12:32:46 2004 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.5 climacs/base.lisp:1.6 --- climacs/base.lisp:1.5 Sun Dec 26 08:18:01 2004 +++ climacs/base.lisp Mon Dec 27 12:32:46 2004 @@ -66,14 +66,12 @@ (end-of-line mark) (delete-region offset mark)))) -(defun buffer-number-of-lines-in-region (mark1 mark2) - "Helper function for number-of-lines-in-region. Moves the position -of mark1 until it is greater than or equal to that of mark2 and counts -Newline characters along the way" - (loop do (end-of-line mark1) - while (mark< mark1 mark2) - count t - do (incf (offset mark1)))) +(defun buffer-number-of-lines-in-region (buffer offset1 offset2) + "Helper function for number-of-lines-in-region. Count newline +characters in the region between offset1 and offset2" + (loop while (< offset1 offset2) + count (eql (buffer-object buffer offset1) #\Newline) + do (incf offset1))) (defgeneric number-of-lines-in-region (mark1 mark2) (:documentation "Return the number of lines (or rather the number of @@ -81,21 +79,13 @@ acceptable to pass an offset in place of one of the marks")) (defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) - (buffer-number-of-lines-in-region (clone-mark mark1) mark2)) + (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2))) (defmethod number-of-lines-in-region ((offset integer) (mark mark)) - (buffer-number-of-lines-in-region - (make-instance 'standard-left-sticky-mark - :buffer (buffer mark) - :offset offset) - mark)) + (buffer-number-of-lines-in-region (buffer mark) offset (offset mark))) (defmethod number-of-lines-in-region ((mark mark) (offset integer)) - (buffer-number-of-lines-in-region - (clone-mark mark) - (make-instance 'standard-left-sticky-mark - :buffer (buffer mark) - :offset offset))) + (buffer-number-of-lines-in-region (buffer mark) (offset mark) offset)) (defun constituentp (obj) "A predicate to ensure that an object is a constituent character." Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.19 climacs/gui.lisp:1.20 --- climacs/gui.lisp:1.19 Mon Dec 27 06:58:29 2004 +++ climacs/gui.lisp Mon Dec 27 12:32:46 2004 @@ -48,6 +48,7 @@ (win (make-pane 'climacs-pane :width 900 :height 400 :name 'win +;;; :incremental-redisplay t :display-function 'display-win)) (int :interactor :width 900 :height 50 :max-height 50)) (:layouts @@ -114,7 +115,7 @@ (format *error-output* "~a~%" condition))) (setf gestures '())) (t nil)))) - (redisplay-frame-panes frame :force-p t)))) + (redisplay-frame-panes frame)))) (define-command com-quit () (frame-exit *application-frame*)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.7 climacs/syntax.lisp:1.8 --- climacs/syntax.lisp:1.7 Mon Dec 27 05:32:44 2004 +++ climacs/syntax.lisp Mon Dec 27 12:32:46 2004 @@ -49,8 +49,7 @@ (let ((buffer (buffer pane))) (with-slots (top bot scan space-width tab-width) syntax (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer) - scan (make-instance 'standard-left-sticky-mark :buffer buffer)) + bot (make-instance 'standard-right-sticky-mark :buffer buffer)) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium))) (setf space-width (text-style-width style medium) @@ -67,27 +66,39 @@ 'string) :stream pane))) +(defmacro maybe-updating-output (stuff &body body) + `(progn ,@body)) + +;; (defmacro maybe-updating-output (stuff &body body) +;; `(updating-output ,stuff ,@body)) + (defmethod display-line (pane (syntax basic-syntax)) (with-slots (saved-offset bot scan cursor-x cursor-y space-width tab-width) syntax (flet ((compute-contents () (unless (null saved-offset) - (prog1 (coerce (region-to-sequence saved-offset scan) 'string) + (prog1 (coerce (buffer-sequence (buffer pane) saved-offset scan) 'string) (setf saved-offset nil))))) (macrolet ((output-word (&body body) `(let ((contents (compute-contents))) - (present-contents contents pane syntax) - ,@body))) - (loop when (mark= scan (point pane)) + (if (null contents) + (progn ,@body) + (maybe-updating-output (pane :unique-id (incf id) + :cache-value contents + :cache-test #'string=) + (present-contents contents pane syntax) + ,@body))))) + (loop with id = 0 + when (mark= scan (point pane)) do (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x (+ x (if (null saved-offset) 0 - (* space-width (- (offset scan) saved-offset)))) + (* space-width (- scan saved-offset)))) cursor-y y)) when (mark= scan bot) do (output-word) (return) - until (eql (object-after scan) #\Newline) - do (let ((obj (object-after scan))) + until (eql (buffer-object (buffer pane) scan) #\Newline) + do (let ((obj (buffer-object (buffer pane) scan))) (cond ((eql obj #\Space) (output-word (princ obj pane))) ((eql obj #\Tab) @@ -97,13 +108,12 @@ pane (- tab-width (mod x tab-width)) 0))) ((constituentp obj) (when (null saved-offset) - (setf saved-offset (offset scan)))) + (setf saved-offset scan))) (t (output-word (princ obj pane))))) - (incf (offset scan)) - finally (output-word) - (incf (offset scan)) - (terpri pane)))))) + (incf scan) + finally (output-word (terpri pane)) + (incf scan)))))) (defmethod redisplay-with-syntax (pane (syntax basic-syntax)) (let* ((medium (sheet-medium pane)) @@ -138,9 +148,11 @@ until (end-of-buffer-p bot) do (incf (offset bot)) (end-of-line bot))) - (setf (offset scan) (offset top)) - (loop until (mark= scan bot) - do (display-line pane syntax)) + (setf scan (offset top)) + (loop for id from 0 + until (mark= scan bot) + do (maybe-updating-output (pane :unique-id id) + (display-line pane syntax))) (when (mark= scan (point pane)) (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x x

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv26075 Modified Files: gui.lisp Log Message: Key bindings for several function keys. Thanks to Alastair Bridgewater. Date: Mon Dec 27 06:58:32 2004 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.18 climacs/gui.lisp:1.19 --- climacs/gui.lisp:1.18 Mon Dec 27 05:32:43 2004 +++ climacs/gui.lisp Mon Dec 27 06:58:29 2004 @@ -93,7 +93,15 @@ do (setf *current-gesture* (read-gesture :stream *standard-input*)) (when (or (characterp *current-gesture*) (and (typep *current-gesture* 'keyboard-event) - (keyboard-event-character *current-gesture*))) + (or (keyboard-event-character *current-gesture*) + (not (member (keyboard-event-key-name + *current-gesture*) + '(:control-left :control-right + :shift-left :shift-right + :meta-left :meta-right + :super-left :super-right + :hyper-left :hyper-right + :shift-lock :caps-lock)))))) (setf gestures (nconc gestures (list *current-gesture*))) (let ((item (find-gestures gestures 'global-climacs-table))) (cond ((not item) @@ -131,6 +139,9 @@ (define-command com-delete-object () (delete-range (point (win *application-frame*)))) +(define-command com-backward-delete-object () + (delete-range (point (win *application-frame*)) -1)) + (define-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -302,6 +313,19 @@ (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\u :meta) 'com-browse-url) + +(global-set-key '(:up) 'com-previous-line) +(global-set-key '(:down) 'com-next-line) +(global-set-key '(:left) 'com-backward-object) +(global-set-key '(:right) 'com-forward-object) +(global-set-key '(:left :control) 'com-backward-word) +(global-set-key '(:right :control) 'com-forward-word) +(global-set-key '(:home) 'com-beginning-of-line) +(global-set-key '(:end) 'com-end-of-line) +(global-set-key '(:home :control) 'com-beginning-of-buffer) +(global-set-key '(:end :control) 'com-end-of-buffer) +(global-set-key #\Rubout 'com-delete-object) +(global-set-key #\Backspace 'com-backward-delete-object) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0