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

Contents of /climacs/text-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide 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 rstrandh 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
2    
3     ;;; (c) copyright 2005 by
4     ;;; Robert Strandh (strandh@labri.fr)
5 mvilleneuve 1.5 ;;; (c) copyright 2005 by
6     ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
7 rstrandh 1.1
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 dholman 1.8 ;;;
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 rstrandh 1.1
55     (in-package :climacs-syntax) ;;; Put this in a separate package once it works
56    
57 rstrandh 1.4 (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 thenriksen 1.11 (define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax)
69 dholman 1.8 ((paragraphs :initform (make-instance 'standard-flexichain))
70     (sentence-beginnings :initform (make-instance 'standard-flexichain))
71     (sentence-endings :initform (make-instance 'standard-flexichain)))
72 crhodes 1.7 (:name "Text")
73     (:pathname-types "text" "txt" "README"))
74 rstrandh 1.1
75 rstrandh 1.2 (defmethod update-syntax (buffer (syntax text-syntax))
76     (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
77 rstrandh 1.1 (low-offset (max (- (offset (low-mark buffer)) 3) 0)))
78 dholman 1.8 (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 thenriksen 1.11 ;; 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 dholman 1.8
152 thenriksen 1.10 (defmethod backward-one-paragraph (mark (syntax text-syntax))
153 rstrandh 1.3 (with-slots (paragraphs) syntax
154 rstrandh 1.4 (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark))))
155 rstrandh 1.3 (when (> pos1 0)
156     (setf (offset mark)
157     (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark)
158     (offset (element* paragraphs (- pos1 2)))
159 thenriksen 1.10 (offset (element* paragraphs (1- pos1)))))
160     t))))
161 rstrandh 1.3
162 thenriksen 1.10 (defmethod forward-one-paragraph (mark (syntax text-syntax))
163 rstrandh 1.3 (with-slots (paragraphs) syntax
164 rstrandh 1.4 (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 rstrandh 1.3 (setf (offset mark)
171     (if (typep (element* paragraphs pos1) 'left-sticky-mark)
172     (offset (element* paragraphs (1+ pos1)))
173 thenriksen 1.10 (offset (element* paragraphs pos1))))
174     t))))
175 dholman 1.8
176 thenriksen 1.10 (defmethod backward-one-sentence (mark (syntax text-syntax))
177 dholman 1.8 (with-slots (sentence-beginnings) syntax
178     (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark))))
179     (when (> pos1 0)
180 thenriksen 1.10 (setf (offset mark)
181     (offset (element* sentence-beginnings (1- pos1))))
182     t))))
183 dholman 1.8
184 thenriksen 1.10 (defmethod forward-one-sentence (mark (syntax text-syntax))
185 dholman 1.8 (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 thenriksen 1.10 (offset (element* sentence-endings pos1)))
194     t))))
195 mvilleneuve 1.5
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 thenriksen 1.10 do (climacs-motion:backward-line mark2 syntax)
201 mvilleneuve 1.5 (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