Hatena::ブログ(Diary)

まめめも このページをアンテナに追加 RSSフィード

2013-03-03

■[Haskell] Type-level Quine (未完)

「型システム入門」（TAPL 日本語版）の発売を記念して、型にまつわる何かを書こうと思い、とりあえず型レベルプログラミングでの Quine に挑戦して見ました。

TAPL の内容には全く関係ありません。型クラスは発展的なものなので、入門書である TAPL には名前しか出てきません *1 。型クラスまで書かなくても 500 ページ超の本になるので、型の世界は奥が深いですね。

デモ

ソースはこちら。

ref: https://github.com/mame/type-level-quine/blob/master/type-level-quine-poc.hs

最後の 2 行に注目。

main = putStr $ show quine                                                                  
quine = undefined :: Q X0 b (...) => b

わけわからん型注釈がついてますが、要は quine = undefined なことに注目。

これを以下のようにコンパイルします。

$ ghc -fcontext-stack=2048 type-level-quine-poc.hs
[1 of 1] Compiling Main             ( type-level-quine-poc.hs, type-level-quine-poc.o )
Linking type-level-quine-poc ...

コンパイルには数十秒から数分かかります。また、-fcontext-stack=2048 を付けることに注意。付けないとコンパイラがスタックオーバーフローします。

そして生成された実行ファイルを実行すると、

$ ./type-level-quine-poc 
-- Type-level Quine  (c) Yusuke Endoh 2013

-- snip!

main = putStr $ show quine
quine = undefined :: Q X0 b ((X2,Xd):-(X2,Xd):-(X2,X0):-(X5,X4):-(X7,X9):-(X7,X0):-(X6,X5):-(X2,Xd):-(X6,Xc):-(X6,X5):-(X7,X6):-(X6,X5):-(X6,Xc):-(X2,X0):-(X5,X1):-(X7,X5):-(X6,X9):-(X6,Xe):-(X6,X5):-(X2,X0):-(X2,X0):-(X2,X8):-(X6,X3):-(X2,X9):-(X2,X0):-(X5,X9):-(X7,X5):-(X7,X3):-(X7,X5):-(X6,Xb):-(X6,X5):-(X2,X0):-(X4,X5):-(X6,Xe):-(X6,X4):-(X6,Xf):-(X6,X8):-(X2,X0):-(X3,X2):-(X3,X0):-(X3,X1):-(X3,X3):-(X0,Xa):-(X0,Xa):-(X2,Xd):-(X2,Xd):-(X2,X0):-(X7,X3):-(X6,Xe):-(X6,X9):-(X7,X0):-(X2,X1):-(X0,Xa):-(X0,Xa):-(X6,Xd):-(X6,X1):-(X6,X9):-(X6,Xe):-(X2,X0):-(X3,Xd):-(X2,X0):-(X7,X0):-(X7,X5):-(X7,X4):-(X5,X3):-(X7,X4):-(X7,X2):-(X2,X0):-(X2,X4):-(X2,X0):-(X7,X3):-(X6,X8):-(X6,Xf):-(X7,X7):-(X2,X0):-(X7,X1):-(X7,X5):-(X6,X9):-(X6,Xe):-(X6,X5):-(X0,Xa):-(X7,X1):-(X7,X5):-(X6,X9):-(X6,Xe):-(X6,X5):-(X2,X0):-(X3,Xd):-(X2,X0):-(X7,X5):-(X6,Xe):-(X6,X4):-(X6,X5):-(X6,X6):-(X6,X9):-(X6,Xe):-(X6,X5):-(X6,X4):-(X2,X0):-(X3,Xa):-(X3,Xa):-(X2,X0):-(X5,X1):-(X2,X0):-(X5,X8):-(X3,X0):-(X2,X0):-(X6,X2):-(X2,X0):-(X2,X8):-E) => b

（途中を snip! してしまってるのを除けば）めでたく Quine になってます。quine = undefined なのにどうしたことか。

種明かし

インタプリタにかけてみるとわかります。

$ ghci -fcontext-stack=2048 type-level-quine-poc.hs
GHCi, version 7.4.2: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
[1 of 1] Compiling Main             ( type-level-quine-poc.hs, interpreted )
Ok, modules loaded: Main.
*Main>

やはり -fcontext-stack=2048 が必要なことに注意。プロンプトが出るまで時間がかかります。

プロンプトが出たら、おもむろに quine の型を見てみます。

*Main> :t quine
quine
  :: (X2, Xd)
     :- ((X2, Xd)
         :- ((X2, X0)
             :- ((X5, X4)
                 :- ((X7, X9)
                     :- ((X7, X0)
                         :- ((X6, X5)
                             :- ((X2, Xd)
                                 :- ((X6, Xc)
                                     :- ((X6, X5)
                                         :- ((X7, X6)
                                             :- ((X6, X5)
                                                 :- ((X6, Xc)
                                                     :- ((X2, X0)
...

中置のコンストラクタを使っているので面食らうかもしれないですが、これは型がリストになっています。Either をリストの cons として使っている感じです (Either head tail のように) 。

このリストの先頭の要素 (すなわち型) は (X2, Xd) です。これは ASCII コードの 0x2d 、つまりハイフンを表しています。その次の要素 (X2, Xd) もハイフン。その次 (X2, X0) は空白。その次 (X5, X4) は T 。同じように解釈を続けて行くと、

-- Type-level ...

というように、ソースコード文字列になっていることがわかります。つまり、quine は項としては undefined だけど型がソースコードを表していたのでした。

コード解説

Quine にするトリックは型クラス Q です。リストの append と Quine の encode を一括しておこなう型レベルの関数として機能しています。

X0 から Xf は nibble (16 進数の 1 文字分) を表しています。型クラス I は、それぞれの nibble を ASCII 文字に変換するための型レベルの関数と、型 X? から対応する整数の値に変換する関数を兼ねています。

文字列を表す型を実際の文字列の値に変換するのは、instance Show のあたりです。

完全な Quine

snip! で省略しない完全な Quine のソースコードは以下。

ref: https://github.com/mame/type-level-quine/blob/master/type-level-quine.hs

quine = undefined の型注釈が長くなったこと以外は poc と同じです。

しかし、このソースをコンパイルしようとするとghc がメモリを食いつぶして OS がフリーズするので、動作は確認できていません。コンパイルだけで OS を落とす Quine 。

なので残念ながら未完です。誰かもっと Haskell に詳しい人が効率的に実行できる型レベル Quine を書いてくれることを期待します。

注意 (再掲)

念のためもう一度。この内容は TAPL とは全く関係ありません。

TAPL には、Quine の名前の由来となった Willard Van Orman Quine の著書の引用がちらほらあって何となく嬉しい気持ちになりましたが、もちろん本記事の意味での Quine の話は出てきません。

また、本内容は @keigoi さんの型レベルプログラミング会議の発表内容をちょっと Quine にしてみただけです。なお、@keigoi さんも TAPL の訳者の 1 人です。

本内容とは無関係ですがアフィリエイトを置いておきます。↓クリックするなよ！

型システム入門 −プログラミング言語と型の理論−
型システム入門 −プログラミング言語と型の理論−
posted with amazlet at 13.03.01
Benjamin C. Pierce
オーム社
売り上げランキング: 598
Amazon.co.jpで詳細を見る

Permalink | コメント(1) | トラックバック(0) Type-level Quine (未完) - まめめも を含むブックマーク Type-level Quine (未完) - まめめも のブックマークコメント

*1：型レベルプログラミングを示唆する記述は 30 章あたりで微妙に出てきます。

2009-09-16

■[Ruby][Python][Perl][Lua][OCaml][Haskell][C][Java][Brainfuck][Whitespace][Unlambda] quine リレー

これはこのプログラム自身を出力する Unlambda プログラム、を出力する Whitespace プログラム、を出力する brainfuck プログラム、を出力する Java プログラム、を出力する C プログラム、を出力する Haskell プログラム、を出力する OCaml プログラム、を出力する Lua プログラム、を出力する Perl プログラム、を出力する Python プログラム、を出力する Ruby プログラム、です。

# ruby
l=92.chr;eval s="s=s.dump[r=1..-2].gsub(/("+l*4+"){4,}(?!\")/){|t|'\"+l*%d+\"'%(t
.size/2)};5.times{s=s.dump[r]};puts\"# python\\nprint(\\\"# perl\\\\nprint(\\\\\\
\"# lua"+l*4+"nprint("+l*7+"\"(* ocaml *)"+l*8+"nprint_endline"+l*15+"\"-- haskel
l"+l*16+"nimport Data.List;import Data.Bits;import Data.Char;main=putStrLn("+l*31
+"\"/* C */"+l*32+"n#include<stdio.h>"+l*32+"nint main(void){char*s[501]={"+l*31+
"\"++intercalate"+l*31+"\","+l*31+"\"(c(tail(init(show("+l*31+"\"/* Java */"+l*32
+"npublic class QuineRelay{public static void main(String[]a){String[]s={"+l*31+"
\"++intercalate"+l*31+"\","+l*31+"\"(c("+l*31+"\"brainfuck"+l*64+"n++++++++[>++++
<-]+++++++++>>++++++++++"+l*31+"\"++(concat(snd(mapAccumL h 2("+l*31+"\"110"+l*31
+"\"++g(length s)++"+l*31+"\"22111211100111112021111102011112120012"+l*31+"\"++co
ncatMap("+l*32+"c->let d=ord c in if d<11then"+l*31+"\"21002"+l*31+"\"else"+l*31+
"\"111"+l*31+"\"++g d++"+l*31+"\"22102"+l*31+"\")s++"+l*31+"\"2100211101012021122
2211211101000120211021120221102111000110120211202"+l*31+"\"))))))++"+l*31+"\","+l
*63+"\""+l*64+"n"+l*63+"\"};int i=0;for(;i<94;i++)System.out.print(s[i]);}}"+l*31
+"\")))))++"+l*31+"\",0};int i=0;for(;s[i];i++)printf("+l*63+"\"%s"+l*63+"\",s[i]
);puts("+l*63+"\""+l*63+"\");return 0;}"+l*31+"\");c s=map("+l*32+"s->"+l*31+"\""
+l*63+"\""+l*31+"\"++s++"+l*31+"\""+l*63+"\""+l*31+"\")(unfoldr t s);t[]=Nothing;
t s=Just(splitAt(if length s>w&&s!!w=='"+l*31+"\"'then 501else w)s);w=500;f 0=Not
hing;f x=Just((if x`mod`2>0then '0'else '1'),x`div`2);g x= reverse (unfoldr f x);
h p c=let d=ord c-48in(d,replicate(abs(p-d))(if d<p then '<'else '>')++"+l*31+"\"
."+l*31+"\");s="+l*31+"\"# ruby"+l*32+"n"+l*31+"\"++"+l*31+"\"l=92.chr;eval s=\"+
(z=l*31)+\"\\\"\"+s+z+\"\\\""+l*31+"\"++"+l*31+"\""+l*32+"n"+l*31+"\""+l*15+"\""+
l*7+"\")"+l*4+"n\\\\\\\")\\\")\"########### (c) Yusuke Endoh, 2009 ###########\n"

最初のコメント行以外の改行は読みやすさのために入れています。QuineRelay.rb などというファイルとして保存してください。以下のように実行します。

$ ruby QuineRelay.rb > QuineRelay.py
$ python QuineRelay.py > QuineRelay.pl
$ perl QuineRelay.pl > QuineRelay.lua
$ lua QuineRelay.lua > QuineRelay.ml
$ ocaml QuineRelay.ml > QuineRelay.hs
$ runghc QuineRelay.hs > QuineRelay.c
$ gcc -Wall -o QuineRelay QuineRelay.c && ./QuineRelay > QuineRelay.java
$ javac QuineRelay.java && java QuineRelay > QuineRelay.bf
$ beef QuineRelay.bf > QuineRelay.ws
$ wspace QuineRelay.ws > QuineRelay.unl
$ unlambda QuineRelay.unl > QuineRelay2.rb

最終的に得られる出力 QuineRelay2.rb は最初の Ruby プログラムと一致するはず。

$ diff QuineRelay.rb QuineRelay2.rb

念のため各処理系バージョンを書いておきます。すべて Debian/lenny の apt でインストールできるものです。

Permalink | コメント(13) | トラックバック(7) quine リレー - まめめも を含むブックマーク quine リレー - まめめも のブックマークコメント

2008-11-19

■[Haskell] Re: ブロックソートを Haskell で書いてみた

ref: http://d.hatena.ne.jp/mono-hate/20081119/1227100016

おお、面白い。ブロックソートは全然知らなかったので、ぼくも書いてみた。

import Data.List (sort, tails, transpose, elemIndex)
import Data.Maybe (fromJust)

encode s = (succ $ fromJust $ elemIndex s t, last $ transpose t)
 where t = sort $ map f $ f $ tails $ cycle s
       f = take (length s)

decode (n, s) = iterate f (repeat []) !! length s !! pred n
 where f = sort . zipWith (:) s

あんまり変わらないですね。

関係ないけど、キャメルケースの関数を使ったら負けた気になる。fromJust とか zipWith とか。

Permalink | コメント(0) | トラックバック(0) Re: ブロックソートを Haskell で書いてみた - まめめも を含むブックマーク Re: ブロックソートを Haskell で書いてみた - まめめも のブックマークコメント

2008-10-31

■[puzzle][Haskell] Seven Trees 解答

ref: http://d.hatena.ne.jp/ku-ma-me/20081023/p1

ref: http://d.hatena.ne.jp/m-hiyama/20081031/1225416719

ポイントは檜山さんが書かれているように、T = 1 + T^2 を使って T から T^7 への式変形を構成するところです。

その式変形は以下。各行は T^0 〜 T^8 までの係数を並べて書いています (T なら 0 1 0 0 0 0 0 0 0 、1 + T^2 なら 1 0 1 0 0 0 0 0 0 、という感じ) 。

0 1 0 0 0 0 0 0 0
 / \
1 0 1 0 0 0 0 0 0
   / \
1 1 0 1 0 0 0 0 0
     / \
1 1 1 0 1 0 0 0 0
       / \
1 1 1 1 0 1 0 0 0
         / \
1 1 1 1 1 0 1 0 0
           / \
1 1 1 1 1 1 0 1 0
             / \
1 1 1 1 1 1 1 0 1
           / \
1 1 1 1 1 2 0 1 1
         / \
1 1 1 1 2 1 1 1 1
     \ /
1 1 0 2 1 1 1 1 1
   \ /
1 0 1 1 1 1 1 1 1
 \ /
0 1 0 1 1 1 1 1 1
   \ /
0 0 1 0 1 1 1 1 1
     \ /
0 0 0 1 0 1 1 1 1
       \ /
0 0 0 0 1 0 1 1 1
         \ /
0 0 0 0 0 1 0 1 1
           \ /
0 0 0 0 0 0 1 0 1
             \ /
0 0 0 0 0 0 0 1 0

ちょうど 18 ステップでした。美しいですね。


面白かったのはここまでで、後は苦行。馬鹿正直に実装にするには、各行ごとに対応する型をバリアントとして定義していきます。

-- 0 1 0 0 0 0 0 0 0 の型
data Step0 = Step0_1 Tree

-- 1 0 1 0 0 0 0 0 0 の型
data Step1 = Step1_0
           | Step1_2 Tree Tree

-- 1 1 0 1 0 0 0 0 0 の型
data Step2 = Step2_0
           | Step2_1 Tree
           | Step2_3 Tree Tree Tree

-- 1 1 1 0 1 0 0 0 0 の型
data Step3 = Step3_0
           | Step3_1 Tree
           | Step3_2 Tree Tree
           | Step3_4 Tree Tree Tree Tree

...

-- 1 1 1 1 2 1 1 1 1 の型
data Step9 = Step9_0
           | Step9_1   Tree
           | Step9_2   Tree Tree
           | Step9_3   Tree Tree Tree
           | Step9_4_a Tree Tree Tree Tree
           | Step9_4_b Tree Tree Tree Tree
           | Step9_5   Tree Tree Tree Tree Tree
           | Step9_6   Tree Tree Tree Tree Tree Tree
           | Step9_7   Tree Tree Tree Tree Tree Tree Tree
           | Step9_8   Tree Tree Tree Tree Tree Tree Tree Tree

...

-- 0 0 0 0 0 0 0 1 0 の型
data Step18 = Step18_7 Tree Tree Tree Tree Tree Tree Tree

係数が 2 のところはバリアントも 2 つ書かないといけないところに注意。

そして Step<n> と Step<n+1> の双方向の変換を書きます。

step0_to_step1 :: Step0 -> Step1
step0_to_step1 (Step0_1 Leaf)         = Step1_0
step0_to_step1 (Step0_1 (Node tl tr)) = Step1_2 tl tr

step1_to_step2 :: Step1 -> Step2
step1_to_step2  Step1_0                  = Step2_0
step1_to_step2 (Step1_2 t0 Leaf)         = Step2_1 t0
step1_to_step2 (Step1_2 t0 (Node tl tr)) = Step2_3 t0 tl tr

step2_to_step3 :: Step2 -> Step3
step2_to_step3  Step2_0                     = Step3_0
step2_to_step3 (Step2_1 t0)                 = Step3_1 t0
step2_to_step3 (Step2_3 t0 t1 Leaf)         = Step3_2 t0 t1
step2_to_step3 (Step2_3 t0 t1 (Node tl tr)) = Step3_4 t0 t1 tl tr

...

step1_to_step0 :: Step1 -> Step0
step1_to_step0  Step1_0        = Step0_1 Leaf
step1_to_step0 (Step1_2 tl tr) = Step0_1 (Node tl tr)

step2_to_step1 :: Step2 -> Step1
step2_to_step1  Step2_0           = Step1_0
step2_to_step1  Step2_1 t0        = Step1_2 t0 Leaf
step2_to_step1 (Step2_3 t0 tl tr) = Step1_2 t0 (Node tl tr)

step3_to_step2 :: Step3 -> Step2
step3_to_step2  Step3_0              = Step2_0
step3_to_step2  Step3_1 t0           = Step2_1 t0
step3_to_step2  Step3_2 t0 t1        = Step2_3 t0 t1 Leaf
step3_to_step2 (Step3_4 t0 t1 tl tr) = Step2_3 t0 t1 (Node tl tr)

...

あとはこれらをつなげて f と g を書きます。

f :: Tree7 -> Tree
f (t0, t1, t2, t3, t4, t5, t6) =
  (\ (Step0_1 t) -> t) $
  step1_to_step0 $
  step2_to_step1 $
  ...
  step17_to_step16 $
  step18_to_step17 $
  Step18_7 t0 t1 t2 t3 t4 t5 t6 t7

g :: Tree -> Tree7
g t =
  (\ (Step18_7 t0 t1 t2 t3 t4 t5 t6) -> (t0, t1, t2, t3, t4, t5, t6)) $
  step17_to_step18 $
  step16_to_step17 $
  ...
  step1_to_step2 $
  step0_to_step1 $
  Step0_1 t

これで終わり。ふう。


ぼくが実際に書いたプログラムは、以下のようにステップを短くして、

0 1 0 0 0 0 0 0 0
 / \
1 0 1 0 0 0 0 0 0
   / \
1 1 0 1 0 0 0 0 0
     / \
1 1 1 0 1 0 0 0 0
       / \
1 1 1 1 0 1 0 0 0
         / \
1 1 1 1 1 0 1 0 0
     \ /   / \
1 1 0 2 0 1 0 1 0
   \ /       / \
1 0 1 1 0 1 1 0 1
 \ /       / \
0 1 0 1 0 2 0 1 1
   \ /   / \
0 0 1 0 1 1 1 1 1
     \ /
0 0 0 1 0 1 1 1 1
       \ /
0 0 0 0 1 0 1 1 1
         \ /
0 0 0 0 0 1 0 1 1
           \ /
0 0 0 0 0 0 1 0 1
             \ /
0 0 0 0 0 0 0 1 0

バリアントを使いまわしたものです。

module Main where
import Control.Monad
import Test.QuickCheck

data Tree = Leaf | Node Tree Tree deriving (Eq, Show)
type Tree7 = (Tree, Tree, Tree, Tree, Tree, Tree, Tree)

instance Arbitrary Tree where
    arbitrary = oneof [ return Leaf, liftM2 Node arbitrary arbitrary ]
instance
  (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d,
   Arbitrary e, Arbitrary f, Arbitrary g) =>
   Arbitrary (a, b, c, d, e, f, g) where
    arbitrary =
      return (,,,,,,)
        `ap` arbitrary `ap` arbitrary `ap` arbitrary `ap` arbitrary
        `ap` arbitrary `ap` arbitrary `ap` arbitrary

data Value = T0
           | T1  Tree
           | T2  Tree Tree
           | T3a Tree Tree Tree
           | T3b Tree Tree Tree
           | T4  Tree Tree Tree Tree
           | T5a Tree Tree Tree Tree Tree
           | T5b Tree Tree Tree Tree Tree
           | T6  Tree Tree Tree Tree Tree Tree
           | T7  Tree Tree Tree Tree Tree Tree Tree
           | T8  Tree Tree Tree Tree Tree Tree Tree Tree
           deriving (Eq, Show)

f :: Tree7 -> Tree
f (it0, it1, it2, it3, it4, it5, it6) = ot
 where v1 = T7 it0 it1 it2 it3 it4 it5 it6
       v2 = case v1 of
              T7  t0 t1 t2 t3 t4 t5 Leaf         -> T6  t0 t1 t2 t3 t4 t5
              T7  t0 t1 t2 t3 t4 t5 (Node tl tr) -> T8  t0 t1 t2 t3 t4 t5 tl tr
              v                                  -> v
       v3 = case v2 of
              T6  t0 t1 t2 t3 t4    Leaf         -> T5a t0 t1 t2 t3 t4
              T6  t0 t1 t2 t3 t4    (Node tl tr) -> T7  t0 t1 t2 t3 t4    tl tr
              v                                  -> v
       v4 = case v3 of
              T5a t0 t1 t2 t3       Leaf         -> T4  t0 t1 t2 t3
              T5a t0 t1 t2 t3       (Node tl tr) -> T6  t0 t1 t2 t3       tl tr
              v                                  -> v
       v5 = case v4 of
              T4  t0 t1 t2          Leaf         -> T3a t0 t1 t2
              T4  t0 t1 t2          (Node tl tr) -> T5a t0 t1 t2          tl tr
              v                                  -> v
       v6 = case v5 of
              T3a t0 t1             Leaf         -> T2  t0 t1
              T3a t0 t1             (Node tl tr) -> T4  t0 t1             tl tr
              v                                  -> v
       v7 = case v6 of
              T2  t0                Leaf         -> T1  t0
              T2  t0                (Node tl tr) -> T3a t0                tl tr
              T4  t0 t1 t2 t3                    -> T5b t0 t1 t2 t3       Leaf
              T6  t0 t1 t2 t3       tl tr        -> T5b t0 t1 t2 t3       (Node tl tr)
              v                                  -> v
       v8 = case v7 of
              T1                    Leaf         -> T0
              T1                    (Node tl tr) -> T2                    tl tr
              T5b t0 t1 t2 t3 t4                 -> T6  t0 t1 t2 t3 t4    Leaf
              T7  t0 t1 t2 t3 t4    tl tr        -> T6  t0 t1 t2 t3 t4    (Node tl tr)
              v                                  -> v
       v9 = case v8 of
              T2  t0                Leaf         -> T1  t0
              T2  t0                (Node tl tr) -> T3b t0                tl tr
              T6  t0 t1 t2 t3 t4 t5              -> T7  t0 t1 t2 t3 t4 t5 Leaf
              T8  t0 t1 t2 t3 t4 t5 tl tr        -> T7  t0 t1 t2 t3 t4 t5 (Node tl tr)
              v                                  -> v
       vA = case v9 of
              T3b t0 t1             Leaf         -> T2  t0 t1
              T3b t0 t1             (Node tl tr) -> T4  t0 t1             tl tr
              T5a t0 t1 t2 t3 t4                 -> T6  t0 t1 t2 t3 t4    Leaf
              T7  t0 t1 t2 t3 t4    tl tr        -> T6  t0 t1 t2 t3 t4    (Node tl tr)
              v                                  -> v
       vB = case vA of
              T4  t0 t1 t2 t3                    -> T5a t0 t1 t2 t3       Leaf
              T6  t0 t1 t2 t3       tl tr        -> T5a t0 t1 t2 t3       (Node tl tr)
              v                                  -> v
       vC = case vB of
              T3a t0 t1 t2                       -> T4  t0 t1 t2          Leaf
              T5a t0 t1 t2          tl tr        -> T4  t0 t1 t2          (Node tl tr)
              v                                  -> v
       vD = case vC of
              T2  t0 t1                          -> T3a t0 t1             Leaf
              T4  t0 t1             tl tr        -> T3a t0 t1             (Node tl tr)
              v                                  -> v
       vE = case vD of
              T1  t0                             -> T2  t0                Leaf
              T3a t0                tl tr        -> T2  t0                (Node tl tr)
              v                                  -> v
       vF = case vE of
              T0                                 -> T1                    Leaf
              T2                    tl tr        -> T1                    (Node tl tr)
              v                                  -> v
       (T1 ot) = vF

g :: Tree -> Tree7
g it = (ot0, ot1, ot2, ot3, ot4, ot5, ot6)
 where v1 = T1 it
       v2 = case v1 of
              T1                    Leaf         -> T0
              T1                    (Node tl tr) -> T2                    tl tr
              v                                  -> v
       v3 = case v2 of
              T2  t0                Leaf         -> T1  t0
              T2  t0                (Node tl tr) -> T3a t0                tl tr
              v                                  -> v
       v4 = case v3 of
              T3a t0 t1             Leaf         -> T2  t0 t1
              T3a t0 t1             (Node tl tr) -> T4  t0 t1             tl tr
              v                                  -> v
       v5 = case v4 of
              T4  t0 t1 t2          Leaf         -> T3a t0 t1 t2
              T4  t0 t1 t2          (Node tl tr) -> T5a t0 t1 t2          tl tr
              v                                  -> v
       v6 = case v5 of
              T5a t0 t1 t2 t3       Leaf         -> T4  t0 t1 t2 t3
              T5a t0 t1 t2 t3       (Node tl tr) -> T6  t0 t1 t2 t3       tl tr
              v                                  -> v
       v7 = case v6 of
              T2  t0 t1                          -> T3b t0 t1             Leaf
              T4  t0 t1             tl tr        -> T3b t0 t1             (Node tl tr)
              T6  t0 t1 t2 t3 t4    Leaf         -> T5a t0 t1 t2 t3 t4
              T6  t0 t1 t2 t3 t4    (Node tl tr) -> T7  t0 t1 t2 t3 t4    tl tr
              v                                  -> v
       v8 = case v7 of
              T1  t0                             -> T2  t0                Leaf
              T3b t0                tl tr        -> T2  t0                (Node tl tr)
              T7  t0 t1 t2 t3 t4 t5 Leaf         -> T6  t0 t1 t2 t3 t4 t5
              T7  t0 t1 t2 t3 t4 t5 (Node tl tr) -> T8  t0 t1 t2 t3 t4 t5 tl tr
              v                                  -> v
       v9 = case v8 of
              T0                                 -> T1                    Leaf
              T2                    tl tr        -> T1                    (Node tl tr)
              T6  t0 t1 t2 t3 t4    Leaf         -> T5b t0 t1 t2 t3 t4
              T6  t0 t1 t2 t3 t4    (Node tl tr) -> T7  t0 t1 t2 t3 t4    tl tr
              v                                  -> v
       vA = case v9 of
              T1  t0                             -> T2  t0                Leaf
              T3a t0                tl tr        -> T2  t0                (Node tl tr)
              T5b t0 t1 t2 t3       Leaf         -> T4  t0 t1 t2 t3
              T5b t0 t1 t2 t3       (Node tl tr) -> T6  t0 t1 t2 t3       tl tr
              v                                  -> v
       vB = case vA of
              T2  t0 t1                          -> T3a t0 t1             Leaf
              T4  t0 t1             tl tr        -> T3a t0 t1             (Node tl tr)
              v                                  -> v
       vC = case vB of
              T3a t0 t1 t2                       -> T4  t0 t1 t2          Leaf
              T5a t0 t1 t2          tl tr        -> T4  t0 t1 t2          (Node tl tr)
              v                                  -> v
       vD = case vC of
              T4  t0 t1 t2 t3                    -> T5a t0 t1 t2 t3       Leaf
              T6  t0 t1 t2 t3       tl tr        -> T5a t0 t1 t2 t3       (Node tl tr)
              v                                  -> v
       vE = case vD of
              T5a t0 t1 t2 t3 t4                 -> T6  t0 t1 t2 t3 t4    Leaf
              T7  t0 t1 t2 t3 t4    tl tr        -> T6  t0 t1 t2 t3 t4    (Node tl tr)
              v                                  -> v
       vF = case vE of
              T6  t0 t1 t2 t3 t4 t5              -> T7  t0 t1 t2 t3 t4 t5 Leaf
              T8  t0 t1 t2 t3 t4 t5 tl tr        -> T7  t0 t1 t2 t3 t4 t5 (Node tl tr)
              v                                  -> v
       (T7 ot0 ot1 ot2 ot3 ot4 ot5 ot6) = vF

main :: IO ()
main = do
    quickCheck $ \x -> x == f (g x)
    quickCheck $ \x -> x == g (f x)

ながー。5 分岐とかは全然考えてないです。

Permalink | コメント(0) | トラックバック(0) Seven Trees 解答 - まめめも を含むブックマーク Seven Trees 解答 - まめめも のブックマークコメント

2008-10-26

■[Ruby][Haskell] レーベンシュタイン距離

ふとレーベンシュタイン距離 (編集距離) の計算を書きたくなったので書いてみた。わりと綺麗に書けたと思った。

def levenshtein_distance(s, t)
  t.chars.with_index.inject(0..s.size) do |r, (a, z)|
    z += 1
    [z] + s.chars.zip(r.each_cons(2)).map do |b, (x, y)|
      z = [y + 1, z + 1, x + (a == b ? 0 : 1)].min
    end
  end.last
end

p levenshtein_distance("kitten", "sitting")   #=> 3
p levenshtein_distance("Saturday", "Sunday")  #=> 3

んー、でも、with_index が 0 origin 固定なのがいまいちですね。あと scanl や mapAccumL が欲しい、かなあ。


やはり Haskell はいい感じ。もっと綺麗に短く書けるかな？

levenshtein_distance :: Eq a => [a] -> [a] -> Int
levenshtein_distance s t = last $ foldl f [0..length s] $ zip t [1..]
  where f r (a, z) = scanl (g a) z $ zip3 s r (tail r)
        g a z (b, x, y) = minimum [y + 1, z + 1, x + fromEnum (a /= b)]

main :: IO ()
main = do
  print $ levenshtein_distance "kitten" "sitting"  -- 3
  print $ levenshtein_distance "Saturday" "Sunday" -- 3

Permalink | コメント(0) | トラックバック(0) レーベンシュタイン距離 - まめめも を含むブックマーク レーベンシュタイン距離 - まめめも のブックマークコメント

プロフィール

ku-ma-me

ku-ma-me

Ruby とか Quine とか esoteric language とかが好きです。あと関東沿線歩きの記録。

カレンダー
<< 2013/05 >>
日 月 火 水 木 金 土
1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31
最近のトラックバック
最近のコメント
カテゴリー