;;;; This file is part of P36-lib
;;;; Copyright (C) 2016-2019 Alexa Jones-Gonzales <alexa@partition36.com>
;;;;
;;;; 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 3 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, see <http://www.gnu.org/licenses/>.
(in-package :p36-lib)
(defun caseless-string= (str1 str2 &key (start1 0) end1 (start2 0) end2)
(declare (optimize (space 0) (safety 1) (debug 1) (compilation-speed 0))
(type (or simple-string character) str1 str2)
(inline))
(string= (string-downcase str1) (string-downcase str2)
:start1 start1 :end1 end1
:start2 start2 :end2 end2))
(defun pretty-print-bytes (size &key always-show-in-bytes (decimal-places 2) (padding 0) (pad-char #\Space))
"Prints SIZE in such a way that it can be a human readable size.
This always outputs using binary units (e.g., KiB instead of KB).
Optional padding can be placed on the left side of the output to
ensure the resulting string is at least PADDING characters wide,
including the suffix."
(declare (type number size)
(type fixnum decimal-places)
(type fixnum padding)
(type character pad-char))
(let ((suffixes '("Bytes" "KiB" "MiB" "GiB" "TiB" "PiB" "EiB" "ZiB" "YiB"))
(mag 0)
(human-size 0)
(main-fmt-str (format nil "~~~d,1,0,'~a@a" padding pad-char))
(byte-fmt-str (format nil "~~:d Bytes"))
(human-fmt-str (format nil "~~,~df ~~a" decimal-places)))
(cond
(always-show-in-bytes
(format nil main-fmt-str (format nil byte-fmt-str size)))
(t
(setf mag (if (> size 0)
(truncate (log size 1024))
0))
(setf human-size (if (> size 0)
(float (/ size (ash 1 (* mag 10))))
0))
(format nil main-fmt-str
(if (= mag 0)
(format nil byte-fmt-str (truncate human-size))
(format nil human-fmt-str human-size (nth mag suffixes))))))))
(defun split-string (str char &optional dont-drop)
"Splits a string STR at each instance of CHAR, returning a vector of
each substring. If DONT-DROP is non-NIL, then CHAR is included in
each substring."
(declare (type string str)
(type character char)
(optimize (speed 3)))
(when (= (length str) 0)
(return-from split-string #()))
(let ((all-pos (make-array 1 :element-type 'fixnum
:adjustable t :fill-pointer 1
:initial-contents '(0))))
(declare (type (vector fixnum) all-pos))
(let ((last-pos 0))
(loop for pos = (position char str :start (1+ last-pos) :test #'eql)
while pos do
(progn
(setf last-pos pos)
(vector-push-extend pos all-pos)))
(setf last-pos 0)
(loop for pos across (subseq all-pos 1)
with ret = (make-array 0 :element-type 'string :adjustable t :fill-pointer 0)
do
(progn
(vector-push-extend (subseq str last-pos (if dont-drop (1+ pos) pos)) ret)
(setf last-pos (1+ pos)))
finally
(progn
(vector-push-extend (subseq str last-pos) ret)
(return ret))))))
(defun print-indented-string (text width indent-length
&key (max-width 80)
(stream *standard-output*)
(indent-first-line nil)
(indent-char #\Space))
(declare (type simple-string text)
(type (unsigned-byte 32) width indent-length max-width)
(type standard-char indent-char)
(type stream stream)
(type boolean indent-first-line)
(optimize (speed 3) (safety 0) (space 0) (debug 1) (compilation-speed 0)))
(let ((pos 0)
(max-line-width 0)
(last-space-pos 0)
(increment 0)
(text-block "")
(on-first-line t))
(declare (type (unsigned-byte 32) pos max-line-width increment last-space-pos)
(type simple-string text-block)
(type boolean on-first-line))
;; POS must always be under the length of our string
(loop while (< pos (length text)) do
;; We have extra to do if we're not on the first
;; line (or INDENT-FIRST-LINE is non-NIL)
(cond
;; Subtract the size of the indent from the maximum width.
;; This is how much text we can print not including the
;; indent.
((or (not on-first-line) indent-first-line)
(setf max-line-width (- max-width indent-length))
(format stream "~a" (make-string indent-length :initial-element indent-char)))
;; If we don't indent the first line, that line's maximum
;; width is always the same as MAX-WIDTH
(t (setf max-line-width width)))
;; We're not on the first line after this
(setf on-first-line nil)
;; See if we can write out the rest of the string on
;; this line or not
(when (>= (+ pos max-line-width) (length text))
(format stream "~a~%" (string-trim '(#\Space) (subseq text pos)))
(return-from print-indented-string))
;; We couldn't write out the rest of the string, so
;; get the next block of text.
(setf text-block (subseq text pos (+ pos max-line-width)))
(cond
;; If this block doesn't contain a space, just write
;; out the entire block. If it wraps, it
;; wraps... we don't handle hyphenation.
((not (find #\Space text-block :test #'equal))
(format stream "~a~%" (string-trim '(#\Space) text-block))
;; Update the position
(incf pos max-line-width))
;; The block does have a space. Find the position of the
;; final space in the block.
(t (setf last-space-pos (position #\Space text-block :from-end t :test #'equal))
(setf increment max-line-width)
(cond
;; If the only space is the very first
;; character, output the block (minus the space)
;; and then go to the bottom of the loop
((= last-space-pos 0)
(format stream "~a~%" (subseq text-block 1))
(incf pos max-line-width))
;; Possibly update the block so that it goes up to the last
;; space.
(t (when (not (equal (elt text-block (1- max-line-width)) #\Space))
(setf text-block (subseq text pos (+ pos last-space-pos)))
(setf increment (1+ last-space-pos)))
;; Write out the block
(format stream "~a~%" (string-trim '(#\Space) text-block))
;; Do some housekeeping
(incf pos increment))))))))
(defmacro indent-string (text width indent-length
&key (max-width 80)
(indent-first-line nil indent-first-line-supplied)
(indent-char #\Space))
(with-gensyms (out)
`(with-output-to-string (,out)
,(let ((func (list 'print-indented-string text width indent-length
:max-width max-width
:stream out
:indent-char indent-char)))
(when indent-first-line-supplied
(setf func (append func (list :indent-first-line indent-first-line))))
func))))
(defun string-replace (string part replacement &key (test #'char=))
"Returns a new string in which all the occurences of the part is
replaced with replacement.
Taken from The Common Lisp Cookbook
http://cl-cookbook.sourceforge.net/index.html"
(declare (type string string part replacement)
(type function test)
(optimize (compilation-speed 0)))
(with-output-to-string (out)
(loop with part-length = (length part)
for old-pos fixnum = 0 then (+ pos part-length)
for pos = (search part string
:start2 old-pos
:test test)
do (write-string string out
:start old-pos
:end (or pos (length string)))
when pos do (write-string replacement out)
while pos)))