Skip to content

Instantly share code, notes, and snippets.

@elpinal

elpinal/listn.md Secret

Last active December 21, 2020 14:37
Show Gist options
  • Save elpinal/fb39bfb2a7fb49aa0dcc2f85da6ba26f to your computer and use it in GitHub Desktop.
Save elpinal/fb39bfb2a7fb49aa0dcc2f85da6ba26f to your computer and use it in GitHub Desktop.
ML Advent Calendar 2020 20日目

長さn以上のリストをファンクタで

空ではないリストを扱いたいとき、 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ストラクチャを定義しないといけないのでしょうか。 これは面倒だ、ということでファンクタを使ってこの問題を解決することにします。

基本的なアイデアは

  1. 「長さ0以上のリスト」を表すストラクチャを用意して、
  2. 「長さ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
end

Listストラクチャはそのままでは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

これらZeroSuccを用いて、 NonEmptyTupleは次のように定義できます。

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]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment