toolkit.lisp

(in-package #:org.shirakumo.text-draw)

(defmacro with-normalized-stream ((stream streamish) &body body)
  (let ((thunk (gensym "THUNK")))
    `(let ((,stream ,streamish))
       (flet ((,thunk (,stream) ,@body))
         (etypecase ,stream
           (stream (,thunk ,stream))
           ((eql T) (,thunk *standard-output*))
           (null (with-output-to-string (,stream)
                   (,thunk ,stream))))))))

(defun split (string split)
  (let ((items ()) (out (make-string-output-stream)))
    (flet ((push-item ()
             (let ((string (get-output-stream-string out)))
               (when (string/= "" string)
                 (push string items)))))
      (loop for char across string
            do (if (char= char split)
                   (push-item)
                   (write-char char out))
            finally (push-item))
      (nreverse items))))

(defun white-char-p (char)
  (and (not (char= char (code-char #x00A0)))
       #+sb-unicode (sb-unicode:whitespace-p char)
       #-sb-unicode (member char '(#\Space #\Tab))))

(defun wrap-char-p (char)
  (and (not (char= char #\Linefeed))
       (not (char= char #\Return))
       (not (char= char (code-char #x00A0)))
       (white-char-p char)))

(defun wrap (line &optional (width most-positive-fixnum))
  (let ((lines ())
        (line-start 0)
        (last-candidate 0))
    (flet ((push-line (at)
             ;; Backscan AT to exclude trailing whitespace
             (let ((start at))
               (loop while (and (< line-start start) (white-char-p (char line (1- start)))) do (decf start))
               (push (subseq line line-start start) lines))
             ;; Forwscan AT to exclude following whitespace
             (loop while (and (< at (length line)) (wrap-char-p (char line at))) do (incf at))
             (setf line-start at last-candidate at)))
      (loop for i from 0 below (length line)
            for char = (char line i)
            do (cond ((< (- i line-start) width)
                      (cond ((member char '(#\Return #\Linefeed))
                             (push-line (1+ i)))
                            ((wrap-char-p char)
                             (setf last-candidate i))))
                     ((= line-start last-candidate)
                      (push-line i))
                     (T
                      (push-line last-candidate)))
            finally (when (< line-start (length line))
                      (push (subseq line line-start) lines)))
      (nreverse lines))))

(defun alignment (alignment line width)
  (let ((diff (- width (length line))))
    (if (<= diff 0)
        (cons 0 0)
        (ecase alignment
          ((:left) (cons 0 diff))
          ((:right) (cons diff 0))
          ((:middle :center) (cons (truncate diff 2) (- diff (truncate diff 2))))))))

(defun lines (text)
  (with-input-from-string (text text)
    (loop for line = (read-line text NIL NIL)
          while line collect line)))

(defun width (text)
  (with-input-from-string (text text)
    (loop for line = (read-line text NIL NIL)
          while line maximize (length line))))