Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Momchil Ivanov
alexandria
Commits
a77441a8
Commit
a77441a8
authored
Oct 16, 2006
by
Nikodemus Siivola
Browse files
new: flatten, map-product, setp. fixed: set-equal
parent
57badd5e
Changes
6
Hide whitespace changes
Inline
Side-by-side
alexandria.asd
View file @
a77441a8
...
...
@@ -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"
))))
doc/alexandria.texinfo
View file @
a77441a8
...
...
@@ -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
...
...
functions.lisp
View file @
a77441a8
...
...
@@ -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
)
...
...
lists.lisp
View file @
a77441a8
...
...
@@ -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
)))
package.lisp
View file @
a77441a8
...
...
@@ -30,8 +30,11 @@
#:proper-list-p
#:proper-list
#:mappend
#:map-product
#:flatten
#:sans
#:set-equal
#:setp
;; Numbers
#:clamp
#:gaussian-random
...
...
tests.lisp
View file @
a77441a8
...
...
@@ -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
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment