空ではないリストを扱いたいとき、
HaskellではData.List.NonEmptyというモジュールがあり、
専用の型と操作が定義されています。
一方、Standard MLのBasis Libraryにはそのようなものがないので自分で定義する必要があります。
そして、そのようなリストは以下のように実装できます。
structure NonEmpty :> sig
type 'a t
val inj : 'a * 'a list -> 'a t
val proj : 'a t -> 'a * 'a list
val map : ('a -> 'b) -> 'a t -> 'b t
val toList : 'a t -> 'a list
...
end = struct
type 'a t = 'a * 'a list
...
endこれで空ではないリストを実装できました。
ところが、今度は更にタプルを表すために「長さ2以上のリスト」を扱いたくなったとします。
ではもう一度NonEmptyのときとほとんど同じ別のTupleストラクチャを定義しないといけないのでしょうか。
これは面倒だ、ということでファンクタを使ってこの問題を解決することにします。
基本的なアイデアは
- 「長さ0以上のリスト」を表すストラクチャを用意して、
- 「長さn以上のリスト」を表すストラクチャから「長さn+1以上のリスト」を表すストラクチャを生成するファンクタを定義する
というものです。
1つ目の「長さ0以上のリスト」というのはまさにBasis LibraryにあるListストラクチャで、
2つ目のファンクタは次のように定義されます。
exception Short
signature L = sig
type 'a t
val cons : 'a * 'a t -> 'a t
val null : 'a t -> bool
val length : 'a t -> int
val @ : 'a t * 'a t -> 'a t
val hd : 'a t -> 'a
val tl : 'a t -> 'a t (* Short *)
val last : 'a t -> 'a
val getItem : 'a t -> ('a * 'a t) option
val nth : 'a t * int -> 'a (* Subscript *)
val take : 'a t * int -> 'a t (* Subscript, Short *)
val drop : 'a t * int -> 'a t (* Subscript, Short *)
val rev : 'a t -> 'a t
val concat : 'a t t -> 'a t
val revAppend : 'a t * 'a t -> 'a t
val app : ('a -> unit) -> 'a t -> unit
val map : ('a -> 'b) -> 'a t -> 'b t
val mapPartial : ('a -> 'b option) -> 'a t -> 'b t (* Short *)
val find : ('a -> bool) -> 'a t -> 'a option
val filter : ('a -> bool) -> 'a t -> 'a t (* Short *)
val partition : ('a -> bool) -> 'a t -> 'a t * 'a t (* Short *)
val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
val foldr : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
val exists : ('a -> bool) -> 'a t -> bool
val all : ('a -> bool) -> 'a t -> bool
val tabulate : int * (int -> 'a) -> 'a t (* Short *)
val collate : ('a * 'a -> order) -> 'a t * 'a t -> order
val minLen : int
val shortest : 'a t -> bool
val concatMap : ('a -> 'b t) -> 'a t -> 'b t
val toList : 'a t -> 'a list
val fromList : 'a list -> 'a t (* Short *)
end
signature LS = sig
include L
type 'a prev
val toPrev : 'a t -> 'a prev
val proj : 'a t -> 'a * 'a prev
val inj : 'a * 'a prev -> 'a t
end
functor Succ (X : L) :> LS where type 'a prev = 'a X.t = struct
type 'a t = 'a * 'a X.t
type 'a prev = 'a X.t
val minLen = X.minLen + 1
fun cons (x, (y, ys)) = (x, X.cons (y, ys))
fun null _ = false
fun length (_, xs) = X.length xs + 1
fun toPrev ((x, xs) : 'a t) : 'a prev = X.cons (x, xs)
fun (x, xs) @ ys =
(x, X.@ (xs, toPrev ys))
fun hd (x, _) = x
fun tl (_, xs) =
if X.shortest xs
then raise Short
else (X.hd xs, X.tl xs)
fun last (x, xs) =
if X.null xs
then x
else X.last xs
(* Assume `X.shortest xs = false`. *)
fun fromPrev xs = (X.hd xs, X.tl xs)
(* Short *)
fun fromPrevChecked xs =
if X.shortest xs
then raise Short
else fromPrev xs
fun getItem (x, xs) =
if X.shortest xs
then NONE
else SOME(x, fromPrev xs)
fun nth ((x, xs), n) =
case Int.compare (n, 0) of
LESS => raise Subscript
| EQUAL => x
| GREATER => X.nth (xs, n - 1)
fun take ((x, xs), n) =
if 0 > n
then raise Subscript
else
if n < minLen
then raise Short
else (x, X.take (xs, n - 1))
(* Short *)
fun drop ((x, xs), n) =
let val l = length (x, xs) in
if l < n
then raise Subscript
else if l - minLen < n
then raise Short
else fromPrev (X.drop (xs, n - 1))
end
fun rev xs =
let val xs = X.rev (toPrev xs) in
(X.hd xs, X.tl xs)
end
fun concat (xs : 'a t, xss : 'a t X.t) =
let
val ys = X.concatMap toPrev xss
in
if X.null ys
then xs
else xs @ fromPrev ys (* `ys`は1つ以上の`'a t`を連結してできたものなのでinvarintは破壊されない。 *)
end
fun revAppend ((x, xs), ys) =
fromPrev (X.revAppend (xs, X.cons (x, toPrev ys)))
fun app f (x, xs) = (f x; X.app f xs)
fun map f (x, xs) = (f x, X.map f xs)
fun mapPartial f (x, xs) =
let
val y = f x
val xs = X.mapPartial f xs
in
case y of
SOME x => (x, xs)
| NONE => fromPrevChecked xs
end
fun find f (x, xs) =
if f x
then SOME x
else X.find f xs
fun filter f (x, xs) =
let
val b = f x
val xs = X.filter f xs
in
if b
then (x, xs)
else
if X.shortest xs
then raise Short
else fromPrev xs
end
fun partition f (x, xs) =
let
val b = f x
val (xs, ys) = X.partition f xs
in
if b
then ((x, xs), fromPrevChecked ys)
else (fromPrevChecked xs, (x, ys))
end
fun foldl f init (x, xs) =
let val acc = f (x, init) in
X.foldl f acc xs
end
fun foldr f init (x, xs) =
f (x, X.foldr f init xs)
fun exists f (x, xs) = f x orelse X.exists f xs
fun all f (x, xs) = f x andalso X.all f xs
fun tabulate (n, f) =
if n < 0
then raise Size
else if n < minLen
then raise Short
else (f 0, X.tabulate (n - 1, f))
fun collate f ((x, xs), (y, ys)) =
case f (x, y) of
LESS => LESS
| EQUAL => X.collate f (xs, ys)
| GREATER => GREATER
fun shortest (_, xs) = X.shortest xs
fun concatMap (f : 'a -> 'b t) (x : 'a, xs : 'a X.t) =
let
val ys : 'b t = f x
val zs : 'b X.t = X.concatMap (toPrev o f) xs
in
if X.null zs
then ys
else ys @ fromPrev zs (* `zs`は1つ以上の`'b t`を連結してできたものなのでinvarintは破壊されない。 *)
end
fun toList (x, xs) = x :: X.toList xs
val fromList =
fn [] => raise Short
| x :: xs => (x, X.fromList xs)
fun proj xs = xs
fun inj xs = xs
endListストラクチャはそのままではSuccファンクタに適用できないので、シグネチャLを持つストラクチャを定義します。
structure Zero : L = struct
open List
type 'a t = 'a list
val cons = op::
val minLen = 0
val shortest = null
fun concatMap f =
fn [] => []
| x :: xs =>
let
val ys = f x
val zs = concatMap f xs
in
ys @ zs
end
fun toList xs = xs
fun fromList xs = xs
endこれらZeroとSuccを用いて、
NonEmptyとTupleは次のように定義できます。
structure NonEmpty = Succ (Zero)
structure Tuple = Succ (NonEmpty)もちろん長さ6以上のリストなども実現できます:
structure List6 = Succ (Succ (Succ (Succ (Succ (Succ (Zero))))))さらに、動的に決まる整数nを用いて長さn以上のリストを表したい場合や、 nが静的に決まるが十分に大きい場合は第1級モジュールが活躍します。
第1級モジュールといえばMoscow MLですね。
ということでMoscow MLを用いた、ファンクタSuccを動的に決まる回数だけ適用する関数listnを与えます。
fun listn n p =
if n <= 0
then p
else
let structure M as L = p in
listn (n - 1) [structure Succ (M) as L]
endこれを使えば、128回もファンクタ適用を書きたくないときや、 ランダムに決まるnに対して「長さn以上のリスト」を得たいときも安心です。
structure List128 as L = listn 128 [structure Zero as L]
structure ListRandom as L = listn (Random.range (0, 1000) (Random.newgen ())) [structure Zero as L]