(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * dfa: Deterministic Finite Automata, decidability of language inclusion *)

Require Import comparisons positives ordinal pair lset.
Require Import monoid boolean prop sups bmx.
Set Implicit Arguments.
Unset Printing Implicit Defensive.

(** * DFA and associated language *)

(** A DFA is given by its number of states, a deterministic transition
   function, an acceptance condition, and a finite subset of the
   alphabet.

   States are represented by ordinals of the appropriate size.

   Making the finite subset of the alphabet explicit avoids us to use
   ordinals for the alphabet. *)

Record t := mk {
  n: nat;
  u: ord n;
  M: ord n -> positive -> ord n;
  v: ord n -> bool;
  vars: list positive
}.
Notation "x ^u" := (u x) (at level 2, left associativity, format "x ^u").
Notation "x ^M" := (M x) (at level 2, left associativity, format "x ^M").
Notation "x ^v" := (v x) (at level 2, left associativity, format "x ^v").

(** changing the initial state *)
Definition reroot A i := mk i A^M A^v (vars A).

Lemma reroot_id A: A = reroot A (A^u).
Proof. destruct A; reflexivity. Qed.

(** language of a DFA [A], starting from state [i] *)
Fixpoint lang A i w :=
  match w with
    | nil => is_true (A^v i)
    | cons a w => In a (vars A) /\ lang A (A^M i a) w
  end.

(** * Reduction of DFA language inclusion to DFA language emptiness  *)

Section diff.

Variables A B: t.

(** automaton for [A\B] *)
Definition diff := mk
  (pair.mk (u A) (u B))
  (fun p a => pair.mk (M A (pair.pi1 p) a) (M B (pair.pi2 p) a))
  (fun p => v A (pair.pi1 p) \cap ! v B (pair.pi2 p))
  (vars A).

(** specification of its language *)
Lemma diff_spec: vars A <== vars B ->
  forall i j, lang A i <== lang B j <-> lang diff (pair.mk i j) <== bot.
Proof.
  intro H.
  cut (forall w i j, lang A i w <== lang B j w <-> ~ lang diff (pair.mk i j) w).
   intros G i j. split. intros Hij w Hw. apply G in Hw as []. apply Hij.
   intros Hij w. apply G. intro Hw. elim (Hij _ Hw).
  induction w; intros i j; simpl lang; rewrite pair.pi1mk, pair.pi2mk.
   case (v A i); case (v B j); firstorder discriminate.
    split. intros Hij [HaB Hw]. apply IHw in Hw as []. intro Aw. apply Hij. now split.
    intros Hw [Ha Aw]. split. apply H, Ha. eapply IHw. 2: eassumption. tauto.
Qed.

End diff.

(** * Decidability of DFA language emptiness

   We proceed as follows:
   1. we forget all transition labels to get a directed graph whose
      nodes have an accepting status.
   2. we compute the reflexive and transitive closure of this graph
   3. we deduce the set of all states reachable from the initial state.
   4. the DFA is empty iff this set does not contain any accepting
      states.

   All these computations are straightforward, except for 2, for which
   we exploit Kleene star on Boolean matrices.

   The resulting algorithm is not efficient at all. We don't care
   because this is not the one we execute in the end: this one is just
   used to establish KA completeness. *)

Section empty_dec.

Variables A: t.

(** erased transition graph, represented as a Boolean matrix *)
Definition step: bmx (n A) (n A) := fun i j => \sup_(a\in vars A) eqb_ord (M A i a) j.

(** reflexive transitive closure of this graph *)
Definition steps := (@str bmx _ step).

Variable i: ord (n A).

(** basic properties of this closed graph *)
Lemma steps_refl: steps i i.
Proof. apply bmx_str_clot. constructor. Qed.

Lemma steps_snoc: forall j a, steps i j -> In a (vars A) -> steps i (M A j a).
Proof.
  setoid_rewrite bmx_str_clot. intros. eapply clot_snoc. eassumption.
  setoid_rewrite is_true_sup. eexists. split. eassumption. apply eqb_refl.
Qed.

(** state reached from [i] by following a word [w] in the DFA *)
Fixpoint Ms i w := match w with nil => i | cons a w => Ms (M A i a) w end.

(** each unlabelled path in the erased graph corresponds to a labelled
   path (word) in the DFA *)
Lemma steps_least: forall j, steps i j -> exists w, w <== vars A /\ j = Ms i w.
Proof.
  intros j H. apply bmx_str_clot in H. induction H as [i|i j k Hij _ [w [Hw ->]]].
   exists nil. split. lattice. reflexivity.
  setoid_rewrite is_true_sup in Hij. destruct Hij as [a [Ha Hij]].
  exists (a::w). split. intros b [<-|Hb]. assumption. now apply Hw.
  revert Hij. case eqb_ord_spec. 2: discriminate. now intros <-.
Qed.

(** can we reach an accepting state from [i] *)
Definition empty := \inf_(j<_) (steps i j <<< !v A j).

(* TODO: les deux lemmes suivants sont certainement simplifiables en
   prouvant directement l'équivalence *)

(** if not, all states reachable from [i] map to the empty language *)
Lemma empty_lang1 j: steps i j -> empty -> lang A j <== bot.
Proof.
  intros Hj He. setoid_rewrite is_true_inf in He. setoid_rewrite le_bool_spec in He.
  pose proof (fun i => He i (ordinal.in_seq _)) as H. clear He.
  intro w. revert j Hj. induction w as [|a w IH]; simpl lang; intros j Hj.
  apply (H j), negb_spec in Hj. rewrite Hj. discriminate.
  intros [Ha Hj']. apply IH in Hj' as []. now apply steps_snoc.
Qed.

(** conversely, if [i] maps to them empty language, then there is no
   reachable accepting state *)
Lemma empty_lang2: lang A i <== bot -> empty.
Proof.
  intro H. setoid_rewrite is_true_inf. intros j _.
  rewrite le_bool_spec. intro Hj. apply steps_least in Hj as [w [Hw ->]].
  generalize i (H w) Hw. clear. induction w; intros i Hi Hw.
   simpl in *. destruct (v A i). now elim Hi. reflexivity.
   apply IHw. intro H. elim Hi. split. apply Hw. now left. assumption.
   intros ? ?. apply Hw. now right.
Qed.

(** decidability of language emptiness follows *)
Theorem empty_dec: {lang A i <== bot} + {~ (lang A i <== bot)}.
Proof.
  case_eq empty; [left|right].
   apply (empty_lang1 _ steps_refl H).
  intro E. apply empty_lang2 in E. rewrite H in E. discriminate.
Qed.

End empty_dec.

(** * Decidability of DFA language inclusion *)

Corollary lang_incl_dec A B: vars A <== vars B ->
  forall i j, {lang A i <== lang B j} + {~(lang A i <== lang B j)}.
Proof. intros. eapply sumbool_iff. symmetry. now apply diff_spec. apply empty_dec. Qed.


Require Import List PeanoNat Omega Recdef.
Set Implicit Arguments.

Record CommSemigroup A := mkCSG
  { CSelem : A;
    CSplus : A -> A -> A;
    CSplus_assoc : forall x y z : A, CSplus (CSplus x y) z = CSplus x (CSplus y z);
    CSplus_comm : forall x y : A, CSplus x y = CSplus y x }.

Section CommSemigroup.

  Variable A : Type.
  Variable A_CSG : CommSemigroup A.
  Infix "+!" := A_CSG.(CSplus) (at level 50, left associativity).

  Inductive Exp :=
  | ExpVar : nat -> Exp
  | ExpPlus : Exp -> Exp -> Exp.

  Definition NF := list nat.

  Fixpoint ins n (nf : NF) : NF :=
    match nf with
    | nil => n :: nil
    | m::nf' =>
      if le_dec n m
        then n :: m :: nf'
        else m :: ins n nf'
    end.

  Fixpoint exp2nf' (ex : Exp)(nf : NF) : NF :=
    match ex with
    | ExpVar n => ins n nf
    | ExpPlus ey ez => exp2nf' ez (exp2nf' ey nf)
    end.
  Definition exp2nf ex := exp2nf' ex nil.

  Fixpoint getKey (val : nat)(table : list (A * nat)) : A :=
    match table with
    | nil => A_CSG.(CSelem)
    | (key,val')::table' =>
      if Nat.eq_dec val val'
        then key
        else getKey val table'
    end.

  Fixpoint exp2A (ex : Exp)(table : list (A * nat)) : A :=
    match ex with
    | ExpVar n => getKey n table
    | ExpPlus ey ez => exp2A ey table +! exp2A ez table
    end.

  Fixpoint nf2A nf table :=
    match nf with
    | nil => A_CSG.(CSelem)
    | n::nil => getKey n table
    | n::nf' => getKey n table +! nf2A nf' table
    end.

  Fixpoint addnf a nf table :=
    match nf with
    | nil => a
    | n::nf' => getKey n table +! addnf a nf' table
    end.

  Lemma addnf_plus : forall table a b nf,
    addnf (a +! b) nf table = a +! addnf b nf table.
  Proof with simpl in *.
    induction nf; [auto|]...
    rewrite IHnf. repeat rewrite <- A_CSG.(CSplus_assoc).
    rewrite (A_CSG.(CSplus_comm) a). reflexivity.
  Qed.

  Lemma addnf_comm : forall table a b nf,
    a +! addnf b nf table = b +! addnf a nf table.
  Proof with simpl in *.
    intros. rewrite <- addnf_plus. rewrite A_CSG.(CSplus_comm). rewrite addnf_plus. auto.
  Qed.

  Lemma addnf_nf2A : forall table n nf,
    addnf (getKey n table) nf table = nf2A (n::nf) table.
  Proof with simpl in *.
    induction nf; [auto|]... rewrite IHnf.
    destruct nf.
    - apply A_CSG.(CSplus_comm).
    - repeat rewrite <- A_CSG.(CSplus_assoc). f_equal.
      apply A_CSG.(CSplus_comm).
  Qed.

  Lemma addnf_left : forall table a n nf,
    addnf a (n::nf) table = a +! nf2A (n::nf) table.
  Proof with simpl in*.
    intros.
    rewrite <- (addnf_nf2A table n nf).
    induction nf; simpl in *; [auto|].
    - apply (A_CSG.(CSplus_comm)).
    - rewrite (A_CSG.(CSplus_comm) (getKey a0 table)).
      repeat rewrite <- A_CSG.(CSplus_assoc). rewrite IHnf.
      repeat rewrite A_CSG.(CSplus_assoc). f_equal. apply A_CSG.(CSplus_comm).
  Qed.

  Lemma nf2A_ins : forall table n nf,
    nf2A (ins n nf) table = nf2A (n::nf) table.
  Proof with simpl in *.
    induction n; induction nf; [auto..|]...
    destruct (le_dec (S n) a)...
     - auto.
     - f_equal. rewrite IHnf.
      destruct nf...
       + apply A_CSG.(CSplus_comm).
       + destruct (le_dec (S n) n1); simpl;
        repeat rewrite <- A_CSG.(CSplus_assoc); f_equal; apply A_CSG.(CSplus_comm).
  Qed.

  Function list_ind2' X (P : list X -> Prop) (H : P nil) (H0 : forall x, P (x :: nil))
    (H1 : forall x y l, P (y :: l) -> P (x :: y :: l)) l {measure length l} : P l :=
    match l return P l with
    | nil => H
    | x::nil => H0 x
    | x::y::l' => H1 x y l' (list_ind2' P H H0 H1 (y :: l'))
    end.
  Proof.
    intros. subst. auto.
  Qed.

  Definition list_ind2 : forall X (P : list X -> Prop),
    P nil ->
    (forall x, P (x :: nil)) ->
    (forall x y l, P (y:: l) -> (P (x :: y :: l))) ->
    forall l, P l := fun X P H H0 H1 l => list_ind2' P H H0 H1 l.

  Lemma exp2nf'_cons : forall ex nf,
    exp2nf' ex nf <> nil.
  Proof with simpl in *.
    induction ex; induction nf...
    - discriminate.
    - destruct (le_dec n a); discriminate.
    - intro. firstorder.
    - intro. firstorder.
  Qed.

  Lemma nf_inj : forall ex nf table,
    addnf (exp2A ex table) nf table = nf2A (exp2nf' ex nf) table.
  Proof with simpl in *.
    induction ex.
    - apply (list_ind2 (fun nf => forall table,
    addnf (exp2A (ExpVar n) table) nf table = nf2A (exp2nf' (ExpVar n) nf) table)); intros...
      + auto.
      + destruct (le_dec n x); simpl; [apply A_CSG.(CSplus_comm)|auto].
      + specialize (H table).
        destruct (le_dec n x); destruct (le_dec n y)...
        * repeat rewrite <- A_CSG.(CSplus_assoc).
          rewrite (A_CSG.(CSplus_comm) (getKey n table)).
          repeat rewrite A_CSG.(CSplus_assoc). f_equal. auto.
        * rewrite H. rewrite nf2A_ins...
          destruct l...
          { rewrite (A_CSG.(CSplus_comm) (getKey y table)).
            repeat rewrite <- A_CSG.(CSplus_assoc).
            f_equal. apply A_CSG.(CSplus_comm). }
          { destruct (le_dec n n1); repeat rewrite <- A_CSG.(CSplus_assoc); f_equal;
            rewrite (A_CSG.(CSplus_comm) (getKey n table)); repeat rewrite A_CSG.(CSplus_assoc); f_equal; apply A_CSG.(CSplus_comm). }
        * f_equal. auto.
        * rewrite H. auto.
    - apply (list_ind2 (fun nf => forall (table : list (A * nat)),
        addnf (exp2A (ExpPlus ex1 ex2) table) nf table =
        nf2A (exp2nf' (ExpPlus ex1 ex2) nf) table)); intros...
      + rewrite <- IHex2.
        destruct (exp2nf' ex1 nil) eqn:?.
        { apply exp2nf'_cons in Heqn. contradiction. }
        rewrite addnf_left. rewrite A_CSG.(CSplus_comm). f_equal.
        rewrite <- Heqn. rewrite <- IHex1... auto.
      + rewrite <- IHex2.
        destruct (exp2nf' ex1 (x :: nil)) eqn:?.
        { apply exp2nf'_cons in Heqn. contradiction. }
        rewrite addnf_left. rewrite <- Heqn. rewrite <- IHex1...
        rewrite (A_CSG.(CSplus_comm) (exp2A ex1 table)). repeat rewrite <- A_CSG.(CSplus_assoc).
        f_equal. apply A_CSG.(CSplus_comm).
      + rewrite H. rewrite <- (IHex2 (exp2nf' ex1 (x :: y :: l))).
        destruct (exp2nf' ex1 (x :: y :: l)) eqn:?.
        { apply exp2nf'_cons in Heqn. contradiction. }
        rewrite addnf_left. rewrite <- Heqn. rewrite <- IHex1.
        rewrite addnf_left. simpl. rewrite <- A_CSG.(CSplus_assoc). rewrite <- A_CSG.(CSplus_assoc).
        rewrite (A_CSG.(CSplus_comm) _ (getKey x table)). rewrite A_CSG.(CSplus_assoc). f_equal.
        rewrite <- IHex2.
        destruct (exp2nf' ex1 (y :: l)) eqn:?.
        { apply exp2nf'_cons in Heqn1. contradiction. }
        rewrite addnf_left. rewrite <- Heqn1. rewrite A_CSG.(CSplus_assoc). f_equal.
        rewrite <- IHex1. rewrite addnf_left. auto.
  Qed.

  Lemma uniq' : forall table ex ey nf,
    exp2nf' ex nf = exp2nf' ey nf ->
    addnf (exp2A ex table) nf table = addnf (exp2A ey table) nf table.
  Proof with simpl in *.
    intros. rewrite nf_inj. rewrite nf_inj. rewrite H. auto.
  Qed.

  Lemma uniq : forall ex ey table,
    exp2nf ex = exp2nf ey -> exp2A ex table = exp2A ey table.
  Proof with simpl in *.
    unfold exp2nf. intros. apply (uniq' table) in H... auto.
  Qed.

End CommSemigroup.

Ltac lookup key table :=
  match table with
  | nil => constr:(@None nat)
  | ?t :: ?table' =>
    match t with
    | (key, ?n) => constr:(Some n)
    | _ => lookup key table'
    end
  end.

Ltac get_CSelem csg := eval simpl in (CSelem csg).
Ltac get_CStype csg :=
  let a0 := get_CSelem csg in
  type of a0.
Ltac get_CSplus csg := eval simpl in (CSplus csg).
Ltac get_CSplus_assoc csg := eval simpl in (CSplus_assoc csg).
Ltac get_CSplus_comm csg := eval simpl in (CSplus_comm csg).

Ltac gen_table' csg x n table :=
  let opt := lookup x table in
  let csplus := get_CSplus csg in
  match opt with
  | None =>
    match x with
    | csplus ?y ?z =>
      let res := gen_table' csg y n table in
      match res with
      | (?n', ?table') =>
        gen_table' csg z n' table'
      end
    | _ => constr:(S n, (x, n)::table)
    end
  | Some ?n' => constr:(n, table)
  end.

Ltac gen_table csg x :=
  let A := get_CStype csg in
  gen_table' csg x O (@nil (A * nat)).

Ltac to_exp csg table x :=
  let csplus := get_CSplus csg in
  match x with
  | csplus ?y ?z =>
    let ey := to_exp csg table y in
    let ez := to_exp csg table z in
    constr:(ExpPlus ey ez)
  | _ =>
    let ex_opt := lookup x table in
    match ex_opt with
    | Some ?ex => constr:(ExpVar ex)
    end
  end.

Ltac semigroup csg :=
  match goal with
  | |- ?x = ?y =>
    let t := gen_table csg x in
    match t with
    | (_, ?table) =>
      let ex := to_exp csg table x in
      let ey := to_exp csg table y in
      enough (exp2A csg ex table = exp2A csg ey table) by auto;
      apply uniq;
      unfold exp2nf;
      auto
    end
  end.