ルービックキューブ解法プログラム
以前書いたHaskellでルービックキューブを解くプログラム。
但しルービックキューブになっておらず、２×２×２でしかも、１つのキューブに本当は
角で3面あるが、ここでは面の概念がなく、その位置のみを扱っている。
更に、出てきた「解」が本当に正しいのかの検証をしていないので
もしかしたら間違っているかも知れない。
-------------------------------------------------
-- rubik.hs
-- ルービックキューブ解法
-------------------------------------------------
-- 単位ベクターから指定されたベクターへの変換を見つける。
-- > search [2,1,3,4,5,6,7,8]
{-
1.場所とコマ
場所は空間的な位置を示す。実際にその場所を占めるコマには因らない。
コマは実際の要素を表す。コマは何れかの場所にいる。
場所の指定。以下のインデックスで場所を指定する。
これが、リストの順番となる。ぞれぞれの場所をL1,L2,..L8で表す。
L4 L3
L1 L2
L8 L7
L5 L6
コマはそれぞれ、C1,C2,..,C8で表す。
コマが占めるべき正しい位置はC1はL1、C2はL2、... C8はL8となる。
2.回転
回転演算はそれぞれの面に対して90度時計回りに回転することを基本演算とする。
可能な面は６面(以下)あるため、基本回転は６種類ある。
右側面, 左側面, 上面, 下面, 前面, 後面
但し、１つのコマの位置を固定して考えることが出来る。
この場合、回転は以下の３種類に絞れる。
右面、上面、全面
実際の変換は以下のようになる。
上面 [C1, C2, C3, C4, C5, C6, C7, C8] -> [C2, C3, C4, C1, C5, C6, C7, C8]
右面 [C1, C2, C3, C4, C5, C6, C7, C8] -> [C1, C6, C2, C4, C5, C7, C3, C8]
前面 [C1, C2, C3, C4, C5, C6, C7, C8] -> [C5, C1, C3, C4, C6, C2, C7, C8]
3.回転代数
回転の演算子は行列で表現される。
ある回転とある回転を連続して作用させることは、行列の積算で表現される。
ある回転の反転はその行列の逆行列で表現される。
行列の要素は0および1のみから構成される。
行列のある要素が1であれば、その同一列、同一行には1は存在しない。
逆行列は転地行列に等しい。
逆行列は逆回転を表す。
コアのある配置は１つの行列で表現できる。
即ち、eをコマが揃った状態とする。e = [1,2,3,4,5,6,7,8]
ある配置を x = [x1,x2,x3,x4,x5,x6,x7,x8] とする。
すると、この２つの配置を変換する１つの行列が存在する。
即ち、１つの行列で全ての可能な変換を表現することができる。
単位行列は上記の３つである。これは実際に操作可能な変換を意味する。
問題は任意の行列（配置から配置への変換）を単に行列の積として表現することである。
可能なコマの配置は7!個ある（相対的位置関係だけが有意なので１つは固定して考えられる）。
即ち全部で5040個。このうちコマが揃った状態が１つ存在する。e = [1,2,3,4,5,6,7,8]
-}
-- 型定義
type Vector = [Int]
type Operator = [[Int]]
-- 基本演算子
opT :: Operator
opT = [[0,1,0,0,0,0,0,0],
[0,0,1,0,0,0,0,0],
[0,0,0,1,0,0,0,0],
[1,0,0,0,0,0,0,0],
[0,0,0,0,1,0,0,0],
[0,0,0,0,0,1,0,0],
[0,0,0,0,0,0,1,0],
[0,0,0,0,0,0,0,1]]
opR :: Operator
opR = [[1,0,0,0,0,0,0,0],
[0,0,0,0,0,1,0,0],
[0,1,0,0,0,0,0,0],
[0,0,0,1,0,0,0,0],
[0,0,0,0,1,0,0,0],
[0,0,0,0,0,0,1,0],
[0,0,1,0,0,0,0,0],
[0,0,0,0,0,0,0,1]]
opF :: Operator
opF = [[0,0,0,0,1,0,0,0],
[1,0,0,0,0,0,0,0],
[0,0,1,0,0,0,0,0],
[0,0,0,1,0,0,0,0],
[0,0,0,0,0,1,0,0],
[0,1,0,0,0,0,0,0],
[0,0,0,0,0,0,1,0],
[0,0,0,0,0,0,0,1]]
-- 正解ベクター
eV :: Vector
eV = [1,2,3,4,5,6,7,8]
-------------------------------------------------
-- 行列のリストを先頭から掛け合わせていく。
-------------------------------------------------
mulOpList :: [Operator] -> Operator
mulOpList [] = []
mulOpList (x:xs)
| xs == [] = x
| otherwise = mulOpList (mulOp (head xs) x : (tail xs))
-------------------------------------------------
-- ベクターに行列のリストを作用させる。
-- これは上記のmulOpListを用いても実装可能であるが、
-- あえて別の方式で実現している。
-- 即ち、ベクタに順に行列を作用させていく。
-------------------------------------------------
opList :: Vector -> [Operator] -> Vector
opList x [] = x
opList x (y:ys) = opList (rotate y x) ys
opListMul :: [Operator] -> Operator
opListMul (x:xs) = opListMul ((mulOp x (head xs)) : (tail xs))
-------------------------------------------------
-- y = A x (x,yはn次元ベクター。Aはn*n行列)
-- 回転演算を行う。
-- ベクターの行列式による演算として実現する。
-------------------------------------------------
rotate :: Operator -> Vector -> Vector
rotate m v = map (op1 v) m
-- ベクターに演算を行う。
-- 演算子ベクターは唯１つの要素のみが１になっており、その他は０である。
-- 演算子の１になっている個所の要素をベクターから抽出する。
-- ex.) op1 [a1,a2,a3,a4,a5] [0,0,1,0,0] => a3
op1 :: Vector -> [Int] -> Int
op1 _ [] = 0
op1 (x:xs) (y:ys)
| y == 1 = x
| otherwise = op1 xs ys
-------------------------------------------------
-- C = A * B (A,B,Cはn*n行列)
-- 行列の掛け算を行う。
-------------------------------------------------
mulOp :: Operator -> Operator -> Operator
mulOp x y = mulr x (invertOp y)
mulr :: [[Int]] -> [[Int]] -> [[Int]]
mulr [] _ = []
mulr (x:xs) y = (mul1 x y) : (mulr xs y)
mul1 :: [Int] -> [[Int]] -> [Int]
mul1 _ [] = []
mul1 x (y:ys) = (mulElem x y) : mul1 x ys
mulElem :: [Int] -> [Int] -> Int
mulElem [] [] = 0
mulElem (x:xs) (y:ys)
| (x == 1) && (y == 1) = 1
| otherwise = mulElem xs ys
-------------------------------------------------
-- 行列の行と列を入れ替える。
-- 行と列の入れ替えは、逆行列を意味する。
-------------------------------------------------
invertOp :: [[Int]] -> [[Int]]
invertOp x = rotate_nth 0 (length x) x
rotate_nth :: Int -> Int -> [[Int]] -> [[Int]]
rotate_nth n max x
| n == max = []
| otherwise = (take_nth n x) : (rotate_nth (n+1) max x)
take_nth :: Int -> [[Int]] -> [Int]
take_nth n x = map (nth_element n) x
nth_element :: Int -> [Int] -> Int
nth_element n x = x!!n
-------------------------------------------------
-- 探索
-------------------------------------------------
-- データ型定義
-- 3つの基本演算を行列ではなく、シンボルで表現している。
-------------------------------------------------
data Op = T | R | F
deriving (Eq, Show)
-------------------------------------------------
-- 変換の解を求める。
-- 単位ベクターから特定のベクターへの変換を行う
-- 回転の並びを出力する。
-- 可能な回転を全て出力する（どこかで停めないと無限ループする）。
-------------------------------------------------
search :: Vector -> [[Op]]
search x = filter (match x) allOp
match :: Vector -> [Op] -> Bool
match v x = same v (ol x)
-------------------------------------------------
-- 全ての演算子の並びを出力する。
-- 当然、「全て」の並びなので無限に存在する。
-- 即ち出力されるリストは無限リストである。
-- 但し、１回転して元に戻るような演算子の並びも出力されてしまう。
-- なので、非常に重複が多い。
-------------------------------------------------
allOp = listOp [[T],[R],[F]]
listOp :: [[Op]] -> [[Op]]
listOp x = x ++ (listOp (makeOps x))
makeOps :: [[Op]] -> [[Op]]
makeOps x = concat (map addDim x)
addDim :: [Op] -> [[Op]]
addDim xs = [x:xs| x <- [T,R,F]]
-------------------------------------------------
-- 単位ベクターを演算子のリストに適用させる。
-------------------------------------------------
ol :: [Op] -> Vector
ol xs = opList eV (map toMatrix xs)
toMatrix :: Op -> Operator
toMatrix x
| x == T = opT
| x == R = opR
| x == F = opF
-------------------------------------------------
-- ２つの配列が同一かどうか調べる。
-- 同一であれば True、異なっていれば False
-------------------------------------------------
same :: [Int] -> [Int] -> Bool
same [] [] = True
same (x:xs) (y:ys)
| x /= y = False
| otherwise = same xs ys
