#| -*-Scheme-*-

$Id: tparse.scm,v 1.78 2003/02/14 18:28:13 cph Exp $

Copyright 1986, 1989-2000 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Text Parsing

(declare (usual-integrations))

;;;; Pages

(define (%forward-page start end page-delimiter)
  (if (not (mark<= start end))
      (error "Marks incorrectly related:" start end))
  (and (mark< start end)
       (or (re-search-forward page-delimiter start end)
	   end)))

(define (%backward-page end start page-delimiter)
  (if (not (mark<= start end))
      (error "Marks incorrectly related:" start end))
  (and (mark< start end)
       (if (re-search-backward page-delimiter (mark-1+ end) start)
	   (re-match-end 0)
	   start)))

(define (%at-page-delimiter? mark page-delimiter)
  (re-match-forward page-delimiter (line-start mark 0) mark))

(define-variable page-delimiter
  "Regexp describing line-beginnings that separate pages."
  "^\f"
  string?)

(define (forward-one-page mark)
  (%forward-page mark
		 (group-end mark)
		 (mark-local-ref mark (ref-variable-object page-delimiter))))

(define (backward-one-page mark)
  (%backward-page mark
		  (group-start mark)
		  (mark-local-ref mark (ref-variable-object page-delimiter))))

(define (page-start mark)
  (let ((page-delimiter
	 (mark-local-ref mark (ref-variable-object page-delimiter))))
    (or (%at-page-delimiter? mark page-delimiter)
	(%backward-page mark (group-start mark) page-delimiter))))

(define forward-page)
(define backward-page)
(make-motion-pair forward-one-page backward-one-page
  (lambda (f b)
    (set! forward-page f)
    (set! backward-page b)
    unspecific))

;;;; Paragraphs

(define-variable paragraph-start
  "Regexp for beginning of a line that starts OR separates paragraphs."
  "[ \t\n\f]"
  string?)

(define-variable paragraph-separate
  "Regexp for beginning of a line that separates paragraphs.
If you change this, you may have to change paragraph-start also."
  "[ \t\f]*$"
  string?)

(define-variable paragraph-ignore-fill-prefix
  "True means the paragraph commands are not affected by fill-prefix.
This is desirable in modes where blank lines are the paragraph delimiters."
  #f
  boolean?)

(define-integrable (mark/paragraph-start mark)
  (mark-local-ref mark (ref-variable-object paragraph-start)))

(define-integrable (mark/paragraph-separate mark)
  (mark-local-ref mark (ref-variable-object paragraph-separate)))

(define (mark/paragraph-fill-prefix mark)
  (if (mark-local-ref mark (ref-variable-object paragraph-ignore-fill-prefix))
      #f
      (mark-local-ref mark (ref-variable-object fill-prefix))))

(define (standard-alternate-paragraph-style! buffer)
  (let ((regexp "[ \t\f]*$"))
    (local-set-variable! paragraph-start regexp buffer)
    (local-set-variable! paragraph-separate regexp buffer)))

(define (paragraph-start? start end)
  (or (re-match-forward (ref-variable paragraph-start start) start end #f)
      (re-match-forward (ref-variable paragraph-separate start) start end #f)))

(define (prefixed-paragraph-start? start end fill-prefix)
  (let ((fp
	 (if fill-prefix
	     (match-forward fill-prefix start end #f)
	     start)))
    (or (not fp)
	(paragraph-start? fp end))))

(define (paragraph-separator? start end)
  (re-match-forward (ref-variable paragraph-separate start) start end #f))

(define (prefixed-paragraph-separator? start end fill-prefix)
  (let ((fp
	 (if fill-prefix
	     (match-forward fill-prefix start end #f)
	     start)))
    (or (not fp)
	(paragraph-separator? fp end))))

(define (forward-one-paragraph mark #!optional limit fill-prefix)
  (let ((limit
	 (if (default-object? limit)
	     (group-end mark)
	     (begin
	       (if (not (mark<= mark limit))
		   (error "Marks incorrectly related:" mark limit))
	       limit)))
	(fill-prefix
	 (if (default-object? fill-prefix)
	     (mark/paragraph-fill-prefix mark)
	     fill-prefix)))
    (and (mark< mark limit)
	 (let ((end (group-end mark))
	       (next-ls
		(lambda (ls)
		  (let ((le (line-end ls 0)))
		    (if (mark< le limit)
			(mark1+ le)
			limit)))))
	   (let ((separator?
		  (lambda (ls)
		    (prefixed-paragraph-separator? ls end fill-prefix))))
	     (letrec
		 ((skip-separators
		   (lambda (ls)
		     (cond ((mark= ls limit) #f)
			   ((separator? ls) (skip-separators (next-ls ls)))
			   (else (skip-body ls)))))
		  (skip-body
		   (lambda (ls)
		     (let ((ls (next-ls ls)))
		       (if (or (mark= ls limit)
			       (prefixed-paragraph-start? ls end fill-prefix))
			   ls
			   (skip-body ls))))))
	       (if (separator? (line-start mark 0))
		   (skip-separators (next-ls mark))
		   (skip-body mark))))))))

(define (backward-one-paragraph mark #!optional limit fill-prefix)
  (let ((limit
	 (if (default-object? limit)
	     (group-start mark)
	     (begin
	       (if (not (mark<= limit mark))
		   (error "Marks incorrectly related:" limit mark))
	       limit)))
	(fill-prefix
	 (if (default-object? fill-prefix)
	     (mark/paragraph-fill-prefix mark)
	     fill-prefix)))
    (let ((prev-ls
	   (lambda (ls)
	     (let ((ls (line-start ls -1 'LIMIT)))
	       (if (mark< ls limit)
		   limit
		   ls))))
	  (end (group-end mark)))
      (let ((separator?
	     (lambda (ls)
	       (prefixed-paragraph-separator? ls end fill-prefix))))
	(letrec ((skip-separators
		  (lambda (ls)
		    (and (mark< limit ls)
			 (let ((ls (prev-ls ls)))
			   (cond ((separator? ls) (skip-separators ls))
				 ((mark= ls limit) ls)
				 (else (skip-body ls)))))))
		 (skip-body
		  (lambda (ls)
		    (if (mark<= ls limit)
			limit
			(let ((ls* (prev-ls ls)))
			  (cond ((separator? ls*) ls*)
				((prefixed-paragraph-start? ls* end
							    fill-prefix)
				 (let ((ls** (prev-ls ls*)))
				   (if (separator? ls**)
				       ls**
				       ls*)))
				(else (skip-body ls*))))))))
	  (and (mark< limit mark)
	       (let ((ls (line-start mark (if (line-start? mark) -1 0))))
		 (and (mark<= limit ls)
		      (cond ((separator? ls) (skip-separators ls))
			    ((mark= limit ls) ls)
			    (else (skip-body ls)))))))))))

(define forward-paragraph)
(define backward-paragraph)
(make-motion-pair forward-one-paragraph backward-one-paragraph
  (lambda (f b)
    (set! forward-paragraph f)
    (set! backward-paragraph b)
    unspecific))

(define (paragraph-text-region mark)
  (let ((end (paragraph-text-end mark)))
    (and end
	 (let ((start (paragraph-text-start end)))
	   (and start
		(make-region start end))))))

(define (paragraph-text-start mark)
  (let ((start (group-start mark))
	(fill-prefix (mark/paragraph-fill-prefix mark)))
    (let ((prev-ls
	   (lambda (ls)
	     (let ((ls (line-start ls -1 'LIMIT)))
	       (if (mark< ls start)
		   start
		   ls))))
	  (end (group-end mark)))
      (let ((separator?
	     (lambda (ls)
	       (prefixed-paragraph-separator? ls end fill-prefix))))
	(letrec ((skip-separators
		  (lambda (ls)
		    (cond ((not (separator? ls)) (skip-body ls))
			  ((mark<= ls start) #f)
			  (else (skip-separators (prev-ls ls))))))
		 (skip-body
		  (lambda (ls)
		    (if (mark<= ls start)
			start
			(let ((ls* (prev-ls ls)))
			  (cond ((separator? ls*) ls)
				((prefixed-paragraph-start? ls* end
							    fill-prefix)
				 ls*)
				(else (skip-body ls*))))))))
	  (skip-separators (line-start mark 0)))))))

(define (paragraph-text-end mark)
  (let ((end (group-end mark))
	(fill-prefix (mark/paragraph-fill-prefix mark)))
    (let ((next-ls
	   (lambda (ls)
	     (let ((le (line-end ls 0)))
	       (if (mark< le end)
		   (mark1+ le)
		   end)))))
      (let ((separator?
	     (lambda (ls)
	       (prefixed-paragraph-separator? ls end fill-prefix))))
	(letrec
	    ((skip-separators
	      (lambda (ls)
		(cond ((mark= ls end) #f)
		      ((separator? ls) (skip-separators (next-ls ls)))
		      (else (skip-body ls)))))
	     (skip-body
	      (lambda (ls)
		(finish
		 (let loop ((ls ls))
		   (let ((ls (next-ls ls)))
		     (if (or (mark= ls end)
			     (prefixed-paragraph-start? ls end fill-prefix))
			 ls
			 (loop ls)))))))
	     (finish
	      (lambda (ls)
		(if (and (mark< mark ls) (line-start? ls))
		    (mark-1+ ls)
		    ls))))
	  (if (separator? (line-start mark 0))
	      (skip-separators (next-ls mark))
	      (skip-body mark)))))))

;;;; Sentences

(define-variable sentence-end
  "Regexp describing the end of a sentence.
All paragraph boundaries also end sentences, regardless."
  "[.?!][]\"')}]*\\($\\|\t\\|  \\)[ \t\n]*"
  string?)

(define-integrable (mark/sentence-end mark)
  (mark-local-ref mark (ref-variable-object sentence-end)))

(define (forward-one-sentence mark)
  (let ((para-end
	 (let loop ((mark mark))
	   (let ((end (paragraph-text-end mark)))
	     (if (or (not end) (mark< mark end))
		 end
		 (and (not (group-end? mark))
		      (loop (mark1+ mark))))))))
    (let ((mark
	   (re-search-forward (mark/sentence-end mark)
			      mark
			      (or para-end (group-end mark)))))
      (if mark
	  (skip-chars-backward " \t\n" mark (re-match-start 0) #f)
	  para-end))))

(define (backward-one-sentence mark)
  (let ((para-start
	 (let loop ((mark mark))
	   (let ((start (paragraph-text-start mark)))
	     (if (or (not start) (mark< start mark))
		 start
		 (and (not (group-start? mark))
		      (loop (mark-1+ mark))))))))
    (if (re-search-backward (string-append (mark/sentence-end mark) "[^ \t\n]")
			    (let ((para-end
				   (and para-start
					(paragraph-text-end para-start))))
			      (if (and para-end (mark< para-end mark))
				  para-end
				  mark))
			    (or para-start (group-start mark)))
	(mark-1+ (re-match-end 0))
	para-start)))

(define forward-sentence)
(define backward-sentence)
(make-motion-pair forward-one-sentence backward-one-sentence
  (lambda (f b)
    (set! forward-sentence f)
    (set! backward-sentence b)
    unspecific))