なんとかモルフィズム - λx. x K S K ＠はてな

PPL2009 に参加してくださった皆さん，本当にありがとうございました．バタバタしていて，あまり多くの方とはお話しできずにすみませんでした． OCaml Users Meeting を日本で開催する際にはぜひ参加したいですね．参加希望ついでに，ずいぶん前に書いた OCaml のコードを晒しておきます．

今回は (今回も?) あまり役に立たないお話で，なんとかモルフィズムの一覧です．以前ここで紹介した代数的データ型の続きみたいなもので， catamorphism や anamorphism や hylomorphism 以外のものも実装しています．ここで実装しているのは以下の14個のほげほげモルフィズム (説明はテキトー) です．全部知っているという人はかなりのマニアです．

catamorphism: list でいう foldr
anamorphism: cata の双対
hylomorphism: cata after ana
metamorphism: ana after cata (hylo の双対)
paramorphism: cata の拡張 (cata は直前の結果と入力の先頭 (最外) しか見ないが，para は直前の結果と入力全体を見て結果を返す)
apomorphism: para の双対
histomorphism: cata の拡張 (直前だけでなく全ての結果を遡って見ることができる)
futumorphism: histo の双対
chronomorphism: histo after futu
zygomorphism: para の拡張 (入力全体の代わりに入力に対する別の補助関数を用意して相互再帰もどき)
cozygomorphism: zygo の双対
dynamorphism: 動的計画法向け hylo
codynamorphism: dyna の双対
mutumorphism: 相互再帰 (組を作る cata の後に射影)

morphism と名のつく単語には，この他にも homomorphism，monomorphism，polymorphism，isomorphism とかがありますが，代数的データ型とは直接関係ないのでここには出てきません (厳密にいうと F 自身が homomorphism なので関係ないわけではないですが)．以下，ソース．

(* 補助的な諸々 (pair とか冗長ですが either との双対性を強調するために導入しました) *)
type ('a,'b) either = Left of 'a | Right of 'b
type ('a,'b) pair = Pair of 'a * 'b
let id x = x
let ($) f g x = f (g x)
let (<&>) f g x = Pair(f x, g x)
let (<|>) f g = function Left x -> f x | Right x -> g x
let left x = Left x and right x = Right x
let fst (Pair(x,_)) = x and snd (Pair(_,y)) = y

(* F の型 *)
module type F = sig
  type 'a t 
  val fmap : ('a -> 'b) -> 'a t -> 'b t
end

(* F の例 *)
module F_int_list : F = struct
  type 'a t = Nil | Cons of int * 'a
  let fmap f = function
    | Nil -> Nil
    | Cons(i,x) -> Cons(i,f x)
end

(* F の不動点の型 *)
module type FixpointType = sig
  type 'a t
  type mu = In of mu t
  type 'a his = His of ('a, 'a his t) pair
  type 'a fut = Fut of ('a, 'a fut t) either
  val in_ : mu t -> mu
  val out : mu -> mu t
  val cata : ('a t -> 'a) -> mu -> 'a
  val ana : ('a -> 'a t) -> 'a -> mu
  val hylo : ('b t -> 'b) -> ('a -> 'a t) -> 'a -> 'b
  val meta : ('a t -> 'a) -> ('a -> 'a t) -> mu -> mu
  val para : ((mu, 'a) pair t -> 'a) -> mu -> 'a
  val apo : ('a -> (mu, 'a) either t) -> 'a -> mu
  val histo : ('a his t -> 'a) -> mu -> 'a
  val futu : ('a -> 'a fut t) -> 'a -> mu
  val chrono : ('b his t -> 'b) -> ('a -> 'a fut t) -> 'a -> 'b
  val zygo : ('b t -> 'b) -> (('b, 'a) pair t -> 'a) -> mu -> 'a
  val cozygo : ('b -> 'b t) -> ('a -> ('b, 'a) either t) -> 'a -> mu
  val dyna : ('b his t -> 'b) -> ('a -> 'a t) -> 'a -> 'b
  val codyna : ('b t -> 'b) -> ('a -> 'a fut t) -> 'a -> 'b
  val mutu : ('a -> 'b) -> ('a t -> 'a) -> mu -> 'b
end

(* F の不動点を生成するファンクタ *)
module MakeFixpoint (F:F) : FixpointType = struct
  type 'a t = 'a F.t
  type mu = In of mu t
  type 'a his = His of ('a, 'a his t) pair
  let head (His(Pair(x,_))) = x
  let (<*>) f g x = His((f<&>g) x)
  type 'a fut = Fut of ('a, 'a fut t) either
  let last x = Fut(Left x)
  let (<+>) f g (Fut x) = (f<|>g) x
  let in_ x = In x
  let out (In x) = x
  (* catamorphism *)
  let rec cata phi x = phi (F.fmap (cata phi) (out x))
  (* anamorphism *)
  let rec ana psi x = in_ (F.fmap (ana psi) (psi x))
  (* hylomorphism : cata phi . ana psi *)
  let rec hylo phi psi x = phi (F.fmap (hylo phi psi) (psi x))
  (* metamorphism *)
  let meta phi psi = ana psi $ cata phi
  (* paramorphism *)
  let rec para phi x = phi (F.fmap (id <&> para phi) (out x))
  (* apomorphism *)
  let rec apo psi x = in_ (F.fmap (id <|> apo psi) (psi x))
  (* histomorphism *)
  let histo phi = head $ cata (phi<*>id)
  (* futumorphism *)
  let futu psi = ana (psi<+>id) $ last
  (* chronomorphism *)
  let chrono phi psi = histo phi $ futu psi
  (* zygomorphism : para = zygo in_ *)
  let zygo f phi = snd $ cata ((f $ F.fmap fst) <&> phi)
  (* cozygomorphism : apo = cozygo out *)
  let cozygo f psi = ana ((F.fmap left $ f) <|> psi) $ right
  (* dynamorphism *)
  let dyna f g = chrono f (F.fmap last $ g)
  (* codynamorphism *)
  let codyna f g = chrono (f $ F.fmap head) g
  (* mutumorphism *)
  let mutu proj phi x = proj (cata phi x)
end