Pure で数独 - zyxwvの日記

年も明けたことだし新しい言語で何か書いてみよう、ということで、書いてみた。言語は Pure (Google Code Archive - Long-term storage for Google Code Project Hosting.)。id:mzp が「HelloWorld の次に書くプログラムと言えばフィボナッチ数か階乗かエラトステネスのふるい」と言っていたが、さらにその次はおそらく数独であろう。
Pure は項書き換え系に基づくらしい言語で、文法は C と Haskell の合わせ技みたいな感じになっとる。ちなみに実行には LLVM を使っているので C と相性がいいらしい。標準ライブラリのソースを眺めつつ、ろくにマニュアルを見ずに書いてみたけど、なんとかなってしまった。残念ながら現時点では、Pure を使う利点が見当たらない。C のコードを簡単に埋め込める(らしい)関数型言語、って感じだろうか。例によって資料が極端に少ないので、もう少し使ってみてまだ興味が残っていれば簡単なまとめとかも書いてみたい。

ソースのはじめの部分には、練習がてら Haskell っぽい関数をたくさん定義してある。型がないどころか名前は全部シンボルなので、エラーがすごくわかりづらい。
例えばこんな感じ。

> let x = tail [];  // <- エラーにならない
> x;
tail []  // <- 書換えルールがないので項がそのまま残っている
>

なので、あとで x をリストだと思って操作するとエラーがでてはまるわけです。

> if null x then 0 else 1;
<stdin>, line 8: unhandled exception 'failed_cond' while evaluating 'if null x then 0 else 1'
>

あと、パーサがちょっとしょぼいみたいで、if 文とか case 文ではまることも。他にもいくつかはまりポイントがあったような気がするんだけど、忘れてしまったので省略。

using system;
using strings;

print = puts . str;

mynot 0 = 1;
mynot 1 = 0;

mem _ [] = false;
mem e (x:xs) = true if e == x;
             = mem e xs;
intersect [] _ = [];
intersect (x:xs) ys = x : intersect xs ys if mem x ys;
                    = intersect xs ys;
foldl1 _ [] = [];
foldl1 f xs = foldl f (head xs) (tail xs);
intersects = foldl1 intersect;
delete _ [] = [];
delete e (x:xs) = xs if e == x;
                = x : delete e xs;
complement all xs = foldr delete all xs;
sum = foldl1 (+);
unions = sum;
concatMap = sum . map;
mapi f xs = map f $ zip (0..#xs) xs;
remove 0 (_:xs) = xs;
remove n (x:xs) = x : remove (n-1) xs;
splitAt m xs = (take m xs, drop m xs);

isList [] = true;
isList (_:_) = true;
isList _ = false;

replace (x:xs) (0,n) new = replace x n new : xs;
replace (x:xs) (m,n) new = x : replace xs (m-1,n) new;
replace (_:xs) 0 new = new : xs;
replace (x:xs) n new = x : replace xs (n-1) new;

merge = foldr (\x -> \y -> if isList x then x+y else x : y) [];
//--------------------------------------------------------------------------------
updateBoardWith f b = update (0,0) b
with
  update (x,y) b = if y == base * base
                     then b
                     else (if x == base * base
                           then update (0,y+1) b
                           else (if isList (b!y!x)
                                 then update (x+1,y) $ f (x,y) b
                                 else update (x+1,y) b));
end;
//--------------------------------------------------------------------------------
getRow (_,y) b = b!y;
getCol (x,_) b = map (\xs -> xs!x) b;
getBox (x,y) b = sum $ map (take base . drop xx) [b!yy, b!(yy+1), b!(yy+2)]
when
  xx = x div base * base;
  yy = y div base * base;
end;
//--------------------------------------------------------------------------------
// method 1
updateCandidate (x,y) b = replace b (y,x) new
with
  sole [x] = x;
  sole x = x;
  new = sole $ intersects [ getCand getRow (x,y) b
                          , getCand getCol (x,y) b
                          , getCand getBox (x,y) b
                          ];
  getCand getter (x,y) b = complement n $ filter (mynot.isList) $ getter (x,y) b;
end;
//--------------------------------------------------------------------------------
// method 2
isUnique xs ys = filter (\x -> mynot $ mem x ys) xs;
unique getter splitter (x,y) board =
  if isList target
    then (case cand of
          [] = board;
          [e] = replace board (y,x) e;
          e = throw "This puzzle sucks!";
          end when cand = isUnique target ab end)
    else board
when
  (a, (target:b)) = splitter (x,y) $ getter (x,y) board;
  ab = merge (a+b);
end;
uniqueRow = unique getRow (\ (x,_) -> splitAt x);
uniqueCol = unique getCol (\ (_,y) -> splitAt y);
uniqueBox = unique getBox (\ (x,y) -> splitAt (y mod base * base + x mod base));
//--------------------------------------------------------------------------------
solve board = if isComplete board 
                then board
                else solve $ updateBoard $ board
with
  isComplete b = all (\l -> all (mynot.isList) l) b;
  updateBoard = foldl1 (.) [ updateBoardWith uniqueRow
                           , updateBoardWith updateCandidate
                           , updateBoardWith uniqueCol
                           , updateBoardWith updateCandidate
                           , updateBoardWith uniqueBox
                           , updateBoardWith updateCandidate
                           ];
end;

print_b [] = ();
print_b (x:xs) = print x $$ print_b xs;
//--------------------------------------------------------------------------------
base = 3;
n = 1..(base * base);
sample = [[n,4,8,n,n,9,n,3,n]
         ,[n,n,n,2,n,n,n,n,7]
         ,[9,n,7,n,n,n,n,1,n]
         ,[n,n,n,n,n,7,5,n,3]
         ,[n,n,3,5,n,6,8,n,n]
         ,[2,n,4,8,n,n,n,n,n]
         ,[n,7,n,n,n,n,4,n,6]
         ,[8,n,n,n,n,4,n,n,n]
         ,[n,9,n,7,n,n,3,8,n]
         ];

print_b $ solve sample;

実行結果。

$ pure sudoku.pure
[1,4,8,6,7,9,2,3,5]
[5,3,6,2,1,8,9,4,7]
[9,2,7,4,3,5,6,1,8]
[6,8,9,1,4,7,5,2,3]
[7,1,3,5,2,6,8,9,4]
[2,5,4,8,9,3,7,6,1]
[3,7,1,9,8,2,4,5,6]
[8,6,2,3,5,4,1,7,9]
[4,9,5,7,6,1,3,8,2]
$

おもしろかったです。