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

今年の正月に、Haskell で 平面ルービックキューブを書いてみた。「Haskell で平面ルービックキューブ」

この時は、Haskell の GUI コーディングはどんなものかと、Gtk2Hs を調べるついでに書いただけなので、シャッフルくらいできるようにしても良いなと思いつつ、放置していた。それを今日は書き足してみた。

====

シャッフルというのは、Esc キーを押すと、6面揃った状態から指定の回数分だけ、ランダムな面と方向で90度回転させるというもの。回数は起動時パラメータで指定する。

下の画像は、Escキーを押した直後。起動時に 3を渡しているので、3回かき回している。

これをよく見て、青を反時計回り(B)、赤を時計回り(r)、白を時計回り(w)と、3回操作すると 6面が揃う。

ソースはこんな感じになる（ブログに貼るにはチト長いが…）

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
import Control.Monad
import System
import System.Random

--図形と色
data SquareColor = G|R|W|Y|O|B deriving Show
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

initialSurface = 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 とウィンドウ操作
main = do
    currentSurfaceIORef <- newIORef initialSurface
    initialSurfaceIORef <- newIORef initialSurface

    initGUI
    Just xml     <- xmlNew "rcube.glade"
    window       <- xmlGetWidget xml castToWindow "window1"
    entry        <- xmlGetWidget xml castToEntry "entry1"
    drawingArea  <- xmlGetWidget xml castToDrawingArea "drawingarea1"

    onDestroy window mainQuit
    onExposeRect drawingArea (const $ do
        dw       <- widgetGetDrawWindow drawingArea
        gc       <- gcNew dw
        surface  <- readIORef currentSurfaceIORef
        size     <- widgetGetSize drawingArea
        drawCube dw gc size surface)
    onEditableChanged entry $ do
        seq      <- get entry entryText
        surface  <- readIORef initialSurfaceIORef
        writeIORef currentSurfaceIORef $ rotateAll surface seq
        widgetQueueDraw drawingArea
    onKeyPress entry (\event -> do
        if 65307 == Evt.eventKeyVal event
        then do
            args <- getArgs
            s <- shuffle $ read $ args!!0
            let shuffled = rotateAll initialSurface s
            writeIORef initialSurfaceIORef shuffled
            writeIORef currentSurfaceIORef shuffled
            widgetQueueDraw drawingArea
            entrySetText entry ""
            return True
        else return False)

    widgetShowAll window
    mainGUI
  where
    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
    shuffle n = replicateM n
              $ getStdRandom (randomR (0,11)) >>= (return.(!!) "rgbywoRGBYWO")

-- 回転操作
rotateAll p [] = p
rotateAll p (x:xs) = rotateAll (rotate p x) xs
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

onKeyPress の辺りを書き足した。Hackage がダウンしていてドキュメントが見られないというアクシデントがあったが、割と簡単に直感で書けてしまう。