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 追記：シャッフルできるようにした

s/UT/UnitTest/

このブログで今まで UnitTest について書いた投稿には、「UT」というラベルを付けていたが、これを今日、「UnitTest」に付け替えた。

最初は何の気なしに「UT」としてしまっていたけど、最近は、なんだか見れば見るほどウォーターフォール文化における単体テストを表す略号に見えてきて、本来語りたい事とのズレが大きく感じられるようになってきた。

ちなみに本文では、だいたい UnitTest とパスカルケースで書いてきたつもり。これは、ウォータフォールの単体テストと区別するためであると同時に、本家 wiki の仕様に合わせてリスペクトを表明しているからでもあったりする。

ところで、ウォーターフォール色が強い組織・現場では、未だに「実装フェーズ」の直後に「単体テストフェーズ」を設けて、そこで初めて JUnitコード を書き始めるような残念な開発が、特に反省されることもなく日々実践されている。

そういう現場でも、理論的には後付けテストはダメなんだと言う事が、何かの拍子に認知され始めて、一応名目上は「実装・UTフェーズ」みたいに、前後関係をボヤかした感じになったりするのだけど、いかんせんプログラマの意識が「テストの事なんか後で考える」のままだから、実質的には何も変わらないし進歩もない。

泳ぎの真似を陸上でどれだけやったところで泳げるようになんかならないように、後付けテストなんか何年やってもテスト・ファーストで書けるようには全然ならない。

だからそろそろ、現場の開発チームで指導的な立場にある人は、「できればなるべく差し支えない範囲でTDD推奨」みたいな感じではなく、そろそろ「TDD必須」って宣言すべきだと思う。

本当に、一度できるようになったら、というか、できるようになってみないと「テストを先に書く」方がその逆よりも、工数、品質、仕事の面白さなど、どれをとっても格段に優れているという認識は成立しないのだろうと、つくづく思う。

とはいっても、「やってみればテストファーストの方が速い事が分かるよ」なんてやんわりと言って聞かせたところで、どうせ一向に浸透しないのはもう分かった。つう事は、山本五十六も「やってみせ、いって聞かせて、させてみて、 褒めてやらねば人は動かじ」なんて言っているとおり、まずは横に座って実演するところから始めなければならない事になるらしい（やっぱ結局XPに戻ってくる事になるのか…）。

高跳びでも、背中を下に向けた方がその逆より高く跳べるという事に、フォスベリーが記録を出すまでは、だれも気づかなかった。だから、まず「やってみせ」から始めないとダメなのだろう。やってみせる事なしに「言って聞かせて」も結局効果がないし、「させてみせ」も、結局ちょっと目を離したスキにうやむやになってしまう。

・・・つう事を考えているのだけど、本当に残念で仕方が無いが、今の現場では直接コードを書いて実演できるような立ち位置ではなかったりする。次の現場こそは、まずは絶対に、自分で「やってみせ」るところから始められる、実装メインのロールでプロジェクトに参画したい。

Haskell でソケット通信をやってみる

Haskell で ソケットを使ったクライアント-サーバ通信をやってみる。

Haskell を使ったネットワーク・プログラミングの入り口が分かればいいので、クライアントから受け取った文字列をひっくり返して返すだけの、簡単なお題とする。

まず、サーバはこんな感じ。

import Network
import System.IO 

main :: IO ()
main = withSocketsDo $ do 
    hSetBuffering stdout NoBuffering
    server `catch` (const $ putStrLn "Exception caught.")
    putStrLn "Connection closed."

server :: IO ()
server = do
    sock <- listenOn (PortNumber 8001)
    repeats (receive sock)
    sClose sock

repeats :: Monad m => m Bool -> m () 
repeats x =
    x >>= (\x' -> if x' then (return ()) else repeats x)

receive :: Socket -> IO Bool
receive sock = do
    (h,host,port) <- accept sock
    hSetBuffering h LineBuffering
    msg <- hGetLine h           
    putStrLn msg 
    hPutStrLn h $ reverse msg 
    return $ null msg

クライアントはこんな感じ。

import Network
import System.IO 

sendMessage msg = withSocketsDo $ do 
        hSetBuffering stdout NoBuffering 
        h <- connectTo "127.0.0.1" (PortNumber 8001)
        hSetBuffering h LineBuffering
        hPutStrLn h msg
        hGetLine h >>= putStrLn
        hClose h

実行は GHCi でやってみる。
以下、サーバ側

ghci> :load server.hs
[1 of 1] Compiling Main             ( server.hs, interpreted )
Ok, modules loaded: Main.
ghci> main
Loading package bytestring-0.9.1.10 ... linking ... done.
 ・・・略・・・
Loading package network-2.3.0.7 ... linking ... done.
hello
1234

Connection closed.
ghci> 

以下、クライアント側

ghci> :load client.hs
[1 of 1] Compiling Main             ( client.hs, interpreted )
Ok, modules loaded: Main.
ghci> sendMessage "hello"
Loading package bytestring-0.9.1.10 ... linking ... done.
 ・・・略・・・
Loading package network-2.3.0.7 ... linking ... done.
olleh
ghci> sendMessage "1234"
4321
ghci> sendMessage ""
ghci> 

思ったより難しくない。次は、マルチスレッド化かなあ。