HaskellでKEMURIソルバーα0.2
HaskellでKEMURIソルバーができたけど、
「1つのPUSHで要求されたデータを作る」という条件が付いている。
まだ最小のコードを出力するとは限らない。
あと、1文字決定するのに11秒くらいかかる。
あ、「g」とかだと、メモリを1ギガ以上食ってものすごく時間がかかりそう。
ダメだなぁ、まだ枝刈りが必要だ。
= ソルバ0.2が作ったコードを見て思ったのだけど、 まず最初にXORを連打して捨てるべきなんだな。 探索の時も、まずPUSHで積んだ後、 XOR連打でスタックの長さが1になるまで縮めて、 ゴールかどうかを判定。 次にXOR連打で長さ2まで縮めて、下の3通りの「正しい方法」で1に縮めて ゴールかどうかの判定。
=
= スタック[1, 2, 4]から長さ2のスタックへの「正しい道筋」リスト。
__ 0.2にバージョンアップ。 0.1では「ROT ROTの後にはROTをおかない、DUPのあとにはDUPをおかない」というルールを入れていたのだけど、これでは「ROT DUP ROT DUP ...」でどんどん無駄に長いスタックを作れてしまう。そこで 「ROT ROTの後にはDUPをおかない、DUP ROTの後にはDUPをおかない、 DUP ROTの後にはROTをおかない」というルールを追加した。 厳密には「目的の文字列を出力するための最小の命令列にはこれらの命令列が含まれていない」ということを証明しないといけない。
でもとりあえずgも出力されるようになった。
(H): `^^^^^^^^^^'^"^^ (o): `^^^^''^"^^^^^^^^ (g): `^^^^^^'^''^"^^^^^ (J): `^^^^'^'^'^'^"^^^^^Hより2ステップ長い。この2ステップがバージョン0.1では致命的だったのだ。
僕が以前手で書いたJをスタックに積むコードは
`"^^"^^^^"^^"^^^^^'"^^"^^'"^^"^^"'^"^^なので、このソルバが出した
`^^^^'^'^'^'^"^^^^^という解は約半分の長さ。
__ ダメだ。「u」の計算が終わらない。 まだまだだ。 アドホックな枝刈りでは解決できない。 冷静に考えてみよう。
スタックにn個積んである状態から、スタックに1個しかないじょうたいに行く過程では、 かならずn-1個の状態を通る。積まれた数が減る命令がXORだけだから。 というわけでn個からn-1個に変化する過程に注目しよう。
言い忘れたけども今回はNOTは使わないことにする。 証明していないけどもなくても構わないと思うので。
そうすると、ROTとDUPとXORの組み合わせで何ができるか、という話になる。 ROTで上3つを並び替えるのが一番深くまで触る命令だから、 スタックのそれより深い部分は無視していい。 つまりa b c -> ... -> x y。
ROTとXORとDUPの組み合わせでできる命令列のうち、 長さ3のスタック[1, 2, 3]を与えて実行すると スタックの長さが2になるような命令列を抽出(take 10)
^: Just [3,4] '^: Just [6,1] "^^: Just [2,4] ''^: Just [5,2] "^'^: Just [6,0] "'^^: Just [2,4] '"^^: Just [4,1] '''^: Just [3,4] "^"^^: Just [2,4] "^''^: Just [4,2]見ての通り、ROT ROT ROT XOR は XOR と同じ結果になる。自明。 他にも DUP XOR XOR は DUP ROT XOR XORと同じ結果。
重複するものを取り除く。
^: Just [3,4] '^: Just [6,1] "^^: Just [2,4] ''^: Just [5,2] "^'^: Just [6,0] '"^^: Just [4,1] "^''^: Just [4,2]これが正しい道筋リスト。 ここで、1と2と4のXORで作ることのできる数は 0～7の8通りなので、 「スタックの長さが2になったときのスタックの中身」 は64通り。 重複したものを取り除いた後でtake 64する。
重複するものを取り除くところで下のようなことをしていたので無限ループに突入(苦笑)
uniq = foldl uniqAdd []
uniqAdd xs x =
if not(any (== (stack x)) (map stack xs)) then
(x:xs)
else
xs
まぁ、十分な長さでtakeすることで、64本の「正しい道筋」リストが完成。
巻末に掲載。
= ソルバ0.2が作ったコードを見て思ったのだけど、 まず最初にXORを連打して捨てるべきなんだな。 探索の時も、まずPUSHで積んだ後、 XOR連打でスタックの長さが1になるまで縮めて、 ゴールかどうかを判定。 次にXOR連打で長さ2まで縮めて、下の3通りの「正しい方法」で1に縮めて ゴールかどうかの判定。
"^^: Just [2] "'^"^^: Just [1] "''"^^^: Just [0]
次にXOR連打で長さ3まで縮めてから、63通りの「正しい方法」で2に縮めて、 そこから3通りの正しい方法で1に縮めて判定。 …というような探索をすればいい気がする。解が見つかったら長さを枝かりに使う。
重要なのは「探索するごとにスタックの長さが1ずつ短くなる」ということ。 探索空間が有限になったので深さ優先で探索できる。 今度はそれを実装することにしよう。
ここまでやってもまだ最短ではないんだよなぁ。 1文字ずつ生成しているから。 例えば"d!"と表示するのに"d"と"!"を別々に作るより、 "Hello, world!"の最後の2文字を使って一度に2つ作る方が短いコードになるはず。
=
-- Kemuri ソルバ
import Data.Char
import Data.Bits
-- main = print $ start_kemuri "`|"
-- main = print $ showCode solve
-- main = print $ take 10 (bfs visit start)
-- main = print $ isGoal (Situation "" (km_xor (km_xor (km_dup (stack start)))))
-- main = putStr.show $ solve "H"
-- main = do input <- getContents
-- putStr (unlines (map format (map (:[]) input)))
main = putStr.format $ "g"
format goal =
"(" ++ goal ++ "): " ++ (show (solve goal))
solve goal = (filter (isGoal goal) (bfs visit start)) !! 0
isGoal _ (Situation _ Nothing) = False
isGoal goal (Situation _ (Just x)) =
x == map ord goal
showCode (Situation code _) = reverse code
bfs :: (a -> [a]) -> a -> [a]
bfs f = bfs' . (:[])
where bfs' [] = []
bfs' xs = xs ++ bfs' (xs >>= f)
visit :: Situation -> [Situation]
visit (Situation code Nothing) = []
visit (Situation code stack)
= [Situation ('^':code) (km_xor stack)]
++ add_rot code stack ++ add_dup code stack
add_dup code stack@(Just xs)
= if length xs < 15 then
if head code == '"' then []
else if take 2 code == "'\"" then []
else if take 3 code == "''\"" then []
else [Situation ('"':code) (km_dup stack)]
else
[]
add_rot code stack
= if take 2 code == "''" then
[]
else if take 2 code == "\"'" then
[]
else
[Situation ('\'':code) (km_rot stack)]
data Situation =
Situation {doneCode::String, stack::Stack}
instance Show Situation where
show x = reverse $ doneCode x
start = Situation "`" (km_push (Just []))
operate_stack :: Stack -> Char -> Stack
operate_stack stack c = case c of
'^' -> km_xor stack
'~' -> km_not stack
'\'' -> km_rot stack
'"' -> km_dup stack
'`' -> km_push stack
_ -> stack
type KemuriResult = Maybe String
kemuri :: Stack -> String -> KemuriResult
kemuri stack (c:code)=
case c of
'|' -> if stack == Nothing then
Nothing
else
add (km_mkstr stack) (start_kemuri code)
where add (Just x) (Just y) = Just (x ++ y)
c -> kemuri (operate_stack stack c) code
kemuri Nothing _ = Nothing
kemuri _ []= Just ""
start_kemuri :: String -> KemuriResult
start_kemuri code = kemuri (Just []) code
type Stack = Maybe [Int]
km_xor :: Stack -> Stack
km_xor (Just (x:(y:rest))) = Just ((xor x y):rest)
km_xor x = Nothing
km_not :: Stack -> Stack
km_not (Just (x:rest)) = Just ((complement x):rest)
km_rot :: Stack -> Stack
km_rot (Just (x:(y:(z:rest)))) = Just (y:z:x:rest)
km_rot x = Nothing
km_dup :: Stack -> Stack
km_dup (Just (x:rest)) = Just (x:x:rest)
km_push :: Stack -> Stack
km_push (Just xs) = Just (map ord "Hello, world!" ++ xs)
km_mkstr :: Stack -> KemuriResult
km_mkstr (Just xs) = Just (map chr xs)
km_mkstr Nothing = Nothing
= スタック[1, 2, 4]から長さ2のスタックへの「正しい道筋」リスト。
^: Just [3,4] '^: Just [6,1] "^^: Just [2,4] ''^: Just [5,2] "^'^: Just [6,0] '"^^: Just [4,1] "^''^: Just [4,2] "'^'^: Just [5,3] '"^'^: Just [5,0] ''"^^: Just [1,2] "^'"^^: Just [4,0] "'^"^^: Just [1,4] "'^''^: Just [7,1] '"'^'^: Just [3,6] ''"^'^: Just [3,0] "^''"^^: Just [0,2] ""^'^'^: Just [4,3] "''"^^^: Just [0,4] '"^'"^^: Just [1,0] '"'^"^^: Just [2,1] '"'^''^: Just [7,2] ''"'^'^: Just [6,5] "^'"'^'^: Just [2,6] "^''"^'^: Just [2,0] ""^'^''^: Just [7,0] "'^''"^^: Just [3,1] "''"^^'^: Just [5,1] '""^'^'^: Just [1,6] '"''"^^^: Just [0,1] ''"'^''^: Just [7,4] "^'"^'"^^: Just [0,0] "^'"'^''^: Just [6,2] "^''"'^'^: Just [6,4] "'^"'^''^: Just [6,3] "'^'"'^'^: Just [2,5] '"^'"'^'^: Just [4,5] '"''"^^'^: Just [3,2] "^'""^'^'^: Just [0,6] ""^'^"'^'^: Just [7,3] "'^'"'^"^^: Just [1,3] "'^''"'^'^: Just [5,7] '"^'"'^''^: Just [5,4] '"'^"'^''^: Just [5,6] "^'"^'"'^'^: Just [4,4] "^'"''"^^'^: Just [2,2] "'^"^'"'^'^: Just [1,5] "'^"'^''"^^: Just [2,3] "'^'""^'^'^: Just [3,5] "'^'"''"^^^: Just [0,3] "''"^^''"^^: Just [1,1] '"^'""^'^'^: Just [0,5] '""^'^"'^'^: Just [7,6] '"'^''"'^'^: Just [3,7] "^"'^''"'^'^: Just [4,6] ""^'^''"'^'^: Just [4,7] "'^"'^'"'^'^: Just [1,7] ''""^'^"'^'^: Just [7,5] ''"'^''"'^'^: Just [6,7] "^'""^'^"'^'^: Just [6,6] ""^'^"'^''"^^: Just [3,3] "''"^^''"'^'^: Just [5,5] '"'^"'^'"'^'^: Just [2,7] ""^'^"'^'"'^'^: Just [0,7] ""^'^"'^''"'^'^: Just [7,7]スタック[1, 2]から長さ1のスタックへの「正しい道筋」リスト。
^: Just [3] "^^: Just [2] "'^"^^: Just [1] "''"^^^: Just [0]
