[climacs-cvs] CVS update: climacs/buffer.lisp climacs/gui.lisp climacs/syntax.lisp
Robert Strandh
rstrandh at common-lisp.net
Fri Dec 24 08:21:39 UTC 2004
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv7462
Modified Files:
buffer.lisp gui.lisp syntax.lisp
Log Message:
Implemented a basic syntax according to the syntax protocol
specification (which I haven't written yet). The current
implementation should be improved upon, but it basically shows how to
do it.
Also implemented a demo command that accepts a string and inserts its
reverse in the buffer. This shows that the words in the buffer are
actually presentations (of type string) that become clickable by the
accept.
Added two missing methods on region-to-sequence. There were no
methods when one of the arguments is an offset instead of a mark.
Date: Fri Dec 24 09:21:35 2004
Author: rstrandh
Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.10 climacs/buffer.lisp:1.11
--- climacs/buffer.lisp:1.10 Thu Dec 23 18:24:44 2004
+++ climacs/buffer.lisp Fri Dec 24 09:21:34 2004
@@ -450,6 +450,12 @@
(assert (eq (buffer mark1) (buffer mark2)))
(buffer-sequence (buffer mark1) (offset mark1) (offset mark2)))
+(defmethod region-to-sequence ((offset integer) (mark mark-mixin))
+ (buffer-sequence (buffer mark) offset (offset mark)))
+
+(defmethod region-to-sequence ((mark mark-mixin) (offset integer))
+ (buffer-sequence (buffer mark) (offset mark) offset))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Buffer modification protocol
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.11 climacs/gui.lisp:1.12
--- climacs/gui.lisp:1.11 Thu Dec 23 19:49:32 2004
+++ climacs/gui.lisp Fri Dec 24 09:21:34 2004
@@ -32,14 +32,15 @@
(defclass climacs-pane (application-pane)
((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
(point :initform nil :initarg :point :reader point)
- (syntax :initform (make-instance 'basic-syntax) :initarg :syntax :accessor syntax)))
+ (syntax :initarg :syntax :accessor syntax)))
(defmethod initialize-instance :after ((pane climacs-pane) &rest args)
(declare (ignore args))
- (with-slots (buffer point) pane
+ (with-slots (buffer point syntax) pane
(when (null point)
(setf point (make-instance 'standard-right-sticky-mark
- :buffer buffer)))))
+ :buffer buffer)))
+ (setf syntax (make-instance 'basic-syntax :buffer buffer :pane pane))))
(define-application-frame climacs ()
((win :reader win))
@@ -162,6 +163,9 @@
(define-command com-insert-weird-stuff ()
(insert-object (point (win *application-frame*)) (make-instance 'weird)))
+(define-command com-insert-reversed-string ()
+ (insert-sequence (point (win *application-frame*))
+ (reverse (accept 'string))))
(define-presentation-type completable-pathname ()
:inherit-from 'pathname)
@@ -238,14 +242,14 @@
(define-command com-find-file ()
(let ((filename (accept 'completable-pathname
- :prompt "Find File"))
- (buffer (make-instance 'climacs-buffer)))
- (setf (buffer (win *application-frame*)) buffer
- (filename (buffer (win *application-frame*))) filename)
- (with-open-file (stream filename :direction :input)
- (input-from-stream stream buffer 0))
- (setf (slot-value (win *application-frame*) 'point)
- (make-instance 'standard-right-sticky-mark :buffer buffer))))
+ :prompt "Find File")))
+ (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 'basic-syntax :buffer buffer :pane (win *application-frame*))
+ (filename buffer) filename)
+ (with-open-file (stream filename :direction :input)
+ (input-from-stream stream buffer 0)))))
(define-command com-save-buffer ()
(let ((filename (or (filename (buffer (win *application-frame*)))
@@ -283,6 +287,7 @@
(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.1 climacs/syntax.lisp:1.2
--- climacs/syntax.lisp:1.1 Thu Dec 23 19:49:32 2004
+++ climacs/syntax.lisp Fri Dec 24 09:21:34 2004
@@ -31,63 +31,101 @@
(defgeneric full-redisplay (pane syntax))
(defclass basic-syntax (syntax)
- ())
+ ((top :reader top)
+ (bot :reader bot)
+ (scan :reader scan)
+ (saved-offset :initform nil :accessor saved-offset)
+ (cursor-x :initform nil)
+ (cursor-y :initform nil)
+ (space-width :initform nil)
+ (tab-width :initform nil)))
+
+(defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key buffer pane)
+ (declare (ignore args))
+ (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))
+ (let* ((medium (sheet-medium pane))
+ (style (medium-text-style medium)))
+ (setf space-width (text-style-width style medium)
+ tab-width (* 8 space-width)))))
+
+(defun present-contents (pane syntax)
+ (with-slots (saved-offset scan) syntax
+ (unless (null saved-offset)
+ (present (coerce (region-to-sequence saved-offset scan) 'string)
+ 'string
+ :stream pane)
+ (setf saved-offset nil))))
+
+(defun display-line (pane syntax)
+ (with-slots (saved-offset bot scan cursor-x cursor-y space-width tab-width) syntax
+ (loop 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))))
+ cursor-y y))
+ when (mark= scan bot)
+ do (present-contents pane syntax)
+ (return)
+ until (eql (object-after scan) #\Newline)
+ do (let ((obj (object-after scan)))
+ (cond ((eql obj #\Space)
+ (present-contents pane syntax)
+ (princ obj pane))
+ ((eql obj #\Tab)
+ (present-contents pane syntax)
+ (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0)))
+ ((constituentp obj)
+ (when (null saved-offset)
+ (setf saved-offset (offset scan))))
+ (t
+ (present-contents pane syntax)
+ (princ obj pane))))
+ (incf (offset scan))
+ finally (present-contents pane syntax)
+ (incf (offset scan))
+ (terpri pane))))
(defmethod redisplay-with-syntax (pane (syntax basic-syntax))
(let* ((medium (sheet-medium pane))
(style (medium-text-style medium))
- (height (text-style-height style medium))
- (width (text-style-width style medium))
- (tab-width (* 8 width))
- (buffer (buffer pane))
- (size (size (buffer pane)))
- (offset 0)
- (offset1 nil)
- (cursor-x nil)
- (cursor-y nil))
- (labels ((present-contents ()
- (unless (null offset1)
- (present (coerce (buffer-sequence buffer offset1 offset) 'string)
- 'string
- :stream pane)
- (setf offset1 nil)))
- (display-line ()
- (loop when (= offset (offset (point pane)))
- do (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x (+ x (if (null offset1)
- 0
- (* width (- offset offset1))))
- cursor-y y))
- when (= offset size)
- do (present-contents)
- (return)
- until (eql (buffer-object buffer offset) #\Newline)
- do (let ((obj (buffer-object buffer offset)))
- (cond ((eql obj #\Space)
- (present-contents)
- (princ obj pane))
- ((eql obj #\Tab)
- (present-contents)
- (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))
- ((constituentp obj)
- (when (null offset1)
- (setf offset1 offset)))
- (t
- (present-contents)
- (princ obj pane))))
- (incf offset)
- finally (present-contents)
- (incf offset)
- (terpri pane))))
- (loop while (< offset size)
- do (display-line))
- (when (= offset (offset (point pane)))
- (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+)))
+ (height (text-style-height style medium)))
+ (with-slots (top bot scan cursor-x cursor-y) 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 (max 1 (floor h (+ height (stream-vertical-spacing pane))))))
+ (loop while (> (1+ (- (line-number bot) (line-number top))) nb-lines)
+ do (beginning-of-line bot)
+ (decf (offset bot)))
+ (loop until (end-of-buffer-p bot)
+ while (< (1+ (- (line-number bot) (line-number top))) nb-lines)
+ do (incf (offset bot))
+ (end-of-line bot))
+ (loop while (mark< (point pane) top)
+ do (decf (offset top))
+ (beginning-of-line top)
+ (beginning-of-line bot)
+ (decf (offset bot)))
+ (loop while (mark> (point pane) bot)
+ do (end-of-line top)
+ (incf (offset top))
+ (incf (offset bot))
+ (end-of-line bot))
+ (setf (offset scan) (offset top))
+ (loop until (mark= scan bot)
+ do (display-line pane syntax))
+ (when (mark= scan (point pane))
+ (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+))))))
More information about the Climacs-cvs
mailing list