kleene.ml

module type KLEENE = sig
  type t 
  val zero : t 
  val one : t
  val ( * ) : t -> t -> t 
  val ( ++ ) : t -> t -> t 
  val star : t -> t 
end

module type MATRIX = sig
  type elt
  type t 

  val dom : t -> int
  val cod : t -> int
  val get : t -> int -> int -> elt

  val id : int -> t 
  val compose : t -> t -> t 

  val zero : int -> int -> t 
  val (++) : t -> t -> t 

  val make : int -> int -> (int -> int -> elt) -> t 
end

module Matrix(R : KLEENE) : MATRIX with type elt = R.t = 
struct
  type elt = R.t 
  type t = {
      row : int; 
      col: int; 
      data : int -> int -> R.t
    }

  let make row col data = {row; col; data}
  let dom m = m.row
  let cod m = m.col

  let get m i j = 
      assert (0 <= i && i < m.row);
      assert (0 <= j && j < m.col);
      m.data i j 

  let id n = make n n (fun i j -> if i = j then R.one else R.zero)

  let compose f g = 
    assert (cod f = dom g);
    let data i j = 
      let rec loop k acc = 
        if k < cod f then
          loop (k+1) R.(acc ++ (get f i k * get g k j))
        else
          acc
      in
      loop 0 R.zero
    in
    make (dom f) (cod g) data

  let zero row col = make row col (fun i j -> R.zero)

  let (++) m1 m2 = 
    assert (dom m1 = dom m2);
    assert (cod m1 = cod m2);
    let data i j = R.(++) (get m1 i j) (get m2 i j) in
    make (dom m1) (cod m1) data 
end                           

module type SIZE = sig 
  val size : int 
end 

module Square(R : KLEENE)
             (M : MATRIX with type elt = R.t)
             (Size : SIZE) : KLEENE with type t = M.t = 
struct
  type t = M.t 

  let (++) = M.(++)
  let ( * ) = M.compose
  let one = M.id Size.size
  let zero = M.zero Size.size Size.size

  let split i m = 
    let open M in 
    assert (i >= 0 && i < dom m);
    let k = dom m - i in 
    let shift m x y = fun i j -> get m (i + x) (j + y) in 
    let a = make i i (shift m 0 0) in
    let b = make i k (shift m 0 i) in
    let c = make k i (shift m i 0) in
    let d = make k k (shift m i i) in 
    (a, b, c, d)

  let merge (a, b, c, d) = 
    assert (M.dom a = M.dom b && M.cod a = M.cod c);
    assert (M.dom d = M.dom c && M.cod d = M.cod b);
    let get i j = 
      match i < M.dom a, j < M.cod a with
      | true, true   -> M.get a i j 
      | true, false  -> M.get b i (j - M.cod a)
      | false, true  -> M.get c (i - M.dom a) j 
      | false, false -> M.get d (i - M.dom a) (j - M.cod a)
    in
    M.make (M.dom a + M.dom d) (M.cod a + M.cod d) get 

  let rec star m = 
    match M.dom m with
    | 0 -> m 
    | 1 -> M.make 1 1 (fun _ _ -> R.star (M.get m 0 0))
    | n -> let (a, b, c, d) = split (n / 2) m in
           let fstar = star (a ++ b * star d * c) in 
           let gstar = star (d ++ c * star a * b) in 
           merge (fstar, fstar * b * gstar,
                  gstar * c * fstar, gstar)
end

               
module Re = struct
  type t = 
    | Chr of char
    | Seq of t * t 
    | Eps
    | Bot 
    | Alt of t * t 
    | Star of t 

  (* We use some smart constructors to do some simplifications
     as we proceed. This makes the output more readable, though
     it does not affect the asymptotic complexity (which is terrible). *)

  let zero = Bot
  let ( ++ ) r1 r2 = 
    let rec loop = function
      | [] -> Bot
      | Bot :: rs -> loop rs
      | Alt(r1, r2) :: rs -> loop (r1 :: r2 :: rs)
      | [r] -> r 
      | r :: rs -> Alt(r, loop rs)
    in
    loop [r1; r2]

  let one = Eps

  let rec ( * ) r1 r2 = 
    let rec loop = function
      | [] -> Eps
      | Eps :: rs -> loop rs
      | Seq(r1, r2) :: rs -> loop (r1 :: r2 :: rs)
      | Bot :: rs -> zero
      | Alt(r1, r2) :: rs -> loop (r1 :: rs) ++ loop (r2 :: rs)
      | [r] -> r 
      | r :: rs -> Seq(r, loop rs)
    in
    loop [r1; r2]


  let star r = Star r 
end

module M = Matrix(Re)
module T = Square(Re)(M)(struct let size = 2 end)

let t = 
  M.make 2 2 (fun i j -> 
      Re.Chr (match i, j with
	      | 0, 0 -> 'a'
	      | 0, 1 -> 'b'
	      | 1, 0 -> 'c'
	      | 1, 1 -> 'd'
	      | _ -> assert false))

let tstar = T.star t