Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Knut Olav Bøhmer
alexandria
Commits
d461c5ff
Commit
d461c5ff
authored
Jul 01, 2007
by
Nikodemus Siivola
Browse files
Combinations, permutations, and derangements
parent
5fed2432
Changes
2
Hide whitespace changes
Inline
Sidebyside
package.lisp
View file @
d461c5ff
...
...
@@ 10,21 +10,21 @@
;; Definitions
#:defineconstant
;; Control flow
#:switch
#:eswitch
#:cswitch
#:eswitch
#:switch
#:whichever
#:xor
;; Hash tables
#:alisthashtable
#:copyhashtable
#:hashtablealist
#:hashtablekeys
#:hashtablevalues
#:hashtableplist
#:hashtablealist
#:alisthashtable
#:plisthashtable
#:hashtablevalues
#:maphashkeys
#:maphashvalues
#:plisthashtable
;; Functions
#:compose
#:conjoin
...
...
@@ 43,16 +43,15 @@
#:ensurecar
#:ensurecons
#:ensurelist
#:flatten
#:lastcar
#:makecircularlist
#:mapproduct
#:mappend
#:nunionf
#:plistalist
#:properlistp
#:properlist
#:mappend
#:mapproduct
#:flatten
#:sans
#:properlistp
#:removefromplist
#:removefromplistf
#:deletefromplist
...
...
@@ 81,31 +80,34 @@
#:arraylength
#:copyarray
;; Sequences
#:emptyp
#:copysequence
#:deletef
#:emptyp
#:endswith
#:endswithsubseq
#:firstelt
#:lastelt
#:startswithsubseq
#:endswithsubseq
#:startswith
#:endswith
#:removef
#:deletef
#:mapcombinations
#:mapderangements
#:mappermuations
#:propersequence
#:randomelt
#:removef
#:rotate
#:sequenceoflengthp
#:shuffle
#:startswith
#:startswithsubseq
;; Macros
#:withuniquenames
#:withgensyms
#:onceonly
#:parsebody
#:withgensyms
#:withuniquenames
;; Symbols
#:ensuresymbol
#:formatsymbol
#:makekeyword
#:makegensymlist
#:makekeyword
;; Strings
#:stringdesignator
;; Types
...
...
sequences.lisp
View file @
d461c5ff
...
...
@@ 245,3 +245,133 @@ an error if SEQUENCE is an improper list."
(
t
(
returnfrom
endswith
nil
))))
object
))
(
defun
mapcombinations
(
function
sequence
&key
(
start
0
)
end
length
(
copy
t
))
"Calls FUNCTION with each combination of LENGTH constructable from the
elements of the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
delimited subsequence. (So unless LENGTH is specified there is only a single
combination, which has the same elements as the delimited subsequence.) If
COPY is true (the default) each combination is freshly allocated. If COPY is
false all combinations are EQ to each other, in which case consequences are
specified if a combination is modified by FUNCTION."
(
let*
((
end
(
or
end
(
length
sequence
)))
(
size
(

end
start
))
(
length
(
or
length
size
))
(
combination
(
subseq
sequence
0
length
))
(
function
(
ensurefunction
function
)))
(
if
(
=
length
size
)
(
funcall
function
combination
)
(
flet
((
call
()
(
funcall
function
(
if
copy
(
copyseq
combination
)
combination
))))
(
etypecase
sequence
;; When dealing with lists we prefer walking back and
;; forth instead of using indexes.
(
list
(
labels
((
combinelist
(
ctail
otail
)
(
if
(
not
ctail
)
(
call
)
(
do
((
tail
otail
(
cdr
tail
)))
((
not
tail
))
(
setf
(
car
ctail
)
(
car
tail
))
(
combinelist
(
cdr
ctail
)
(
cdr
tail
))))))
(
combinelist
combination
(
nthcdr
start
sequence
))))
(
vector
(
labels
((
combine
(
count
start
)
(
if
(
zerop
count
)
(
call
)
(
loop
for
i
from
start
below
end
do
(
let
((
j
(

count
1
)))
(
setf
(
aref
combination
j
)
(
aref
sequence
i
))
(
combine
j
(
+
i
1
)))))))
(
combine
length
start
)))
(
sequence
(
labels
((
combine
(
count
start
)
(
if
(
zerop
count
)
(
call
)
(
loop
for
i
from
start
below
end
do
(
let
((
j
(

count
1
)))
(
setf
(
elt
combination
j
)
(
elt
sequence
i
))
(
combine
j
(
+
i
1
)))))))
(
combine
length
start
)))))))
sequence
)
(
defun
mappermutations
(
function
sequence
&key
(
start
0
)
end
length
(
copy
t
))
"Calls function with each permutation of LENGTH constructable
from the subsequence of SEQUENCE delimited by START and END. START
defaults to 0, END to length of the sequence, and LENGTH to the
length of the delimited subsequence."
(
let*
((
end
(
or
end
(
length
sequence
)))
(
size
(

end
start
))
(
length
(
or
length
size
)))
(
labels
((
permute
(
seq
n
)
(
let
((
n1
(

n
1
)))
(
if
(
zerop
n1
)
(
funcall
function
(
if
copy
(
copyseq
seq
)
seq
))
(
if
(
evenp
n1
)
(
loop
for
i
from
0
upto
n1
do
(
permute
seq
n1
)
(
if
(
evenp
n1
)
(
rotatef
(
elt
seq
0
)
(
elt
seq
n1
))
(
rotatef
(
elt
seq
i
)
(
elt
seq
n1
))))))))
(
permutesequence
(
seq
)
(
permute
seq
length
)))
(
if
(
=
length
size
)
;; Things are simple if we need to just permute the
;; full STARTEND range.
(
permutesequence
(
subseq
sequence
start
end
))
;; Otherwise we need to generate all the combinations
;; of LENGTH in the STARTEND range, and then permute
;; a copy of the result: can't permute the combination
;; directly, as they share structure with each other.
(
let
((
permutation
(
subseq
sequence
0
length
)))
(
flet
((
permutecombination
(
combination
)
(
permutesequence
(
replace
permutation
combination
))))
(
declare
(
dynamicextent
#'
permutecombination
))
(
mapcombinations
#'
permutecombination
sequence
:start
start
:end
end
:length
length
:copy
nil
)))))))
(
defun
mapderangements
(
function
sequence
&key
(
start
0
)
end
(
copy
t
))
"Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
by the bounding index designators START and END. Derangement is a permutation
of the sequence where no element remains in place. SEQUENCE is not modified,
but individual derangements are EQ to each other. Consequences are unspecified
if calling FUNCTION modifies either the derangement or SEQUENCE."
(
let*
((
end
(
or
end
(
length
sequence
)))
(
size
(

end
start
))
;; We don't really care about the elements here.
(
derangement
(
subseq
sequence
0
size
))
;; Bitvector that has 1 for elements that have been deranged.
(
mask
(
makearray
size
:elementtype
'bit
:initialelement
0
)))
(
declare
(
dynamicextent
mask
))
;; ad hoc algorith
(
labels
((
derange
(
place
n
)
;; Perform one recursive step in deranging the
;; sequence: PLACE is index of the original sequence
;; to derange to another index, and N is the number of
;; indexes not yet deranged.
(
if
(
zerop
n
)
(
funcall
function
(
if
copy
(
copyseq
derangement
)
derangement
))
;; Itarate over the indexes I of the subsequence to
;; derange: if I != PLACE and I has not yet been
;; deranged by an earlier call put the element from
;; PLACE to I, mark I as deranged, and recurse,
;; finally removing the mark.
(
loop
for
i
from
0
below
size
do
(
unless
(
or
(
=
place
(
+
i
start
))
(
not
(
zerop
(
bit
mask
i
))))
(
setf
(
elt
derangement
i
)
(
elt
sequence
place
)
(
bit
mask
i
)
1
)
(
derange
(
1+
place
)
(
1
n
))
(
setf
(
bit
mask
i
)
0
))))))
(
derange
start
size
)
sequence
)))
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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