#!MUNGERPATH

; Copyright (c) 2004, 2026, James Bailie <jimmy@mammothcheese.ca>.
; All rights reserved.
; 
; Redistribution and use in source form, with or without
; modification, are permitted provided that the following conditions are met:
; 
;     * Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;     * The name of James Bailie may not be used to endorse or promote 
; products derived from this software without specific prior written permission.
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS"
; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.

; This script emulates the "fmt" utility.  It is much less efficient than
; the system format because this version uses regular expressions.

; The script recognizes three optional arguments:

; -l n specifies the desired line length of output lines.  Defaults to 75
;      characters.

; -t n specifies where tabstops occur.  Defaults to every 8 columns.

; -p   by itself indicates the script should only format the text appearing 
;      after a prefix string consisting of non-alphanumeric characters,
;      optionally delimited by whitespace.  The prefix string is extracted
;      from the first input line and printed at the beginning of all output 
;      lines.  This option can also be used to cause the leading whitespace 
;      of the first input line to be propagated to all the output lines, 
;      which means with this option, you can prevent leading whitespace
;      from being consumed during the reflow operation.
;      Prefixes are not recognized by default.

(fatal)                  ; Exit on lisp errors.

(setq len 75)            ; Default desired line length of output lines.
(setq tabstop 8)         ; Default tabstop periodicity.
(setq prefix "")         ; Variable to hold quote or comment
                         ; prefix if we are recognizing one.

(setq current_line "")   ; Working variable holding text accumulated
                         ; from the current paragraph.

; Regexp used to detect quote and comment prefixes, and indentation.

(setq prefix_rx (regcomp "^([\b\t]*[^A-Za-z0-9\b\t\"'`&<(]*[\b\t]*)([^\b\t])?"))

; Regexps used to detect leading and trailing whitespace, and strings composed
; entirely of whitespace.

(setq trail_rx (regcomp "\b*$"))
(setq lead_rx (regcomp "^\b+(.*)"))
(setq space_rx (regcomp "^\b*$"))

; Regexp used to find the breakpoint when wrapping long lines.

(setq wrap_rx (regcomp "^(.*[^\b])?\b+([^\b]+)?$"))

; Check for options.  Don't allow a value <= 0.

(load (join "/" (libdir) "options.munger"))
(getopt "p")

(let ((arg ()))

   (when (setq arg (lookup options "l"))
      (setq len (or (abs (digitize arg)) 75)))

   (when (setq arg (lookup options "p"))
      (setq prefix arg))

   (when (setq arg (lookup options "t"))
      (setq tabstop (or (abs (digitize arg)) 8))))

; This function is called to continue to process unprocessed input for the
; current paragraph, after we have stopped receiving input for the current
; paragraph.

(defun print_rest (last)

   ; Feed process_line dummy lines, to get it to work through the remaining
   ; stored text.

   (while (process_line ""))

   ; process_line will return 0 when there is insufficient stored text left to
   ; break into two lines.  This means a last short line may still be present
   ; in current_line.  If so, we print it out.

   (when (not (eq current_line ""))
      (print prefix current_line (char 10)))

   ; If this function is called with a "last" argument of 0, then the script
   ; has encountered a blank line between paragraphs, so we need to print a
   ; blank line and clear out the last line of input data.  Otherwise, the
   ; script has reached the end of input data, and we need do nothing more.

   (unless last 
      (print prefix (char 10))
      (setq current_line "")))

; Wrapper function for process_line, which detects paragraph-separating blank
; lines, and removes quote and comment prefixes if we are recognizing them.

(defun wrapper (line)

   ; Remove terminators and expand tabs.

   (setq line (expand tabstop (chomp line)))

   ; If we're recognizing prefixes and this is the first line read, record the
   ; prefix and alter the line length as necessary.

   (when (eq prefix 1)
      (setq prefix (cadr (matches prefix_rx line)))

      ; If the prefix found is longer than the specified line length, ignore
      ; the request to recognize prefixes.

      (let ((old len))
         (when (<= (setq len (- len (length prefix))) 0)
            (setq prefix "")
            (setq len old))))

   ; If we're recognizing prefixes, remove the prefix from the line.

   (when (not (eq prefix ""))
      (setq line (substitute prefix_rx "\2" line)))

   ; Do we have a paragraph separating blank line, or text?

   (if (match space_rx line)
      (print_rest 0)
      (process_line line)))

; Function which does the reflow.

(defun process_line (line)

   ; First section appends new input line to stored text with separator.
   ; Trailing whitespace is removed.

   (setq current_line 
      (concat current_line 

         (if (or (eq line "") (eq current_line ""))
            ""
            " ")

         (substitute trail_rx "" line)))

   ; Second section is executed only when we have enough stored text to split
   ; off a new line of the specified width.

   (when (> (length current_line) len)

      ; The stored text is split at the desired width.

      (letn ((before (substring current_line 0 len))
             (after (substring current_line len 0))
             (m ())
             (m2 (matches lead_rx after))
             (len2 (length after)))

         (if m2

            ; This clause is executed if the stored text splits naturally
            ; before a chunk of whitespace.  If the part of the stored text
            ; before the split is not whitespace, we print it as a new line,
            ; trimming any trailing whitespace, and update the stored text.

            (progn
               (unless (match space_rx before)
                  (print prefix (substitute trail_rx "" before) (char 10)))
               (setq current_line (cadr m2)))

            ; Otherwise if wrap_rx does not match the segment of the stored
            ; text before the split location, that means there is no
            ; whitespace in that segment, so we move the location of the split
            ; forward until we either run out of characters, or we find some
            ; whitespace to break the line at.

            (while (and (not (setq m (matches wrap_rx before))) len2)
               (setq before (concat before (substring after 0 1)))
               (setq after (if (> len2 1) (substring after 1 0) ""))
               (dec len2))

            (if (not m)

               ; This clause executes if there is no whitespace left in the
               ; stored input text.  We just spit it all out as a one big
               ; line, and clear out the stored text.

               (progn
                  (print prefix current_line (char 10))
                  (setq current_line ""))

               ; Otherwise, we print the segment of the stored text before the
               ; (possibly new) split location and update the stored text
               ; text.

               (when (cadr m) (print prefix (cadr m) (char 10)))
               (setq current_line (concat (car (cddr m)) after)))))))

(foreach_line wrapper)
(print_rest 1)
(exit 0)
