suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

clean up Meta-q implementation

Browse Source 
svn: r4902
This commit is contained in:
Matthew Flatt 2006-11-21 01:40:26 +00:00
parent d0a37a636c
commit a67ea80b65
1 changed files with 103 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

182
collects/sirmail/sendr.ss
View File

@ -840,85 +840,109 @@
(send edit set-wordbreak-map reflow-wordbreak-map) (send edit set-wordbreak-map reflow-wordbreak-map)
(send edit begin-edit-sequence)) (send edit begin-edit-sequence))
(lambda () (lambda ()
(let ([p (max start-min (send edit get-start-position))] (let* ([p (max start-min (send edit get-start-position))]
[min-line (send edit position-paragraph start-min)]) [min-line (send edit position-paragraph start-min)]
(let loop ([start-l (send edit position-paragraph p)]) [end-line (send edit position-paragraph p)])
(if (or (<= start-l min-line) ;; Find start and end lines that form a paragraph:
(= (send edit paragraph-start-position start-l) (let* ([start-l
(add1 (send edit paragraph-start-position (sub1 start-l))))) (let loop ([start-l end-line])
(let loop ([end-l start-l]) (if (or (<= start-l min-line)
(if (or (= end-l (send edit last-paragraph)) (= (send edit paragraph-start-position start-l)
(= (send edit paragraph-end-position end-l) (add1 (send edit paragraph-start-position (sub1 start-l)))))
(sub1 (send edit paragraph-end-position (add1 end-l))))) start-l
(let ([orig-start (send edit paragraph-start-position start-l)] (loop (sub1 start-l))))]
[end (send edit paragraph-end-position end-l)] [end-l
[second-line-prefix (let loop ([end-l start-l])
(if (= start-l end-l) (if (or (= end-l (send edit last-paragraph))
"" (= (send edit paragraph-end-position end-l)
(let ([p (send edit paragraph-start-position (add1 start-l))]) (sub1 (send edit paragraph-end-position (add1 end-l)))))
(let loop ([pe p]) end-l
(case (send edit get-character pe) (loop (add1 end-l))))])
[(#\space #\tab #\>) (loop (add1 pe))] ;; Remember start and end positions, and determine the paragraph prefix:
[else (send edit get-text p pe)]))))]) (let ([orig-start (send edit paragraph-start-position start-l)]
(let ([start ; skip spaces on first line (if there's a non-space): [end (send edit paragraph-end-position end-l)]
(let ([start-end (send edit paragraph-end-position start-l)]) [second-line-prefix
(let loop ([start orig-start]) (if (= start-l end-l)
(cond ""
[(= start-end start) orig-start] (let ([p (send edit paragraph-start-position (add1 start-l))])
[(memq (send edit get-character start) '(#\space #\tab)) (let loop ([pe p])
(loop (add1 start))] (case (send edit get-character pe)
[else start])))]) [(#\space #\tab #\>) (loop (add1 pe))]
; Remove all line breaks and double-spaces [else (send edit get-text p pe)]))))])
; spaces ;; Adjust starting position by skipping spaces on the first line:
(let loop ([start start] (let ([start
[end end] (let ([start-end (send edit paragraph-end-position start-l)])
[l (list (string-append (string #\newline) (let loop ([start orig-start])
second-line-prefix) (cond
(string #\newline) [(= start-end start) orig-start]
(string #\tab) [(memq (send edit get-character start) '(#\space #\tab))
(string #\space #\space))]) (loop (add1 start))]
(let ([p (send edit find-string (car l) [else start])))])
'forward start end)] ;; Remove all line breaks, double spaces, tabs, and prefixes,
[line-break (string-append (string #\newline) ;; producing a revised start and end position:
second-line-prefix)] (let-values ([(start end)
[slp-len (string-length second-line-prefix)]) (let loop ([start start]
(if (or p (pair? (cdr l))) [end end]
(if p ;; l is the list of patterns to delete:
(let ([len (string-length (car l))]) [l (list (string-append (string #\newline)
(send edit insert " " p (+ p len)) second-line-prefix)
(loop start (- end len -1) l)) (string #\newline)
(loop start end (cdr l))) (string #\tab)
; Insert good line breaks (string #\space #\space))])
(let loop ([start start] ;; Look for the first thing in l:
[len (- start orig-start)] (let ([p (send edit find-string (car l)
; First, remove ending space 'forward start end)])
[end (if (or (= end start) (if (or p (pair? (cdr l)))
(not (char=? (if p
#\space ;; Found an instance; replace it with a single space,
(send edit get-character ;; and look again
(sub1 end))))) (let ([len (string-length (car l))])
end (send edit insert " " p (+ p len))
(begin (loop start (- end len -1) l))
(send edit delete (sub1 end) end) ;; Didn't find an instance; start looking for the
(sub1 end)))]) ;; next thing in our list
(unless (>= start end) (loop start end (cdr l)))
(let ([ebox (box start)]) ;; Nothing else to find, so we're done removing things
(send edit find-wordbreak #f ebox 'line) (values start end))))])
(let* ([p (unbox ebox)] ;; At this point the paragraph should be on a single line.
[wlen (- p start)]) ;; Insert good line breaks to wrap the paragraph:
(cond (let ([line-break (string-append (string #\newline)
[(or (zero? len) (< (+ len wlen) 72)) second-line-prefix)]
(loop p (+ len wlen) end)] [slp-len (string-length second-line-prefix)])
[(char=? #\space (send edit get-character start)) (let loop ([start start]
(send edit insert line-break start (add1 start)) [len (- start orig-start)]
(loop (+ p slp-len) (+ wlen -1 slp-len) ;; Actually, remove ending space before we start:
(+ slp-len end))] [end (if (or (= end start)
[else (not (char=?
(send edit insert line-break start) #\space
(loop (+ p 1 slp-len) (+ wlen slp-len) (send edit get-character
(+ end 1 slp-len))])))))))))) (sub1 end)))))
(loop (add1 end-l)))) end
(loop (sub1 start-l)))))) (begin
(send edit delete (sub1 end) end)
(sub1 end)))])
(unless (>= start end)
;; Find end of the current word:
(let ([ebox (box start)])
(send edit find-wordbreak #f ebox 'line)
(let* ([p (unbox ebox)]
[wlen (- p start)])
(cond
;; If it's the first word on the line, or if it fits,
;; no line break
[(or (zero? len) (< (+ len wlen) 72))
(loop p (+ len wlen) end)]
;; If the next thing is a space, then replace the space with a
;; newline and prefix
[(char=? #\space (send edit get-character start))
(send edit insert line-break start (add1 start))
(loop (+ p slp-len) (+ wlen -1 slp-len)
(+ slp-len end))]
;; Otherwise, insert a newline and prefix
[else
(send edit insert line-break start)
(loop (+ p 1 slp-len) (+ wlen slp-len)
(+ end 1 slp-len))]))))))))))))
(lambda () (lambda ()
(send edit end-edit-sequence) (send edit end-edit-sequence)
(send edit set-wordbreak-map wbm))) (send edit set-wordbreak-map wbm)))