Commit a77441a8 authored by Nikodemus Siivola's avatar Nikodemus Siivola

new: flatten, map-product, setp. fixed: set-equal

parent 57badd5e
......@@ -6,11 +6,11 @@
(:static-file "tests.lisp")
(:file "package")
(:file "hash-tables" :depends-on ("package"))
(:file "functions" :depends-on ("package"))
(:file "lists" :depends-on ("package"))
(:file "sequences" :depends-on ("package"))
(:file "macros" :depends-on ("package"))
(:file "symbols" :depends-on ("package"))
(:file "arrays" :depends-on ("package"))
(:file "types" :depends-on ("package"))
(:file "functions" :depends-on ("package" "symbols"))
(:file "lists" :depends-on ("package" "functions"))
(:file "numbers" :depends-on ("package" "sequences"))))
......@@ -134,7 +134,10 @@ terms and conditions:
@include include/fun-alexandria-ensure-list.texinfo
@include include/fun-alexandria-sans.texinfo
@include include/fun-alexandria-mappend.texinfo
@include include/fun-alexandria-map-product.texinfo
@include include/fun-alexandria-set-equal.texinfo
@include include/fun-alexandria-setp.texinfo
@include include/fun-alexandria-flatten.texinfo
@node Sequence Manipulation
@comment node-name, next, previous, up
......
......@@ -90,7 +90,6 @@ it is called with to FUNCTION."
`(let ,(mapcar #'list curries arguments)
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest more)
(declare (dynamic-extent more))
(apply ,function ,@curries more)))))
(defun rcurry (function &rest arguments)
......
......@@ -111,23 +111,61 @@ all the result list to a single list. FUNCTION must return a list."
(loop for results in (apply #'mapcar function lists)
append results))
(defun set-equal (list1 list2 &key (test #'eql) (key #'identity))
(defun setp (object &key (test #'eql) (key #'identity))
"Returns true if OBJECT is a list that denotes a set, NIL otherwise. A list
denotes a set if each element of the list is unique under KEY and TEST."
(and (listp object)
(let (seen)
(dolist (elt object t)
(let ((key (funcall key elt)))
(if (member key seen :test test)
(return nil)
(push key seen)))))))
(defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
"Returns true if every element of LIST1 matches some element of LIST2 and
every element of LIST2 matches some element of LIST1. Otherwise returns false."
(let* ((table1 (make-hash-table :test test))
(table2 (make-hash-table :test test))
(keylist1 (mapcar (lambda (elt)
(let ((elt-key (funcall key elt)))
(setf (gethash elt-key table1) t)
elt-key))
list1)))
(dolist (elt list2)
(let ((elt-key (funcall key elt)))
(unless (gethash elt-key table1)
(return-from set-equal nil))
(setf (gethash elt-key table2) t)))
(dolist (elt-key keylist1)
(unless (gethash elt-key table2)
(return-from set-equal nil))))
t)
(let ((keylist1 (if keyp (mapcar key list1) list1))
(keylist2 (if keyp (mapcar key list2) list2)))
(and (dolist (elt keylist1 t)
(or (member elt keylist2 :test test)
(return nil)))
(dolist (elt keylist2 t)
(or (member elt keylist1 :test test)
(return nil))))))
(defun map-product (function list &rest more-lists)
"Returns a list containing the results of calling FUNCTION with one argument
from LIST, and one from each of MORE-LISTS for each combination of arguments.
In other words, returns the product of LIST and MORE-LISTS using FUNCTION.
Example:
(map-product 'list '(1 2) '(3 4) '(5 6)) => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
(2 3 5) (2 3 6) (2 4 5) (2 4 6))
"
(labels ((%map-product (f lists)
(let ((more (cdr lists))
(one (car lists)))
(if (not more)
(mapcar f one)
(mappend (lambda (x)
(%map-product (curry f x) more))
one)))))
(%map-product (if (functionp function)
function
(fdefinition function))
(cons list more-lists))))
(defun flatten (tree)
"Traverses the tree in order, collecting non-null leaves into a list."
(let (list)
(labels ((traverse (subtree)
(when subtree
(if (consp subtree)
(progn
(traverse (car subtree))
(traverse (cdr subtree)))
(push subtree list)))))
(traverse tree))
(nreverse list)))
......@@ -30,8 +30,11 @@
#:proper-list-p
#:proper-list
#:mappend
#:map-product
#:flatten
#:sans
#:set-equal
#:setp
;; Numbers
#:clamp
#:gaussian-random
......
......@@ -342,6 +342,67 @@
(ensure-list y)))
((1) (2)))
(deftest setp.1
(setp '(1))
t)
(deftest setp.2
(setp nil)
t)
(deftest setp.3
(setp "foo")
nil)
(deftest setp.4
(setp '(1 2 3 1))
nil)
(deftest setp.5
(setp '(1 2 3))
t)
(deftest setp.6
(setp '(a :a))
t)
(deftest setp.7
(setp '(a :a) :key 'character)
nil)
(deftest setp.8
(setp '(a :a) :key 'character :test (constantly nil))
t)
(deftest set-equal.1
(set-equal '(1 2 3) '(3 1 2))
t)
(deftest set-equal.2
(set-equal '("Xa") '("Xb")
:test (lambda (a b) (eql (char a 0) (char b 0))))
t)
(deftest set-equal.3
(set-equal '(1 2) '(4 2))
nil)
(deftest set-equal.4
(set-equal '(a b c) '(:a :b :c) :key 'string :test 'equal)
t)
(deftest set-equal.5
(set-equal '(a d c) '(:a :b :c) :key 'string :test 'equal)
nil)
(deftest map-product.1
(map-product 'cons '(2 3) '(1 4))
((2 . 1) (2 . 4) (3 . 1) (3 . 4)))
(deftest flatten.1
(flatten '((1) 2 (((3 4))) ((((5)) 6)) 7))
(1 2 3 4 5 6 7))
(deftest sans.1
(let ((orig '(a 1 b 2 c 3 d 4)))
(list (sans orig 'a 'c)
......
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