test.ml

let first f (x, y) = (f x, y)

(** A more efficient version of List.concat. *)
let list_concat ll = List.rev (List.fold_left (fun a b -> List.rev_append b a) [] ll)

module type Monoid = sig
  type t
  val mempty : t
  val mappend : t -> t -> t
  val mconcat : t list -> t
end

module ListMonoid (T: sig type a end) = struct
  type t = T.a list
  let mempty = []
  let mappend l1 l2 = l1 @ l2
  let mconcat = list_concat
end

module StringMonoid : Monoid = struct
  type t = string
  let mempty = ""
  let mappend l1 l2 = l1 ^ l2
  let mconcat ll = List.fold_right mappend ll mempty
end

(** State transitions. *)
module State = struct
  type ('s, 'a) t = 's -> ('a * 's)

  let fmap f m s0 = let a, s = m s0 in f a, s

  let return v s = (v, s)

  let (>>=) m f s0 = let a, s = m s0 in f a s

  let (>>) m m1 s0 = let _, s = m s0 in m1 s

  module OfMonoid (M: Monoid) = struct
    let run_until pred transition init =
      let rec run accum s =
        if pred s then
          accum, s
        else
          let nextr, nexts = transition s in
          run (nextr::accum) nexts
      in first M.mconcat (run [] init)
  end

  let run_until (type a') f =
    let module LM = ListMonoid (struct type a = a' end) in
    let module SList = OfMonoid (LM) in
    SList.run_until f
end