Haskell で平面ルービックキューブ

急に、ルービックキューブをプログラムで解いてみたい衝動にかられたが、手元にブツが無い。近所のコンビニにも無かったので、作ってみることにした。

以下のような方針

• 極力シンプルに。本物に近い操作感とか立体性とか別にいらないので、二次元の図形で表現する。
• 中央の小正方形は動かさない事にする。
• 操作はテキストボックスへの入力とする。色を表す文字一文字により、その色が中央となる面の回転を表し、小文字なら時計回り、大文字ならその逆とする。
• 現在、テキストボックスに入力されている文字列全体が反映された結果を描画する。
• 図形は中央に描画する。
• Haskell でやってみる

結果から示すと、以下が実際の様子。まず初期表示

初期表示

赤い面を時計回りに2回、青い面を時計回りに1回、赤い面を反時計まわりに1回、青い面を反時計まわりに1回、それぞれ90度回転させた結果。

コードは以下のような感じになる。

module Main where

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.Gdk.GC
import Graphics.UI.Gtk.Gdk.Drawable
import Graphics.UI.Gtk.Gdk.Events as Evt
import Data.IORef

--図形
data SquareColor = G|R|W|Y|O|B
color G = Color 0x0000 0xE000 0x0000
color R = Color 0xE000 0x0000 0x0000
color W = Color 0xFFFF 0xFFFF 0xFFFF
color Y = Color 0xFFFF 0xFFFF 0x0000
color O = Color 0xF000 0x5000 0x0000
color B = Color 0x0000 0x0000 0xD000

initialState = map (replicate 9) [G,R,W,Y,O,B]

v60    = (18, -10)
v120   = (18,  10)
v180   = (0,   21)
angles = [[(-108,-30), v120,v180],
          [(-108,-30), v60, v120],
          [(-54,   0), v60, v180],
          [(0,   -30), v60, v180],
          [(0,    33), v60, v120],
          [(54,  -60), v120,v180]]
allParas = concatMap createParas angles 
createParas v = map toPara $
    map (\n -> dupV v n) [0..2] >>= (\x -> map (\n ->dupH x n) [0..2])
toPara = (\[(ox,oy), (x1,y1), (x2,y2)] ->
  [(ox,oy), (ox+x1-1, oy+y1-1),
  (ox+x1+x2-2, oy+y1+y2-2),(ox+x2-1, oy+y2-1)])
dupH = (\[(ox,oy), v1@(x1,y1), v2] n -> [(ox+x1*n, oy+y1*n), v1, v2])
dupV = (\[(ox,oy), v1, v2@(x2,y2)] n -> [(ox+x2*n, oy+y2*n), v1, v2])

centering _ [] = []
centering size (angle: angles) =
  (map (centeringPoint size) angle): (centering size angles)

centeringPoint (w, h) (x, y) = (x + (div w 2), y + (div h 2))

--ウィンドウ操作
main = do
    initGUI
    surfaceIORef <- newIORef initialState
    Just xml     <- xmlNew "rcube.glade"

    window       <- xmlGetWidget xml castToWindow "window1"
    onDestroy window mainQuit

    drawingArea  <- xmlGetWidget xml castToDrawingArea "drawingarea1"
    onExposeRect drawingArea (const $ do
        dw       <- widgetGetDrawWindow drawingArea
        gc       <- gcNew dw
        surface  <- readIORef surfaceIORef
        size     <- widgetGetSize drawingArea
        drawCube dw gc size surface)

    entry        <- xmlGetWidget xml castToEntry "entry1"
    onEditableChanged entry $ do 
        n <- get entry entryText
        writeIORef surfaceIORef $ rotateAll initialState n
        widgetQueueDraw drawingArea

    widgetShowAll window
    mainGUI
  where
    rotateAll p [] = p
    rotateAll p (x:xs) = rotateAll (rotate p x) xs
 
    drawCube d g size x = do
      drawParas d g (foldl (++) [] x) $ centering size allParas
    drawParas d g _ [] = return ()
    drawParas d g (x:xs) (p: ps) = do
      gcSetValues g $ newGCValues { foreground = color x }
      drawPolygon d g True p
      drawParas d g xs ps

-- 回転操作
g2r [g,r,w,y,o,b] = [r6 o,r3 g,r3 w,r3 r,y,   r9 b]
r2g [o,g,w,r,y,b] = [r9 g,r9 r,r9 w,y,   r6 o,r3 b]
w2r [g,r,w,y,o,b] = [r9 g,w,   r3 o,r3 y,r3 b,r6 r] 
r2w [g,w,o,y,b,r] = [r3 g,r6 r,w,   r9 y,r9 o,r9 b] 
y2r [g,r,w,y,o,b] = [r9 w,y,   o,   r3 b,r3 g,r9 r]
r2y [w,y,o,b,g,r] = [r9 g,r3 r,r3 w,y,   o,   r9 b]
o2r [g,r,w,y,o,b] = [r6 b,r6 o,r6 y,r6 w,r6 r,r6 g]
r2o [b,o,y,w,r,g] = [r6 g,r6 r,r6 w,r6 y,r6 o,r6 b]
b2r [g,r,w,y,o,b] = [r9 y,b,   r9 o,r3 g,r3 w,r]
r2b [y,b,o,g,w,r] = [r9 g,r,   r9 w,r3 y,r3 o,b]
rotate [(g1:g2:g3:gs), [r1,r2,r3,r4,r5,r6,r7,r8,r9],
        (w1:w2:w3:ws), (y1:y2:y3:ys),
        o,              (b1:b2:b3:bs)] 'r' =
       [(w1:w2:w3:gs), [r7,r4,r1,r8,r5,r2,r9,r6,r3],
        (y1:y2:y3:ws), (b1:b2:b3:ys),
        o,              (g1:g2:g3:bs)]
rotate [(g1:g2:g3:gs), [r1,r2,r3,r4,r5,r6,r7,r8,r9],
        (w1:w2:w3:ws), (y1:y2:y3:ys),
        o,             (b1:b2:b3:bs)] 'R' =
       [(b1:b2:b3:gs), [r3,r6,r9,r2,r5,r8,r1,r4,r7],
        (g1:g2:g3:ws), (w1:w2:w3:ys),
        o,             (y1:y2:y3:bs)]
rotate p 'g' =r2g (rotate (g2r p) 'r')
rotate p 'G' =r2g (rotate (g2r p) 'R')
rotate p 'w' =r2w (rotate (w2r p) 'r')
rotate p 'W' =r2w (rotate (w2r p) 'R')
rotate p 'y' =r2y (rotate (y2r p) 'r')
rotate p 'Y' =r2y (rotate (y2r p) 'R')
rotate p 'o' =r2o (rotate (o2r p) 'r')
rotate p 'O' =r2o (rotate (o2r p) 'R')
rotate p 'b' =r2b (rotate (b2r p) 'r')
rotate p 'B' =r2b (rotate (b2r p) 'R')
rotate p _ = p
r3 [s1,s2,s3,s4,s5,s6,s7,s8,s9] = [s7,s4,s1,s8,s5,s2,s9,s6,s3]
r6 x = r3 $ r3 x
r9 x = r6 $ r3 x

画面定義は、GtkWindow に GtkVBox を置いて、その上側に GtkDrawingArea、下側に GtkEntryを置いたものを、Glade 3.8.1 で適当に作っておく。

====

一応、ルービックキューブにはなったが、遊ぶにはシャッフルする機能を追加する必要がある。あと、そもそもの目的だった、解く方のコードも書こうと思うのだけど、なんかここまでの作業で変にコーディング欲が充足されてしまって、当初のモチベーションが既に半減してしまった。なんだかなあ。

====

--2012/08/12 追記：シャッフルできるようにした