順列や組み合わせを生成したり、その総数を求める関数を集めたライブラリです。
アーカイブファイル minlib.tar.gz をインストールする、または プログラムリスト にある以下の 4 つのファイルを、~/common-lisp/ 以下の適当なサブディレクトリ (たとえば combination など) に配置してください。
2nＣn (2n)!
Ｃn = ------- = ----------
n+1 (n+1)!n!
A1 = 0 A2 = 1 An = (n - 1) * (An-1 + An-2) ; n >= 3
nＳ1 = nＳn = 1 nＳk = n-1Ｓk-1 + k * n-1Ｓk
B(0) = 1
n
B(n+1) = Σ nＣk * B(k) ; n >= 1
k=0
B(0) = 1
n
B(n) = Σ nＳk
k=1
* (asdf:test-system :combination)
; compiling file ... 略 ...
----- test start -----
(LET ((A NIL))
(PERMUTATION (LAMBDA (X) (PUSH X A)) 3 '(A B C))
(REVERSE A))
=> ((A B C) (A C B) (B A C) (B C A) (C A B) (C B A)) OK
(PERMUTATION-SET 3 '(A B C))
=> ((A B C) (A C B) (B A C) (B C A) (C A B) (C B A)) OK
(LET ((A NIL))
(REPEATED-PERMUTATION (LAMBDA (X) (PUSH X A)) 2 '(A B C))
(REVERSE A))
=> ((A A) (A B) (A C) (B A) (B B) (B C) (C A) (C B) (C C)) OK
(REPEATED-PERMUTATION-SET 2 '(A B C))
=> ((A A) (A B) (A C) (B A) (B B) (B C) (C A) (C B) (C C)) OK
(LET ((A NIL))
(DERANGEMENT (LAMBDA (X) (PUSH X A)) '(A B C D))
(REVERSE A))
=> ((B A D C) (B C D A) (B D A C) (C A D B) (C D A B) (C D B A) (D A B C)
(D C A B) (D C B A)) OK
(DERANGEMENT-SET '(A B C D))
=> ((B A D C) (B C D A) (B D A C) (C A D B) (C D A B) (C D B A) (D A B C)
(D C A B) (D C B A)) OK
(LET ((A NIL))
(COMBINATION (LAMBDA (X) (PUSH X A)) 3 '(A B C D E))
(REVERSE A))
=> ((A B C) (A B D) (A B E) (A C D) (A C E) (A D E) (B C D) (B C E) (B D E)
(C D E)) OK
(COMBINATION-SET 3 '(A B C D E))
=> ((A B C) (A B D) (A B E) (A C D) (A C E) (A D E) (B C D) (B C E) (B D E)
(C D E)) OK
(LET ((A NIL))
(REPEATED-COMBINATION (LAMBDA (X) (PUSH X A)) 2 '(A B C D))
(REVERSE A))
=> ((A A) (A B) (A C) (A D) (B B) (B C) (B D) (C C) (C D) (D D)) OK
(REPEATED-COMBINATION-SET 2 '(A B C D))
=> ((A A) (A B) (A C) (A D) (B B) (B C) (B D) (C C) (C D) (D D)) OK
(LET ((A NIL))
(PRODUCT (LAMBDA (X) (PUSH X A)) '(A B C) '(D E F))
(REVERSE A))
=> ((A D) (A E) (A F) (B D) (B E) (B F) (C D) (C E) (C F)) OK
(PRODUCT-SET '(A B C) '(D E F))
=> ((A D) (A E) (A F) (B D) (B E) (B F) (C D) (C E) (C F)) OK
(MAPCAR #'FACTORIAL '(0 10 11 20))
=> (1 3628800 39916800 2432902008176640000) OK
(MAPCAR #'FIBONACCI '(0 10 20 40 80))
=> (0 55 6765 102334155 23416728348467685) OK
(MAPCAR (LAMBDA (XS) (APPLY #'PERMUTATION-NUMBER XS))
'((10 4) (10 5) (10 6) (20 10)))
=> (5040 30240 151200 670442572800) OK
(MAPCAR (LAMBDA (XS) (APPLY #'COMBINATION-NUMBER XS))
'((5 3) (10 5) (20 10) (30 15) (40 20)))
=> (10 252 184756 155117520 137846528820) OK
(MAPCAR (LAMBDA (XS) (APPLY #'REPEATED-COMBINATION-NUMBER XS))
'((5 3) (10 5) (20 10) (30 15)))
=> (35 2002 20030010 229911617056) OK
(MAPCAR (LAMBDA (X) (CATALAN-NUMBER X)) '(0 1 2 3 10 20 30))
=> (1 1 2 5 16796 6564120420 3814986502092304) OK
(MAPCAR (LAMBDA (X) (MONTMORT-NUMBER X)) '(1 2 3 4 10 20))
=> (0 1 2 9 1334961 895014631192902121) OK
(MAPCAR (LAMBDA (XS) (APPLY #'STIRLING2-NUMBER XS))
'((0 0) (1 0) (1 1) (5 1) (5 3) (5 5) (20 10)))
=> (1 0 1 1 25 1 5917584964655) OK
(MAPCAR (LAMBDA (X) (BELL-NUMBER X)) '(0 1 2 3 4 10 20))
=> (1 1 2 5 15 115975 51724158235372) OK
(MAPCAR (LAMBDA (X) (PARTITION-NUMBER X)) '(1 2 3 4 10 100 200))
=> (1 2 3 5 42 190569292 3972999029388) OK
----- test end -----
TEST: 22
OK: 22
NG: 0
ERR: 0
T
;;;
;;; magic.lisp : 魔方陣
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :utils)
(use-package :utils)
(require :combination)
(use-package :combination)
;;; 盤面
;;; 0 1 2
;;; 3 4 5
;;; 6 7 8
;;; 直線
(defconstant lines '((0 1 2) (3 4 5) (6 7 8) (0 3 6) (1 4 7) (2 5 8)
(0 4 8) (2 4 6)))
;;; 直線の和
(defun sum-line (b x y z)
(+ (elt b x) (elt b y) (elt b z)))
;;; 解法
(defun magic ()
(permutation
(lambda (xs)
(let ((values (mapcar (lambda (ps) (apply #'sum-line xs ps))
lines)))
(when (apply #'= values)
(print xs))))
9 (iota 9 :start 1)))
* (load "magic.lisp") T * (magic) (2 7 6 9 5 1 4 3 8) (2 9 4 7 5 3 6 1 8) (4 3 8 9 5 1 2 7 6) (4 9 2 3 5 7 8 1 6) (6 1 8 7 5 3 2 9 4) (6 7 2 1 5 9 8 3 4) (8 1 6 3 5 7 4 9 2) (8 3 4 1 5 9 6 7 2) NIL
;;;
;;; hukumen.lisp : 覆面算 (send + more = money)
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :combination)
(use-package :combination)
;;; m = 1 は自明、s e n d o r y の値を求める
(defun hukumen ()
(permutation
(lambda (xs)
(destructuring-bind
(s e n d o r y) xs
(let ((send (+ (* s 1000) (* e 100) (* n 10) d))
(more (+ 1000 (* o 100) (* r 10) e))
(money (+ 10000 (* o 1000) (* n 100) (* e 10) y)))
(when (= (+ send more) money)
(format t "~d + ~d = ~d~%" send more money)))))
7
'(0 2 3 4 5 6 7 8 9)))
* (load "hukumen.lisp") T * (hukumen) 9567 + 1085 = 10652 NIL
;;;
;;; master.lisp : マスターマインドの解法
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :utils)
(use-package :utils)
(require :combination)
(use-package :combination)
;;; bulls を数える
(defun count-bulls (xs ys)
(count t (mapcar #'= xs ys)))
;;; 同じ数字を数える
(defun count-same-numbers (xs ys)
(let ((c 0))
(dolist (x xs c)
(when (member x ys) (incf c)))))
;;; bulls と cows を求める
(defun check-code (xs ys)
(let ((bulls (count-bulls xs ys)))
(values bulls (- (count-same-numbers xs ys) bulls))))
;;; 過去の質問と矛盾しないか
(defun check-query (qs code)
(every (lambda (q)
(multiple-value-bind
(bulls cows)
(check-code (first q) code)
(and (= bulls (second q)) (= cows (third q)))))
qs))
;;; 解法
(defun master (ans)
(let ((qs nil) (cnt 1))
(dolist (code (permutation-set 4 (iota 10)))
(when (check-query qs code)
(multiple-value-bind
(bulls cows)
(check-code ans code)
(push (list code bulls cows) qs)
(format t "~d: ~a, bulls = ~d, cows = ~d~%" cnt code bulls cows)
(incf cnt)
(when (= bulls 4)
(format t "Good Job!!")
(return-from master t)))))))
* (load "master.lisp") T * (master '(9 8 7 6)) 1: (0 1 2 3), bulls = 0, cows = 0 2: (4 5 6 7), bulls = 0, cows = 2 3: (5 4 8 9), bulls = 0, cows = 2 4: (6 7 9 8), bulls = 0, cows = 4 5: (8 9 7 6), bulls = 2, cows = 2 6: (9 8 7 6), bulls = 4, cows = 0 Good Job!! T * (master '(5 2 9 3)) 1: (0 1 2 3), bulls = 1, cows = 1 2: (0 2 4 5), bulls = 1, cows = 1 3: (0 3 5 6), bulls = 0, cows = 2 4: (1 5 4 3), bulls = 1, cows = 1 5: (1 6 2 5), bulls = 0, cows = 2 6: (4 2 6 3), bulls = 2, cows = 0 7: (5 2 7 3), bulls = 3, cows = 0 8: (5 2 8 3), bulls = 3, cows = 0 9: (5 2 9 3), bulls = 4, cows = 0 Good Job!! T * (master '(9 4 3 1)) 1: (0 1 2 3), bulls = 0, cows = 2 2: (1 0 4 5), bulls = 0, cows = 2 3: (2 3 5 4), bulls = 0, cows = 2 4: (3 4 0 6), bulls = 1, cows = 1 5: (3 5 6 1), bulls = 1, cows = 1 6: (6 5 0 2), bulls = 0, cows = 0 7: (7 4 3 1), bulls = 3, cows = 0 8: (8 4 3 1), bulls = 3, cows = 0 9: (9 4 3 1), bulls = 4, cows = 0 Good Job!! T
;;;
;;; lo.lisp : ライツアウトの解法
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :utils)
(use-package :utils)
(require :combination)
(use-package :combination)
;;; ボタンを押したときのパターン
(defconstant pattern
#(#x0000023 #x0000047 #x000008e #x000011c #x0000218
#x0000461 #x00008e2 #x00011c4 #x0002388 #x0004310
#x0008c20 #x0011c40 #x0023880 #x0047100 #x0086200
#x0118400 #x0238800 #x0471000 #x08e2000 #x10c4000
#x0308000 #x0710000 #x0e20000 #x1c40000 #x1880000))
;;; ボタンを押す
(defun push-buttons (xs board)
(if (null xs)
board
(push-buttons (cdr xs) (logxor (aref pattern (car xs)) board))))
;;; 解の表示
(defun print-answer (xs n)
(when (< n 25)
(when (zerop (mod n 5)) (terpri))
(format t (if (member n xs) "O " ". "))
(print-answer xs (1+ n))))
;;; 単純版
(defun lo (board)
(do ((n 1 (1+ n)))
((> n 25))
(format t "----- ~d -----~%" n)
(combination
(lambda (xs)
(when (zerop (push-buttons xs board))
(print-answer xs 0)
(return t)))
n
(iota 25))))
;;; 高速版
(defun lo-fast (board)
(dolist (xs (mapcan (lambda (n) (combination-set n '(0 1 2 3 4)))
'(1 2 3 4 5)))
(do ((b (push-buttons xs board))
(i 5 (1+ i))
(ys (reverse xs)))
((>= i 25)
(when (zerop b)
(print-answer (reverse ys) 0)
(terpri)))
(when (logbitp (- i 5) b)
(setf b (logxor (aref pattern i) b))
(push i ys)))))
* (load "lo.lisp") T * (time (lo #x1ffffff)) ----- 1 ----- ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- ----- 10 ----- ----- 11 ----- ----- 12 ----- ----- 13 ----- ----- 14 ----- ----- 15 ----- O O . . . O O . O O . . O O O . O O O . . O O . O Evaluation took: 5.699 seconds of real time 5.694773 seconds of total run time (5.643229 user, 0.051544 system) [ Run times consist of 0.190 seconds GC time, and 5.505 seconds non-GC time. ] 99.93% CPU 13,680,533,282 processor cycles 6,699,396,224 bytes consed T * (time (lo-fast #x1ffffff)) O O . . . O O . O O . . O O O . O O O . . O O . O . . . O O O O . O O O O O . . . O O O . O . O O . O . O O . . O O O . O O O . . O O . O O . . . O O . O O . O . O O O . . . O O O O O . O O O O . . . Evaluation took: 0.000 seconds of real time 0.000330 seconds of total run time (0.000323 user, 0.000007 system) 100.00% CPU 776,626 processor cycles 0 bytes consed NIL 実行環境: SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz
;;;
;;; combination.lisp : 順列と組み合わせ
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :combination)
(defpackage :combination (:use :cl))
(in-package :combination)
(export '(factorial
permutation-number
permutation
permutation-set
repeated-permutation
repeated-permutation-set
montmort-number
derangement
derangement-set
combination-number
combination
combination-set
repeated-combination-number
repeated-combination
repeated-combination-set
product
product-set
fibonacci
catalan-number
partition-number
stirling2-number
bell-number
))
;;; 階乗 n!
(defun factorial (n &optional (a 1))
(if (zerop n)
a
(factorial (1- n) (* n a))))
;;;
;;; 順列
;;;
;;; n 個の中らから k 個を選ぶ順列
(defun permutation-number (n k &optional (a 1))
(if (zerop k)
a
(permutation-number (1- n) (1- k) (* a n))))
;;; 高階関数版
(defun permutation (fn n xs &optional (a nil))
(if (zerop n)
(funcall fn (reverse a))
(dolist (x xs)
(permutation fn (1- n) (remove x xs :count 1) (cons x a)))))
;;; リストに格納して返す
(defun permutation-set (n xs)
(if (zerop n)
'(())
(mapcan (lambda (x)
(mapcar (lambda (ys) (cons x ys))
(permutation-set (1- n) (remove x xs :count 1))))
xs)))
;;; 重複順列 (高階関数版)
(defun repeated-permutation (fn n xs &optional (a nil))
(if (zerop n)
(funcall fn (reverse a))
(dolist (x xs)
(repeated-permutation fn (1- n) xs (cons x a)))))
;;; 重複順列 (リストに格納して返す)
(defun repeated-permutation-set (n xs)
(if (zerop n)
'(())
(mapcan (lambda (x)
(mapcar (lambda (ys) (cons x ys))
(repeated-permutation-set (1- n) xs)))
xs)))
;;;
;;; 完全順列
;;;
;;; 完全順列の総数 (モンモール数)
(defun montmort-number (n)
(do ((i 1 (1+ i))
(a 0)
(b 1))
((>= i n) a)
(psetq a b
b (* (1+ i) (+ a b)))))
;;; 高階関数
(defun derangement-sub (fn xs zs a)
(if (null xs)
(funcall fn (reverse a))
(dolist (z zs)
(unless (eql (car xs) z)
(derangement-sub fn (cdr xs) (remove z zs :count 1) (cons z a))))))
(defun derangement (fn xs)
(derangement-sub fn xs xs nil))
;;; リストに格納して返す
(defun derangement-set-sub (xs zs)
(if (null xs)
'(())
(mapcan (lambda (z)
(unless (eql (car xs) z)
(mapcar (lambda (ls) (cons z ls))
(derangement-set-sub (cdr xs) (remove z zs :count 1)))))
zs)))
(defun derangement-set (xs) (derangement-set-sub xs xs))
;;;
;;; 組み合わせ
;;;
;;; 組み合わせの数
(defun combination-number (n r)
(if (or (= n r) (zerop r))
1
(/ (* (combination-number n (1- r)) (1+ (- n r))) r)))
;;; 高階関数版
(defun combination (fn n xs &optional (a nil))
(cond
((zerop n)
(funcall fn (reverse a)))
((null xs) nil)
(t
(combination fn (1- n) (cdr xs) (cons (car xs) a))
(combination fn n (cdr xs) a))))
;;; リストに格納して返す
(defun combination-set (n xs)
(cond
((zerop n) '(()))
((null xs) nil)
(t
(append
(mapcar (lambda (ys) (cons (car xs) ys))
(combination-set (1- n) (cdr xs)))
(combination-set n (cdr xs))))))
;;; 重複組み合わせの数
(defun repeated-combination-number (n r) (combination-number (1- (+ n r)) r))
;;; 重複組み合わせ (高階関数版)
(defun repeated-combination (fn n xs &optional (a nil))
(cond
((zerop n)
(funcall fn (reverse a)))
((null xs) nil)
(t
(repeated-combination fn (1- n) xs (cons (car xs) a))
(repeated-combination fn n (cdr xs) a))))
;;; 重複組み合わせ (リストに格納して返す)
(defun repeated-combination-set (n xs)
(cond
((zerop n) '(()))
((null xs) nil)
(t
(append (mapcar (lambda (ys) (cons (car xs) ys))
(repeated-combination-set (1- n) xs))
(repeated-combination-set n (cdr xs))))))
;;; 直積集合
(defun product-sub (fn a xss)
(if (null xss)
(funcall fn (reverse a))
(dolist (x (car xss))
(product-sub fn (cons x a) (cdr xss)))))
(defun product (fn &rest args)
(product-sub fn nil args))
(defun product-set (&rest args)
(cond
((null args) (list '()))
((null (cdr args))
(mapcar (lambda (x) (list x)) (car args)))
(t
(mapcan (lambda (x) (mapcar (lambda (ys) (cons x ys))
(apply #'product-set (cdr args))))
(car args)))))
;;; フィボナッチ数
(defun fibonacci (n &optional (a 0) (b 1))
(if (zerop n)
a
(fibonacci (1- n) b (+ a b))))
;;; カタラン数
(defun catalan-number (n)
(/ (combination-number (* n 2) n) (1+ n)))
;;; 分割数 (自然数の分割)
(defun partition-number (n)
(let ((a (make-array (+ n 1) :initial-element 1)))
(do ((k 2 (1+ k)))
((< n k) (aref a n))
(do ((m k (1+ m)))
((< n m))
(incf (aref a m) (aref a (- m k)))))))
;;; 第 2 種スターリング数
(defun stirling2-sub (n)
(let ((xs (list 0 1)))
(dotimes (i (1- n) xs)
(do ((j 0 (1+ j))
(zs xs (cdr zs))
(ys (list 0)))
((null (cdr zs))
(setq ys (cons 1 ys)
xs (nreverse ys)))
(push (+ (car zs) (* (1+ j) (cadr zs))) ys)))))
(defun stirling2-number (n k)
(if (= n k 0)
1
(elt (stirling2-sub n) k)))
;;; ベル数
(defun bell-number (n)
(if (or (zerop n) (= n 1))
1
(reduce #'+ (stirling2-sub n))))
リスト : combination.asd (defsystem :combination :description "combination and permutation" :version "0.1.0" :author "Makoto Hiroi" :license "MIT License" :depends-on () :in-order-to ((test-op (test-op :comb_tst))) :components ((:file "combination")))
;;;
;;; comb_tst.lisp : combination のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :comb_tst)
(defpackage :comb_tst (:use :cl :combination :mintst))
(in-package :comb_tst)
(export '(test))
(defvar xs1 '((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)))
(defvar xs2 '((A A) (A B) (A C) (B A) (B B) (B C) (C A) (C B) (C C)))
(defvar xs3 '((B A D C) (B C D A) (B D A C) (C A D B) (C D A B)
(C D B A) (D A B C) (D C A B) (D C B A)))
(defvar xs4 '((A B C) (A B D) (A B E) (A C D) (A C E)
(A D E) (B C D) (B C E) (B D E) (C D E)))
(defvar xs5 '((A A) (A B) (A C) (A D) (B B) (B C) (B D) (C C) (C D) (D D)))
(defvar xs6 '((A D) (A E) (A F) (B D) (B E) (B F) (C D) (C E) (C F)))
(defun test ()
(initial)
(run (let ((a nil))
(permutation (lambda (x) (push x a)) 3 '(a b c))
(reverse a))
xs1)
(run (permutation-set 3 '(a b c)) xs1)
(run (let ((a nil))
(repeated-permutation (lambda (x) (push x a)) 2 '(a b c))
(reverse a))
xs2)
(run (repeated-permutation-set 2 '(a b c)) xs2)
(run (let ((a nil))
(derangement (lambda (x) (push x a)) '(a b c d))
(reverse a))
xs3)
(run (derangement-set '(a b c d)) xs3)
(run (let ((a nil))
(combination (lambda (x) (push x a)) 3 '(a b c d e))
(reverse a))
xs4)
(run (combination-set 3 '(a b c d e)) xs4)
(run (let ((a nil))
(repeated-combination (lambda (x) (push x a)) 2 '(a b c d))
(reverse a))
xs5)
(run (repeated-combination-set 2 '(a b c d)) xs5)
(run (let ((a nil))
(product (lambda (x) (push x a)) '(a b c) '(d e f))
(reverse a))
xs6)
(run (product-set '(a b c) '(d e f)) xs6)
(run (mapcar #'factorial '(0 10 11 20)) '(1 3628800 39916800 2432902008176640000))
(run (mapcar #'fibonacci '(0 10 20 40 80)) '(0 55 6765 102334155 23416728348467685))
(run (mapcar (lambda (xs) (apply #'permutation-number xs)) '((10 4) (10 5) (10 6) (20 10)))
'(5040 30240 151200 670442572800))
(run (mapcar (lambda (xs) (apply #'combination-number xs)) '((5 3) (10 5) (20 10) (30 15) (40 20)))
'(10 252 184756 155117520 137846528820))
(run (mapcar (lambda (xs) (apply #'repeated-combination-number xs)) '((5 3) (10 5) (20 10) (30 15)))
'(35 2002 20030010 229911617056))
(run (mapcar (lambda (x) (catalan-number x)) '(0 1 2 3 10 20 30))
'(1 1 2 5 16796 6564120420 3814986502092304))
(run (mapcar (lambda (x) (montmort-number x)) '(1 2 3 4 10 20))
'(0 1 2 9 1334961 895014631192902121))
(run (mapcar (lambda (xs) (apply #'stirling2-number xs))
'((0 0) (1 0) (1 1) (5 1) (5 3) (5 5) (20 10)))
'(1 0 1 1 25 1 5917584964655))
(run (mapcar (lambda (x) (bell-number x)) '(0 1 2 3 4 10 20))
'(1 1 2 5 15 115975 51724158235372))
(run (mapcar (lambda (x) (partition-number x)) '(1 2 3 4 10 100 200))
'(1 2 3 5 42 190569292 3972999029388))
(final))
リスト : comb_tst.asd (defsystem :comb_tst :description "test for combination" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on (:mintst :combination) :perform (test-op (o s) (symbol-call :comb_tst :test)) :components ((:file "comb_tst")))