More
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Thu, 20 Nov 2025 11:24:53 -0500 |
| parents |
a65fd2691c94 |
| children |
(none) |
(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 'output-options
:title "Output Options"
:options (list *option/mode/permutations*
*option/mode/combinations*
*option/mode/derangements*
*option/mode/product*
*option/n*))
(adopt:make-group 'input-options
:title "Input Options"
:options (list *option/trim*
*option/no-trim*))
(adopt:make-group 'separators
:title "File Separator Options"
:options (list *option/input-sep*
*option/input-sep-nul*
*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* :option-width 23))
(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)))))))