;; Copyright 2006 Pablo Barenbaum

;; This program 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.

;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

(defvar *blanks* '(#\Space #\Tab #\Newline #\Return))
(defvar *tabs* '(#\Tab))
(defvar *comment-markers* `(#\;))
(defvar *tab-width* 8)

(defun width (char)
 (if (member char *tabs*)
   *tab-width*
   1))

(defun distance (str)
(do ((col 0 (+ col (width (aref str col)))))
  ((not (member (aref str col) *blanks* :test #'char=))
   col)))

(defun trim-blanks (str)
 (string-trim *blanks* str))

(defun blank-line-p (str)
(let ((trimmed (trim-blanks str)))
  (or (string= "" trimmed)
      (member (aref trimmed 0) *comment-markers* :test #'char=))))

(defun last-line-p (line)
(or (eq line 'eof) (string= (trim-blanks line) "!#")))

(defun read-off-side-to-string (stream)
(let ((prev-lines (list (list "PROGN")))
      (prev-dists (list -1))
      (prev-dist -1))
  (flet ((pop-expr ()
           (let* ((tail (pop prev-lines))
                  (head (pop (first prev-lines))))
             (push
               (format nil "(~A~%~{~A~%~})" head (nreverse tail))
               (first prev-lines))))
         (next-line ()
	   (loop for line = (read-line stream nil 'eof)
                  while (and (not (eq line 'eof)) (blank-line-p line))
                  finally (return line))))
    (with-output-to-string (s)
      (loop
        for line = (next-line)
        while (not (last-line-p line))
        do (let ((dist (distance line)))
             (when (> dist prev-dist)
               (push dist prev-dists)
               (push (list) prev-lines))
             (loop while (and (not (null (cdr prev-dists)))
                              (< dist (car prev-dists)))
                   do (pop prev-dists)
                   do (pop-expr))
             (push line (first prev-lines))
             (setf prev-dist dist)))

      (loop while (not (null (cdr prev-dists)))
            do (pop prev-dists)
            do (pop-expr))
      (format s "~{~A~%~}" (nreverse (pop prev-lines)))))))

(defun read-off-side (stream c n)
 (let ((r (nth-value 0 (read-from-string (read-off-side-to-string stream)))))
   (if (atom r)
     (list r)
     r)))