src/utilities.lisp @ 84fa1724b747 default tip

(in-package :tdcb)

(define-modify-macro ashf (count) ash "Arithmetic shift in place")
(define-modify-macro logiorf (&rest integers) logior "Logical inclusive or in place")

(deftype u8 () '(unsigned-byte 8))


(defun random-bytes (length &aux (result (make-array length)))
  (dotimes (i length)
    (setf (aref result i) (random 256)))
  result)


(defun compress-octets (function data)
  (let* ((in (flexi-streams:make-in-memory-input-stream data))
         (out (flexi-streams:make-in-memory-output-stream)))
    (with-bits-output (out out)
      (funcall function in out))
    (let ((result (flexi-streams:get-output-stream-sequence out)))
      (values result
              (list :data (length data)
                    :result (length result)
                    :ratio (coerce (/ (length result) (length data))
                                   'double-float))))))

(defun compress-string (function string)
  (compress-octets function (flexi-streams:string-to-octets string :external-format :utf-8)))

(defun extract-octets (function data)
  (let ((in (flexi-streams:make-in-memory-input-stream data))
        (out (flexi-streams:make-in-memory-output-stream)))
    (with-bits-input (in in)
      (funcall function in out))
    (flexi-streams:get-output-stream-sequence out)))

(defun extract-string (function data)
  (flexi-streams:octets-to-string (extract-octets function data)
                                  :external-format :utf-8))

(defun roundtrip-octets (compress extract octets)
  (multiple-value-bind (data stats) (compress-octets compress octets)
    (let ((result (extract-octets extract data)))
      (assert (equal octets result))
      stats)))

(defun roundtrip-string (compress extract string)
  (multiple-value-bind (data stats) (compress-string compress string)
    (let ((result (extract-string extract data)))
      (assert (string= string result))
      stats)))

(defun stress-test (compress extract)
  (iterate
    (for length :from 2 :below 200 :by 3)
    (format t "Testing random vectors of length ~D…~%" length)
    (dotimes (_ 1000)
      (roundtrip-octets compress extract (random-bytes length)))))