圏論勉強会#10 練習問題 回答(1問目) http://nineties.github.io/category-seminar/10.html#/38

tree.sml

(**
 * 圏論勉強会#10 練習問題 回答
 *   http://nineties.github.io/category-seminar/10.html#/38
 *
 *
 * 実行方法:
 *   $ cat tree.cm
 *     group
 *     is
 *       $/basis.cm
 *     	$/smlunitlib.cm
 *     	tree.sml
 *   $ sml
 *   CM.make "tree.cm";
 *   -
 *)
structure Tree =
struct
  fun id x = x

  datatype 'a t = Leaf of 'a
                | Node of 'a t * 'a t

  fun toString to (Leaf x) = concat["(",to x,")"]
    | toString to (Node(l,r)) = concat["(",toString to l,",",toString to r,")"]

  (* 考えてみたらcatamorphismも必要じゃないですかやだー *)
  fun foldr f e (Leaf x) = e x
    | foldr f e (Node(l,r)) = f (foldr f e l, foldr f e r)

  (* 二分木などの型函手及び融合則の導出 *)
  fun fmap f = foldr Node (Leaf o f)

local
  open SMLUnit
  open Assert
  val ($,&,%) = (Test.TestLabel,Test.TestList,Test.TestCase)
  fun assertTree f =
    let
      fun eq (Leaf x,Leaf y) = x=y
        | eq (Node(lx,rx),Node(ly,ry)) = lx=ly andalso rx=ry
        | eq _ = false
    in assertEqual eq (toString f)
    end
in
val _ =
  let
    val int = Int.toString
    val test =
      &[ $("foldr"
          , &[ % (fn()=> assertEqualInt   0 (foldr op+ id (Leaf 0)))
             , % (fn()=> assertEqualInt 384 (foldr op+ id (Leaf 384)))
             , % (fn()=> assertEqualInt  15 (foldr op+ id (Node(Node(Node(Leaf 1, Leaf 2)
                                                                    ,Node(Leaf 3, Leaf 4))
                                                               ,Leaf 5))))
             ])
       , $("type functor"
          , &[ % (fn()=> assertTree id (Leaf "314") (fmap Int.toString (Leaf 314)))
             , % (fn()=> assertTree int (Node(Node(Leaf 2, Leaf 4), Leaf 6))
                                        (fmap (fn x=>x*2) (Node(Node(Leaf 1, Leaf 2), Leaf 3))))
             ])]
  in
    TextUITestRunner.runTest {output=TextIO.stdOut} test
  end
end (* unit test *)
end

http://d.hatena.ne.jp/eldesh/20130725/1374683458