vendor/quickutils.lisp @ f0ec1842d603

;;;; This file was automatically generated by Quickutil.
;;;; See http://quickutil.org for details.

;;;; To regenerate:
;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-LIST :FLIP :RANGE :RCURRY :RIFFLE :SPLIT-SEQUENCE) :ensure-package T :package "CHANCERY.QUICKUTILS")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package "CHANCERY.QUICKUTILS")
    (defpackage "CHANCERY.QUICKUTILS"
      (:documentation "Package that contains Quickutil utility functions.")
      (:use #:cl))))

(in-package "CHANCERY.QUICKUTILS")

(when (boundp '*utilities*)
  (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
                                         :CURRY :ENSURE-BOOLEAN :ENSURE-LIST
                                         :FLIP :RANGE :RCURRY :RIFFLE
                                         :SPLIT-SEQUENCE))))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-gensym-list (length &optional (x "G"))
    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
using the second (optional, defaulting to `\"G\"`) argument."
    (let ((g (if (typep x '(integer 0)) x (string x))))
      (loop repeat length
            collect (gensym g))))
  )                                        ; eval-when
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;;; To propagate return type and allow the compiler to eliminate the IF when
  ;;; it is known if the argument is function or not.
  (declaim (inline ensure-function))

  (declaim (ftype (function (t) (values function &optional))
                  ensure-function))
  (defun ensure-function (function-designator)
    "Returns the function designated by `function-designator`:
if `function-designator` is a function, it is returned, otherwise
it must be a function name and its `fdefinition` is returned."
    (if (functionp function-designator)
        function-designator
        (fdefinition function-designator)))
  )                                        ; eval-when

  (defun curry (function &rest arguments)
    "Returns a function that applies `arguments` and the arguments
it is called with to `function`."
    (declare (optimize (speed 3) (safety 1) (debug 1)))
    (let ((fn (ensure-function function)))
      (lambda (&rest more)
        (declare (dynamic-extent more))
        ;; Using M-V-C we don't need to append the arguments.
        (multiple-value-call fn (values-list arguments) (values-list more)))))

  (define-compiler-macro curry (function &rest arguments)
    (let ((curries (make-gensym-list (length arguments) "CURRY"))
          (fun (gensym "FUN")))
      `(let ((,fun (ensure-function ,function))
             ,@(mapcar #'list curries arguments))
         (declare (optimize (speed 3) (safety 1) (debug 1)))
         (lambda (&rest more)
           (apply ,fun ,@curries more)))))
  

  (defun ensure-boolean (x)
    "Convert `x` into a Boolean value."
    (and x t))
  

  (defun ensure-list (list)
    "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
    (if (listp list)
        list
        (list list)))
  

  (defun flip (f)
    "Return a function whose argument order of a binary function `f` is reversed."
    #'(lambda (y x)
        (funcall f x y)))
  

  (defun range (start end &key (step 1) (key 'identity))
    "Return the list of numbers `n` such that `start <= n < end` and
`n = start + k*step` for suitable integers `k`. If a function `key` is
provided, then apply it to each number."
    (assert (<= start end))
    (loop :for i :from start :below end :by step :collecting (funcall key i)))
  

  (defun rcurry (function &rest arguments)
    "Returns a function that applies the arguments it is called
with and `arguments` to `function`."
    (declare (optimize (speed 3) (safety 1) (debug 1)))
    (let ((fn (ensure-function function)))
      (lambda (&rest more)
        (declare (dynamic-extent more))
        (multiple-value-call fn (values-list more) (values-list arguments)))))
  

  (defun riffle (list obj)
    "Insert the item `obj` in between each element of `list`."
    (loop :for (x . xs) :on list
          :collect x
          :when xs
            :collect obj))
  

  (defun split-from-end (position-fn sequence start end count remove-empty-subseqs)
    (loop
      :for right := end :then left
      :for left := (max (or (funcall position-fn sequence right) -1)
                        (1- start))
      :unless (and (= right (1+ left))
                   remove-empty-subseqs) ; empty subseq we don't want
        :if (and count (>= nr-elts count))
          ;; We can't take any more. Return now.
          :return (values (nreverse subseqs) right)
      :else
        :collect (subseq sequence (1+ left) right) into subseqs
        :and :sum 1 :into nr-elts
      :until (< left start)
      :finally (return (values (nreverse subseqs) (1+ left)))))

  (defun split-from-start (position-fn sequence start end count remove-empty-subseqs)
    (let ((length (length sequence)))
      (loop
        :for left := start :then (+ right 1)
        :for right := (min (or (funcall position-fn sequence left) length)
                           end)
        :unless (and (= right left)
                     remove-empty-subseqs) ; empty subseq we don't want
          :if (and count (>= nr-elts count))
            ;; We can't take any more. Return now.
            :return (values subseqs left)
        :else
          :collect (subseq sequence left right) :into subseqs
          :and :sum 1 :into nr-elts
        :until (>= right end)
        :finally (return (values subseqs right)))))
  
  (macrolet ((check-bounds (sequence start end)
               (let ((length (gensym (string '#:length))))
                 `(let ((,length (length ,sequence)))
                    (check-type ,start unsigned-byte "a non-negative integer")
                    (when ,end (check-type ,end unsigned-byte "a non-negative integer or NIL"))
                    (unless ,end
                      (setf ,end ,length))
                    (unless (<= ,start ,end ,length)
                      (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end))))))

    (defun split-sequence (delimiter sequence &key (start 0) (end nil) (from-end nil)
                                                   (count nil) (remove-empty-subseqs nil)
                                                   (test #'eql) (test-not nil) (key #'identity))
      "Return a list of subsequences in seq delimited by delimiter.

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded.  All other keywords
work analogously to those for CL:SUBSTITUTE.  In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
      (check-bounds sequence start end)
      (cond
        ((and (not from-end) (null test-not))
         (split-from-start (lambda (sequence start)
                             (position delimiter sequence :start start :key key :test test))
                           sequence start end count remove-empty-subseqs))
        ((and (not from-end) test-not)
         (split-from-start (lambda (sequence start)
                             (position delimiter sequence :start start :key key :test-not test-not))
                           sequence start end count remove-empty-subseqs))
        ((and from-end (null test-not))
         (split-from-end (lambda (sequence end)
                           (position delimiter sequence :end end :from-end t :key key :test test))
                         sequence start end count remove-empty-subseqs))
        ((and from-end test-not)
         (split-from-end (lambda (sequence end)
                           (position delimiter sequence :end end :from-end t :key key :test-not test-not))
                         sequence start end count remove-empty-subseqs))))

    (defun split-sequence-if (predicate sequence &key (start 0) (end nil) (from-end nil)
                                                      (count nil) (remove-empty-subseqs nil) (key #'identity))
      "Return a list of subsequences in seq delimited by items satisfying
predicate.

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded.  All other keywords
work analogously to those for CL:SUBSTITUTE-IF.  In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
      (check-bounds sequence start end)
      (if from-end
          (split-from-end (lambda (sequence end)
                            (position-if predicate sequence :end end :from-end t :key key))
                          sequence start end count remove-empty-subseqs)
          (split-from-start (lambda (sequence start)
                              (position-if predicate sequence :start start :key key))
                            sequence start end count remove-empty-subseqs)))

    (defun split-sequence-if-not (predicate sequence &key (count nil) (remove-empty-subseqs nil)
                                                          (from-end nil) (start 0) (end nil) (key #'identity))
      "Return a list of subsequences in seq delimited by items satisfying
\(CL:COMPLEMENT predicate).

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded.  All other keywords
work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
the behaviour of :from-end is possibly different from other versions
of this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
      (check-bounds sequence start end)
      (if from-end
          (split-from-end (lambda (sequence end)
                            (position-if-not predicate sequence :end end :from-end t :key key))
                          sequence start end count remove-empty-subseqs)
          (split-from-start (lambda (sequence start)
                              (position-if-not predicate sequence :start start :key key))
                            sequence start end count remove-empty-subseqs))))
  
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(curry ensure-boolean ensure-list flip range rcurry riffle
            split-sequence split-sequence-if split-sequence-if-not)))

;;;; END OF quickutils.lisp ;;;;