Commit 5387ee80 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Merged.

parents c05b944a 7c1a70b9
......@@ -208,7 +208,8 @@ RETURN: a path, ie. a list of nodes from START-NODE to
'(a f k l m n o t y)))
:success)
(test)
;; (test)
;;;; THE END ;;;;
......
......@@ -40,7 +40,8 @@
"HASHED-REMOVE-DUPLICATES" "HASHED-DELETE-DUPLICATES"
"DUPLICATES"
"REPLACE-SUBSEQ"
"DELETEF")
"DELETEF"
"GROUP-BY")
(:documentation
"
......@@ -51,7 +52,7 @@ License:
AGPL3
Copyright Pascal J. Bourguignon 2004 - 2014
Copyright Pascal J. Bourguignon 2004 - 2015
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
......@@ -284,6 +285,26 @@ RETURN: Either the modified SEQUENCE, or a fresh sequence of
(replace sequence insert :start1 start))))))
(defgeneric group-by (sequence n)
(:documentation "Returns a list of subsequences of SEQUENCE of length N,
whose concatenation is equal to SEQUENCE.")
(:method ((sequence vector) n)
(check-type n (integer 1))
(loop
:with length := (length sequence)
:for i :from 0 :by n
:while (< i length)
:collect (subseq sequence i (min length (+ i n)))))
(:method ((sequence list) n)
(check-type n (integer 1))
(loop
:for sub := sequence :then rest
:for rest := (nthcdr n sub)
:while sub
:collect (ldiff sub rest))))
;;; TESTS
(defun test/replace-subseq ()
(let ((*standard-output* (make-broadcast-stream)))
......@@ -319,7 +340,28 @@ RETURN: Either the modified SEQUENCE, or a fresh sequence of
(assert (nth-value 1 (ignore-errors (replace-subseq "abc" "def" -2 4))))
:success)
(defun test/group-by ()
(assert (equalp (group-by '() 3) '()))
(assert (equalp (group-by '(1) 3) '((1))))
(assert (equalp (group-by '(1 2) 3) '((1 2))))
(assert (equalp (group-by '(1 2 3) 3) '((1 2 3))))
(assert (equalp (group-by '(1 2 3 4) 3) '((1 2 3) (4))))
(assert (equalp (group-by '(1 2 3 4 5) 3) '((1 2 3) (4 5))))
(assert (equalp (group-by '(1 2 3 4 5 6) 3) '((1 2 3) (4 5 6))))
(assert (equalp (group-by '(1 2 3 4 5 6 7) 3) '((1 2 3) (4 5 6) (7))))
(assert (equalp (group-by '(1 2 3 4 5 6 7 8) 3) '((1 2 3) (4 5 6) (7 8))))
(assert (equalp (group-by #() 3) '()))
(assert (equalp (group-by #(1) 3) '(#(1))))
(assert (equalp (group-by #(1 2) 3) '(#(1 2))))
(assert (equalp (group-by #(1 2 3) 3) '(#(1 2 3))))
(assert (equalp (group-by #(1 2 3 4) 3) '(#(1 2 3) #(4))))
(assert (equalp (group-by #(1 2 3 4 5) 3) '(#(1 2 3) #(4 5))))
(assert (equalp (group-by #(1 2 3 4 5 6) 3) '(#(1 2 3) #(4 5 6))))
(assert (equalp (group-by #(1 2 3 4 5 6 7) 3) '(#(1 2 3) #(4 5 6) #(7))))
(assert (equalp (group-by #(1 2 3 4 5 6 7 8) 3) '(#(1 2 3) #(4 5 6) #(7 8))))
:success)
(test/replace-subseq)
(test/group-by)
;;;; THE END ;;;;
......@@ -38,14 +38,11 @@
(declaim (also-use-packages "ASDF"))
(defpackage "COM.INFORMATIMAGO.TOOLS.MANIFEST"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.SCRIPT"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.VERSION"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.FILE"
"SPLIT-SEQUENCE")
(:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.SCRIPT"
"CONCAT")
(:export "ASDF-SYSTEM-NAME"
"ASDF-SYSTEM-LICENSE"
"SYSTEM-DEPENDS-ON"
......@@ -132,28 +129,47 @@ stdout in a string (going thru a file)."
(defun prepare-options (options)
(mapcar (lambda (option)
(typecase option
(keyword (format nil "-~(~A~)" option))
(symbol (string-downcase option))
(string option)
(t (prin1-to-string option))))
options))
(declaim (inline trim))
(defun trim (string) (string-trim #(#\space #\tab #\newline) string))
(defun uname (&rest options)
"Without OPTIONS, return a keyword naming the system (:LINUX, :DARWIN, etc).
With options, returns the first line output by uname(1)."
(flet ((first-line (text) (subseq text 0 (position #\newline text))))
(let ((uname (shell-command-to-string "uname ~{~A~^ ~}" (prepare-options options))))
(if (and uname (plusp (length (trim uname))))
(values (if options
(first-line uname)
(intern (string-upcase (first-line uname))
"KEYWORD")))
:unknown))))
(defun distribution ()
"Return a list identifying the system, distribution and release.
RETURN: (system distrib release)
System and distrib are keywords, release is a string."
(flet ((trim (string) (string-trim #(#\space #\tab #\newline) string))
(words (string) (split-sequence-if (lambda (ch) (find ch #(#\space #\tab)))
(flet ((words (string) (split-sequence-if (lambda (ch) (find ch #(#\space #\tab)))
string :remove-empty-subseqs t)))
(let ((system #+windows :windows
;; #+(and ccl windows-target)
;; '(:cygwin :unknown "1.7.11,0.260,5,3")
#+linux :linux
#+darwin :darwin
#+(and unix (not (or linux darwin)))
(let ((uname (shell-command-to-string "uname")))
(if (and uname (plusp (length (trim uname))))
(with-input-from-string (inp uname)
(let ((*package* (find-package "KEYWORD"))
(*read-eval* nil))
(read file inp)))
:unknown)
#-(or windows linux darwin unix)
:unknown))
(let ((system #+windows :windows
;; #+(and ccl windows-target)
;; '(:cygwin :unknown "1.7.11,0.260,5,3")
#+linux :linux
#+darwin :darwin
#+(and unix (not (or linux darwin)))
(uname)
#-(or windows linux darwin unix)
:unknown)
(distrib :unknown)
(release :unknown))
(case system
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment