DouKaku?beta

Comment detail

与えられた並べ替えを実現するあみだくじの生成 (Nested Flatten) 
全探索を行って、最も行数が少なく、横線の本数が少ない解答を出力します。

[xsd@celldev dk109]$ ./dk109
0 1 2 3 4 5
| |-| | | |
|-| |-| |-|
| |-| |-| |
|-| |-| |-|
| |-| |-| |
3 5 2 4 0 1
Height=5, Lines=11
 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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
let comb n =
    let rec comb1 mask cost acc = function
        | 0 -> if cost = 0 then acc else (mask, cost) :: acc
        | x ->
            let acc = comb2 (mask lor x) (cost+1) acc (x lsr 1) in
                      comb1  mask         cost    acc (x lsr 1)
    and comb2 mask cost acc = function
        | 0 -> (mask, cost) :: acc
        | x -> comb1 mask cost acc (x lsr 1) in
    comb1 0 0 [] (1 lsl (n - 2))

let apply mask cost (state, (c1, c2)) =
    let rec apply' prev mask = function
        | []    -> [ prev ]
        | head :: tail ->
            if (mask land 1)=1 then head :: apply' prev (mask lsr 1) tail
                               else prev :: apply' head (mask lsr 1) tail in
    (match state with
    | []       -> []
    | hd :: tl -> apply' hd mask tl), (c1 + 1, c2 + cost)

let drawamida mask n =
    let rec amida s mask = function
        | 0 -> s
        | x -> if (mask land 1) = 0 then amida (s ^ " |") (mask lsr 1) (x-1)
                                    else amida (s ^ "-|") (mask lsr 1) (x-1) in
    amida "|" mask (n - 1)

let rec equal arg1 arg2 = match arg1, arg2 with
    | [], []                -> true
    | h1 :: t1, h2 :: t2    -> if h1 <> h2 then false else equal t1 t2
    | _, _                  -> false

let solve targetstate options limitcost initstate =
    let rec loop target options best current =
        let bestsoln, bestcost  = best in
        let curstate, curoption, cursoln, curcost = current in
        let costcomp (c1, c2) (m1, m2) = c1 >= m1 ||  c2 >= m2 in
        if (costcomp curcost bestcost) then best else (
            if equal target curstate then cursoln, curcost else (
                match curoption with
                    | []       -> best
                    | (mask, cost) :: tl ->
                        let newstate, newcost = apply mask cost (curstate, curcost) in
                        let best =  loop target options best (newstate, options, (mask :: cursoln), newcost) in
                                    loop target options best (curstate, tl, cursoln, curcost)
            )
        ) in
    loop targetstate options ([], limitcost) (initstate, options, [], (0, 0))

let main target =
    let rec prt = function | [] -> print_endline "" | hd :: tl -> let _ = Printf.printf "%d " hd in prt tl in
    let rec seq n   = function [] -> [] | _ :: tl -> n :: (seq (n+1) tl) in
    let len         = List.length target in
    let start       = seq 0 target in
    let _           = prt start in
    let best, (c,d) = solve target (comb len) (len, len * len) start in
    let rec prt2 n  = function [] -> () | hd :: tl -> (print_endline (drawamida hd n); prt2 n tl) in
    let _           = prt2 len (List.rev best) in
    let _           = prt target  in
    Printf.printf "Height=%d, Lines=%d\n" c d

let _ = main [ 3; 5; 2; 4; 0; 1]

おお、すごい。

ちなみに、横棒の数の最小値は、与えられたリストをpermutationと見た場合のinversionの数と同じであることが知られているそうです。(inversionとは、リストのi番目の要素をa_iと書く時、 i < j かつ a_i > a_j となっている箇所。(3 5 2 4 0 1) の場合は、(3,2) (3,0) (3,1) (5,2) (5,4) (5,0) (5,1) (2,0) (2,1) (4,0) (4,1) の11個。)

ああそうか．
inversion を求めて，隣接するものを採用，残りを採用したもので変換，
というのを繰り返せばいいのか．これで多分，横棒数，段数ともに最小になるはず？

印字系は手抜きです(縦棒10本まで対応)．置換を与えると，阿弥陀籤を印字します．

実行結果
*Main> :main [3,5,2,4,0,1]
0 1 2 3 4 5
| |-| | |-|
|-| |-| | |
| |-| |-| |
|-| |-| |-|
| |-| |-| |
3 5 2 4 0 1
*Main> :main [5,4,3,2,1,0]
0 1 2 3 4 5
|-| |-| |-|
| |-| |-| |
|-| |-| |-|
| |-| |-| |
|-| |-| |-|
| |-| |-| |
5 4 3 2 1 0

 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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
module Main (main) where

import Data.List
import System.Environment

main :: IO ()
main = do { a:_ <- getArgs
          ; let { e = read a :: [Int]
                ; s = sort e
                ; caption = putStrLn . concat . intersperse " " . map show
                }
          ; caption s >> putStr (showAmida (length e - 1) (amida e)) >> caption e
          }

amida :: [Int] -> [[(Int,Int)]]
amida p = reverse $ fst $ head $ dropWhile (not . null . snd) $ iterate f ([],invs)
  where invs = inversions p
        f (acc,invs) = case select invs of
                         (xs,ys) -> (xs:acc, foldr map ys (map exchange xs))

inversions :: [Int] -> [(Int,Int)]
inversions [] = []
inversions (y:ys) = map (flip (,) y) (filter (y >) ys) ++ inversions ys

select :: [(Int,Int)] -> ([(Int,Int)],[(Int,Int)])
select invs = case partition ((1==) . uncurry subtract) $ sort $ invs of
                ([]  ,ys)       -> ([],ys)
                (x:xs,ys) 
                  -> case partition (share x) (xs++ys) of
                        (zs,ws) -> case select ws of
                                     (us,vs) -> (x:us,zs++vs)

share :: (Int,Int) -> (Int,Int) -> Bool
share (x,y) (p,q) = x == p || x == q || y == p || y == q

exchange :: (Int,Int) -> (Int,Int) -> (Int,Int)
exchange (x,y) pq@(p,q) | x == p    = (y,q)
                        | x == q    = (p,y)
                        | y == p    = (x,q)
                        | y == q    = (p,x)
                        | otherwise = pq

showAmida :: Int -> [[(Int,Int)]] -> String
showAmida n = unlines . map (showStep n)

showStep :: Int -> [(Int,Int)] -> String
showStep n xs = '|':step n 0 xs
  where step n m xs 
          | n == m    = ""
          | otherwise = case xs of
                          [] -> nostep $ step n (m+1) xs
                          (i,_):rs | m == i    -> astep  $ step n (m+1) rs
                                   | otherwise -> nostep $ step n (m+1) xs
        nostep = (' ':).('|':)
        astep  = ('-':).('|':)

(5 4 3 2 1 0)でテストしたところ、正しく解を見つけないバグがあったので、修正します。

プラス評価いただいていたのに申し訳ないです。

コメント元の投稿は自分でマイナスしておきました。

1
2
3
4
5
6
7
8
--- dk109.bug.ml        2007-12-17 23:28:16.000000000 +0900
+++ dk109.ml    2007-12-17 23:28:55.000000000 +0900
@@ -38 +38 @@
-        let costcomp (c1, c2) (m1, m2) = c1 >= m1 ||  c2 >= m2 in
+        let costcomp (c1, c2) (m1, m2) = c1 > m1 ||  c2 > m2 in
@@ -57 +57 @@
-    let best, (c,d) = solve target (comb len) (len, len * len) start in
+    let best, (c,d) = solve target (comb len) (len+1, len * len) start in

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]