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

Contents of /climacs/text-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Sat Dec 8 08:55:06 2007 UTC (6 years, 4 months ago) by thenriksen
Branch: MAIN
Changes since 1.13: +13 -8 lines
Changed Climacs to use a view-paradigm. Somewhat hacky, probably buggy.
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 thenriksen 1.14 (in-package :climacs-text-syntax)
56 rstrandh 1.1
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.12 (define-syntax text-syntax (drei-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 thenriksen 1.14 (defmethod update-syntax ((syntax text-syntax) prefix-size suffix-size
76     &optional begin end)
77     (declare (ignore begin end))
78     (let* ((buffer (buffer syntax))
79     (high-mark-offset (- (size buffer) suffix-size))
80     (low-mark-offset prefix-size)
81     (high-offset (min (+ high-mark-offset 3) (size buffer)))
82     (low-offset (max (- low-mark-offset 3) 0)))
83 dholman 1.8 (with-slots (paragraphs sentence-beginnings sentence-endings) syntax
84     (let ((pos1 (index-of-mark-after-offset paragraphs low-offset))
85     (pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset))
86     (pos-sentence-endings (index-of-mark-after-offset sentence-endings low-offset)))
87 thenriksen 1.11 ;; start by deleting all syntax marks that are between the low and
88     ;; the high marks
89     (loop repeat (- (nb-elements paragraphs) pos1)
90     while (mark<= (element* paragraphs pos1) high-offset)
91     do (delete* paragraphs pos1))
92     (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings)
93     while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset)
94     do (delete* sentence-beginnings pos-sentence-beginnings))
95     (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings)
96     while (mark<= (element* sentence-endings pos-sentence-endings) high-offset)
97     do (delete* sentence-endings pos-sentence-endings))
98    
99     ;; check the zone between low-offset and high-offset for
100     ;; paragraph delimiters and sentence delimiters
101     (loop with buffer-size = (size buffer)
102     for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls,
103     for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides.
104     for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset)))
105     for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset)))
106     for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2)))
107     do (progn
108     (cond ((and (< offset buffer-size)
109     (member prev-object '(#\. #\? #\!))
110     (or (= offset (1- buffer-size))
111     (and (member current-object '(#\Newline #\Space #\Tab))
112     (or (= offset 1)
113     (not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
114 thenriksen 1.14 (let ((m (make-buffer-mark buffer low-mark-offset :left)))
115 thenriksen 1.11 (setf (offset m) offset)
116     (insert* sentence-endings pos-sentence-endings m))
117     (incf pos-sentence-endings))
118    
119     ((and (>= offset 0)
120     (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab)))
121     (or (= offset 0)
122     (member prev-object '(#\Newline #\Space #\Tab)))
123     (or (<= offset 1)
124     (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
125 thenriksen 1.14 (let ((m (make-buffer-mark buffer low-mark-offset :right)))
126 thenriksen 1.11 (setf (offset m) offset)
127     (insert* sentence-beginnings pos-sentence-beginnings m))
128     (incf pos-sentence-beginnings))
129     (t nil))
130    
131     ;; Paragraphs
132    
133     (cond ((and (< offset buffer-size) ;; Ends
134     (not (eql current-object #\Newline))
135     (or (zerop offset)
136     (and (eql prev-object #\Newline)
137     (or (= offset 1)
138     (eql before-prev-object #\Newline)))))
139 thenriksen 1.14 (let ((m (make-buffer-mark buffer low-mark-offset :left)))
140 thenriksen 1.11 (setf (offset m) offset)
141     (insert* paragraphs pos1 m))
142     (incf pos1))
143    
144     ((and (plusp offset) ;;Beginnings
145     (not (eql prev-object #\Newline))
146     (or (= offset buffer-size)
147     (and (eql current-object #\Newline)
148     (or (= offset (1- buffer-size))
149     (eql next-object #\Newline)))))
150 thenriksen 1.14 (let ((m (make-buffer-mark buffer low-mark-offset :right)))
151 thenriksen 1.11 (setf (offset m) offset)
152     (insert* paragraphs pos1 m))
153     (incf pos1))
154     (t nil)))))))
155     (call-next-method))
156 dholman 1.8
157 thenriksen 1.10 (defmethod backward-one-paragraph (mark (syntax text-syntax))
158 rstrandh 1.3 (with-slots (paragraphs) syntax
159 rstrandh 1.4 (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark))))
160 rstrandh 1.3 (when (> pos1 0)
161     (setf (offset mark)
162     (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark)
163     (offset (element* paragraphs (- pos1 2)))
164 thenriksen 1.10 (offset (element* paragraphs (1- pos1)))))
165     t))))
166 rstrandh 1.3
167 thenriksen 1.13 (defmethod forward-one-paragraph ((mark mark) (syntax text-syntax))
168 rstrandh 1.3 (with-slots (paragraphs) syntax
169 rstrandh 1.4 (let ((pos1 (index-of-mark-after-offset
170     paragraphs
171     ;; if mark is at paragraph-end, jump to end of next
172     ;; paragraph
173     (1+ (offset mark)))))
174     (when (< pos1 (nb-elements paragraphs))
175 rstrandh 1.3 (setf (offset mark)
176     (if (typep (element* paragraphs pos1) 'left-sticky-mark)
177     (offset (element* paragraphs (1+ pos1)))
178 thenriksen 1.10 (offset (element* paragraphs pos1))))
179     t))))
180 dholman 1.8
181 thenriksen 1.13 (defmethod backward-one-sentence ((mark mark) (syntax text-syntax))
182 dholman 1.8 (with-slots (sentence-beginnings) syntax
183     (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark))))
184     (when (> pos1 0)
185 thenriksen 1.10 (setf (offset mark)
186     (offset (element* sentence-beginnings (1- pos1))))
187     t))))
188 dholman 1.8
189 thenriksen 1.13 (defmethod forward-one-sentence ((mark mark) (syntax text-syntax))
190 dholman 1.8 (with-slots (sentence-endings) syntax
191     (let ((pos1 (index-of-mark-after-offset
192     sentence-endings
193     ;; if mark is at sentence-end, jump to end of next
194     ;; sentence
195     (1+ (offset mark)))))
196     (when (< pos1 (nb-elements sentence-endings))
197     (setf (offset mark)
198 thenriksen 1.10 (offset (element* sentence-endings pos1)))
199     t))))
200 mvilleneuve 1.5
201 thenriksen 1.13 (defmethod syntax-line-indentation ((mark mark) tab-width (syntax text-syntax))
202 mvilleneuve 1.5 (loop with indentation = 0
203     with mark2 = (clone-mark mark)
204     until (beginning-of-buffer-p mark2)
205 thenriksen 1.12 do (drei-motion:backward-line mark2 syntax)
206 mvilleneuve 1.5 (setf indentation (line-indentation mark2 tab-width))
207     while (empty-line-p mark2)
208     finally (return indentation)))

  ViewVC Help
Powered by ViewVC 1.1.5