DouKaku?

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  = ('-':).('|':)

module Main
    where

combine :: [a] -> ([a], [b]) -> ([a], [b])
combine xs1 (xs2, is) = (xs1 ++ xs2, is)

bPath :: [Int] -> Int -> [Int] -> ([Int], [Int])
bPath []       _ is = ([], is)
bPath [x]      _ is = ([x], is)
bPath (a:b:xs) i is
    | a <= b    = combine [a]    $ bPath (b:xs) (i + 1) is
    | otherwise = combine [b, a] $ bPath xs     (i + 2) (i:is)

bSort :: [Int] -> [[Int]] -> ([Int], [[Int]])
bSort xs iss = recurse
    where
        (xs', is) = bPath xs 0 []
        recurse 
            | null is   = (xs', iss)
            | otherwise = bSort xs' ([is] ++ iss)

dumpRow :: Int -> [Int] -> IO()
dumpRow n xs = putStrLn $ " |" ++ dumpRowInner n 0 xs
    where
        dumpRowInner :: Int -> Int -> [Int] -> String
        dumpRowInner n i xs
            | n == i + 1 = ""
            | elem i xs  = "-|" ++ dumpRowInner n (i + 1) xs
            | otherwise  = " |" ++ dumpRowInner n (i + 1) xs

dumpAmida :: Int -> [[Int]] -> IO()
dumpAmida n [] = return ()
dumpAmida n (x:xs) = do
    dumpRow n x
    dumpAmida n xs

main :: IO()
main = do
    putStrLn $ show goal
    dumpAmida (length lst) ops
    putStrLn $ show lst
    where
        lst = [3, 5, 2, 4, 0, 1]
        (goal, ops) = bSort lst []

[0,1,2,3,4,5]
 | |-| | | |
 |-| |-| |-|
 | |-| |-| |
 |-| |-| |-|
 | |-| |-| |
[3,5,2,4,0,1]

-- http://ja.doukaku.org/109/
import List(intersperse,sort,unfoldr)
import System(getArgs)

main = do
  a:_ <- getArgs
  let goal = (read a :: [Int])
  putStrLn $ show_amida goal $ resolve goal

resolve :: [Int] -> [[Int]]
resolve q = unfoldr b_sort q
    where 
      b_sort q | null ops = Nothing
               | otherwise = Just (ops,next_q)
          where
            (next_q,ops) = f 0 q [] []
            f n (a:b:rest) q' ops | a > b = f (n+2) rest (a:b:q') (n:ops)
                                  | otherwise = f (n+1) (b:rest) (a:q') ops
            f _ r q' ops = (reverse q' ++ r,ops)

show_amida :: [Int] -> [[Int]] -> String
show_amida q result = join "\n" ([header (sort q)] ++ body ++ [header q])
    where
      join a ls = concat (intersperse a ls)
      header = (join " ") . (map show)
      body = reverse $ map make_line result
      make_line bars = "|" ++ line ++ "|"
          where
            line = join "|" $ 
                   map (\n->if elem n bars then "-" else " ") [0..(length q-2)]