lisp/combos.lisp @ a65fd2691c94 default tip

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload '(:adopt :str :alexandria) :silent t))

(defpackage :combos
  (:use :cl)
  (:export :toplevel :*ui*))

(in-package :combos)


;;;; Configuration ------------------------------------------------------------
(defparameter *n* 2)
(defparameter *trim* t)
(defparameter *mode* nil)
(defparameter *output-sep-field* " ")
(defparameter *output-sep-record* (string #\newline))
(defparameter *input-sep* (string #\newline))

(defvar *first* t)

;;;; Functionality ------------------------------------------------------------
(defun print-record (fields)
  (if *first*
    (setf *first* nil)
    (write-string *output-sep-record*))
  (write-string (str:join *output-sep-field* fields)))

(defun print-record% (&rest fields)
  (print-record fields))

(defun run/permutations (lines) (alexandria:map-permutations #'print-record lines :length *n*))
(defun run/combinations (lines) (alexandria:map-combinations #'print-record lines :length *n*))
(defun run/derangements (lines) (alexandria:map-derangements #'print-record lines))
(defun run/product (lines)
  (apply #'alexandria:map-product #'print-record% (loop :repeat *n* :collect lines)))

(defun run ()
  (let* ((input (alexandria:read-stream-content-into-string *standard-input*))
         (lines (str:split *input-sep* input :omit-nulls t)))
    (when *trim*
      (setf lines (mapcar #'str:trim lines)))
    (setf *first* t)
    (funcall (ecase *mode*
               (:permutations #'run/permutations)
               (:combinations #'run/combinations)
               (:derangements #'run/derangements)
               (:product #'run/product))
             lines)))


;;;; User Interface -----------------------------------------------------------
(defparameter *option/help*
  (adopt:make-option 'help
    :help "Display help and exit."
    :long "help"
    :short #\h
    :reduce (constantly t)))

(defparameter *option/version*
  (adopt:make-option 'version
    :help "Display version information and exit."
    :long "version"
    :reduce (constantly t)))

(defparameter *option/n*
  (adopt:make-option 'n
    :help "Size of permutations/combinations/derangements (default 2)."
    :parameter "N"
    :long "length"
    :short #\n
    :reduce #'adopt:last
    :initial-value 2
    :key #'parse-integer))

(defparameter *option/mode/permutations*
  (adopt:make-option 'mode
    :help "Output permutations of the input lines."
    :long "permutations"
    :short #\P
    :reduce (constantly :permutations)))

(defparameter *option/mode/combinations*
  (adopt:make-option 'mode
    :help "Output combinations of the input lines."
    :long "combinations"
    :short #\C
    :reduce (constantly :combinations)))

(defparameter *option/mode/derangements*
  (adopt:make-option 'mode
    :help "Output derangements of the input lines (ignores -n)."
    :long "derangements"
    :short #\D
    :reduce (constantly :derangements)))

(defparameter *option/mode/product*
  (adopt:make-option 'mode
    :help "Output cartesian product of the input lines."
    :long "cartesian-product"
    :short #\X
    :reduce (constantly :product)))

(defparameter *option/input-sep*
  (adopt:make-option 'input-sep
    :help "Input separator (default newline)."
    :parameter "SEP"
    :long "input-separator"
    :short #\i
    :reduce #'adopt:last
    :initial-value (string #\newline)))

(defparameter *option/input-sep-nul*
  (adopt:make-option 'input-sep-nul
    :result-key 'input-sep
    :help "Use NUL byte as input separator."
    :long "input-separator-0"
    :reduce (constantly (string #\nul))))

(defparameter *option/output-sep/field*
  (adopt:make-option 'output-sep/field
    :help "Output field separator (default \" \")."
    :parameter "SEP"
    :long "output-field-separator"
    :short #\f
    :reduce #'adopt:last
    :initial-value " "))

(defparameter *option/output-sep/field-nul*
  (adopt:make-option 'output-sep/field-nul
    :result-key 'output-sep/field
    :help "Use NUL byte as field separator."
    :long "output-field-separator-0"
    :reduce (constantly (string #\nul))))

(defparameter *option/output-sep/record*
  (adopt:make-option 'output-sep/record
    :help "Output record separator (default newline)."
    :parameter "SEP"
    :long "output-record-separator"
    :short #\r
    :reduce #'adopt:last
    :initial-value (string #\newline)))

(defparameter *option/output-sep/record-nul*
  (adopt:make-option 'output-sep/record-nul
    :result-key 'output-sep/record
    :help "Use NUL byte as record separator."
    :long "output-record-separator-0"
    :reduce (constantly (string #\nul))))

(adopt:defparameters (*option/trim* *option/no-trim*)
  (adopt:make-boolean-options 'trim
    :short #\t
    :long "trim"
    :help "Trim whitespace from input (the default)."
    :help-no "Do not trim whitespace from input."
    :initial-value t))


(adopt:define-string *help-text*
  "combos takes entries from standard input, combines them (as permutations, ~
   combinations, derangements, or the cartesian product) and outputs the ~
   resulting combos to standard output.")

(defparameter *examples*
  '(("Print 2-length permutations of 1..4:"
     . "seq 4 | combos --permutations -n 2")
    ("Print comma-separated 3-length combinations of 1..5:"
     . "seq 5 | combos --combinations -n 3 -f ,")
    ("Print every possible pairing of NUL delimited input:"
     . "find . -name '*.lisp' -print0 | combos --cartesian-product --input-separator-0 -n 2")))

(defparameter *ui*
  (adopt:make-interface
    :name "combos"
    :usage "MODE [OPTIONS]"
    :summary "combine and output lines of input"
    :help *help-text*
    :examples *examples*
    :contents (list
                *option/help*
                *option/version*
                (adopt:make-group 'input-options
                  :title "Input Options"
                  :options (list *option/input-sep*
                                 *option/input-sep-nul*
                                 *option/trim*
                                 *option/no-trim*))
                (adopt:make-group 'output-options
                  :title "Output Options"
                  :options (list *option/mode/permutations*
                                 *option/mode/combinations*
                                 *option/mode/derangements*
                                 *option/mode/product*
                                 *option/n*
                                 *option/output-sep/field*
                                 *option/output-sep/field-nul*
                                 *option/output-sep/record*
                                 *option/output-sep/record-nul*)))))


(defun toplevel ()
  (adopt::quit-on-ctrl-c ()
    (multiple-value-bind (arguments options) (adopt:parse-options-or-exit *ui*)
      (when (gethash 'help options)
        (adopt:print-help-and-exit *ui*))
      (let ((*mode* (gethash 'mode options))
            (*n* (gethash 'n options))
            (*output-sep-field* (gethash 'output-sep/field options))
            (*output-sep-record* (gethash 'output-sep/record options))
            (*input-sep* (gethash 'input-sep options))
            (*trim* (gethash 'trim options)))
        (handler-case
            (progn
              (assert (null arguments) () "No arguments accepted.")
              (run))
          (error (e)
                 (adopt:print-error-and-exit e)))))))