Haskellを書いてみよう - ryamadaのコンピュータ・数学メモ

あちこち読みかじったので、雰囲気はわかってきたので書いてみる
具体例はこちらでも扱われている「車両のソート問題」
- いくつかのソースがこちらにあります

- 問題は、上手のように引き込み線が複数あって、それらを出たり入ったりできて、一番左から、世の中の線路に出ていける、というような車庫があり、その奥に車両が連結しておいてある。この車両の順番を指定した上で、世の中に送り出したい。そのためには、車両の連結器を外しては、隣の引き込み線に入れて、また、適当な部分を移動させて連結しなおして、という作業を繰り返します。うまく並べ替える方法を探すのが、問題の本体
- 並べ替え法を探すのは、どうしても「手続き(アルゴリズム)」的になってHaskellらしくないので、問題を少し変えよう
車両のソート問題とは
- 引き込み線
  - 引き込み線と呼ばれるものがn個ある
  - 引き込み線は１列に並んでいる
  - 相隣り合う引き込み線はつながっている
  - 引き込み線は隣の引き込み線とつながる側とつながらない側の２端を持つ
- 車両
  - 車両と呼ばれるものがk個ある
  - 車両は引き込み線上に並ぶ
  - 車両は隣の引き込み線に移動できる
    - 車両が移動するときには、同一の引き込み線上にある車両のうち、隣の引き込み線とつながりのある側の車両だけが移動できる
    - 移動した車両は移動した先の車両の列の最も隣接引き込み線側に並ぶ
- この引き込み線という環境において、車両の移動のルールを守らせた上で、ある車両の配置状態(どの引き込み線にどの車両がどういう順序に存在するかの状態)から、ある車両の配置状態へと動かす手順の探索がソート問題
上記の車両のソート問題を次の２つに分ける
- 移動ルール　と
- ソート手順探索　と
そのうえで「ソート手順探索」は「手続き」なので、(手順なしの)Haskell的に書くと場合分け爆発になってしまうので、それはアルゴリズムの役割として、Haskellにはやらせないことにして(やらせてももちろん良いわけだが)、「移動ルール」の部分を、Haskell的に書いてみよう
Haskell的とは
- 状態を静的に書く
- 遅延評価でしか実現できないこと(要素数無限、場合によっては無限ループも)をあえて使った形で書く
  - 以下のコードをテキストファイル myrail.hs に書いて、以下のようにロードすることを前提にしている

:load myrail.hs

処理
- その１
  - ある引き込み線にk個の車両だけを残す
    - リストの処理takeそのものであるが、ここではわかりやすいように、車両移動の源(Source)側の車両列変化として以下のように書く
  - kと車両列を表すリストを引数にして、引数を返り値とする

moveSource :: Int -> [Int] -> [Int]
moveSource k xs = take k xs

- その２
  - 隣の引き込み線では、k個の車両の順番が逆になって、付け加わる
  - kは移動車両数、移動元の車両リストxsと移動先の車両リストysを引数に、移動先の車両リストを返す
  - xsのうち、移動する分をdrop関数で取り出して、reverse関数で逆にして、ysに連結する

moveTarget :: Int -> [Int] -> [Int] -> [Int]
moveTarget k xs ys = (++) ys (reverse (drop k xs))

- 注：「その１」と「その２」では複数の車両を一度に動かしているので逆順化などをしているが、１車両ずつを動かす動作を１単位として、そのk回繰り返し、とする方がHaskellらしいやり方だろう(が、ここではこのまま行こう)
- その３
  - 複数の引き込み線の車両列の状態すべてを表したリストのリストを扱えるように拡張する
  - １引き込み線の状態である車両列が[Int]というリストであるので、複数の引き込み線の状態はxss (Int)
  - 車両の移動は、車両の数k (Int)、移動元の引き込み線番号 ts (Int)、移動先の引き込み線番号 tt (Int)がわかれば、結果としてできる複数の引き込み線の状態(Int)は決まるから、引数はそのようになっている
  - 車両の移動は、移動元と移動先の引き込み線が隣り合っているので
    - (1) 移動元・先の引き込み線より手前にある引き込み線たち(その数は0かもしれない)
    - (2) 移動元・先の引き込み線のうち、手前にあるもの
    - (3) 移動元・先の引き込み線のうち、先にあるもの
    - (4) 移動元・先の引き込み線より先にある引き込み線たち
  - の４つの部分に分けられる
  - ４つの部分の指定は、移動元・先の引き込み線のどちらが手前の引き込み線かによって変わるので、場合分けして対応している
  - 移動元・移動先が同じであることは、考えないことが現実的だが、考えておくと、首尾一貫していて安心なので、その場合は、何もかわらないものとして与えておく
  - 移動元が移動先より手前の場合
    - (1) (take ts xss)
      - 全体のうち手前の引き込み線部分を取り出している
    - (2) *1 [])
      - 移動元の処理。moveSourceの処理でできるのが[Int]なので、Intにするために、(:) を使って、空のリストとつないでいる
    - (3) *2 [])
      - 移動先の処理。moveTargetの処理でできるのが[Int]なので、Intになるように処理を加えている
    - (4) (drop (tt+1) xss)
  - 移動先が移動元より手前の場合
    - (1),(4)の部分を指定するための引数ts,ttの与え方を変えている
    - (2),(3)は入れ替わっている

moveN :: [[Int]] -> Int -> Int -> Int -> [[Int]]
moveN xss ts tt k 
  |  ts < tt =  (take ts xss)  ++ ((:) (moveSource k ((!!) xss ts)) []) ++ ((:) (moveTarget k ((!!) xss ts) ((!!) xss tt)) []) ++  (drop (tt+1) xss) 
  |  ts == tt = xss
  |  otherwise =  (take tt xss) ++ ((:) (moveTarget k ((!!) xss ts) ((!!) xss tt)) []) ++ ((:) (moveSource k ((!!) xss ts)) []) ++  (drop (ts+1) xss)

- その４
  - 移動は何回かあるので、それができるようにさらに処理をまとめる
  - 複数引き込み線の状態に移動元・移動先・移動車両数を与えれば、次の状態が作れるから
  - 移動元をどこにするか、移動先をどこにするか、移動車両数をいくつにするかをそれぞれ、リストにして与えて、そのリストから一つずつ取り出して、再帰的な処理で書いてやるとHaskellらしくなる

serialMoveN :: [[Int]] -> [Int] -> [Int] -> [Int] -> [[Int]]
serialMoveN xss [] [] [] = xss
serialMoveN xss (ts:tss) (tt:tts) (k:ks) = serialMoveN (moveN xss ts tt k) tss tts ks

- これで状態の記述と移動の記述は終わり
- その５
  - 初期状態を与えることにする
  - 初期状態は、どのように与えてもよいが、１番手前の引き込み線に、適当に定めた車両番号列で存在しているものとし、引き込み線の数を適当に与えてつくることができる
  - 車両数nに対して $2^n$ 本の引き込み線があれば、ソートは必ずできるらしいので、それっぽい数値を引き込み線の数にしてもよい
  - また、遅延評価の性質を利用すれば、引き込み線数を無限にして定義することも可能
  - initTrain にある引き込み線の車両列をリストで指定する
  - 車両数をlengthTrainとして与え
  - 引き込み線数をにしたり
    - replicate (numLanes-1) [] によって、2番目以降の引き込み線に車両がない状態を作っている
  - 引き込み線数を無限にしたりしている
    - repeat []によって、車両がない引き込み線を無限に作っている
  - initPositionはその初期状態のInt

initTrain :: [Int]
initTrain = [9,3,10,1,4,11,2,6,5,0,8,7]
lengthTrain :: Int
lengthTrain = length initTrain
numLanes :: Int
numLanes = 2^lengthTrain
initPosition :: [[Int]]              -- テスト用データ
initPosition = [initTrain] ++ (replicate (numLanes-1) [])
--initTrain = [[3,1,4,5,2,6,7,0]] ++ (repeat [])

- その６
  - 移動パターンを指定してみる

tss, tts, ks :: [Int]

tss = [0,1,2,3,2,4,1,5]
tts = [1,2,3,2,1,5,2,6]
ks  = [2,2,3,1,2,3,2,3]

これら一連のをひとまとめにしたのがこちら

moveSource :: Int -> [Int] -> [Int]
moveSource k xs = take k xs

moveTarget :: Int -> [Int] -> [Int] -> [Int]
moveTarget k xs ys = (++) ys (reverse (drop k xs))


moveN :: [[Int]] -> Int -> Int -> Int -> [[Int]]
moveN xss ts tt k 
  |  ts < tt =  (take ts xss)  ++ ((:) (moveSource k ((!!) xss ts)) []) ++ ((:) (moveTarget k ((!!) xss ts) ((!!) xss tt)) []) ++  (drop (tt+1) xss) 
  |  ts == tt = xss
  |  otherwise =  (take tt xss) ++ ((:) (moveTarget k ((!!) xss ts) ((!!) xss tt)) []) ++ ((:) (moveSource k ((!!) xss ts)) []) ++  (drop (ts+1) xss)

serialMoveN :: [[Int]] -> [Int] -> [Int] -> [Int] -> [[Int]]
serialMoveN xss [] [] [] = xss
serialMoveN xss (ts:tss) (tt:tts) (k:ks) = serialMoveN (moveN xss ts tt k) tss tts ks 


initTrain :: [Int]
initTrain = [9,3,10,1,4,11,2,6,5,0,8,7]
lengthTrain :: Int
lengthTrain = length initTrain
numLanes :: Int
numLanes = 2^lengthTrain
initPosition :: [[Int]]              -- テスト用データ
initPosition = [initTrain] ++ (replicate (numLanes-1) [])
--initTrain = [[3,1,4,5,2,6,7,0]] ++ (repeat [])

tss, tts, ks :: [Int]

tss = [0,1,2,3,2,4,1,5]
tts = [1,2,3,2,1,5,2,6]
ks  = [2,2,3,1,2,3,2,3]

実行してみる
- 対話式処理の動詞 letを使って、処理結果をtestoutに入れている

:load myrail.hs
let testout=serialMoveN initPosition tss tts ks

- 引き込み線数が多いので端折って表示させる

*Main> take 20 testout
[[9,3],[7,8],[10,1,4,11,2,6,5],[0],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[]]

*1::) (moveSource k ((!!) xss ts

*2::) (moveTarget k ((!!) xss ts) ((!!) xss tt