#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Sorting



(define (sort-region region reverse?
		     forward-record record-end
		     key-start key-end
		     compare)
  (let* ((start (region-start region))
	 (end (region-end region))
	 (delete-end (mark-right-inserting-copy end))
	 (unsorted-list (identify-records region forward-record record-end))
	 (sorted-list
	  (sort unsorted-list
	    (let ((order (if reverse? not identity-procedure)))
	      (lambda (element1 element2)
		(order
		 (let ((start1 (key-start (car element1) (cdr element1)))
		       (start2 (key-start (car element2) (cdr element2))))
		   (compare start1
			    (key-end start1 (cdr element1))
			    start2
			    (key-end start2 (cdr element2))))))))))
    (insert-reordered-region start end sorted-list unsorted-list)
    (kill-string start delete-end)
    (mark-temporary! delete-end)))

(define (identify-records region forward-record record-end)
  (let ((limit (region-end region)))
    (let next-record ((start (region-start region)))
      (if (and start (mark< start limit))
	  (let ((end (record-end start)))
	    (if (and end (mark< end limit))
		(cons (cons start (mark-temporary-copy end))
		      (next-record (forward-record end)))
		(list (cons start (mark-temporary-copy limit)))))
	  '()))))

(define (insert-reordered-region start end sorted-list unsorted-list)
  (let ((end-mark (mark-right-inserting-copy end))
	(insert-mark (mark-left-inserting-copy end)))
    (let next-element ((previous start)
		       (sorted-list sorted-list)
		       (unsorted-list unsorted-list))
      (if (null? sorted-list)
	  (if (mark< previous end-mark)
	      (insert-string
	       (extract-string previous end-mark)
	       insert-mark))
	  (begin
	    (if (mark< previous (caar unsorted-list))
		(insert-string (extract-string previous (caar unsorted-list))
			       insert-mark))
	    (insert-string
	     (extract-string (caar sorted-list)
			     (cdar sorted-list))
	     insert-mark)
	    (next-element (cdar unsorted-list)
			  (cdr sorted-list)
			  (cdr unsorted-list)))))
    (mark-temporary! end-mark)
    (mark-temporary! insert-mark)))

(define (sort-textual-comparison start1 end1 start2 end2)
  (string<? (extract-string start1 end1)
	    (extract-string start2 end2)))

(define (sort-numeric-comparison start1 end1 start2 end2)
  (let ((string1 (extract-string start1 end1))
	(string2 (extract-string start2 end2)))
    (let ((value1 (string->number string1))
	  (value2 (string->number string2)))
      (if (and value1 value2)
	  (< value1 value2)
	  (string<? string1 string2)))))

(define-command sort-lines
  "Sort lines in region in ascending order by comparing the text of
the lines.  Argument means sort in descending order."
  "P\nr"
  (lambda (reverse? region)
    (sort-region region reverse?
		 (lambda (mark) (forward-line mark 1))
		 (lambda (mark) (line-end mark 0))
		 (lambda (mark end) end mark)
		 (lambda (mark end) mark end)
		 sort-textual-comparison)))

(define-command sort-paragraphs
  "Sort paragraphs in region in ascending order by comparing the text
of the paragraphs, not including blank lines at the beginning and end.
Argument means sort in descending order."
  "P\nr"
  (lambda (reverse? region)
    (sort-region region reverse?
		 (let ((end (region-end region)))
		   (lambda (mark)
		     (skip-chars-forward " \n\r\t\f" mark end #f)))
		 paragraph-text-end
		 (lambda (mark end) end mark)
		 (lambda (mark end) end (line-end mark 0))
		 sort-textual-comparison)))

(define-command sort-pages
  "Sort pages in region in ascending order by comparing the text of
the pages.  Argument means sort in descending order."
  "P\nr"
  (lambda (reverse? region)
    (let ((end (region-end region)))
      (sort-region region reverse?
		   (lambda (mark)
		     (skip-chars-forward "\n\r" (forward-one-page mark) end #f))
		   (lambda (mark)
		     (re-match-forward "[^\f]*" mark end))
		   (lambda (mark end) end mark)
		   (lambda (mark end) end (line-end mark 0))
		   sort-textual-comparison))))

(define ((sort-fields compare) field region)
  (if (zero? field) (editor-error "Field number must be non-zero."))
  (sort-region region
	       (negative? field)
	       (lambda (mark) (forward-line mark 1))
	       (lambda (mark) (line-end mark 0))
	       (lambda (mark end)
		 (let next-whitespace
		     ((count (- (abs field) 1))
		      (mark (or (re-match-forward "\\s-+" mark end) mark)))
		   (if (zero? count)
		       mark
		       (let ((mark* (re-match-forward "\\S-+\\s-*" mark end)))
			 (if mark*
			     (next-whitespace (- count 1) mark*)
			     mark)))))
	       (lambda (mark end)
		 (or (re-match-forward "\\S-+" mark end) mark))
	       compare))

(define-command sort-fields
  "Sort lines in region in ascending order by comparing the text of
the (ABS N)th whitespace-separated field of each line.  Negative N
argument means sort in descending order."
  "p\nr"
  (sort-fields sort-textual-comparison))

(define-command sort-numeric-fields
  "Sort lines in region in ascending order by comparing the numeric
value of the (ABS N)th whitespace-separated field of each line.
Negative N argument means sort in descending order."
  "p\nr"
  (sort-fields sort-numeric-comparison))

(define-command sort-columns
  "Sort lines in region in ascending order by comparing the text from
a fixed range of columns.  Argument means sort in descending order.
Range of columns is defined to start in whatever column the region
begins and end in whatever column region ends.  Beginning of first
line, even if it extends outside region, is sorted with the rest of
the line.  The last line is treated similarly."
  "P\nr"
  (lambda (reverse? region)
    (let* ((start (region-start region))
	   (end (region-end region))
	   (start-column (mark-column start))
	   (end-column (mark-column end)))
    (sort-region (make-region (line-start start 0) (line-end end 0))
		 reverse?
		 (lambda (mark) (forward-line mark 1))
		 (lambda (mark) (line-end mark 0))
		 (lambda (mark end) end (move-to-column mark start-column))
		 (lambda (mark end) end (move-to-column mark end-column))
		 sort-textual-comparison))))