January 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 12 Jan '05

12 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1612 Modified Files: gui.lisp syntax.lisp Log Message: * added numeric arguments. This feature requires a CVS version of McCLIM as of 2005-01-11. Only a few commands take numeric arguments at the moment such as forward-object, backward-object, delete-object, and backward-delete-object. There are more to come. * the cursor display problem has been "fixed" by drawing a rectangle rather than a line. This makes obsolete the hacky code for explicit rounding of cursor coordinates. Date: Wed Jan 12 17:41:17 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.61 climacs/gui.lisp:1.62 --- climacs/gui.lisp:1.61 Mon Jan 10 06:31:16 2005 +++ climacs/gui.lisp Wed Jan 12 17:41:16 2005 @@ -71,15 +71,17 @@ :name 'win :incremental-redisplay t :display-function 'display-win)) - (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 (make-pane 'minibuffer-pane - :width 900 :height 20 :max-height 20 :min-height 20 - :scroll-bars nil))) + + (info :application + :width 900 :height 20 :max-height 20 + :name 'info :background +light-gray+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info) + (int (make-pane 'minibuffer-pane + :width 900 :height 20 :max-height 20 :min-height 20 + :scroll-bars nil))) (:layouts (default (vertically (:scroll-bars nil) @@ -162,10 +164,10 @@ (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture))) - (cond ((event-matches-gesture-name-p gesture '(#\u :control)) + (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME (let ((numarg 4)) (loop for gesture = (climacs-read-gesture) - while (event-matches-gesture-name-p gesture '(#\u :control)) + while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) finally (unread-gesture gesture :stream stream)) (let ((gesture (climacs-read-gesture))) @@ -175,11 +177,12 @@ (loop for gesture = (climacs-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) - do (setf gesture (+ (* 10 numarg) - (- (char-code gesture) (char-code #\0)))) + do (setf numarg (+ (* 10 numarg) + (- (char-code gesture) (char-code #\0)))) finally (unread-gesture gesture :stream stream) (return (values numarg t)))) (t + (unread-gesture gesture :stream stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) @@ -202,29 +205,29 @@ (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) (loop (catch 'outer-loop - (loop with gestures = '() - with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) - do (setf *current-gesture* (climacs-read-gesture)) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (setf gestures '())) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '()) - (setf (previous-command *standard-output*) - (if (consp command) - (car command) - command)))) - (t nil))) + (loop for gestures = '() + for numarg = (read-numeric-argument :stream *standard-input*) + do (loop (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (return)) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)) + (return))) + (t nil)))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) @@ -236,7 +239,9 @@ (redisplay-frame-panes frame)))) (defmacro define-named-command (command-name args &body body) - `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body)) + `(define-climacs-command ,(if (listp command-name) + `(,@command-name :name t) + `(,command-name :name t)) ,args ,@body)) (define-named-command (com-quit) () (frame-exit *application-frame*)) @@ -260,11 +265,11 @@ (define-named-command com-end-of-line () (end-of-line (point (win *application-frame*)))) -(define-named-command com-delete-object () - (delete-range (point (win *application-frame*)))) +(define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")) + (delete-range (point (win *application-frame*)) count)) -(define-named-command com-backward-delete-object () - (delete-range (point (win *application-frame*)) -1)) +(define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")) + (delete-range (point (win *application-frame*)) (- count))) (define-named-command com-transpose-objects () (let* ((point (point (win *application-frame*)))) @@ -277,11 +282,11 @@ (insert-object point object) (forward-object point))))) -(define-named-command com-backward-object () - (backward-object (point (win *application-frame*)))) +(define-named-command com-backward-object ((count 'integer :prompt "Number of Objects")) + (backward-object (point (win *application-frame*)) count)) -(define-named-command com-forward-object () - (forward-object (point (win *application-frame*)))) +(define-named-command com-forward-object ((count 'integer :prompt "Number of Objects")) + (forward-object (point (win *application-frame*)) count)) (define-named-command com-transpose-words () (let* ((point (point (win *application-frame*)))) @@ -676,11 +681,11 @@ (global-set-key #\newline 'com-self-insert) (global-set-key #\tab 'com-self-insert) -(global-set-key '(#\f :control) 'com-forward-object) -(global-set-key '(#\b :control) 'com-backward-object) +(global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) +(global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) (global-set-key '(#\a :control) 'com-beginning-of-line) (global-set-key '(#\e :control) 'com-end-of-line) -(global-set-key '(#\d :control) 'com-delete-object) +(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*)) (global-set-key '(#\p :control) 'com-previous-line) (global-set-key '(#\n :control) 'com-next-line) (global-set-key '(#\o :control) 'com-open-line) @@ -709,8 +714,8 @@ (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) `(com-backward-object ,*numeric-argument-marker*)) +(global-set-key '(:right) `(com-forward-object *numeric-argument-marker*)) (global-set-key '(:left :control) 'com-backward-word) (global-set-key '(:right :control) 'com-forward-word) (global-set-key '(:home) 'com-beginning-of-line) @@ -719,8 +724,8 @@ (global-set-key '(:next) 'com-page-down) (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) +(global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*)) +(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*)) (global-set-key '(:insert) 'com-toggle-overwrite-mode) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.21 climacs/syntax.lisp:1.22 --- climacs/syntax.lisp:1.21 Mon Jan 10 06:31:17 2005 +++ climacs/syntax.lisp Wed Jan 12 17:41:17 2005 @@ -279,12 +279,6 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -;;; this one should not be necessary. -(defun round-up (x) - (cond ((zerop x) 2) - ((evenp x) x) - (t (1+ x)))) - (defmethod redisplay-with-syntax (pane (syntax basic-syntax)) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) @@ -310,13 +304,10 @@ (setf cursor-x x cursor-y y))) (updating-output (pane :unique-id -1) - (draw-line* pane - ;; cursors with odd or zero x-positions were invisible - ;; so we round them up to even. - ;; We don't know why, though. - (round-up cursor-x) (- cursor-y (* 0.2 height)) - (round-up cursor-x) (+ cursor-y (* 0.8 height)) - :ink +red+))))) + (draw-rectangle* pane + cursor-x (- cursor-y (* 0.2 height)) + (1+ 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 10 Jan '05

10 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17277 Modified Files: gui.lisp syntax.lisp Log Message: Removed the line number from the status line until we have the better buffer implementation. Right now, this function requires scanning the entire buffer and counting newlines. Fixed adjust-cache so that it doesn't do anything when there has been no modification of the buffer since previous redisplay. Date: Mon Jan 10 06:31:20 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.60 climacs/gui.lisp:1.61 --- climacs/gui.lisp:1.60 Sun Jan 9 15:08:27 2005 +++ climacs/gui.lisp Mon Jan 10 06:31:16 2005 @@ -115,7 +115,7 @@ (name (syntax win)) (if *overwrite-mode* "Ovwrt" - (format nil "L~d" (line-number (point win))))))) + "")))) (princ name-info pane))) (defun display-win (frame pane) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.20 climacs/syntax.lisp:1.21 --- climacs/syntax.lisp:1.20 Sun Jan 9 12:54:50 2005 +++ climacs/syntax.lisp Mon Jan 10 06:31:17 2005 @@ -233,23 +233,24 @@ (and (mark< low-mark top) (>= (number-of-lines-in-region top high-mark) (nb-elements cache)))) (reposition-window pane syntax) - (let* ((n1 (number-of-lines-in-region top low-mark)) - (n2 (1+ (number-of-lines-in-region low-mark high-mark))) - (n3 (number-of-lines-in-region high-mark bot)) - (diff (- (+ n1 n2 n3) (nb-elements cache)))) - (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop for i from n1 below (nb-elements cache) - do (setf (element* cache i) nil))) - ((>= diff 0) - (loop repeat diff do (insert* cache n1 nil)) - (loop for i from (+ n1 diff) below (+ n1 n2) - do (setf (element* cache i) nil))) - (t - (loop repeat (- diff) do (delete* cache n1)) - (loop for i from n1 below (+ n1 n2) - do (setf (element* cache i) nil)))))))) + (when (mark>= high-mark low-mark) + (let* ((n1 (number-of-lines-in-region top low-mark)) + (n2 (1+ (number-of-lines-in-region low-mark high-mark))) + (n3 (number-of-lines-in-region high-mark bot)) + (diff (- (+ n1 n2 n3) (nb-elements cache)))) + (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) + (setf (offset bot) (offset top)) + (end-of-line bot) + (loop for i from n1 below (nb-elements cache) + do (setf (element* cache i) nil))) + ((>= diff 0) + (loop repeat diff do (insert* cache n1 nil)) + (loop for i from (+ n1 diff) below (+ n1 n2) + do (setf (element* cache i) nil))) + (t + (loop repeat (- diff) do (delete* cache n1)) + (loop for i from n1 below (+ n1 n2) + do (setf (element* cache i) nil))))))))) (adjust-cache-size-and-bot pane syntax)) (defun page-down (pane syntax)

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 09 Jan '05

09 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3491 Modified Files: base.lisp gui.lisp packages.lisp Log Message: upcase, downcase, capitalize words from Rudi Schlatte. Thanks! Date: Sun Jan 9 15:08:27 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.13 climacs/base.lisp:1.14 --- climacs/base.lisp:1.13 Sun Jan 9 12:54:50 2005 +++ climacs/base.lisp Sun Jan 9 15:08:26 2005 @@ -111,20 +111,28 @@ #+sbcl (sb-impl::whitespacep obj) #-sbcl (member obj '(#\Space #\Tab)))) -(defun forward-word (mark) - "Forward the mark to the next word." +(defun forward-to-word-boundary (mark) + "Forward the mark forward to the beginning of the next word." (loop until (end-of-buffer-p mark) until (constituentp (object-after mark)) - do (incf (offset mark))) + do (incf (offset mark)))) + +(defun backward-to-word-boundary (mark) + "Move the mark backward to the end of the previous word." + (loop until (beginning-of-buffer-p mark) + until (constituentp (object-before mark)) + do (decf (offset mark)))) + +(defun forward-word (mark) + "Forward the mark to the next word." + (forward-to-word-boundary mark) (loop until (end-of-buffer-p mark) while (constituentp (object-after mark)) do (incf (offset mark)))) (defun backward-word (mark) "Shuttle the mark to the start of the previous word." - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (decf (offset mark))) + (backward-to-word-boundary mark) (loop until (beginning-of-buffer-p mark) while (constituentp (object-before mark)) do (decf (offset mark)))) @@ -155,6 +163,45 @@ (constituentp (buffer-object (buffer mark) (1- i)))) finally (return i)) mark)) + +(defun downcase-word (mark &optional (n 1)) + "Convert the next N words to lowercase, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + for character = (object-after mark) + if (upper-case-p character) + do (progn (delete-range mark 1) + (insert-object mark (char-downcase character))) + else + do (incf (offset mark))))) + +(defun upcase-word (mark &optional (n 1)) + "Convert the next N words to uppercase, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + for character = (object-after mark) + when (lower-case-p character) + do (progn + (delete-range mark 1) + (insert-object mark (char-upcase character))) + else + do (incf (offset mark))))) + +(defun capitalize-word (mark &optional (n 1)) + "Capitalize the next N words, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (unless (end-of-buffer-p mark) + (let ((character (object-after mark))) + (when (lower-case-p character) + (delete-range mark 1) + (insert-object mark (char-upcase character)))) + (when (constituentp (object-after mark)) + (downcase-word mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.59 climacs/gui.lisp:1.60 --- climacs/gui.lisp:1.59 Sun Jan 9 12:54:50 2005 +++ climacs/gui.lisp Sun Jan 9 15:08:27 2005 @@ -378,6 +378,15 @@ (define-named-command com-backward-delete-word () (backward-delete-word (point (win *application-frame*)))) +(define-named-command com-upcase-word () + (upcase-word (point (win *application-frame*)))) + +(define-named-command com-downcase-word () + (downcase-word (point (win *application-frame*)))) + +(define-named-command com-capitalize-word () + (capitalize-word (point (win *application-frame*)))) + (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) @@ -683,6 +692,9 @@ (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 '(#\u :meta) 'com-upcase-word) +(global-set-key '(#\l :meta) 'com-downcase-word) +(global-set-key '(#\c :meta) 'com-capitalize-word) (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\w :meta) 'com-copy-out) @@ -690,7 +702,6 @@ (global-set-key '(#\v :meta) 'com-page-up) (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 '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.25 climacs/packages.lisp:1.26 --- climacs/packages.lisp:1.25 Sun Jan 9 12:54:50 2005 +++ climacs/packages.lisp Sun Jan 9 15:08:27 2005 @@ -49,6 +49,7 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word + #:upcase-word #:downcase-word #:capitalize-word #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 09 Jan '05

09 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29333 Modified Files: base.lisp buffer.lisp gui.lisp packages.lisp syntax.lisp Log Message: Moved forward-object and backward-object to base.lisp because I needed them in syntax.lisp. Improved performance of end-of-line, the slowness of which was a problem for redisplay. Fixed (I hope) bug in redisplay code. I don't seem to be able to convince McCLIM to avoid redrawing all the lines after a new line has been inserted, though. Date: Sun Jan 9 12:54:50 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.12 climacs/base.lisp:1.13 --- climacs/base.lisp:1.12 Fri Jan 7 08:26:23 2005 +++ climacs/base.lisp Sun Jan 9 12:54:50 2005 @@ -28,6 +28,16 @@ (in-package :climacs-base) +(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)) + (defun previous-line (mark &optional column) "Move a mark up one line conserving horizontal position." (unless column Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.16 climacs/buffer.lisp:1.17 --- climacs/buffer.lisp:1.16 Wed Jan 5 22:39:23 2005 +++ climacs/buffer.lisp Sun Jan 9 12:54:50 2005 @@ -288,8 +288,14 @@ at the end of the buffer if no following newline character exists.")) (defmethod end-of-line ((mark mark-mixin)) - (loop until (end-of-line-p mark) - do (incf (offset mark)))) + (let* ((offset (offset mark)) + (buffer (buffer mark)) + (chain (slot-value buffer 'contents)) + (size (nb-elements chain))) + (loop until (or (= offset size) + (eql (element* chain offset) #\Newline)) + do (incf offset)) + (setf (offset mark) offset))) (defgeneric line-number (mark) (:documentation "Return the line number of the mark. Lines are numbered from zero.")) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.58 climacs/gui.lisp:1.59 --- climacs/gui.lisp:1.58 Sun Jan 9 03:42:14 2005 +++ climacs/gui.lisp Sun Jan 9 12:54:50 2005 @@ -277,16 +277,6 @@ (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*)))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.24 climacs/packages.lisp:1.25 --- climacs/packages.lisp:1.24 Sun Jan 9 03:46:35 2005 +++ climacs/packages.lisp Sun Jan 9 12:54:50 2005 @@ -42,7 +42,8 @@ (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) - (:export #:previous-line #:next-line + (:export #:forward-object #:backward-object + #:previous-line #:next-line #:open-line #:kill-line #:number-of-lines-in-region #:constituentp #:whitespacep Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.19 climacs/syntax.lisp:1.20 --- climacs/syntax.lisp:1.19 Mon Jan 3 16:07:09 2005 +++ climacs/syntax.lisp Sun Jan 9 12:54:50 2005 @@ -64,6 +64,11 @@ ;;; ;;; Basic syntax +(defun make-cache () + (let ((cache (make-instance 'standard-flexichain))) + (insert* cache 0 nil) + cache)) + (define-syntax basic-syntax ("Basic" (syntax)) ((top :reader top) (bot :reader bot) @@ -72,7 +77,7 @@ (cursor-y :initform 2) (space-width :initform nil) (tab-width :initform nil) - (cache :initform nil))) + (cache :initform (make-cache)))) (defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane) (declare (ignore args)) @@ -151,92 +156,113 @@ (terpri pane) (incf scan)))))) -(defgeneric compute-cache (pane syntax)) +(defgeneric fill-cache (pane syntax) + (:documentation "fill nil cache entries from the buffer")) -(defmethod compute-cache (pane (syntax basic-syntax)) +(defmethod fill-cache (pane (syntax basic-syntax)) (with-slots (top bot cache) syntax - (let* ((buffer (buffer pane)) - (high-mark (high-mark buffer)) - (low-mark (low-mark buffer))) - (when (or (mark< low-mark top) (mark> high-mark bot)) - (setf cache nil)) - (if (null cache) - (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))) - (mark1 (clone-mark top)) - (mark2 (clone-mark top))) - (setf cache (make-instance 'standard-flexichain)) - (loop for line from 0 below nb-lines-on-display - do (beginning-of-line mark1) - (end-of-line mark2) - (insert* cache line (region-to-sequence mark1 mark2)) - unless (end-of-buffer-p mark2) - do (setf (offset mark1) (1+ (offset mark2)) - (offset mark2) (offset mark1)))) - (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))) - (mark1 (clone-mark low-mark)) - (mark2 (clone-mark low-mark)) - (size1 (number-of-lines-in-region top low-mark)) - (size2 (number-of-lines-in-region high-mark bot))) - (loop repeat (- (nb-elements cache) size1 size2) - do (delete* cache size1)) - (loop for line from size1 - repeat (- nb-lines-on-display (nb-elements cache)) - do (beginning-of-line mark1) - (end-of-line mark2) - (insert* cache line (region-to-sequence mark1 mark2)) - unless (end-of-buffer-p mark2) - do (setf (offset mark1) (1+ (offset mark2)) - (offset mark2) (offset mark1)))))))) + (let ((mark1 (clone-mark top)) + (mark2 (clone-mark top))) + (loop for line from 0 below (nb-elements cache) + do (beginning-of-line mark1) + (end-of-line mark2) + when (null (element* cache line)) + do (setf (element* cache line) (region-to-sequence mark1 mark2)) + unless (end-of-buffer-p mark2) + do (setf (offset mark1) (1+ (offset mark2)) + (offset mark2) (offset mark1)))))) -(defun position-window (pane syntax) +(defun nb-lines-in-pane (pane) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) + (multiple-value-bind (x y w h) (bounding-rectangle* pane) + (declare (ignore x y w)) + (max 1 (floor h (+ height (stream-vertical-spacing pane))))))) + +;;; make the region on display fit the size of the pane as closely as +;;; possible by adjusting bot leaving top intact. Also make the cache +;;; size fit the size of the region on display. +(defun adjust-cache-size-and-bot (pane syntax) + (let ((nb-lines-in-pane (nb-lines-in-pane pane))) + (with-slots (top bot cache) syntax + (setf (offset bot) (offset top)) + (loop until (end-of-buffer-p bot) + repeat (1- nb-lines-in-pane) + do (forward-object bot) + (end-of-line bot)) + (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) + (loop repeat (- (nb-elements cache) nb-lines-on-display) + do (pop-end cache)) + (loop repeat (- nb-lines-on-display (nb-elements cache)) + do (push-end cache nil)))))) + +;;; put all-nil entries in the cache +(defun empty-cache (cache) + (loop for i from 0 below (nb-elements cache) + do (setf (element* cache i) nil))) + +;;; empty the cache and try to put point close to the middle +;;; of the pane by moving top half a pane-size up. +(defun reposition-window (pane syntax) + (let ((nb-lines-in-pane (nb-lines-in-pane pane))) + (with-slots (top bot cache) syntax + (empty-cache cache) + (setf (offset top) (offset (point pane))) + (loop do (beginning-of-line top) + repeat (floor nb-lines-in-pane 2) + until (beginning-of-buffer-p top) + do (decf (offset top)) + (beginning-of-line top))))) + +;;; Make the cache reflect the contents of the buffer starting at top, +;;; trying to preserve contents as much as possible, and inserting a +;;; nil entry where buffer contents is unknonwn. The size of the +;;; cache size at the end may be smaller than, equal to, or greater +;;; than the number of lines in the pane. +(defun adjust-cache (pane syntax) + (let* ((buffer (buffer pane)) + (high-mark (high-mark buffer)) + (low-mark (low-mark buffer)) + (nb-lines-in-pane (nb-lines-in-pane pane))) (with-slots (top bot cache) syntax (beginning-of-line top) (end-of-line bot) - (multiple-value-bind (x y w h) (bounding-rectangle* pane) - (declare (ignore x y w)) - (let ((nb-lines-in-pane (max 1 (floor h (+ height (stream-vertical-spacing pane))))) - (nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) - ;; adjust the region on display to fit the pane - (loop repeat (- nb-lines-on-display nb-lines-in-pane) - do (beginning-of-line bot) - (decf (offset bot)) - (unless (null cache) - (pop-end cache))) - (loop until (end-of-buffer-p bot) - repeat (- nb-lines-in-pane nb-lines-on-display) - do (incf (offset bot)) + (if (or (mark< (point pane) top) + (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane) + (and (mark< low-mark top) + (>= (number-of-lines-in-region top high-mark) (nb-elements cache)))) + (reposition-window pane syntax) + (let* ((n1 (number-of-lines-in-region top low-mark)) + (n2 (1+ (number-of-lines-in-region low-mark high-mark))) + (n3 (number-of-lines-in-region high-mark bot)) + (diff (- (+ n1 n2 n3) (nb-elements cache)))) + (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) + (setf (offset bot) (offset top)) (end-of-line bot) - (setf cache nil)) - ;; move region on display if point is outside the current region - (when (or (mark< (point pane) top) (mark> (point pane) bot)) - (setf cache nil) - (setf (offset top) (offset (point pane))) - (loop do (beginning-of-line top) - repeat (floor nb-lines-in-pane 2) - until (beginning-of-buffer-p top) - do (decf (offset top)) - (beginning-of-line top)) - (setf (offset bot) (offset top)) - (loop do (end-of-line bot) - repeat (1- nb-lines-in-pane) - until (end-of-buffer-p bot) - do (incf (offset bot)) - (end-of-line bot)))))))) + (loop for i from n1 below (nb-elements cache) + do (setf (element* cache i) nil))) + ((>= diff 0) + (loop repeat diff do (insert* cache n1 nil)) + (loop for i from (+ n1 diff) below (+ n1 n2) + do (setf (element* cache i) nil))) + (t + (loop repeat (- diff) do (delete* cache n1)) + (loop for i from n1 below (+ n1 n2) + do (setf (element* cache i) nil)))))))) + (adjust-cache-size-and-bot pane syntax)) (defun page-down (pane syntax) - (position-window pane syntax) + (adjust-cache pane syntax) (with-slots (top bot cache) syntax (when (mark> (size (buffer bot)) bot) + (empty-cache cache) (setf (offset top) (offset bot)) (beginning-of-line top) - (setf (offset (point pane)) (offset top)) - (setf cache nil)))) + (setf (offset (point pane)) (offset top))))) (defun page-up (pane syntax) - (position-window pane syntax) + (adjust-cache pane syntax) (with-slots (top bot cache) syntax (when (> (offset top) 0) (let ((nb-lines-in-region (number-of-lines-in-region top bot))) @@ -247,10 +273,10 @@ do (decf (offset top)) (beginning-of-line top)) (setf (offset (point pane)) (offset top)) - (position-window pane syntax) + (adjust-cache pane syntax) (setf (offset (point pane)) (offset bot)) (beginning-of-line (point pane)) - (setf cache nil))))) + (empty-cache cache))))) ;;; this one should not be necessary. (defun round-up (x) @@ -263,8 +289,8 @@ (style (medium-text-style medium)) (height (text-style-height style medium))) (with-slots (top bot scan cache cursor-x cursor-y) syntax - (position-window pane syntax) - (compute-cache pane syntax) + (adjust-cache pane syntax) + (fill-cache pane syntax) (loop with start-offset = (offset top) for id from 0 below (nb-elements cache) do (setf scan start-offset)

1 0

[climacs-cvs] CVS update: climacs/packages.lisp
by abakic＠common-lisp.net 09 Jan '05

09 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1638 Modified Files: packages.lisp Log Message: Rollback (repeat: no protocol changes). Date: Sun Jan 9 03:46:43 2005 Author: abakic Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.23 climacs/packages.lisp:1.24 --- climacs/packages.lisp:1.23 Sun Jan 9 03:42:14 2005 +++ climacs/packages.lisp Sun Jan 9 03:46:35 2005 @@ -33,7 +33,7 @@ #:beginning-of-line-p #:end-of-line-p #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence - #:update-object #:insert-object #:insert-sequence + #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp
by abakic＠common-lisp.net 09 Jan '05

09 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1272 Modified Files: gui.lisp packages.lisp Log Message: Overwrite mode: first iteration (no protocol changes). Date: Sun Jan 9 03:42:15 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.57 climacs/gui.lisp:1.58 --- climacs/gui.lisp:1.57 Sat Jan 8 18:16:19 2005 +++ climacs/gui.lisp Sun Jan 9 03:42:14 2005 @@ -104,13 +104,18 @@ (defun display-message (format-string &rest format-args) (apply #'format *standard-input* format-string format-args)) +(defvar *overwrite-mode* nil) + (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) - (name-info (format nil " ~a ~a Syntax: ~a" + (name-info (format nil " ~a ~a Syntax: ~a ~a" (if (needs-saving buf) "**" "--") (name buf) - (name (syntax win))))) + (name (syntax win)) + (if *overwrite-mode* + "Ovwrt" + (format nil "L~d" (line-number (point win))))))) (princ name-info pane))) (defun display-win (frame pane) @@ -236,10 +241,18 @@ (define-named-command (com-quit) () (frame-exit *application-frame*)) +(define-named-command com-toggle-overwrite-mode () + (setf *overwrite-mode* (not *overwrite-mode*))) + (define-command com-self-insert () - (unless (constituentp *current-gesture*) - (possibly-expand-abbrev (point (win *application-frame*)))) - (insert-object (point (win *application-frame*)) *current-gesture*)) + (let ((point (point (win *application-frame*)))) + (unless (constituentp *current-gesture*) + (possibly-expand-abbrev point)) + (if (and *overwrite-mode* (not (end-of-line-p point))) + (progn + (delete-range point) + (insert-object point *current-gesture*)) + (insert-object point *current-gesture*)))) (define-named-command com-beginning-of-line () (beginning-of-line (point (win *application-frame*)))) @@ -707,6 +720,8 @@ (global-set-key '(:end :control) 'com-end-of-buffer) (global-set-key #\Rubout 'com-delete-object) (global-set-key #\Backspace 'com-backward-delete-object) + +(global-set-key '(:insert) 'com-toggle-overwrite-mode) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.22 climacs/packages.lisp:1.23 --- climacs/packages.lisp:1.22 Fri Jan 7 14:07:45 2005 +++ climacs/packages.lisp Sun Jan 9 03:42:14 2005 @@ -33,7 +33,7 @@ #:beginning-of-line-p #:end-of-line-p #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence - #:insert-object #:insert-sequence + #:update-object #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence

1 0

[climacs-cvs] CVS update: climacs/INSTALL
by ejohnson＠common-lisp.net 08 Jan '05

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7947 Modified Files: INSTALL Log Message: testing cvs commit Date: Sat Jan 8 19:07:40 2005 Author: ejohnson Index: climacs/INSTALL diff -u climacs/INSTALL:1.2 climacs/INSTALL:1.3 --- climacs/INSTALL:1.2 Wed Dec 22 15:43:18 2004 +++ climacs/INSTALL Sat Jan 8 19:07:30 2005 @@ -33,3 +33,5 @@ Start the Climacs editor. + +

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by abridgewater＠common-lisp.net 08 Jan '05

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5135 Modified Files: gui.lisp Log Message: Made PgUp and PgDn (:PRIOR and :NEXT) keys work. Date: Sat Jan 8 18:16:22 2005 Author: abridgewater Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.56 climacs/gui.lisp:1.57 --- climacs/gui.lisp:1.56 Sat Jan 8 08:46:33 2005 +++ climacs/gui.lisp Sat Jan 8 18:16:19 2005 @@ -701,6 +701,8 @@ (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 '(:prior) 'com-page-up) +(global-set-key '(:next) 'com-page-down) (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)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by ejohnson＠common-lisp.net 08 Jan '05

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8946 Modified Files: gui.lisp Log Message: Fixed the beeping from C-k at end-of-buffer, thanks Robert Date: Sat Jan 8 08:46:33 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.55 climacs/gui.lisp:1.56 --- climacs/gui.lisp:1.55 Sat Jan 8 07:30:25 2005 +++ climacs/gui.lisp Sat Jan 8 08:46:33 2005 @@ -350,13 +350,12 @@ (let* ((pane (win *application-frame*)) (point (point pane)) (mark (offset point))) - (if (end-of-line-p point) - (forward-object point) - (progn - (end-of-line point) - (cond ((or (beginning-of-buffer-p point) - (end-of-buffer-p point)) nil) - ((beginning-of-line-p point)(forward-object point))))) + (cond ((end-of-buffer-p point) nil) + ((end-of-line-p point)(forward-object point)) + (t + (end-of-line point) + (cond ((beginning-of-buffer-p point) nil) + ((beginning-of-line-p point)(forward-object point))))) (if (eq (previous-command pane) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mark point))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by ejohnson＠common-lisp.net 08 Jan '05

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4907 Modified Files: gui.lisp Log Message: Minor clean ups on com-cut-out and com-copy-out. Basically leftover bits of code that could be factored out. Date: Sat Jan 8 07:30:28 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.54 climacs/gui.lisp:1.55 --- climacs/gui.lisp:1.54 Fri Jan 7 19:58:08 2005 +++ climacs/gui.lisp Sat Jan 8 07:30:25 2005 @@ -572,24 +572,18 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (with-slots (buffer point mark)(win *application-frame*) - (let ((offset-point (offset point)) - (offset-mark (offset mark))) - (if (< offset-point offset-mark) - (progn - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (delete-buffer-range buffer offset-point (- offset-mark offset-point ))) - (progn - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) - (delete-buffer-range buffer offset-mark (- offset-point offset-mark))))))) - + (with-slots (point mark)(win *application-frame*) + (cond ((< (offset mark)(offset point)) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-region (offset mark) point)) + (t + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-region (offset point) mark))))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () (with-slots (point mark)(win *application-frame*) - (if (< (offset point) (offset mark)) - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))))) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)))) (define-named-command com-rotate-yank ()

1 0