/[climacs]/climacs/text-syntax.lisp
ViewVC logotype

Contents of /climacs/text-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sat Sep 2 21:43:56 2006 UTC (7 years, 7 months ago) by thenriksen
Branch: MAIN
CVS Tags: works-with-0_9_3
Changes since 1.10: +70 -69 lines
Removed the Basic syntax and the `cache' slot in the `climacs-pane'
class. Fundamental syntax is now the default. This also required
moving some things around, but there has not been any functionality
changes.
1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2005 by
6 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; Syntax for analysing ordinary text.
24
25 ;;; Invariants after a complete syntax analysis:
26 ;;;
27 ;;; There is exactly one left-sticky mark at every offset followed by
28 ;;; character other than a newline and preceded either by nothing
29 ;;; (beginning of the buffer), by a newline character at the beginning
30 ;;; of the buffer, or by two newline characters.
31 ;;;
32 ;;; There is exactly one right-sticky mark at every offset preceded by
33 ;;; a character other than a newline and followed either by nothing
34 ;;; (end of the buffer), by a newline character at the end of the
35 ;;; buffer, or by two newline characters.
36 ;;;
37 ;;; It follows that:
38 ;;; * there can never be two marks in the same place,
39 ;;; * there are as many left-sticky marks as right-sticky marks,
40 ;;; * left-sticky and right-sticky marks alternate, starting with a
41 ;;; left-sticky mark
42 ;;;
43 ;;; N.B.: These invariants only hold AFTER a complete syntax analysis.
44 ;;; we do now know what might have happened during the editing
45 ;;; phase between to invocations of the analysis.
46 ;;;
47 ;;; D.H.: Invariant text needs to change to reflect sentences.
48 ;;; Should there be paragraph invariants and sentence invariants?
49 ;;; Did I ducttape this in the wrong place?
50 ;;; Sentence invariants:
51 ;;; Left stickies after . ? and !, at the end of the buffer
52 ;;; Right stickies at non whitespace characters preceeded by space and punctuation.
53 ;;;
54
55 (in-package :climacs-syntax) ;;; Put this in a separate package once it works
56
57 (defun index-of-mark-after-offset (flexichain offset)
58 "Searches for the mark after `offset' in the marks stored in `flexichain'."
59 (loop with low-position = 0
60 with high-position = (nb-elements flexichain)
61 for middle-position = (floor (+ low-position high-position) 2)
62 until (= low-position high-position)
63 do (if (mark>= (element* flexichain middle-position) offset)
64 (setf high-position middle-position)
65 (setf low-position (floor (+ low-position 1 high-position) 2)))
66 finally (return low-position)))
67
68 (define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax)
69 ((paragraphs :initform (make-instance 'standard-flexichain))
70 (sentence-beginnings :initform (make-instance 'standard-flexichain))
71 (sentence-endings :initform (make-instance 'standard-flexichain)))
72 (:name "Text")
73 (:pathname-types "text" "txt" "README"))
74
75 (defmethod update-syntax (buffer (syntax text-syntax))
76 (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
77 (low-offset (max (- (offset (low-mark buffer)) 3) 0)))
78 (with-slots (paragraphs sentence-beginnings sentence-endings) syntax
79 (let ((pos1 (index-of-mark-after-offset paragraphs low-offset))
80 (pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset))
81 (pos-sentence-endings (index-of-mark-after-offset sentence-endings low-offset)))
82 ;; start by deleting all syntax marks that are between the low and
83 ;; the high marks
84 (loop repeat (- (nb-elements paragraphs) pos1)
85 while (mark<= (element* paragraphs pos1) high-offset)
86 do (delete* paragraphs pos1))
87 (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings)
88 while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset)
89 do (delete* sentence-beginnings pos-sentence-beginnings))
90 (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings)
91 while (mark<= (element* sentence-endings pos-sentence-endings) high-offset)
92 do (delete* sentence-endings pos-sentence-endings))
93
94 ;; check the zone between low-offset and high-offset for
95 ;; paragraph delimiters and sentence delimiters
96 (loop with buffer-size = (size buffer)
97 for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls,
98 for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides.
99 for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset)))
100 for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset)))
101 for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2)))
102 do (progn
103 (cond ((and (< offset buffer-size)
104 (member prev-object '(#\. #\? #\!))
105 (or (= offset (1- buffer-size))
106 (and (member current-object '(#\Newline #\Space #\Tab))
107 (or (= offset 1)
108 (not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
109 (let ((m (clone-mark (low-mark buffer) :left)))
110 (setf (offset m) offset)
111 (insert* sentence-endings pos-sentence-endings m))
112 (incf pos-sentence-endings))
113
114 ((and (>= offset 0)
115 (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab)))
116 (or (= offset 0)
117 (member prev-object '(#\Newline #\Space #\Tab)))
118 (or (<= offset 1)
119 (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
120 (let ((m (clone-mark (low-mark buffer) :right)))
121 (setf (offset m) offset)
122 (insert* sentence-beginnings pos-sentence-beginnings m))
123 (incf pos-sentence-beginnings))
124 (t nil))
125
126 ;; Paragraphs
127
128 (cond ((and (< offset buffer-size) ;; Ends
129 (not (eql current-object #\Newline))
130 (or (zerop offset)
131 (and (eql prev-object #\Newline)
132 (or (= offset 1)
133 (eql before-prev-object #\Newline)))))
134 (let ((m (clone-mark (low-mark buffer) :left)))
135 (setf (offset m) offset)
136 (insert* paragraphs pos1 m))
137 (incf pos1))
138
139 ((and (plusp offset) ;;Beginnings
140 (not (eql prev-object #\Newline))
141 (or (= offset buffer-size)
142 (and (eql current-object #\Newline)
143 (or (= offset (1- buffer-size))
144 (eql next-object #\Newline)))))
145 (let ((m (clone-mark (low-mark buffer) :right)))
146 (setf (offset m) offset)
147 (insert* paragraphs pos1 m))
148 (incf pos1))
149 (t nil)))))))
150 (call-next-method))
151
152 (defmethod backward-one-paragraph (mark (syntax text-syntax))
153 (with-slots (paragraphs) syntax
154 (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark))))
155 (when (> pos1 0)
156 (setf (offset mark)
157 (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark)
158 (offset (element* paragraphs (- pos1 2)))
159 (offset (element* paragraphs (1- pos1)))))
160 t))))
161
162 (defmethod forward-one-paragraph (mark (syntax text-syntax))
163 (with-slots (paragraphs) syntax
164 (let ((pos1 (index-of-mark-after-offset
165 paragraphs
166 ;; if mark is at paragraph-end, jump to end of next
167 ;; paragraph
168 (1+ (offset mark)))))
169 (when (< pos1 (nb-elements paragraphs))
170 (setf (offset mark)
171 (if (typep (element* paragraphs pos1) 'left-sticky-mark)
172 (offset (element* paragraphs (1+ pos1)))
173 (offset (element* paragraphs pos1))))
174 t))))
175
176 (defmethod backward-one-sentence (mark (syntax text-syntax))
177 (with-slots (sentence-beginnings) syntax
178 (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark))))
179 (when (> pos1 0)
180 (setf (offset mark)
181 (offset (element* sentence-beginnings (1- pos1))))
182 t))))
183
184 (defmethod forward-one-sentence (mark (syntax text-syntax))
185 (with-slots (sentence-endings) syntax
186 (let ((pos1 (index-of-mark-after-offset
187 sentence-endings
188 ;; if mark is at sentence-end, jump to end of next
189 ;; sentence
190 (1+ (offset mark)))))
191 (when (< pos1 (nb-elements sentence-endings))
192 (setf (offset mark)
193 (offset (element* sentence-endings pos1)))
194 t))))
195
196 (defmethod syntax-line-indentation (mark tab-width (syntax text-syntax))
197 (loop with indentation = 0
198 with mark2 = (clone-mark mark)
199 until (beginning-of-buffer-p mark2)
200 do (climacs-motion:backward-line mark2 syntax)
201 (setf indentation (line-indentation mark2 tab-width))
202 while (empty-line-p mark2)
203 finally (return indentation)))

  ViewVC Help
Powered by ViewVC 1.1.5