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

Contents of /climacs/text-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sat Jan 15 21:35:53 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.2: +34 -0 lines
Implemented beginning-of-paragraph and end-of-paragraph, the first
commands to exploit a syntax, in this case text-syntax.
1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; Syntax for analysing ordinary text.
22
23 ;;; Invariants after a complete syntax analysis:
24 ;;;
25 ;;; There is exactly one left-sticky mark at every offset followed by
26 ;;; character other than a newline and preceded either by nothing
27 ;;; (beginning of the buffer), by a newline character at the beginning
28 ;;; of the buffer, or by two newline characters.
29 ;;;
30 ;;; There is exactly one right-sticky mark at every offset preceded by
31 ;;; a character other than a newline and followed either by nothing
32 ;;; (end of the buffer), by a newline character at the end of the
33 ;;; buffer, or by two newline characters.
34 ;;;
35 ;;; It follows that:
36 ;;; * there can never be two marks in the same place,
37 ;;; * there are as many left-sticky marks as right-sticky marks,
38 ;;; * left-sticky and right-sticky marks alternate, starting with a
39 ;;; left-sticky mark
40 ;;;
41 ;;; N.B.: These invariants only hold AFTER a complete syntax analysis.
42 ;;; we do now know what might have happened during the editing
43 ;;; phase between to invocations of the analysis.
44
45 (in-package :climacs-syntax) ;;; Put this in a separate package once it works
46
47 (define-syntax text-syntax ("Text" (basic-syntax))
48 ((paragraphs :initform (make-instance 'standard-flexichain))))
49
50 (defmethod update-syntax (buffer (syntax text-syntax))
51 (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
52 (low-offset (max (- (offset (low-mark buffer)) 3) 0)))
53 (with-slots (paragraphs) syntax
54 (let* ((nb-paragraphs (nb-elements paragraphs))
55 (pos2 nb-paragraphs)
56 (pos1 0))
57 ;; start by deleting all syntax marks that are between the low and
58 ;; the high marks
59 (loop until (= pos1 pos2)
60 do (cond ((mark< (element* paragraphs (floor (+ pos1 pos2) 2))
61 low-offset)
62 (setf pos1 (floor (+ pos1 1 pos2) 2)))
63 (t
64 (setf pos2 (floor (+ pos1 pos2) 2)))))
65 (loop repeat (- nb-paragraphs pos1)
66 while (mark<= (element* paragraphs pos1) high-offset)
67 do (delete* paragraphs pos1))
68 ;; check the zone between low-offset and high-offset for
69 ;; paragraph delimiters
70 (loop with buffer-size = (size buffer)
71 for offset from low-offset to high-offset
72 do (cond ((and (< offset buffer-size)
73 (not (eql (buffer-object buffer offset) #\Newline))
74 (or (zerop offset)
75 (and (eql (buffer-object buffer (1- offset)) #\Newline)
76 (or (= offset 1)
77 (eql (buffer-object buffer (- offset 2)) #\Newline)))))
78 (insert* paragraphs pos1
79 (make-instance 'standard-left-sticky-mark
80 :buffer buffer :offset offset))
81 (incf pos1))
82 ((and (plusp offset)
83 (not (eql (buffer-object buffer (1- offset)) #\Newline))
84 (or (= offset buffer-size)
85 (and (eql (buffer-object buffer offset) #\Newline)
86 (or (= offset (1- buffer-size))
87 (eql (buffer-object buffer (1+ offset)) #\Newline)))))
88 (insert* paragraphs pos1
89 (make-instance 'standard-right-sticky-mark
90 :buffer buffer :offset offset))
91 (incf pos1))
92 (t nil)))))))
93
94 (defgeneric beginning-of-paragraph (mark text-syntax))
95
96 (defmethod beginning-of-paragraph (mark (syntax text-syntax))
97 (with-slots (paragraphs) syntax
98 (let* ((nb-paragraphs (nb-elements paragraphs))
99 (pos2 nb-paragraphs)
100 (pos1 0)
101 (offset (offset mark)))
102 (loop until (= pos1 pos2)
103 do (if (mark>= (element* paragraphs (floor (+ pos1 pos2) 2)) offset)
104 (setf pos2 (floor (+ pos1 pos2) 2))
105 (setf pos1 (floor (+ pos1 1 pos2) 2))))
106 (when (> pos1 0)
107 (setf (offset mark)
108 (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark)
109 (offset (element* paragraphs (- pos1 2)))
110 (offset (element* paragraphs (1- pos1)))))))))
111
112 (defmethod end-of-paragraph (mark (syntax text-syntax))
113 (with-slots (paragraphs) syntax
114 (let* ((nb-paragraphs (nb-elements paragraphs))
115 (pos2 nb-paragraphs)
116 (pos1 0)
117 (offset (offset mark)))
118 (loop until (= pos1 pos2)
119 do (if (mark<= (element* paragraphs (floor (+ pos1 pos2) 2)) offset)
120 (setf pos1 (floor (+ pos1 1 pos2) 2))
121 (setf pos2 (floor (+ pos1 pos2) 2))))
122 (when (< pos1 nb-paragraphs)
123 (setf (offset mark)
124 (if (typep (element* paragraphs pos1) 'left-sticky-mark)
125 (offset (element* paragraphs (1+ pos1)))
126 (offset (element* paragraphs pos1))))))))

  ViewVC Help
Powered by ViewVC 1.1.5