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

Diff of /climacs/text-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by thenriksen, Mon Jun 12 19:10:58 2006 UTC revision 1.11 by thenriksen, Sat Sep 2 21:43:56 2006 UTC
# Line 65  Line 65 
65              (setf low-position (floor (+ low-position 1 high-position) 2)))              (setf low-position (floor (+ low-position 1 high-position) 2)))
66       finally (return low-position)))       finally (return low-position)))
67    
68  (define-syntax text-syntax (basic-syntax)  (define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax)
69    ((paragraphs :initform (make-instance 'standard-flexichain))    ((paragraphs :initform (make-instance 'standard-flexichain))
70     (sentence-beginnings :initform (make-instance 'standard-flexichain))     (sentence-beginnings :initform (make-instance 'standard-flexichain))
71     (sentence-endings :initform (make-instance 'standard-flexichain)))     (sentence-endings :initform (make-instance 'standard-flexichain)))
# Line 79  Line 79 
79        (let ((pos1 (index-of-mark-after-offset paragraphs low-offset))        (let ((pos1 (index-of-mark-after-offset paragraphs low-offset))
80              (pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset))              (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)))              (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          ;; start by deleting all syntax marks that are between the low and
83           ;; the high marks          ;; the high marks
84           (loop repeat (- (nb-elements paragraphs) pos1)          (loop repeat (- (nb-elements paragraphs) pos1)
85                 while (mark<= (element* paragraphs pos1) high-offset)             while (mark<= (element* paragraphs pos1) high-offset)
86                 do (delete* paragraphs pos1))             do (delete* paragraphs pos1))
87           (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings)          (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings)
88                 while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset)             while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset)
89                 do (delete* sentence-beginnings pos-sentence-beginnings))             do (delete* sentence-beginnings pos-sentence-beginnings))
90           (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings)          (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings)
91                 while (mark<= (element* sentence-endings pos-sentence-endings) high-offset)             while (mark<= (element* sentence-endings pos-sentence-endings) high-offset)
92                 do (delete* sentence-endings pos-sentence-endings))             do (delete* sentence-endings pos-sentence-endings))
93    
94           ;; check the zone between low-offset and high-offset for          ;; check the zone between low-offset and high-offset for
95           ;; paragraph delimiters and sentence delimiters          ;; paragraph delimiters and sentence delimiters
96           (loop with buffer-size = (size buffer)          (loop with buffer-size = (size buffer)
97                 for offset from low-offset to high-offset              ;; Could be rewritten with even fewer buffer-object calls,             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.             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)))             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)))             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)))             for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2)))
102                 do (progn             do (progn
103                      (cond ((and (< offset buffer-size)                  (cond ((and (< offset buffer-size)
104                                  (member prev-object '(#\. #\? #\!))                              (member prev-object '(#\. #\? #\!))
105                                  (or (= offset (1- buffer-size))                              (or (= offset (1- buffer-size))
106                                      (and (member current-object '(#\Newline #\Space #\Tab))                                  (and (member current-object '(#\Newline #\Space #\Tab))
107                                           (or (= offset 1)                                       (or (= offset 1)
108                                               (not (member before-prev-object '(#\Newline #\Space #\Tab)))))))                                           (not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
109                             (let ((m (clone-mark (low-mark buffer) :left)))                         (let ((m (clone-mark (low-mark buffer) :left)))
110                               (setf (offset m) offset)                           (setf (offset m) offset)
111                               (insert* sentence-endings pos-sentence-endings m))                           (insert* sentence-endings pos-sentence-endings m))
112                             (incf pos-sentence-endings))                         (incf pos-sentence-endings))
113    
114                          ((and (>= offset 0)                        ((and (>= offset 0)
115                                (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab)))                              (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab)))
116                                (or (= offset 0)                              (or (= offset 0)
117                                    (member prev-object '(#\Newline #\Space #\Tab)))                                  (member prev-object '(#\Newline #\Space #\Tab)))
118                                (or (<= offset 1)                              (or (<= offset 1)
119                                    (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))                                  (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
120                           (let ((m (clone-mark (low-mark buffer) :right)))                         (let ((m (clone-mark (low-mark buffer) :right)))
121                             (setf (offset m) offset)                           (setf (offset m) offset)
122                             (insert* sentence-beginnings pos-sentence-beginnings m))                           (insert* sentence-beginnings pos-sentence-beginnings m))
123                           (incf pos-sentence-beginnings))                         (incf pos-sentence-beginnings))
124                          (t nil))                        (t nil))
125    
126                      ;; Paragraphs                  ;; Paragraphs
127    
128                      (cond ((and (< offset buffer-size) ;; Ends                  (cond ((and (< offset buffer-size) ;; Ends
129                                (not (eql current-object #\Newline))                              (not (eql current-object #\Newline))
130                                (or (zerop offset)                              (or (zerop offset)
131                                    (and (eql prev-object #\Newline)                                  (and (eql prev-object #\Newline)
132                                         (or (= offset 1)                                       (or (= offset 1)
133                                             (eql before-prev-object #\Newline)))))                                           (eql before-prev-object #\Newline)))))
134                           (let ((m (clone-mark (low-mark buffer) :left)))                         (let ((m (clone-mark (low-mark buffer) :left)))
135                             (setf (offset m) offset)                           (setf (offset m) offset)
136                             (insert* paragraphs pos1 m))                           (insert* paragraphs pos1 m))
137                           (incf pos1))                         (incf pos1))
138    
139                          ((and (plusp offset) ;;Beginnings                        ((and (plusp offset) ;;Beginnings
140                                (not (eql prev-object #\Newline))                              (not (eql prev-object #\Newline))
141                                (or (= offset buffer-size)                              (or (= offset buffer-size)
142                                    (and (eql current-object #\Newline)                                  (and (eql current-object #\Newline)
143                                         (or (= offset (1- buffer-size))                                       (or (= offset (1- buffer-size))
144                                             (eql next-object #\Newline)))))                                           (eql next-object #\Newline)))))
145                           (let ((m (clone-mark (low-mark buffer) :right)))                         (let ((m (clone-mark (low-mark buffer) :right)))
146                             (setf (offset m) offset)                           (setf (offset m) offset)
147                             (insert* paragraphs pos1 m))                           (insert* paragraphs pos1 m))
148                           (incf pos1))                         (incf pos1))
149                          (t nil))))))))                        (t nil)))))))
150      (call-next-method))
151    
152  (defmethod backward-one-paragraph (mark (syntax text-syntax))  (defmethod backward-one-paragraph (mark (syntax text-syntax))
153    (with-slots (paragraphs) syntax    (with-slots (paragraphs) syntax

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

  ViewVC Help
Powered by ViewVC 1.1.5