(* Ceci est le projet du cours d'assistants de preuves du MPRI 2-7-2 *)
(* Josselin GIET M2 DI/ENS *)
(*
  J'ai traité le sujet dans son intégralité, mais je ne suis pas parvenu
  à trouver une preuve pour la question III.3.4.
  Ce document a été testé sur la version 8.8.1 de coq.
 *)
(* II. Implementing the decision procedure *)
(* ======================================= *)

(* II.2. Building the tactic *)
(* ------------------------- *)

(* ___  ___     ____      _
  |_ _||_ _|   |___ \    / |
   | |  | |      __) |   | |
   | |  | |  _  / __/  _ | |
  |___||___|(_)|_____|(_)|_|
*)
(*  _              _        _
   | |_ __ _ _   _| |_ ___ / |
   | __/ _` | | | | __/ _ \| |
   | || (_| | |_| | || (_) | |
    \__\__,_|\__,_|\__\___/|_|
*)

Ltac tauto1 :=
    match goal with
    (* ===/  Easy rules  \=== *)
    (* ---------------------- *)
    (* Rule : [Ax] *)
    | _ : ?A |- ?A =>
        idtac "Ax";
        assumption
    (* Rule : [False - E] *)
    | _ : False |- _ =>
        idtac "False - E";
        contradiction
    (* Rule : [True - I] *)
    | |- True =>
        idtac "True - I";
        auto

    (* ===/  Rules for ->  \=== *)
    (* ----------------------- *)
    (* Rule : [-> - I]*)
    | |- ?A -> ?B =>
        idtac "->-I";
        intro; tauto1
    (* Rule : [-> - E]*)
    | H : ?A -> ?B |- ?C =>
        idtac "->-E";
        let Ha := fresh in
        let Hb := fresh in
        assert (Hb : B);
            [
                assert( Ha : A);
                [
                    clear H; tauto1
                |
                    apply H in Ha;
                    assumption
                ]
            |
            clear H; tauto1]

    (* ===/  Rules for \/  \=== *)
    (* ----------------------- *)
    (* Rule : [\/ - I] *)
    | |- ?A \/ ?B =>
        idtac "\/-I";
        (left; tauto1) || (right; tauto1)
    (* Rule : [\/ - E] *)
    | H: ?A \/ ?B |- _ =>
        idtac "\/-E";
        destruct H; [tauto1 | tauto1]

    (* ===/  Rules for /\  \=== *)
    (* ----------------------- *)
    (* Rule : [/\ - I] *)
    | |- ?A /\ ?B =>
        idtac "/\-I";
        split; [tauto1 | tauto1]
    (* Rule : [/\ - E] *)
    | H: ?A /\ ?B |- _ =>
        idtac "/\-E";
        destruct H; tauto1
    end.

(*  ___  ___     ____      ____
   |_ _||_ _|   |___ \    |___ \
    | |  | |      __) |     __) |
    | |  | |  _  / __/  _  / __/
   |___||___|(_)|_____|(_)|_____|
*)
(* Voici les tests : tous résolus par un appel à tauto1 ! *)
Section Tests.
    Variable A : Prop.
    Variable B : Prop.
    Variable C : Prop.
    Lemma Test1 : False -> A.
    Proof.
        tauto1.
    Qed.
    Lemma Test2 : A /\ B -> A.
    Proof.
        tauto1.
    Qed.
    Lemma Test3 : A /\ B -> B.
    Proof.
        tauto1.
    Qed.
    Lemma Test4 : A /\ B -> B /\ A.
    Proof.
        tauto1.
    Qed.
    Lemma Test5 : A -> A \/ B.
    Proof.
        tauto1.
    Qed.
    Lemma Test6 : B -> A \/ B.
    Proof.
        tauto1.
    Qed.
    Lemma Test7 : ( A -> C ) -> ( B -> C ) -> A \/ B -> C.
    Proof.
        tauto1.
    Qed.
    Lemma Test8 : A -> ( A -> B ) -> B.
    Proof.
        tauto1.
    Qed.
    Lemma test9 : A -> ( A -> B ) -> ( B -> C ) -> B.
    Proof.
        tauto1.
    Qed.
    Lemma test10 : A -> ( A -> B ) -> ( B -> C ) -> C.
    Proof.
        tauto1.
    Qed.
    Lemma test_fast : A /\ B \/ True.
    Proof.
        tauto1.
    Qed.
End Tests.

(* II.3 Backtrack control *)
(* ---------------------- *)

(* ___  ___     _____    _
  |_ _||_ _|   |___ /   / |
   | |  | |      |_ \   | |
   | |  | |  _  ___) |_ | |
  |___||___|(_)|____/(_)|_|
*)
(* Les règles réversibles sont :
    - [-> - I]
    - [/\ - I]
    - [/\ - E]
    - [\/ - I]
      /!\ La version utilisée est `(left; tauto1) || (right; tauto1)`
    - [\/ - E]

La règle [-> - E] n'est pas réversible en effet si on considère le séquent :

   C |- A        B, C |- C
  ========================
       A -> B, C |- C

Le code obtenu est donc un « copier-coller » de tauto1 à un changement près :
Toutes stratégies non atomiques (i.e. celles qui ne sont pas [Ax] [False-E] ou
[True-I]) à l'exception de [-> - E] sont dès lors de la forme
  ( <\tactique essayée\> ) + ( idtac "back [rulename]"k; fail 1 )
*)
(* _              _       ____
  | |_ __ _ _   _| |_ ___|___ \
  | __/ _` | | | | __/ _ \ __) |
  | || (_| | |_| | || (_) / __/
   \__\__,_|\__,_|\__\___/_____|
*)
Ltac tauto2 :=
    match goal with
    (* ===/  Easy rules  \=== *)
    (* ---------------------- *)
    (* Rule : [Ax] *)
    | _ : ?A |- ?A =>
        idtac "Ax";
        assumption
    (* Rule : [False - E] *)
    | _ : False |- _ =>
        idtac "False-E";
        contradiction
    (* Rule : [True - I] *)
    | |- True =>
        idtac "True-I";
        auto

    (* ===/  Rules for ->  \=== *)
    (* ----------------------- *)
    (* Rule : [-> - I]*)
    | |- ?A -> ?B =>
        idtac "->-I";
        (intro; tauto2) + (idtac "back [->-I]"; fail 1)
    (* Rule : [-> - E]*)
    | H : ?A -> ?B |- ?C =>
        idtac "->-E";
        let Ha := fresh in
        let Hb := fresh in
        assert (Hb : B);
            [
                assert( Ha : A);
                [
                    clear H; tauto2
                |
                    apply H in Ha;
                    assumption
                ]
            |
            clear H; tauto2]

    (* ===/  Rules for \/  \=== *)
    (* ----------------------- *)
    (* Rule : [\/ - I] *)
    | |- ?A \/ ?B =>
        idtac "\/-I";
        ((left; tauto2) || (right; tauto2)) + (idtac "back [\/-I]"; fail 1)
    (* Rule : [\/ - E] *)
    | H: ?A \/ ?B |- _ =>
        idtac "\/-E";
        (destruct H; [tauto2 | tauto2]) + (idtac "back [\/-E]"; fail 1)

    (* ===/  Rules for /\  \=== *)
    (* ----------------------- *)
    (* Rule : [/\ - I] *)
    | |- ?A /\ ?B =>
        idtac "/\-I";
        (split; [tauto2 | tauto2]) + (idtac "back [/\-I]"; fail 1)
    (* Rule : [/\ - E] *)
    | H: ?A /\ ?B |- _ =>
        idtac "/\-E";
        (destruct H; tauto2) + (idtac "back [/\-E]"; fail 1)
    end.

(* ___  ___     _____    ____
  |_ _||_ _|   |___ /   |___ \
   | |  | |      |_ \     __) |
   | |  | |  _  ___) |_  / __/
  |___||___|(_)|____/(_)|_____|
*)
Lemma exple_backtracking : forall A B  : Prop,
    (* A /\ A -> A /\ A -> A /\ A -> *) A /\ A -> A /\ A -> (B \/ B) \/ A.
Proof.
    intros A B.
    tauto1.  (* Fait un grand nombre d'essais d'appels de règles *)
    Restart.
    intros A B.
    tauto2. (* Fait beaucoup moins de règles... *)
Qed.

(* III. Formalizing the tactic *)
(* ========================== *)

(* III.1. Tactic steps *)
(* ------------------- *)

(* Quelques importations utiles ... *)
Require Import List Arith Bool.

(* ___  ___  ___     _     _
  |_ _||_ _||_ _|   / |   / |
   | |  | |  | |    | |   | |
   | |  | |  | |  _ | | _ | |
  |___||___||___|(_)|_|(_)|_|
*)
(*  __
   / _| ___  _ __ _ __ ___
  | |_ / _ \| '__| '_ ` _ \
  |  _| (_) | |  | | | | | |
  |_|  \___/|_|  |_| |_| |_|
*)
(* Définition du type des formules. *)
Inductive form : Set :=
    | Leaf : nat -> form
    | True_form : form
    | False_form : form
    | Impl : form -> form -> form
    | And : form -> form -> form
    | Or : form -> form -> form .

(* ___  ___  __ _
  / __|/ _ \/ _` |
  \__ \  __/ (_| |
  |___/\___|\__, |
               |_|
*)
(* Définition du type d'un séquant. *)
Definition seq : Set :=
    (list form)* form.

(* ___  ___  ___     _     ____
  |_ _||_ _||_ _|   / |   |___ \
   | |  | |  | |    | |     __) |
   | |  | |  | |  _ | | _  / __/
  |___||___||___|(_)|_|(_)|_____|
*)
(* Tout d'abord, une fonction annexe qui décide si deux formules sont égales *)
Fixpoint equal_form (f1 f2 : form) : bool :=
  match f1, f2 with
  | Leaf n1, Leaf n2 => beq_nat n1 n2
  | True_form, True_form
  | False_form, False_form => true
  | Impl f1g f1d, Impl f2g f2d => andb (equal_form f1g f2g) (equal_form f1d f2d)
  | And f1g f1d, And f2g f2d => andb (equal_form f1g f2g) (equal_form f1d f2d)
  | Or f1g f1d, Or f2g f2d => andb (equal_form f1g f2g) (equal_form f1d f2d)
  | _, _ => false
  end.

(* Le lemme qui vérifie la validité de la fonction précédente.
   On ne vérifie qu'une implication, mais c'est suffisant pour la suite.
   La preuve ne peut pas se faire avec une simple induction,
   on utilise donc une récurrence forte, par un point fixe. *)
Lemma equal_form_sound : forall f1 f2 : form,
  (equal_form f1 f2) = true -> f1 = f2.
Proof.
  fix Hl 1.
  intros f1 f2.
  destruct f1,f2;
  simpl; intro H; first [inversion H  ].
  + apply beq_nat_true in H; rewrite H; reflexivity.
  + reflexivity.
  + reflexivity.
  + apply andb_true_iff in H; destruct H as [H_1 H_2].
    apply Hl in H_1.
    apply Hl in H_2.
    rewrite H_1; rewrite H_2.
    reflexivity.
  + apply andb_true_iff in H; destruct H as [H_1 H_2].
    apply Hl in H_1.
    apply Hl in H_2.
    rewrite H_1; rewrite H_2.
    reflexivity.
+ apply andb_true_iff in H; destruct H as [H_1 H_2].
    apply Hl in H_1.
    apply Hl in H_2.
    rewrite H_1; rewrite H_2.
    reflexivity.
Qed.

(* De même, on se donne une fonction booléenne qui teste si une formule
   est présente dans une liste de formules. *)
Fixpoint in_bool (l : list form) (f : form) :=
  match l with
  | nil => false
  | cons f' l' => orb (equal_form f' f) (in_bool l' f)
  end.

(* Ce lemme montre que la fonction est la contrepartie booléenne valide de In. *)
Lemma in_bool_soound :
  forall f : form, forall l : list form,
  in_bool l f = true -> In f l.
Proof.
  intros f l.
  induction l.
  + intro H; simpl in H; inversion H.
  + intro H; simpl in H.
    simpl.
    apply orb_true_iff in H.
    destruct H as [ H | H].
    - apply equal_form_sound in H; left; assumption.
    - apply IHl in H; right; assumption.
Qed.

(* _         _             __
  (_)___    | | ___  __ _ / _|
  | / __|   | |/ _ \/ _` | |_
  | \__ \   | |  __/ (_| |  _|
  |_|___/___|_|\___|\__,_|_|
*)
(* Cette fonction teste si on peut appliquer
   au séquent un des cas de base du calcul intuitionniste. *)
Definition is_leaf ( seq : seq ) : bool :=
    match snd seq with
    | True_form => true
    (* Si on doit prouver le TOP *)
    | Leaf _ as f =>
    (* Quand le but est une variable *)
      orb (in_bool (fst seq) f)
          (* On regarde si elle n'est pas dans les hypothèses *)
          (in_bool (fst seq) False_form)
          (* Sinon, on regarde si on a l'hypothèse BOTTOM *)
    | _ => in_bool (fst seq) False_form
    (* Pour les autres cas, on regarde si on a l'hypothèse BOTTOM *)
    end.

(* ___  ___  ___     _     _____
  |_ _||_ _||_ _|   / |   |___ /
   | |  | |  | |    | |     |_ \
   | |  | |  | |  _ | | _  ___) |
  |___||___||___|(_)|_|(_)|____/
*)

(* Quelques définitions de types utils dans la suite ...*)
Definition subgoals := list (list seq).
Definition picked_hyp := list (form * list form).

(* Cette fonction auxiliaire permet de mettre en valmeur une hypothèse *)
Fixpoint pick_hyp_aux ( hyps acc : list form ) : picked_hyp :=
  match hyps with
  | nil => nil
  | hd :: tl => (hd, acc++tl) :: (pick_hyp_aux tl (hd::acc))
  end.

(* Un lemme de validité associé à la fonction ci-dessus.
   Elle est assez technique, mais elle permet de voir l'intérêt
   d'une seule fonction avec accumulateur. *)
Lemma pick_hyp_aux_sound :
  forall l acc: list form,
  forall p_hyps : form * list form,
    In p_hyps (pick_hyp_aux l acc) ->
      In (fst p_hyps) l /\
      forall f : form, In f (snd p_hyps) -> (In f l \/ In f acc).
Proof.
  intros l.
  induction l; intros acc p_hyps H.
  + split.
    - simpl. contradiction.
    - intros; simpl; contradiction.
  + split.
    - simpl in H.
      destruct H.
      ++ left; rewrite <- H; simpl; auto.
      ++ simpl. right. eapply IHl with (acc := a::acc); assumption.
    - intros f Hf.
      simpl in H.
      destruct H.
      ++ rewrite <- H in Hf. simpl in Hf.
        apply in_app_or in Hf.
        destruct Hf.
        +++ right; auto.
        +++ left; simpl; right; assumption.
      ++ assert (In (fst p_hyps) l /\ (forall f : form, In f (snd p_hyps) -> In f l \/ In f (a::acc))).
        +++ apply (IHl (a::acc) p_hyps). assumption.
        +++ destruct H0 as [H04 H0].
            assert (In f l \/ In f (a :: acc)).
            -- apply H0; assumption.
            -- simpl in H1; destruct H1.
              * left; simpl; right; assumption.
              * destruct H1.
                ** left; simpl; left; assumption.
                ** right; assumption.
Qed.

(*       _      _        _
   _ __ (_) ___| | __   | |__  _   _ _ __
  | '_ \| |/ __| |/ /   | '_ \| | | | '_ \
  | |_) | | (__|   <    | | | | |_| | |_) |
  | .__/|_|\___|_|\_\___|_| |_|\__, | .__/
  |_|                          |___/|_|
*)
Definition pick_hyp (seq : seq) : picked_hyp :=
  pick_hyp_aux (fst seq) nil.

(* Cette fonction gère les règles d'introduction :
   elles sont dirigées par la forme du but *)
Definition intro_rules (seq : seq) : subgoals :=
  match snd seq with
  | Leaf _ | True_form | False_form => nil
  | Impl premisse conclusion =>
    ((cons premisse (fst seq), conclusion)::nil )::nil
  | And left_form right_form =>
    ((fst seq, left_form) :: (fst seq, right_form) ::nil)::nil
  | Or left_form right_form =>
    ((fst seq, left_form)::nil) :: ((fst seq, right_form)::nil)::nil
  end.

Definition elim_rules (hyps : form * list form) (goal : form) : subgoals :=
  match fst hyps with
  | Leaf _ | True_form | False_form => nil
  | Impl premisse conclusion =>
    ((snd hyps, premisse) :: (conclusion::(snd hyps), goal) :: nil)::nil
  | And left_form right_form =>
    ((left_form::right_form::(snd hyps), goal)::nil)::nil
  | Or left_form right_form =>
    ( (left_form :: (snd hyps), goal) :: (right_form :: (snd hyps), goal) :: nil )::nil
  end.

Fixpoint elim_rules_multi (hyps : picked_hyp) (goal : form) : subgoals :=
  match hyps with
  | nil => nil
  | hyp :: tl => (elim_rules hyp goal) ++ (elim_rules_multi tl goal)
  end.

Definition elim_rules_final (seq : seq) : subgoals :=
  (elim_rules_multi (pick_hyp seq) (snd seq)).

(*     _
   ___| |_ ___ _ __
  / __| __/ _ \ '_ \
  \__ \ ||  __/ |_) |
  |___/\__\___| .__/
              |_|
*)
Definition step (seq : seq) : subgoals :=
  (intro_rules seq) ++ (elim_rules_final seq).

(* ___  ___  ___     _    _  _
  |_ _||_ _||_ _|   / |  | || |
   | |  | |  | |    | |  | || |_
   | |  | |  | |  _ | | _|__   _|
  |___||___||___|(_)|_|(_)  |_|
*)
Fixpoint tauto (fuel : nat) (seqt : seq) : bool :=
  is_leaf seqt
  ||
    match fuel with
    | 0 => false
    | S n =>
      (* le nom « étrange » donné à subgoalz corrige les problèmes de typage
         pour éviter le shadowing du type par la variable *)
      let subgoalz := step seqt in
      let fix handle_subgoal (subgoal: list seq) : bool :=
        match subgoal with
        | nil => false
        (* On ne doit pas avoir un sous-but vide renvoyé par `step` *)
        | seq :: nil => tauto n seq
        | seq :: tl => (tauto n seq) && (handle_subgoal tl)
        end in
      let fix handle_subgoals (subgoalz: subgoals) : bool :=
        match subgoalz with
        | nil => false
        | subgoal :: tl => (handle_subgoal subgoal) || (handle_subgoals tl)
        end in
      handle_subgoals subgoalz
    end.

(* III.2. Termination *)
(* ------------------ *)

(* ___  ___  ___     ____      _
  |_ _||_ _||_ _|   |___ \    / |
   | |  | |  | |      __) |   | |
   | |  | |  | |  _  / __/  _ | |
  |___||___||___|(_)|_____|(_)|_|
*)

(*     _              __
   ___(_)_______     / _| ___  _ __ _ __ ___
  / __| |_  / _ \   | |_ / _ \| '__| '_ ` _ \
  \__ \ |/ /  __/   |  _| (_) | |  | | | | | |
  |___/_/___\___|___|_|  \___/|_|  |_| |_| |_|
*)
Fixpoint size_form (f : form) : nat :=
  match f with
  | Leaf _ | True_form | False_form => 1
  | Impl f1 f2 => 1 + (size_form f1) + (size_form f2)
  | And f1 f2 => 1 + (size_form f1) + (size_form f2)
  | Or f1 f2 => 1 + (size_form f1) + (size_form f2)
  end.

Fixpoint size_hyps (hyps : list form) : nat :=
  match hyps with
  | nil => 0
  | hyp :: hyps => (size_form hyp) + (size_hyps hyps)
  end.

(*     _
   ___(_)_______     ___  ___  __ _
  / __| |_  / _ \   / __|/ _ \/ _` |
  \__ \ |/ /  __/   \__ \  __/ (_| |
  |___/_/___\___|___|___/\___|\__, |
                                 |_|
*)
Definition size_seq (seq : seq) : nat :=
  let hyps := fst seq in
  let goal := snd seq in
  (size_hyps hyps) + (size_form goal).

(* ___  ___  ___     ____      ____
  |_ _||_ _||_ _|   |___ \    |___ \
   | |  | |  | |      __) |     __) |
   | |  | |  | |  _  / __/  _  / __/
  |___||___||___|(_)|_____|(_)|_____|
*)
(* Quelques remarques sur la preuve de terminaison :
   - Elle commence par deux lemmes qui monternt que le séquents sont plus petits
     si on applique une règle d'introduction ou d'élimination.
     Ces lemmes ont des preuves longues mais qui ne présentent pas de
     difficulté.
   - Viennent ensuite deux lemmes qui expriment des propriétés sur la
     concaténation des listes : présevation des éléments et
     de la taille totale des hypothèses
   - Puis un lemme technique pour le cas des règles d'élimination et
     notamment le cas de la fonction pick_hyp.
   - Le lemme final est le lemme `size_decrease` *)
Require Import Omega.

Lemma size_decrease_intro :
  forall s : seq, forall s' : seq, forall subgoal : list seq,
  (In subgoal (intro_rules s)) /\ (In s' subgoal)
    -> (size_seq s') < (size_seq s).
Proof.
  intros s s' sg.
  unfold intro_rules.
  case_eq (snd s).
  - intros n H9 H; destruct H as [H1 H2]; unfold In in H1; contradiction.
  - intros H9 H; destruct H as [H1 H2]; unfold In in H1; contradiction.
  - intros H9 H; destruct H as [H1 H2]; unfold In in H1; contradiction.
  - intros f1 f2 Hs H.
    destruct H as [H1 H2].
    assert (s' = (f1 :: fst s, f2)).
    + unfold In in H1.
      destruct H1; try contradiction.
      rewrite <- H in H2.
      unfold In in H2.
      destruct H2; try contradiction.
      rewrite H0; reflexivity.
    + unfold size_seq.
      rewrite H; rewrite Hs.
      simpl; omega.
  - intros f1 f2 Hs H.
    destruct H as [H1 H2].
    unfold In in H1.
    destruct H1; try contradiction.
    rewrite <- H in H2.
    unfold In in H2; unfold In in H2.
    destruct H2.
    * unfold size_seq.
      rewrite <- H0; rewrite Hs.
      simpl; omega.
    * destruct H0; try contradiction.
      unfold size_seq.
      rewrite <- H0; rewrite Hs.
      simpl; omega.
  - intros f1 f2 Hs H.
    destruct H as [H1 H2].
    unfold In in H1.
    destruct H1.
    + rewrite <- H in H2.
      unfold In in H2.
      destruct H2; try contradiction.
      unfold size_seq.
      rewrite <- H0; rewrite Hs.
      simpl; omega.
    + destruct H; try contradiction.
      rewrite <- H in H2.
      destruct H2; try contradiction.
      unfold size_seq.
      rewrite <- H0; rewrite Hs.
      simpl; omega.
Qed.

Lemma size_decrease_elim :
  forall hyps : form*list form, forall goal : form, forall s' : seq, forall subgoal : list seq,
  (In subgoal (elim_rules hyps goal)) /\ (In s' subgoal) ->
  (size_seq s') < (size_seq ((fst hyps)::(snd hyps), goal)).
Proof.
  intros hyps goal s' sg.
  unfold elim_rules.
  case_eq (fst hyps).
  - intros n H9 H; destruct H as [H1 H2]; unfold In in H1; contradiction.
  - intros H9 H; destruct H as [H1 H2]; unfold In in H1; contradiction.
  - intros H9 H; destruct H as [H1 H2]; unfold In in H1; contradiction.
  - intros f1 f2 Hs H.
    destruct H as [H1 H2].
    unfold In in H1.
    destruct H1 as [H1 | H1]; try contradiction.
    rewrite <- H1 in H2.
    unfold In in H2.
    destruct H2 as [H2 | H2].
    + rewrite <- H2.
      unfold size_seq; simpl; omega.
    + destruct H2 as [H2|H2]; try contradiction.
      rewrite <- H2.
      unfold size_seq; simpl; omega.
  - intros f1 f2 Hs H.
    destruct H as [H1 H2].
    unfold In in H1.
    destruct H1 as [H1|H1]; try contradiction.
    rewrite <- H1 in H2.
    unfold In in H2.
    destruct H2 as [H2|H2]; try contradiction.
    rewrite <- H2.
    unfold size_seq; simpl; omega.
  - intros f1 f2 Hs H.
    destruct H as [H1 H2].
    unfold In in H1.
    destruct H1 as [H1 | H1 ]; try contradiction.
    rewrite <- H1 in H2.
    unfold In in H2.
    destruct H2 as [H2 | H2].
    + rewrite <- H2.
      unfold size_seq; simpl; omega.
    + destruct H2 as [H2|H2]; try contradiction.
      rewrite <- H2.
      unfold size_seq; simpl; omega.
Qed.

Lemma size_equal_concat :
  forall l1 l2 : list form,
  size_hyps (l1++l2) = size_hyps l1 + size_hyps l2.
Proof.
  intros l1 l2; induction l1; simpl; omega.
Qed.

Lemma concat_in :
  forall f : list seq,
  forall l1 l2 : list (list seq),
  In f (l1 ++ l2) -> In f l1 \/ In f l2.
Proof.
  intros f l1; induction l1.
  + intros l2 H; simpl in H; right; assumption.
  + simpl; intros l2 H. destruct H.
    - left; left; assumption.
    - apply IHl1 in H; destruct H.
      * left; right; assumption.
      * right; assumption.
Qed.

Lemma size_decrease_elim_final_aux :
  forall s s' : seq, forall sg : list seq,
  forall l acc : list form,
  In sg (elim_rules_multi (pick_hyp_aux l acc) (snd s)) /\ In s' sg ->
  size_seq s' < size_hyps l + size_hyps acc + size_form (snd s).
Proof.
  intros s s' sg l.
  induction l.
  - intros acc H; destruct H as [H0 H1]; simpl in H0; contradiction.
  - intros acc H. destruct H as [H0 H1]; simpl in H0.
    apply concat_in in H0; destruct H0.
    + simpl.
      assert ( (size_seq s') < (size_seq ((fst (a, acc ++ l))::(snd (a, acc ++ l)), (snd s)))).
      * apply (size_decrease_elim (a, acc ++ l) (snd s) s' sg).
        split; assumption.
      * simpl in H0. unfold size_seq in H0. simpl in H0.
        unfold size_seq.
        assert (size_hyps (acc ++ l) = size_hyps acc + size_hyps l).
          -- apply size_equal_concat.
          -- rewrite H2 in H0; omega.
   + simpl.
     assert (size_seq s' < size_hyps l + size_hyps (a::acc) + size_form (snd s)).
    * apply (IHl (a::acc)).
      split; assumption.
    * simpl in H0; omega.
Qed.

Lemma size_decrease_elim_final :
  forall s : seq, forall s' : seq, forall subgoal : list seq,
  (In subgoal (elim_rules_final s)) /\ (In s' subgoal)
    -> (size_seq s') < (size_seq s).
Proof.
  intros s s' sg.
  unfold elim_rules_final; simpl.
  unfold pick_hyp. unfold size_seq.
  intro H.
  assert (size_seq s' < size_hyps (fst s) + size_hyps nil + size_form (snd s)).
  + apply (size_decrease_elim_final_aux s s' sg (fst s) nil); assumption.
  + simpl in H0; unfold size_seq in H0; omega.
Qed.

(*     _                _
   ___(_)_______     __| | ___  ___ _ __ ___  __ _ ___  ___
  / __| |_  / _ \   / _` |/ _ \/ __| '__/ _ \/ _` / __|/ _ \
  \__ \ |/ /  __/  | (_| |  __/ (__| | |  __/ (_| \__ \  __/
  |___/_/___\___|___\__,_|\___|\___|_|  \___|\__,_|___/\___|
*)
Theorem size_decrease :
  forall s : seq, forall s' : seq, forall subgoal : list seq,
  (In subgoal (step s)) /\ (In s' subgoal) -> (size_seq s') < (size_seq s).
Proof.
  intros s s' sg.
  intros H; destruct H as [H0 H1].
  unfold step in H0.
  apply concat_in in H0.
  destruct H0.
  - apply (size_decrease_intro s s' sg); auto.
  - apply (size_decrease_elim_final s s' sg); auto.
Qed.

(* III.3. Soundness *)
(* ---------------- *)

(* ___  ___  ___     _____    _
  |_ _||_ _||_ _|   |___ /   / |
   | |  | |  | |      |_ \   | |
   | |  | |  | |  _  ___) |_ | |
  |___||___||___|(_)|____/(_)|_|
*)

Fixpoint sem (f : form) (sem_nat : nat -> Prop) : Prop :=
    match f with
    | True_form => True
    | False_form => False
    | Leaf n => sem_nat n
    | Impl f1 f2 => (sem f1 sem_nat) -> (sem f2 sem_nat)
    | And f1 f2 => (sem f1 sem_nat) /\ (sem f2 sem_nat)
    | Or f1 f2 => (sem f1 sem_nat) \/ (sem f2 sem_nat)
    end.

Fixpoint sem_hyps (hyps : list form) (sem_nat : nat -> Prop) :=
  match hyps with
  | nil => True
  | hyp :: hyps => (sem hyp sem_nat) /\ (sem_hyps hyps sem_nat)
  end.

Definition seq_valid (s : seq) : Prop :=
    forall sem_nat : nat -> Prop,
    sem_hyps (fst s) sem_nat -> sem (snd s) sem_nat.

Fixpoint conj_seqs_valid (seqs : list seq) : Prop :=
  match seqs with
  | nil => True
  | s::seqs => (seq_valid s) /\ (conj_seqs_valid seqs)
  end.

Fixpoint subgoals_valid (sg : subgoals) : Prop :=
  match sg with
  | nil => False
  | seqs :: sg => conj_seqs_valid seqs \/ subgoals_valid sg
  end.

(* ___  ___  ___     _____    ____
  |_ _||_ _||_ _|   |___ /   |___ \
   | |  | |  | |      |_ \     __) |
   | |  | |  | |  _  ___) |_  / __/
  |___||___||___|(_)|____/(_)|_____|
*)
(* _         _             __                             _
  (_)___    | | ___  __ _ / _|  ___  ___  _   _ _ __   __| |
  | / __|   | |/ _ \/ _` | |_  / __|/ _ \| | | | '_ \ / _` |
  | \__ \   | |  __/ (_| |  _| \__ \ (_) | |_| | | | | (_| |
  |_|___/___|_|\___|\__,_|_|___|___/\___/ \__,_|_| |_|\__,_|
*)
Lemma is_leaf_sound : forall s : seq, is_leaf s = true  -> seq_valid s.
Proof.
  intros s H.
  unfold seq_valid.
  unfold is_leaf in H; destruct (snd s); simpl in H.
  + apply orb_true_iff in H; destruct H.
    - unfold seq_valid.
      intros sem_nat H_hyps; simpl.
      induction (fst s).
      * simpl in H; apply eq_true_false_abs in H.
        -- contradiction.
        -- reflexivity.
      * simpl in H; apply orb_true_iff in H; simpl in H_hyps.
        destruct H_hyps; destruct H.
        -- apply equal_form_sound in H; rewrite H in H0.
           simpl in H0; assumption.
        -- apply (IHl H H1); assumption.
    - intros sem_nat H_hyps; induction (fst s).
      * simpl in H; apply eq_true_false_abs in H.
        -- contradiction.
        -- reflexivity.
      * simpl in H; apply orb_true_iff in H; simpl in H_hyps.
        destruct H_hyps; destruct H.
        -- apply equal_form_sound in H; rewrite H in H0.
           simpl in H0; contradiction.
        -- apply (IHl H H1); assumption.
  + intros sem_nat H_hyps; simpl; auto.
  + intros sem_nat H_hyps; induction (fst s).
    - simpl in H; apply eq_true_false_abs in H.
      -- contradiction.
      -- reflexivity.
    - simpl in H; simpl in H_hyps; destruct H_hyps.
      apply orb_true_iff in H; destruct H.
      * apply equal_form_sound in H; rewrite H in H0; simpl in H0; contradiction.
      * apply (IHl H H1); assumption.
  + intros sem_nat H_hyps; induction (fst s).
    - simpl in H; apply eq_true_false_abs in H.
      -- contradiction.
      -- reflexivity.
    - simpl in H; simpl in H_hyps; destruct H_hyps.
      apply orb_true_iff in H; destruct H.
      * apply equal_form_sound in H; rewrite H in H0; simpl in H0; contradiction.
      * apply (IHl H H1); assumption.
  + intros sem_nat H_hyps; induction (fst s).
    - simpl in H; apply eq_true_false_abs in H.
      -- contradiction.
      -- reflexivity.
    - simpl in H; simpl in H_hyps; destruct H_hyps.
      apply orb_true_iff in H; destruct H.
      * apply equal_form_sound in H; rewrite H in H0; simpl in H0; contradiction.
      * apply (IHl H H1); assumption.
  + intros sem_nat H_hyps; induction (fst s).
    - simpl in H; apply eq_true_false_abs in H.
      -- contradiction.
      -- reflexivity.
    - simpl in H; simpl in H_hyps; destruct H_hyps.
      apply orb_true_iff in H; destruct H.
      * apply equal_form_sound in H; rewrite H in H0; simpl in H0; contradiction.
      * apply (IHl H H1); assumption.
 Qed.

(* ___  ___  ___     _____    _____
  |_ _||_ _||_ _|   |___ /   |___ /
   | |  | |  | |      |_ \     |_ \
   | |  | |  | |  _  ___) |_  ___) |
  |___||___||___|(_)|____/(_)|____/
*)
(* Les preuves de validits dans cette section sont de la même nature que pour
   les preuves de terminaisons.
   ie :
   - deux lemmes sont les fonctions intro|elim-rules,
   - des lemmes pour prendre en compte la fonction `pick_hyp`
   - Le théorême final sur la validité de la fonction step.
*)
Lemma intro_rules_sound :
  forall s : seq,
  subgoals_valid (intro_rules s) -> seq_valid s.
Proof.
  intros s Hs.
  unfold intro_rules in Hs.
  case_eq (snd s).
  - intros n Hn; rewrite Hn in Hs; simpl in Hs; contradiction.
  - intro H; rewrite H in Hs; simpl in Hs; contradiction.
  - intro H; rewrite H in Hs; simpl in Hs; contradiction.
  - intros f1 f2 Hf; rewrite Hf in Hs; simpl in Hs.
    unfold seq_valid; rewrite Hf.
    intros sem_nat Hfs.
    destruct Hs as [Hs | Hfalse].
    + destruct Hs as [Hs Htrue].
      unfold seq_valid in Hs; simpl in Hs.
      simpl; intro Hf1; apply (Hs sem_nat).
      split; assumption.
    + contradiction.
  - intros f1 f2 Hf; rewrite Hf in Hs; simpl in Hs.
    unfold seq_valid; rewrite Hf; simpl.
    intros sem_nat Hfs.
    unfold seq_valid in Hs; simpl.
    destruct Hs as [Hs | Hs].
    + destruct Hs as [H1 H2]; destruct H2 as [H2 Htrue]; split.
      * simpl in H1; apply (H1 sem_nat Hfs).
      * simpl in H2; apply (H2 sem_nat Hfs).
    + contradiction.
  - intros f1 f2 Hf; rewrite Hf in Hs; simpl in Hs.
    unfold seq_valid; rewrite Hf; simpl.
    intros sem_nat Hfs.
    unfold seq_valid in Hs; simpl in Hs.
    destruct Hs as [H1 | H2].
    + destruct H1 as [H1 Htrue]; left; apply (H1 sem_nat Hfs).
    + destruct H2 as [H2 | Hfalse].
      -- destruct H2 as [H2 Htrue]; right; apply (H2 sem_nat Hfs).
      -- contradiction.
Qed.

Lemma elim_rules_sound :
  forall hyps : form * list form,
  forall goal : form,
  subgoals_valid (elim_rules hyps goal) ->
    seq_valid ((fst hyps)::(snd hyps), goal).
Proof.
  intros hyps goal Hsg.
  unfold elim_rules in Hsg.
  case_eq (fst hyps).
  - intros n Hf; rewrite Hf in Hsg; simpl in Hsg; contradiction.
  - intros Hf; rewrite Hf in Hsg; simpl in Hsg; contradiction.
  - intros Hf; rewrite Hf in Hsg; simpl in Hsg; contradiction.
  - intros f1 f2 Hf; rewrite Hf in Hsg; simpl in Hsg.
    unfold seq_valid; simpl.
    intros sem_nat H; destruct H as [H12 H_hyps].
    destruct Hsg.
    + unfold seq_valid in H; simpl in H;
      destruct H as [H1 H2]; destruct H2 as [H2 Htrue].
      assert (sem f1 sem_nat) by apply (H1 sem_nat H_hyps).
      apply H12 in H.
      apply (H2 sem_nat); split; assumption.
    + contradiction.
  - intros f1 f2 Hf; rewrite Hf in Hsg; simpl in Hsg.
    unfold seq_valid; simpl.
    intros sem_nat H; destruct H as [H12 H_hyps].
    destruct Hsg as [Hsg | Hfalse]. destruct Hsg as [Hsg Htrue].
    + unfold seq_valid in Hsg; simpl in Hsg.
      apply Hsg; split;  try split; destruct H12; assumption.
    + contradiction.
  - intros f1 f2 Hf; rewrite Hf in Hsg; simpl in Hsg.
    unfold seq_valid; simpl.
    intros sem_nat H; destruct H as [H12 H_hyps].
    destruct Hsg.
    destruct H as [Hf1 Hf2]; destruct Hf2 as [Hf2 Htrue].
    + destruct H12 as [H1 | H2].
      * unfold seq_valid in Hf1; simpl in Hf1;
        apply (Hf1 sem_nat); split; assumption.
      * unfold seq_valid in Hf2; simpl in Hf2;
        apply (Hf2 sem_nat); split; assumption.
    + contradiction.
Qed.

Lemma concat_subgoals_sound :
  forall sg1 sg2 : subgoals,
  subgoals_valid (sg1 ++ sg2) ->
    subgoals_valid sg1 \/ subgoals_valid sg2.
Proof.
  intros sg1 sg2; induction sg1.
  - simpl; intro H; right; assumption.
  - simpl; intro H; destruct H.
    + left; left; assumption.
    + apply IHsg1 in H. destruct H.
      * left; right; assumption.
      * right; assumption.
Qed.

(* Pour ce lemme, l'équivalence est nécessaire. *)
Lemma concat_hyps_sound :
  forall sem_nat : nat -> Prop,
  forall l1 l2 : list form,
  sem_hyps (l1 ++ l2) sem_nat <->
    sem_hyps l1 sem_nat /\ sem_hyps l2 sem_nat.
Proof.
  intros sem_nat l1 l2; induction l1.
  - simpl; split.
    + intro; split; auto.
    + intro H; destruct H; assumption.
  - simpl; split.
    + intro H; destruct H as [Ha H]; apply IHl1 in H; destruct H;
      split; try split; assumption.
    + intro H. destruct H as [H H2]; destruct H as [Ha H1].
      split; try assumption.
      apply IHl1; split; assumption.
Qed.

Lemma elim_rules_final_sound_aux :
  forall goal : form,
  forall l acc : list form,
  subgoals_valid (elim_rules_multi (pick_hyp_aux l acc) goal) ->
    seq_valid (l++acc, goal).
Proof.
  intros goal l; induction l.
  - intros acc H; simpl in H; contradiction.
  - intros acc H; simpl in H.
    apply concat_subgoals_sound in H; destruct H.
    + assert (seq_valid (a::(acc++l), goal))
      by apply (elim_rules_sound (a, acc ++ l) goal H).
      unfold seq_valid; simpl; unfold seq_valid in H0; simpl in H0.
      intros sem_nat H_hyps; destruct H_hyps; apply (H0 sem_nat); split.
      * assumption.
      * apply concat_hyps_sound in H2; destruct H2.
        apply concat_hyps_sound; split; assumption.
    + assert (seq_valid (l ++ (a::acc), goal)) by apply (IHl (a::acc) H).
      unfold seq_valid; simpl; unfold seq_valid in H0; simpl in H0.
      intros sem_nat H_hyps; apply H0.
      destruct H_hyps as [Ha H_hyps]; apply concat_hyps_sound in H_hyps;
      destruct H_hyps as [Hl Hacc].
      apply concat_hyps_sound; simpl; auto.
Qed.

Lemma elim_rules_final_sound :
  forall s : seq,
  subgoals_valid (elim_rules_final s) -> seq_valid s.
Proof.
  intros s Hs. unfold elim_rules_final in Hs. unfold pick_hyp in Hs.
  unfold seq_valid.
  apply elim_rules_final_sound_aux in Hs; unfold seq_valid in Hs; simpl in Hs.
  intros sem_nat H; apply Hs.
  apply concat_hyps_sound; split; simpl; auto.
Qed.

(*    _                                          _
  ___| |_ ___ _ __     ___  ___  _   _ _ __   __| |
 / __| __/ _ \ '_ \   / __|/ _ \| | | | '_ \ / _` |
 \__ \ ||  __/ |_) |  \__ \ (_) | |_| | | | | (_| |
 |___/\__\___| .__/___|___/\___/ \__,_|_| |_|\__,_|
*)
Theorem step_sound :
  forall s : seq,
    subgoals_valid ( step s ) -> seq_valid s.
Proof.
  intros s H; unfold step in H; apply concat_subgoals_sound in H; destruct H.
  + apply intro_rules_sound; assumption.
  + apply elim_rules_final_sound; assumption.
Qed.

(* ___  ___  ___     _____   _  _
  |_ _||_ _||_ _|   |___ /  | || |
   | |  | |  | |      |_ \  | || |_
   | |  | |  | |  _  ___) |_|__   _|
  |___||___||___|(_)|____/(_)  |_|
*)
(* _              _                                     _
  | |_ __ _ _   _| |_ ___     ___  ___  _   _ _ __   __| |
  | __/ _` | | | | __/ _ \   / __|/ _ \| | | | '_ \ / _` |
  | || (_| | |_| | || (_) |  \__ \ (_) | |_| | | | | (_| |
   \__\__,_|\__,_|\__\___/___|___/\___/ \__,_|_| |_|\__,_|
*)
Theorem tauto_sound :
  forall n : nat,
  forall seq : seq,
  tauto n seq = true -> seq_valid seq.
Proof.
  intros n; induction n.
  - intros seq Hs; simpl in Hs. apply orb_true_iff in Hs. destruct Hs.
    + apply is_leaf_sound in H; assumption.
    + apply eq_true_false_abs in H; try reflexivity. contradiction.
  - intros seq Hs; simpl in Hs; apply orb_true_iff in Hs; destruct Hs as [Hs|Hs].
    + apply is_leaf_sound in Hs; auto.
    + case_eq (step seq).
      * intro H_seq; rewrite H_seq in Hs; simpl in Hs.
        apply eq_true_false_abs in Hs; try reflexivity; contradiction.
      * intros sg sgs H_seq; rewrite H_seq in Hs.
        apply orb_true_iff in Hs; destruct Hs as [Hs|Hs].
        -- case_eq sg.
          ++ intro H; rewrite H in Hs; simpl in Hs.
             apply eq_true_false_abs in Hs; try reflexivity; contradiction.
          ++ intros s l Hsg; rewrite Hsg in Hs.
             induction l.
             ** apply IHn in Hs. rewrite Hsg in H_seq.
                assert (subgoals_valid (step seq)).
                --- rewrite H_seq; simpl; left; auto.
                --- apply step_sound; assumption.
             **
Admitted.

(* Je ne suis pas parvenu à trouver une tactique de preuve efficace :
  les doubles points fixes m'ont compliqué la tache !
  Mais je ne sais pas comment m'en débarrassé dans l'implémentation ... *)


Require Import Coq.Lists.List.
Require Import ChargeCore.Logics.ILogic.
Require Import SLogic.Logic.
Require Import SLogic.LTLNotation.

Local Open Scope LTL_scope.

(* Is there a simple way to make this heterogenous? *)
(* Specifies that a list of [StateVal]s don't change
   during a transition. *)
Fixpoint Unchanged {st T : Type} (xs : list (StateVal st T))
  : ActionProp st :=
  match xs with
  | nil => ltrue
  | x :: xs =>
    x! `= !x //\\ Unchanged xs
  end.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal34.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (a:natural):@eq natural (qmult x y (plus (plus z y) a)) (qmult x y (plus (plus z a) y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal34_plus_qmult_66_plus_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) (a:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"++ "|" ++"a:" ++ "(" ++ show a ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z a.
QuickChick collect_data.
Success.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal34.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (a:natural):@eq natural (qmult x y (plus z (plus y a))) (qmult x y (plus (plus z a) y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_smallclam_lf_goal34_plus_qmult_66_plus_commut/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) (a:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"++ "|" ++"a:" ++ "(" ++ show a ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z a.
QuickChick collect_data.
Success.


Inductive M (A:Type) : Type := M'.
Axiom pi : forall (P : Prop) (p : P), Prop.
Definition test1 A (x : _) := pi A x.           (* success     *)
Fail Definition test2 A (x : A) := pi A x.           (* failure ??? *)
Fail Definition test3 A (x : A) (_ : M A) := pi A x. (* failure     *)
Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *)


Require Import SfLib.
Require Import Coq.Strings.String.
Module UTLCWOSE.

Definition literal := string.

Definition disjoint_sum (A B : Prop) : Prop :=
    (A \/ B) /\ (A -> ~ B).

Definition ctxId := id.
(* Dynamic Typed Lambda calculus with fixpoint,
 type inference is nt so trivial*)
(*
Inductive ty : Type :=
    | TList : ty -> ty
    | TNum : ty
    | TBool : ty
    | TPair : ty -> ty -> ty
    | TFun : ty -> ty -> ty.
*)

Inductive tm : Type :=
    (* Predicate *)
    | atomp : tm -> tm
    | pairp : tm -> tm
    (* Operator*)
    | car : tm -> tm
    | cdr : tm -> tm
    | cond : tm -> tm -> tm -> tm
    | sadd : tm -> tm -> tm
    | ssub : tm -> tm -> tm
    | smult : tm -> tm -> tm
    | sdivide : tm -> tm -> tm
    (* Constructor *)
    | STrue : tm
    | SFalse : tm
    | SNum : nat -> nat -> tm
    (* All Quotient *)
    | SDouble : literal -> tm
    | SString : literal -> tm
    | SPair : tm -> tm -> tm
    | SFun : id -> tm -> ctxId -> tm
    | SSymbol : tm -> tm
    | SCont : id -> tm -> tm
    (* Statement *)
    | SSeq : tm -> tm -> tm
    | SLet : id -> tm -> tm -> tm
    | SLetc : id -> tm -> tm.

Inductive Value : tm -> Prop :=
    | vTrue : Value STrue
    | vFalse : Value SFalse
    | vNum : forall n d, Value (SNum n d)
    | vDouble : forall s, Value (SDouble s)
    | vString : forall s, Value (SString s)
    | vPair : forall pre post,
        Value pre ->
        Value post ->
        Value (SPair pre post)
    | vFun : forall id tm ctx,
        Value (SFun id tm ctx)
    | vSymbol : forall q pre post,
            q <> (SPair pre post) ->
            Value (SSymbol q).


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Types.Unit HoTT.Types.Prod.

Generalizable Variables A B C.

Open Scope list_scope.

(** Standard notations for lists.
In a special module to avoid conflicts. *)
Module ListNotations.
Notation " [] " := nil : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; y ; .. ; z ] " :=  (cons x (cons y .. (cons z nil) ..))
  : list_scope.
End ListNotations.

Import ListNotations.

Fixpoint length {A} (l : list A) := match l with
  | [] => O
  | _ :: l => S (length l)
  end.

Fixpoint fold_left {A B} (f : A -> B -> A) (acc : A) (l : list B) :=
  match l with
  | [] => acc
  | x :: l => fold_left f (f acc x) l
  end.

Fixpoint map {A B} (f : A -> B) (l : list A) :=
  match l with
  | [] => []
  | x :: l => (f x) :: (map f l)
  end.

Fixpoint map2 `(f : A -> B -> C)
  (def_l : list A -> list C) (def_r : list B -> list C)
  l1 l2 :=
  match l1, l2 with
  | [], [] => []
  | [], _ => def_r l2
  | _, [] => def_l l1
  | x :: l1, y :: l2 => (f x y) :: (map2 f def_l def_r l1 l2)
  end.

Lemma map2_cons `(f : A -> B -> C) defl defr x l1 y l2 :
  map2 f defl defr (x::l1) (y::l2) = (f x y) :: map2 f defl defr l1 l2.
Proof.
reflexivity.
Qed.

Lemma map_id `(f : A -> A) (Hf : forall x, f x = x) (l : list A) : map f l = l.
Proof.
induction l as [|x l IHl].
- reflexivity.
- simpl. rewrite Hf,IHl. reflexivity.
Qed.

Instance sg_op_app A : SgOp (list A) := @app A.

Instance app_assoc A : Associative (@app A).
Proof.
intros l1. induction l1 as [|x l1 IH];intros l2 l3.
- reflexivity.
- simpl;apply ap;apply IH.
Qed.

Fixpoint for_all {A} (P : A -> Type) l : Type :=
  match l with
  | [] => Unit
  | x :: l => P x /\ for_all P l
  end.

Lemma for_all_trivial {A} (P : A -> Type) : (forall x, P x) ->
  forall l, for_all P l.
Proof.
intros HP l;induction l as [|x l IHl];split;auto.
Qed.

Lemma for_all_map {A B} P Q (f : A -> B) (Hf : forall x, P x -> Q (f x))
 : forall l, for_all P l -> for_all Q (map f l).
Proof.
intros l;induction l as [|x l IHl];simpl.
- auto.
- intros [Hx Hl]. split;auto.
Defined.

Lemma for_all_map2 {A B C} P Q R
  `(f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y))
  def_l (Hdefl : forall l1, for_all P l1 -> for_all R (def_l l1))
  def_r (Hdefr : forall l2, for_all Q l2 -> for_all R (def_r l2))
  : forall l1 l2, for_all P l1 -> for_all Q l2 ->
    for_all R (map2 f def_l def_r l1 l2).
Proof.
intros l1;induction l1 as [|x l1 IHl1].
- simpl. intros [|y l2] _; auto.
- simpl. intros [|y l2] [Hx Hl1];[intros _|intros [Hy Hl2]];simpl;auto.
  apply Hdefl. simpl;auto.
Qed.

Lemma fold_preserves {A B} P Q (f : A -> B -> A)
  (Hf : forall x y, P x -> Q y -> P (f x y))
  : forall acc (Ha : P acc) l (Hl : for_all Q l), P (fold_left f acc l).
Proof.
intros acc Ha l Hl;revert l Hl acc Ha.
intros l;induction l as [|x l IHl].
- intros _ acc Ha. exact Ha.
- simpl. intros [Hx Hl] acc Ha.
  apply IHl;auto.
Qed.

Instance for_all_trunc {A} {n} (P : A -> Type) : forall l,
  for_all (fun x => IsTrunc n (P x)) l -> IsTrunc n (for_all P l).
Proof.
intros l;induction l as [|x l IHl];simpl.
- intros _. destruct n;apply _.
- intros [Hx Hl].
  apply IHl in Hl. apply _.
Qed.

(* Copy pasted from the Coq library. *)
Definition tl {A} (l:list A) : list A :=
  match l with
    | [] => nil
    | a :: m => m
  end.

(* Modified copy from the Coq library. *)
(** The "In list" predicate *)
Fixpoint InList {A} (a:A) (l:list A) : Type0 :=
  match l with
    | [] => False
    | b :: m => b = a |_| InList a m
  end.

Fixpoint fold_right {A} {B} (f : B -> A -> A) (x : A) (l : list B) : A :=
  match l with
    | nil => x
    | cons b t => f b (fold_right f x t)
  end.


From Coq Require Import Arith.
From Coq Require Import Lists.List.
From Coq Require Import Lia.

From Elo Require Import Util.
From Elo Require Import Array.
From Elo Require Import Map.
From Elo Require Import Core.
From Elo Require Import ValidAddresses.
From Elo Require Import Access.
From Elo Require Import References.
From Elo Require Import Soundness.
From Elo Require Import UnsafeAccess.
From Elo Require Import SafeSpawns.
From Elo Require Import SMS.
From Elo Require Import Multistep.

(* ------------------------------------------------------------------------- *)
(* mstep -- reflexive transitive closure                                     *)
(* ------------------------------------------------------------------------- *)

Reserved Notation "m / t '==[' tc ']==>*' m' / t'"
  (at level 40, t at next level, tc at next level,
                m' at next level, t' at next level).

Definition mtrace := list effect.

Inductive mmultistep : mem -> tm -> mtrace -> mem -> tm -> Prop :=
  | mmultistep_refl: forall m t,
    m / t ==[nil]==>* m / t

  | mmultistep_trans : forall m m' m'' t t' t'' tc eff,
    m  / t  ==[tc]==>* m'  / t'  ->
    m' / t' ==[eff]==> m'' / t'' ->
    m  / t  ==[eff :: tc]==>* m'' / t''

  where "m / t '==[' tc ']==>*' m' / t'" := (mmultistep m t tc m' t').

(* ------------------------------------------------------------------------- *)
(*                                                                           *)
(* ------------------------------------------------------------------------- *)

Lemma monotonic_nondecreasing_memory_length' : forall m m' eff t t',
  m / t ==[eff]==>* m' / t' ->
  #m <= #m'.
Proof.
  assert (forall m m' eff t t',
    m / t ==[eff]==> m' / t' ->
    length m <= length m'). {
    intros * Hmstep. inversion Hmstep; subst; try lia.
    - rewrite add_increments_length. lia.
    - eauto using Nat.eq_le_incl, set_preserves_length.
  }
  intros * Hmmultistep. induction Hmmultistep; eauto using Nat.le_trans.
Qed.

Lemma alloc_increments_memory_length : forall m m' t t' ad v Tr,
  m / t ==[EF_Alloc ad v Tr]==> m' / t' ->
  #m' = S (#m).
Proof.
  intros. inversion_mstep. eauto using add_increments_length.
Qed.

Lemma destruct_multistep' : forall tc eff m0 mF t0 tF,
  m0 / t0  ==[tc ++ eff :: nil]==>* mF / tF ->
  (exists m t, m0 / t0 ==[eff]==> m / t /\ m / t ==[tc]==>* mF / tF).
Proof.
  intros ?. induction tc as [| eff tc IH];
  intros * Hmultistep; inversion Hmultistep; subst.
  - eexists. eexists. inversion H3; subst. split; eauto using mmultistep.
  - specialize (IH _ _ _ _ _ H3) as [? [? [? ?]]].
    eexists. eexists. split; eauto using mmultistep.
Qed.

Theorem duplicate_alloc : forall m m' t t' tc ad v v' Tr Tr',
  ~ (m / t ==[EF_Alloc ad v Tr :: tc ++ EF_Alloc ad v' Tr' :: nil]==>* m' / t').
Proof.
  assert (not_Sn_le_n : forall n, ~ (S n <= n)). {
    unfold not. intros * F. induction n;
    eauto using le_S_n. inversion F.
  }
  unfold not. intros * Hmultistep.
  inversion Hmultistep; subst; clear Hmultistep;
  destruct tc; try discriminate.
  - match goal with H : _ / _ ==[_]==>* _ / _ |- _ =>
      rewrite app_nil_l in H; inversion H; subst
    end.
    match goal with
    H1 : _ / _ ==[_]==> _ / _,
    H2 : _ / _ ==[_]==> _ / _ |- _ =>
      inversion H1; inversion H2; subst;
      eapply alloc_increments_memory_length in H1;
      eapply alloc_increments_memory_length in H2
    end.
    lia.
  - match goal with
    H : _ / _ ==[_]==>* _ / _ |- _ =>
      eapply destruct_multistep' in H as [? [? [? Hmultistep']]]
    end.
    eapply monotonic_nondecreasing_memory_length' in Hmultistep'.
    match goal with
    H1 : _ / _ ==[_]==> _ / _,
    H2 : _ / _ ==[_]==> _ / _ |- _ =>
      inversion H1; inversion H2; subst
    end.
    match goal with
    | H1 : length ?x = length _, H2 : length _ <= length ?x |- _ =>
      rewrite H1 in H2;
      rewrite add_increments_length in H2
    end.
    lia.
Qed.

(* ------------------------------------------------------------------------- *)
(*                                                                           *)
(* ------------------------------------------------------------------------- *)

Local Lemma destruct_multistep : forall tc m1 m3 ths1 ths3 tid eff,
  m1 / ths1  ~~[tc ++ (tid, eff) :: nil]~~>* m3 / ths3 ->
  (exists m2 ths2,
    m1 / ths1 ~~[tid, eff]~~> m2 / ths2 /\
    m2 / ths2 ~~[tc]~~>*      m3 / ths3).
Proof.
  intros ?. induction tc; intros * Hmultistep;
  inversion_clear_multistep.
  - inversion_multistep. do 2 eexists. split; eauto using multistep.
  - match goal with
    | Hmultistep : _ / _ ~~[ _ ]~~>* _ / _ |- _ =>
      decompose record (IHtc _ _ _ _ _ _ Hmultistep);
      do 2 eexists; split; eauto using multistep
    end.
Qed.

Local Lemma cstep_read_requires_acc : forall m m' ths ths' tid ad v,
  m / ths ~~[tid, EF_Read ad v]~~> m' / ths' ->
  access m ths[tid] ad.
Proof.
  intros. inversion_clear_cstep. inversion_clear_mstep. induction_step;
  eauto using access.
Qed.

Local Lemma cstep_write_requires_uacc : forall m m' ths ths' tid ad v Tr,
  forall_threads ths well_typed ->
  m / ths ~~[tid, EF_Write ad v Tr]~~> m' / ths' ->
  UnsafeAccess m ths[tid] ad.
Proof.
  intros * Htype. intros. destruct (Htype tid) as [T ?].
  inversion_clear_cstep. inversion_clear_mstep. generalize dependent T.
  induction_step; intros; inversion_type; eauto using UnsafeAccess.
  inversion_type. eauto using UnsafeAccess.
Qed.

(* ------------------------------------------------------------------------- *)
(* TODO                                                                      *)
(* ------------------------------------------------------------------------- *)

Local Lemma split_trace3 : forall m m' ths ths' tc,
  #ths < #ths' ->
  m / ths ~~[tc]~~>* m' / ths' ->
  exists mA thsA mB thsB tc1 tc2 tid block,
    tc = tc1 ++ (tid, EF_Spawn block) :: tc2 /\
    m  / ths  ~~[tc1]~~>*                mA / thsA /\
    mA / thsA ~~[tid, EF_Spawn block]~~> mB / thsB /\
    mB / thsB ~~[tc2]~~>*                m' / ths'.
Proof.
  intros.
  generalize dependent m'. generalize dependent ths'.
  induction tc; intros; inversion_multistep; try lia.
  rename m'0 into mA. rename ths'0 into thsA.
  specialize (IHtc thsA).
Abort.

Local Lemma spawn_sacc : forall m m' ths ths' tid ad eff,
  forall_threads ths SafeSpawns ->
  m / ths ~~[tid, eff]~~> m' / ths' ->
  access m' ths'[#ths] ad ->
  ~ UnsafeAccess m' ths'[#ths] ad.
Proof.
  intros. inversion_clear_cstep; simpl_array; intros ?;
  eauto using nomut_then_nuacc, nomut_block.
  unfold thread_default in *. inversion_acc.
Qed.

Local Lemma memtyp_sacc : forall m t ad,
  forall_memory m value ->
  forall_memory m (well_typed_references m) ->
  well_typed_references m t ->
  access m t ad ->
  ~ UnsafeAccess m t ad ->
  exists T, m[ad].typ = <{{ i&T }}>.
Proof.
  intros * ? HwtrM ? Hacc Hnuacc. induction Hacc;
  inversion_clear_wtr; try inversion_nuacc; eauto using nuacc_refI.
Qed.

Local Lemma todo : forall m m' ths ths' ad tc,
  forall_memory m value ->
  forall_program m ths (well_typed_references m) ->
  forall_program m ths (valid_addresses m) ->
  forall_program m ths SafeSpawns ->
  ~ access m ths[#ths] ad -> (* TODO: assert *)
  m / ths ~~[tc]~~>* m' / ths' ->
  access m' ths'[#ths] ad ->
  exists T, m'[ad].typ = <{{ i&T }}>.
Proof.
  intros * Hval [? ?] [? ?] [? ?] Hnacc Hmultistep Hacc. induction_multistep.
  - simpl_array. unfold thread_default in *. inversion_acc.
  - do 8 auto_specialize.
    destruct (acc_dec m' ths'[#ths] ad).
    + destruct IHHmultistep as [T Hmemtyp]; eauto.
      exists T. rewrite <- Hmemtyp. eapply cstep_memtyp; eauto.
      * admit.
      * assert (forall_program m' ths' (valid_addresses m')) as [? ?]
          by eauto using valid_addresses_multistep_preservation.
        eauto using vad_then_vac, vac_length.
    + clear IHHmultistep.
      inversion_cstep.
      * admit.
      *

      specialize Hacc as F. contradict F.
      eapply not_access_multistep_preservation; eauto.
      * admit.
      * admit.
      * admit.
      * admit.
      * admit.
Abort.

Theorem safety : forall m m' ths ths' tid1 tid2 ad v1 v2 tc Tr,
  forall_memory m value ->
  forall_program m ths well_typed ->
  forall_program m ths (valid_addresses m) ->
  forall_program m ths (well_typed_references m) ->
  forall_program m ths SafeSpawns ->
  safe_memory_sharing m ths ->
  (* --- *)
  tid1 <> tid2 ->
  m / ths ~~[(tid1, EF_Read  ad v1   ) :: tc ++
             (tid2, EF_Write ad v2 Tr) :: nil]~~>* m' / ths' ->
  False.
Proof.
  intros * ? [? ?] [? ?] [? ?] ? Hsms. intros. inversion_clear_multistep.
  rename m'0 into m3. rename ths'0 into ths3.
  assert (Hacc' : access m3 ths3[tid1] ad)
    by eauto using cstep_read_requires_acc.
  match goal with
  | H1 : _ / _ ~~[ _    ]~~>* _ / _
  , H2 : _ / _ ~~[ _, _ ]~~>  _ / _
  |- _ =>
    rename H1 into Hmultistep; rename H2 into H3_cstep
  end.
  eapply destruct_multistep in Hmultistep
    as [m2 [ths2 [H1_cstep H2_multistep]]].
  assert (Huacc : UnsafeAccess m ths[tid2] ad)
    by eauto using cstep_write_requires_uacc.
  destruct (acc_dec m ths[tid1] ad);
  try solve [eapply (Hsms tid2 tid1); eauto].
  assert (forall_threads ths (valid_accesses m))
    by eauto using forall_threads_vad_then_vac.
  assert (ad < #m) by eauto using vac_length, cstep_write_requires_uacc,
    uacc_then_acc.
  assert (ad < #m2) by eauto using Nat.lt_le_trans,
    monotonic_nondecreasing_memory_length, multistep.
  decompose sum (lt_eq_lt_dec tid1 (#ths)); subst.
  - assert (tid1 < #ths2) by eauto using Nat.lt_le_trans,
      monotonic_nondecreasing_threads_length, multistep.
    eapply (not_access_multistep_preservation m2 m3 ths2 ths3); eauto.
    + eapply memory_value_multistep_preservation; eauto using multistep.
    + eapply well_typed_multistep_preservation; eauto using multistep.
    + eapply valid_addresses_multistep_preservation; eauto using multistep.
    + eapply well_typed_multistep_preservation; eauto using multistep.
    + eapply safe_spawns_multistep_preservation; eauto using multistep.
    + eapply safe_memory_sharing_multistep_preservation; eauto using multistep.
    + eapply (not_access_multistep_preservation m m2 ths ths2);
      eauto using multistep.
  - assert (exists T, m[ad].typ = <{{ &T }}>) as [T Htype1]
      by eauto using (memtyp_uacc _ ths[tid2]).
    eapply cstep_memtyp_preservation in H1_cstep as Hext; eauto.
    eapply well_typed_multistep_preservation in H2_multistep as [_ [_ ?]].
    + shelve.
    + eapply valid_addresses_multistep_preservation; eauto using multistep.
    + eapply well_typed_multistep_preservation; eauto using multistep.
    + eapply well_typed_multistep_preservation; eauto using multistep.
    Unshelve.
    assert (m3 extends m) by eauto using Extension.trans.
    assert (Htype1': m3[ad].typ = m[ad].typ) by eauto using Extension.get.
    rewrite Htype1 in Htype1'.

  -
Qed.

(* ------------------------------------------------------------------------- *)
(* TODO                                                                      *)
(* ------------------------------------------------------------------------- *)

Local Lemma access_add : forall m t ad v Tr,
  ~ access m t ad ->
  ~ access m v ad ->
  ~ access (m +++ (v, Tr)) t ad.
Proof.
  intros * HnaccT HnaccV Hacc.
  induction Hacc; eauto using access.
  eapply IHHacc; clear IHHacc; trivial.
  decompose sum (lt_eq_lt_dec ad' (length m)); subst; simpl_array;
  eauto using access. intros ?. unfold memory_default in *. simpl in *.
  inversion_acc.
Qed.

Local Lemma not_access_stored_value : forall m t t' ad ad' v Tr,
  ~ access m t ad ->
  t --[EF_Write ad' v Tr]--> t' ->
  ~ access m v ad.
Proof.
  intros. induction_step; eauto using access.
Qed.

Local Lemma not_access_allocated_value : forall m t t' ad ad' v Tr,
  ~ access m t ad ->
  t --[EF_Alloc ad' v Tr]--> t' ->
  ~ access m v ad.
Proof.
  intros * Hnacc Hstep. induction_step; eauto using access.
Qed.

Lemma access_granted_by_alloc_is_memory_length : forall m t t' ad v Tr,
  ~ access m t ad ->
  t --[EF_Alloc (#m) v Tr]--> t' ->
  access (m +++ (v, Tr)) t' ad ->
  ad = length m.
Proof.
  intros * Hnacc ? Hacc.
  induction_step; inversion_nacc Hnacc; inversion_acc; eauto using access.
  - match goal with F : access _ _ _ |- _ => contradict F end.
    simpl_array. eapply access_add; eauto.
  - do 2 auto_specialize. eapply IHstep.
    eapply acc_asg in Hacc as [? | ?]; eauto.
    exfalso. eapply (not_access_allocated_value _ l) in HnaccL; eauto.
    eapply (access_add _ r); eauto.
  - eapply asg_access_inverse in Hnacc as [? HnaccR].
    match goal with IH : _ -> _ -> _ -> ?x |- ?x => eapply IH; eauto end.
    eapply asg_access in Hacc as [? | ?]; eauto.
    exfalso. eapply (not_access_allocated_value _ r) in HnaccR; eauto.
    eapply (access_add _ l); eauto.
  - eapply seq_access_inverse in Hnacc as [HnaccT1 ?].
    match goal with IH : _ -> _ -> _ -> ?x |- ?x => eapply IH; eauto end.
    eapply seq_access in Hacc as [? | ?]; eauto.
    exfalso. eapply (not_access_allocated_value _ t1) in HnaccT1; eauto.
    eapply (access_add _ t2); eauto.
Qed.

Theorem access_needs_alloc : forall m m' t t' eff ad,
  ~ access m t ad ->
  m / t ==[eff]==> m' / t' ->
  access m' t' ad ->
  exists v, eff = (EF_Alloc ad v).
Proof.
  intros * Hnacc Hmstep Hacc. inversion Hmstep; subst.
  - contradict Hacc. eauto using none_does_not_grant_access.
  - eexists. erewrite <- access_granted_by_alloc_is_memory_length; eauto.
  - contradict Hacc. eauto using load_does_not_grant_access.
  - contradict Hacc. eauto using store_does_not_grant_access.
Qed.

Theorem access_needs_alloc_multistep : forall m m' t t' ad tc,
  ~ access m t ad ->
  m / t ==[tc]==>* m' / t' ->
  access m' t' ad ->
  exists v, In (EF_Alloc ad v) tc.
Proof.
  intros * Hnacc Hmultistep Hacc.
  induction Hmultistep; try solve [exfalso; eauto].
  destruct (access_dec m' t' ad) as [Hacc' | ?].
  - destruct (IHHmultistep Hnacc Hacc').
    eexists. right. eauto.
  - assert (Heq : exists v, eff = EF_Alloc ad v);
    eauto using access_needs_alloc.
    destruct Heq. eexists. left. eauto.
Qed.

(*

(* PART 6 *)

Theorem concurrent_duplicate_alloc :
  forall m m' ths ths' tid tid' tc1 tc2 ad v v',
  ~ (m / ths ~~[tc1 ++ (tid , EF_Alloc ad v ) ::
                tc2 ++ (tid', EF_Alloc ad v') :: nil]~~>* m' / ths').
Proof.
  intros * F. inversion F; subst; clear F.
Abort.

*)


Require Import
  Coq.Lists.List MathClasses.interfaces.abstract_algebra MathClasses.theory.categories MathClasses.theory.forget_algebra MathClasses.theory.forget_variety
  MathClasses.theory.rings MathClasses.interfaces.universal_algebra MathClasses.interfaces.functors
  MathClasses.categories.setoids MathClasses.categories.varieties.
Require
  MathClasses.categories.product MathClasses.varieties.monoids MathClasses.categories.algebras
  MathClasses.categories.categories MathClasses.theory.setoids.

Module ua := universal_algebra.

Instance: Arrows Type := λ X Y, X → Y.
  (* todo: move elsewhere *)

(* First, the nice clean high level encapsulated version: *)

Class PoshSequence
   (free: setoids.Object → monoids.Object) `{!Fmap free}
   (inject: id ⇛ monoids.forget ∘ free)
   (extend: `((x ⟶ monoids.forget y) → (free x ⟶ y))): Prop :=
   { sequence_adjunction: ηAdjunction _ _ inject extend
   ; extend_morphism: `(Setoid_Morphism (extend x y)) }.
     (* todo: how come extend_morphism isn't part of ηAdjunction? *)

(* This looks very nice, but the encapsulation of the parameters makes it
a bit awkward to work with. Hence, let us define a more down to earth
version. *)

Section practical.
  (* Here, again, are the ingredients, this time in somewhat more raw form: *)

  Class ExtendToSeq (free: Type → Type) :=
    extend: ∀ {x y} `{!SgOp y} `{!MonUnit y}, (x → y) → (free x → y).
      (* todo: rename to extend_to_seq or something *)

  Class InjectToSeq (free: Type → Type) := inject: ∀ x, x → free x.
      (* todo: rename to singleton or something *)

  Context
   (free: Type → Type) {raw_fmap: Fmap free}
   `{∀ a, MonUnit (free a)}
   `{∀ a, SgOp (free a)}
   `{∀ a, Equiv a → Equiv (free a)}
   `{!InjectToSeq free} `{!ExtendToSeq free}.

  Class Sequence :=
    { sequence_makes_monoids:> ∀ `{Setoid a}, Monoid (free a)
    ; sequence_inject_morphism:> ∀ `{Setoid a}, Setoid_Morphism (inject a)
    ; sequence_map_morphism:> ∀ `{Equiv x} `{Equiv y} (f: x → y),
        Setoid_Morphism f → Monoid_Morphism (raw_fmap _ _ f)
    ; sequence_fmap_proper: ∀ `{Equiv x} `{Equiv y} (f g: x → y), f = g → fmap free f = raw_fmap _ _ g
    ; sequence_fmap_id: ∀ `{Equiv x}, raw_fmap _ _ (@id x) = id
    ; sequence_fmap_comp: ∀ `{Equiv x} `{Equiv y} `{Equiv z} (f: y → z) (g: x → y),
        raw_fmap _ _ (f ∘ g) = raw_fmap _ _ f ∘ raw_fmap _ _ g
    ; sequence_extend_makes_morphisms:> ∀ `{Equiv x} `{Monoid y} (f: x → y),
        Setoid_Morphism f → Monoid_Morphism (extend f)
    ; sequence_inject_natural: ∀ `{Setoid A} `{Setoid B} (f: A → B), Setoid_Morphism f →
        inject B ∘ f = raw_fmap _ _ f ∘ inject A
    ; sequence_extend_commutes: ∀ `{Setoid x} `{Monoid y} (f: x → y), Setoid_Morphism f →
        extend f ∘ inject x = f
    ; sequence_only_extend_commutes: ∀ `{Setoid x} `{Monoid y} (f: x → y), Setoid_Morphism f →
        (∀ (g: free x → y), Monoid_Morphism g →  g ∘ inject x = f → g = extend f)
    ; sequence_extend_morphism: ∀ `{Setoid x} `{Monoid y} (f g: x → y),
        Setoid_Morphism f → Setoid_Morphism g →
        f = g → extend f (free:=free) = extend g (free:=free)
    }.

  (* From this motley collection we can construct the encapsulated free/inject/extend: *)

  Context `{PS: Sequence}.

  Program Definition posh_free (X: setoids.Object): monoids.Object := monoids.object (free X).

  Program Instance posh_fmap: functors.Fmap posh_free :=
    λ _ _ X _, raw_fmap _ _ X.

  Next Obligation. apply monoids.encode_morphism_only. destruct X. apply _. Qed.

  Instance: Functor posh_free posh_fmap.
  Proof with try apply _.
   constructor...
     repeat intro.
     constructor...
     repeat intro.
     simpl.
     apply sequence_fmap_proper.
     intro.
     apply H2.
     reflexivity.
    repeat intro.
    simpl.
    apply sequence_fmap_id.
    reflexivity.
   repeat intro.
   simpl.
   apply sequence_fmap_comp.
   reflexivity.
  Qed.

  Program Definition posh_inject: id ⇛ monoids.forget ∘ posh_free := λ a, inject a.

  (* Needed for some type conversions. *)
  Typeclasses Transparent compose.

  Program Definition posh_extend (x: setoids.Object) (y: monoids.Object)
    (X: x ⟶ monoids.forget y): posh_free x ⟶ y
    := λ u, match u return posh_free x u → y u with tt => extend X end.
  Next Obligation.
   apply monoids.encode_morphism_only.
   destruct X. simpl in *.
   apply (sequence_extend_makes_morphisms _). apply _.
  Qed.

  (* ... and show that they form a posh sequence: *)

  Instance: NaturalTransformation posh_inject.
  Proof.
   unfold NaturalTransformation.
   intros [???] [???] [??] ?? E.
   simpl in *.
   rewrite E.
   apply sequence_inject_natural.
   apply _.
   reflexivity.
  Qed.

  Goal @PoshSequence posh_free posh_fmap posh_inject posh_extend.
  Proof.
   constructor.
    constructor; try apply _.
    intros [x xE xH] y [f fM].
    pose proof (@monoids.decode_variety_and_ops y _ _ _).
    split.
     repeat intro.
     simpl in *.
     rewrite H3.
     symmetry.
     apply (@sequence_extend_commutes PS x _ _ _ _ _ _ H2 f fM).
     reflexivity.
    unfold compose.
    intros [x0 h] H4 [] a.
    unfold equiv, setoids.Equiv_instance_0 in H4.
    simpl in *.
    apply (@sequence_only_extend_commutes PS x _ _ _ _ _ _ H2 f _ (x0 tt)).
     apply (@monoids.decode_morphism_and_ops _ _ _ _ _ _ _ _ _ h).
    intros. symmetry. apply H4. reflexivity.
   unfold posh_extend.
   intros [x ??] [y ?? yV].
   constructor; try apply _.
   intros [] [] E [] a.
   simpl in *.
   apply (@sequence_extend_morphism PS x _ _ _ _ _ _
     (@monoids.decode_variety_and_ops _ _ _ yV) _ _ _ _).
   intro. apply E. reflexivity.
  Qed. (* todo: clean up *)

  Definition fold `{MonUnit M} `{SgOp M}: free M → M := extend id.

  Global Instance fold_mor `{Monoid M}: Monoid_Morphism (fold (M:=M)).
  Proof. apply _. Qed.

End practical.


Require Import TestSuite.admit.
Require Import Setoid.
Require Import Morphisms.
Require Vector.
Notation vector := Vector.t.
Notation Vcons n t := (@Vector.cons _ n _ t).

Class Equiv A := equiv : A -> A -> Prop.
Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv).

Instance vecequiv A `{Equiv A} n : Equiv (vector A n).
admit.
Qed.

Global Instance vcons_proper A `{Equiv A} `{!Setoid A} :
 Proper (equiv ==> forall_relation (fun k => equiv ==> equiv))
        (@Vector.cons A).
Proof. Admitted.

Instance vecseotid A `{Setoid A} n : Setoid (vector A n).
Proof. Admitted.

(* Instance equiv_setoid A {e : Equiv A} {s : @Setoid A e} : Equivalence e. *)
(* apply setoid_equiv. *)
(* Qed. *)
(* Typeclasses Transparent Equiv. *)

Goal forall A `{Equiv A} `{!Setoid A} (f : A -> A) (a b : A) (H : equiv a b) n (v : vector A n),
       equiv (Vcons a v) (Vcons b v).
Proof.
  intros.
  rewrite H0.
  reflexivity.
Qed.


Require Export ModelProperties.

Require Export openIsSecure.
Require Export readIsSecure.
Require Export writeIsSecure.
Require Import InitialState.
Require Export Le.

(*This definition generalizes the notion of secure state. It includes*)
(*all the security relevant conditions and also the mathematicals    *)
(*ones (for instance the one that asserts that subjectSC is a partial*)
(*function).                                                         *)

Definition GeneralSecureState (s : SFSstate) : Prop :=
  SecureState s /\
  StarProperty s /\
  FuncPre1 s /\
  FuncPre2 s /\
  FuncPre3 s /\ FuncPre4 s /\ FuncPre5 s /\ FuncPre6 s /\ FuncPre7 s.

(*********************************************************************)
(*                       The Model's Lemmas                          *)
(*********************************************************************)

(*The following Lemma shows that the initial state is a secure state.*)

Lemma InitialStateIsSecure : GeneralSecureState InitState.
unfold GeneralSecureState, SecureState, InitState, DACSecureState,
 MACSecureState, StarProperty, FuncPre1, FuncPre2, FuncPre3, FuncPre4,
 FuncPre5, FuncPre6, FuncPre7 in |- *; simpl in |- *.
repeat (split; auto).
intros.
elim (fSSC SysSubjectSC root); auto.

contradiction.

contradiction.

contradiction.

Qed.

(*The main lemma deals with secuences of SFSstates.                  *)
(*In that lemma we'll use the function nth (defined in PolyList)     *)
(*which takes a natural (n), a list, and a default element with the  *)
(*type of the list, and returns the n(th) element of list if there   *)
(*are enough elements in it, or the default element if not.          *)
(*For this reason, we need to define a default SFSstate. In fact we  *)
(*won't use it in the proof, it's just a type requirement.           *)

Parameter defaultState : SFSstate.

(*The main Lemma for the model is the following one, wich says that  *)
(*for any given sequence of states such that the initial state is    *)
(*secure and for any two consecutives states, s and t, exists an     *)
(*operation (op) and a user (u) executing it, such that              *)
(*(TransFunc u s op t) holds, then every state in the secuence is    *)
(*secure.                                                            *)

Lemma BasicSecurityTheorem :
 forall tr : list SFSstate,
 GeneralSecureState (nth 0 tr defaultState) ->
 (forall n : nat,
  n < length tr ->
  exists op : Operation,
    (exists u : SUBJECT,
       TransFunc u (nth n tr defaultState) op (nth (S n) tr defaultState))) ->
 forall n : nat, n <= length tr -> GeneralSecureState (nth n tr defaultState).
intros.
induction  n as [| n Hrecn].
auto.

generalize Hrecn.
cut
 (exists op : Operation,
    (exists u : SUBJECT,
       TransFunc u (nth n tr defaultState) op (nth (S n) tr defaultState))).
elim (nth n tr defaultState).
intros.
elim H2; intros.
elim H3; intros.
cut
 (forall u : SUBJECT,
  GeneralSecureState
    (mkSFS groups primaryGrp subjectSC AllGrp RootGrp SecAdmGrp objectSC acl
       secmat files directories) ->
  TransFunc u
    (mkSFS groups primaryGrp subjectSC AllGrp RootGrp SecAdmGrp objectSC acl
       secmat files directories) x (nth (S n) tr defaultState) ->
  GeneralSecureState (nth (S n) tr defaultState)).
intro GTR; apply (GTR x0).
apply Hrecn0; auto with *.

auto.

unfold GeneralSecureState in |- *; intros u GSSi TF; decompose [and] GSSi;
 clear GSSi.
split.
induction  x ;
 prolog
  [  OpenPSS  ReadPSS
   WritePSS ] 2.

split.
induction  x ;
 prolog
  [ OpenPSP
   ReadPSP
   WritePSP ] 2.

split.
unfold FuncPre1 in |- *; unfold FuncPre1 in H6; decompose [and] H6;
 repeat (split; eauto).

unfold FuncPre2, FuncPre3, FuncPre4, FuncPre5, FuncPre6, FuncPre7 in |- *;
 unfold FuncPre2, FuncPre3, FuncPre4, FuncPre5, FuncPre6, FuncPre7
  in H8, H9, H10, H11, H12, H14; repeat (split; eauto).

auto.

Qed.


(*
chronos@localhost / $ sudo enter-chroot
Entering /mnt/stateful_partition/crouton/chroots/precise...
(precise)administrator@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Exercise_Nine.

Coq < Goal forall b f a g e k h:Prop, (((b \/ f) -> (a -> g)) /\ ((b \/ e) -> (g -> k)) /\ (b /\ ~h)) -> (a -> k).
1 subgoal

  ============================
   forall b f a g e k h : Prop,
   (b \/ f -> a -> g) /\ (b \/ e -> g -> k) /\ b /\ ~ h -> a -> k

Unnamed_thm < intros.
1 subgoal

  b : Prop
  f : Prop
  a : Prop
  g : Prop
  e : Prop
  k : Prop
  h : Prop
  H : (b \/ f -> a -> g) /\ (b \/ e -> g -> k) /\ b /\ ~ h
  H0 : a
  ============================
   k

Unnamed_thm < elim H.
1 subgoal

  b : Prop
  f : Prop
  a : Prop
  g : Prop
  e : Prop
  k : Prop
  h : Prop
  H : (b \/ f -> a -> g) /\ (b \/ e -> g -> k) /\ b /\ ~ h
  H0 : a
  ============================
   (b \/ f -> a -> g) -> (b \/ e -> g -> k) /\ b /\ ~ h -> k

Unnamed_thm < intro.
1 subgoal

  b : Prop
  f : Prop
  a : Prop
  g : Prop
  e : Prop
  k : Prop
  h : Prop
  H : (b \/ f -> a -> g) /\ (b \/ e -> g -> k) /\ b /\ ~ h
  H0 : a
  H1 : b \/ f -> a -> g
  ============================
   (b \/ e -> g -> k) /\ b /\ ~ h -> k

Unnamed_thm < intro.
1 subgoal

  b : Prop
  f : Prop
  a : Prop
  g : Prop
  e : Prop
  k : Prop
  h : Prop
  H : (b \/ f -> a -> g) /\ (b \/ e -> g -> k) /\ b /\ ~ h
  H0 : a
  H1 : b \/ f -> a -> g
  H2 : (b \/ e -> g -> k) /\ b /\ ~ h
  ============================
   k

Unnamed_thm < firstorder.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder  .

Unnamed_thm is defined

Coq <
*)

Section Exercise_Nine.
Goal forall b f a g e k h:Prop, (((b \/ f) -> (a -> g)) /\ ((b \/ e) -> (g -> k)) /\ (b /\ ~h)) -> (a -> k).
intros.
elim H.
intro.
intro.
 firstorder.
 Qed.


Require Import CommonTacs.

Require Import ParserArg.
Require Export Xform.
Require Export GrammarType.

Set Implicit Arguments.

(** Our user-facing [grammar]s, indexed by a [type], reflecting the type of the
    semantic value returned by the grammar when used in parsing. *)
Inductive grammar : type -> Type :=
| Eps : grammar Unit_t
| Zero : forall t, grammar t
| Char : char_p -> grammar Char_t
| Any : grammar Char_t
| Cat : forall t1 t2, grammar t1 -> grammar t2 -> grammar (Pair_t t1 t2)
| Alt : forall t1 t2, grammar t1 -> grammar t2 -> grammar (Sum_t t1 t2)
| Star : forall t, grammar t -> grammar (List_t t)
| Map : forall t1 t2, (interp t1 -> interp t2) -> grammar t1 -> grammar t2.
(* | Xform : forall t1 t2, t1 ->> t2 -> grammar t1 -> grammar t2. *)
Extraction Implicit Zero [t].
Extraction Implicit Cat [t1 t2].
Extraction Implicit Alt [t1 t2].
Extraction Implicit Star [t].
Extraction Implicit Map [t1 t2].
(* Extraction Implicit Xform [t1 t2]. *)

(** * Denotation of Grammars *)
(** I'm a little annoyed that I had to break out so many equalities, but
    found this worked a little better for both inversion and proving. *)
Inductive in_grammar : forall t, grammar t -> list char_p -> (interp t) -> Prop :=
| InEps : forall s v, s = nil -> v = tt -> in_grammar Eps s v
| InChar : forall c s v, s = c::nil -> v = c -> in_grammar (Char c) s v
| InAny : forall c s v, s = c::nil -> v = c -> in_grammar Any s v
| InCat : forall t1 t2 (g1:grammar t1) (g2:grammar t2) s1 s2 v1 v2 s v,
    in_grammar g1 s1 v1 -> in_grammar g2 s2 v2 ->
    s = s1 ++ s2 -> v = (v1,v2) -> in_grammar (Cat g1 g2) s v
| InAlt_l : forall t1 t2 (g1:grammar t1) (g2:grammar t2) s v1 v,
    in_grammar g1 s v1 -> v = inl _ v1 -> in_grammar (Alt g1 g2) s v
| InAlt_r : forall t1 t2 (g1:grammar t1) (g2:grammar t2) s v2 v,
    in_grammar g2 s v2 -> v = inr _ v2 -> in_grammar (Alt g1 g2) s v
| InStar_eps : forall t (g:grammar t) s v, s = nil -> v = nil ->
                                           in_grammar (Star g) s v
| InStar_cons : forall t (g:grammar t) s1 v1 s2 v2 s v,
    in_grammar g s1 v1 -> in_grammar (Star g) s2 v2 ->
    s1 <> nil -> s = s1 ++ s2 -> v = v1::v2 -> in_grammar (Star g) s v
| InMap : forall t1 t2 (f:interp t1 -> interp t2) (g:grammar t1) s v1 v2,
    in_grammar g s v1 -> v2 = f v1 -> in_grammar (@Map t1 t2 f g) s v2.
(* | InXform : forall t1 t2 (f: t1 ->> t2) (g:grammar t1) s v1 v2, *)
(*     in_grammar g s v1 -> v2 = xinterp f v1 -> in_grammar (Xform f g) s v2. *)
Hint Constructors in_grammar.

(** * Optimizing constructors for grammars.  These try to reduce the
      grammar, but must make adjustments to the semantic actions.  We
      use optimized transforms to get this effect. *)

(** g ++ 0 ==> g @ inl *)
Definition OptAlt_r t2 (g2:grammar t2) :
  forall t1, grammar t1 -> grammar (Sum_t t1 t2) :=
  match g2 in grammar t2' return forall t1, grammar t1 -> grammar (Sum_t t1 t2') with
    | Zero t2 => fun t1 g1 => Map (Sum_t t1 t2) inl g1
    | g2' => fun t1 g1 => Alt g1 g2'
  end.
Extraction Implicit OptAlt_r [t2 t1].

(** 0 ++ g ==> g @ inr *)
Definition OptAlt_l t1 (g1:grammar t1) :
  forall t2, grammar t2 -> grammar (Sum_t t1 t2) :=
  match g1 in grammar t1' return forall t2, grammar t2 -> grammar (Sum_t t1' t2) with
    | Zero t1 => fun t2 g2 => Map (Sum_t t1 t2) inr g2
    | g1' => fun t2 g2 => OptAlt_r g2 g1'
  end.
Extraction Implicit OptAlt_l [t1 t2].

(** We would like to reduce (g ++ g) ==> g but this loses information and
    turns a potentially ambiguous grammar into one that is not.  More
    importantly, we can't actually compare grammars for equality because
    we are trying to keep the [type] index computationally irrelevant.
*)
Definition OptAlt t1 t2 (g1:grammar t1) (g2:grammar t2) := OptAlt_l g1 g2.
Extraction Implicit OptAlt [t1 t2].

(** g $ 0 ==> 0 @ zero_to_t
    g $ eps ==> g @ add_unit_r *)
Definition OptCat_r t2 (g2:grammar t2) : forall t1, grammar t1 -> grammar (Pair_t t1 t2) :=
  match g2 in grammar t2' return forall t1, grammar t1 -> grammar (Pair_t t1 t2') with
    | Zero t2' => fun t1 (g2 : grammar t1) => Zero _
    | Eps => fun t1 (g1 : grammar t1) => Map (Pair_t t1 Unit_t) (fun x => (x,tt)) g1
    | g2' => fun t1 (g1 : grammar t1) => Cat g1 g2'
  end.
Extraction Implicit OptCat_r [t2 t1].

(** 0 $ g ==> 0 @ zero_to_t
    eps $ g ==> g @ add_unit_l *)
Definition OptCat t1 (g1:grammar t1) :
  forall t2, grammar t2 -> grammar (Pair_t t1 t2) :=
  match g1 in grammar t1' return forall t2, grammar t2 -> grammar (Pair_t t1' t2) with
    | Zero t1' => fun t2 (g2 : grammar t2) => Zero _
    | Eps => fun t2 (g2 : grammar t2) => Map (Pair_t Unit_t t2) (fun x => (tt,x)) g2
    | g1' => fun t2 (g2 : grammar t2) => OptCat_r g2 g1'
  end.
Extraction Implicit OptCat [t1 t2].

(** star (star g) ==> (star g) @ mklist
    star eps ==> eps @ to_empty_list
    star 0 ==> eps @ to_empty_list
*)
Definition OptStar t (g:grammar t) : grammar (List_t t) :=
  match g in grammar t' return grammar (List_t t') with
    | Star g' => Map (List_t _) (fun x => x::nil) (Star g')
    | Eps => Map (List_t _) (fun x => nil) Eps
    | Zero t => Map (List_t _) (fun x => nil) Eps
    | g' => Star g'
  end.
Extraction Implicit OptStar [t].

(** 0 @ f ==> 0
    g @ f1 @ f2 ==> g @ (f1 o f2)
*)
Definition OptMap' t1 (g:grammar t1) :
  forall t2, (interp t1 -> interp t2) -> grammar t2 :=
  match g in grammar t1' return forall t2, (interp t1' -> interp t2) -> grammar t2 with
    | Zero t => fun t2 f => Zero t2
    | Map u2 f' g' => fun t2 f => Map t2 (fun x => f (f' x)) g'
    | g' => fun t2 f => @Map _ t2 f g'
  end.
Extraction Implicit OptMap' [t1 t2].

Definition OptMap t1 t2 (f:interp t1 -> interp t2) (g:grammar t1) : grammar t2 :=
  @OptMap' t1 g t2 f.
Extraction Implicit OptMap [t1 t2].

(* Definition OptXform' t1 (g:grammar t1) : forall t2, t1->>t2 -> grammar t2 := *)
(*   match g in grammar t1' return forall t2, t1'->>t2 -> grammar t2 with *)
(*     | Zero t => fun t2 x => Zero t2 *)
(*     | Xform u1 u2 x' g' => fun t2 x => Xform (xcomp x' x) g' *)
(*     | g' => fun t2 x => Xform x g' *)
(*   end. *)
(* Extraction Implicit OptXform' [t1 t2]. *)

(* Definition OptXform t1 t2 (x:t1->>t2) (g:grammar t1) := @OptXform' t1 g t2 x. *)
(* Extraction Implicit OptXform [t1 t2]. *)

(** Explicit inversion principles for the grammars -- needed because
    of typing dependencies, though a little awkward that we can't just
    use [dependent inversion] to solve them. *)
Lemma inv_Eps : forall cs v, in_grammar Eps cs v -> cs = nil /\ v = tt.
Proof. intros. inversion H ; crush. Qed.

Lemma inv_Any : forall cs v, in_grammar Any cs v -> cs = v::nil.
Proof. intros. inversion H ; crush. Qed.

Lemma inv_Char :
  forall c cs v, in_grammar (Char c) cs v -> cs = c::nil /\ v = c.
Proof. intros. inversion H ; crush. Qed.

Lemma inv_Cat : forall t1 t2 (g1:grammar t1) (g2:grammar t2) cs v,
  in_grammar (Cat g1 g2) cs v ->
  exists cs1, exists cs2, exists v1, exists v2,
    in_grammar g1 cs1 v1 /\ in_grammar g2 cs2 v2 /\ cs = cs1++cs2 /\ v = (v1,v2).
Proof. intros. inversion H ; crush. repeat econstructor ; eauto. Qed.

Lemma inv_Alt : forall t1 t2 (g1:grammar t1) (g2:grammar t2) cs v,
  in_grammar (Alt g1 g2) cs v ->
  (exists v1, in_grammar g1 cs v1 /\ v = inl _ v1) \/
  (exists v2, in_grammar g2 cs v2 /\ v = inr _ v2).
Proof. intros ; inversion H ; crush. Qed.

Lemma inv_Star : forall t (g:grammar t) cs v,
  in_grammar (Star g) cs v -> (cs = nil /\ v = nil) \/
  (exists cs1, exists v1, exists cs2, exists v2,
    cs1 <> nil /\ in_grammar g cs1 v1 /\ in_grammar (Star g) cs2 v2 /\
    cs = cs1 ++ cs2 /\ v = v1::v2).
Proof.
  intros ; inversion H ; clear H ; crush ; right ; exists s1 ; exists v1 ;
  exists s2 ; exists v2 ; auto.
Qed.

Lemma inv_Map : forall t1 t2 (f:interp t1 -> interp t2) (g:grammar t1) cs v,
  in_grammar (@Map t1 t2 f g) cs v -> exists v', in_grammar g cs v' /\ v = f v'.
Proof. intros ; inversion H ; crush. Qed.

Lemma inv_Zero : forall t cs v, in_grammar (Zero t) cs v -> False.
Proof. intros ; inversion H. Qed.

(* Lemma inv_Xform : forall t1 t2 (x:t1->>t2) (g:grammar t1) cs v, *)
(*   in_grammar (Xform x g) cs v -> exists v', in_grammar g cs v' /\ v = xinterp x v'. *)
(* Proof. intros ; inversion H ; crush. Qed. *)

Lemma in_cat_eps : forall t (g:grammar t) s v1 v,
  in_grammar g s v1 -> v = (v1,tt) -> in_grammar (Cat g Eps) s v.
Proof. intros ; econstructor ; eauto. apply app_nil_end. Qed.
Hint Resolve in_cat_eps.

Ltac local_simpl :=
  simpl in * ; intros ;
    repeat
      match goal with
        | [ |- _ /\ _ ] => split
        | [ H : _ /\ _ |- _ ] => destruct H
        | [ |- context[ _ ++ nil ] ] => rewrite <- app_nil_end
        | [ H : exists x, _ |- _ ] => destruct H
        | [ H : _ \/ _ |- _] => destruct H
        | [ H : _ <-> _ |- _] => destruct H
        | [ |- _ <-> _ ] => split
        | [ H : _::_ = _::_ |- _] => injection H ; clear H
        | _ => idtac
      end ; auto.

(** Tactic for invoking inversion principles on a proof that some string
    and value are in the denotation of a grammar.  We don't unroll the
    [Star] case because that would loop. *)
Ltac in_grammar_inv :=
    match goal with
      | [ H : in_grammar Eps _ _ |- _ ] => generalize (inv_Eps H) ; clear H
      | [ H : in_grammar Any _ _ |- _ ] => generalize (inv_Any H) ; clear H
      | [ H : in_grammar (Char _) _ _ |- _ ] => generalize (inv_Char H) ; clear H
      | [ H : in_grammar (Alt _ _) _ _ |- _ ] => generalize (inv_Alt H) ; clear H
      | [ H : in_grammar (Cat _ _) _ _ |- _ ] => generalize (inv_Cat H) ; clear H
      | [ H : in_grammar (Zero _) _ _ |- _ ] => contradiction (inv_Zero H)
      | [ H : in_grammar (Map _ _ _) _ _ |- _ ] => generalize (inv_Map H) ; clear H
      (* | [ H : in_grammar (Xform _ _) _ _ |- _ ] =>  *)
      (*   generalize (inv_Xform H) ; clear H *)
      | _ => local_simpl ; subst ; eauto
    end.

(** Correctness proofs for the optimizing grammar constructors. *)
Lemma opt_alt_corr : forall t1 t2 (g1:grammar t1) (g2:grammar t2) s v,
  in_grammar (Alt g1 g2) s v <-> in_grammar (OptAlt g1 g2) s v.
Proof. destruct g1 ; destruct g2; simpl; crush; repeat in_grammar_inv. Qed.

Lemma opt_cat_corr : forall t1 t2 (g1:grammar t1) (g2:grammar t2) s v,
  in_grammar (Cat g1 g2) s v <-> in_grammar (OptCat g1 g2) s v.
Proof.
  destruct g1 ; destruct g2 ; simpl ; try tauto ; repeat local_simpl;
    repeat in_grammar_inv.
Qed.

Lemma opt_map_corr : forall t1 t2 (f:interp t1 -> interp t2) (g:grammar t1) s v,
  in_grammar (@Map t1 t2 f g) s v <-> in_grammar (@OptMap t1 t2 f g) s v.
Proof.
  destruct g ; simpl ; try tauto ; repeat local_simpl; repeat in_grammar_inv.
Qed.

(* Lemma opt_xform_corr : forall t1 t2 (x:t1->>t2) (g:grammar t1) s v, *)
(*   in_grammar (Xform x g) s v <-> in_grammar (OptXform x g) s v. *)
(* Proof. *)
(*   destruct g ; simpl ; try tauto ; repeat local_simpl ; repeat in_grammar_inv ; *)
(*   eapply InXform ; eauto ; rewrite xcomp_corr ;auto. *)
(* Qed. *)

(* (** Conceptually, returns [Eps] if [g] accepts the empty string, and  *)
(*     [Zero] otherwise.  In practice, we won't get exactly [Eps] since *)
(*     we could have [Map]s, [Xform]s, etc. in there. *) *)
(* Fixpoint null t (g:grammar t) : grammar t :=  *)
(*   match g in grammar t' return grammar t' with *)
(*     | Zero t => Zero t *)
(*     | Eps => Eps *)
(*     | Any => Zero _ *)
(*     | Char c => Zero _ *)
(*     | Alt t1 t2 g1 g2 => OptAlt (null g1) (null g2) *)
(*     | Cat t1 t2 g1 g2 => OptCat (null g1) (null g2) *)
(*     | Map t1 t2 f g => OptMap t2 f (null g) *)
(*     | Xform t1 t2 x g => OptXform x (null g) *)
(*     | Star t g => Xform (Xempty _ _) Eps *)
(*   end. *)
(* Extraction Implicit null [t]. *)

(* (** Computes the derivative of [g] with respect to [c]. Denotationally, *)
(*     this is { (s,v) | (c::s,v) in_grammar[g] }. *) *)
(* Fixpoint deriv t (g:grammar t) (c:char_p) : grammar t :=  *)
(*   match g in grammar t' return grammar t' with *)
(*     | Zero t => Zero t *)
(*     | Eps => Zero Unit_t *)
(*     | Char c' => if char_dec c c' then Xform (Xchar _ c') Eps else Zero _ *)
(*     | Any => Xform (Xchar _ c) Eps *)
(*     | Alt t1 t2 g1 g2 => OptAlt (deriv g1 c) (deriv g2 c) *)
(*     | Map t1 t2 f g => OptMap t2 f (deriv g c) *)
(*     | Xform t1 t2 x g => OptXform x (deriv g c) *)
(*     | Cat t1 t2 g1 g2 =>  *)
(*         OptXform (Xmatch (Xid _) (Xid _)) *)
(*           (OptAlt (OptCat (deriv g1 c) g2) (OptCat (null g1) (deriv g2 c))) *)
(*     | Star t g =>  *)
(*         OptXform (Xcons (Xfst _ _) (Xsnd _ _)) (OptCat (deriv g c) (Star g)) *)
(*   end. *)
(* Extraction Implicit deriv [t]. *)

(** * Splitting a [grammar] into a [regexp] and a top-level fix-up function *)

Require Import Coq.Program.Equality.
Require Import Regexp.

(* a fixup function; used in split_grammar and split_bigrammar *)
Definition fixfn (r:regexp) (t:type) :=
  xt_interp (regexp_type r) -> interp t.

Definition re_and_fn (t:type) (r:regexp) (f:fixfn r t): {r:regexp & fixfn r t } :=
  existT (fun r => fixfn r t) r f.
Extraction Implicit re_and_fn [t].

(** Split a [grammar] into a simplified [regexp] (with no maps) and a top-level fix-up
    function that can turn the results of the [regexp] back into the user-specified
    values.  Notice that the resulting regexp has no [gMap] or [gXform] inside of it. *)
Fixpoint split_grammar t (g:grammar t) : { ag : regexp & fixfn ag t} :=
  match g in grammar t' return { ag : regexp & fixfn ag t'} with
    | Eps => @re_and_fn Unit_t rEps (fun x => x)
    | Zero t => @re_and_fn _ rZero (fun x => match x with end)
    | Char c => @re_and_fn Char_t (rChar c) (fun x => x)
    | Any => @re_and_fn Char_t rAny (fun x => x)
    | @Cat t1 t2 g1 g2 =>
      let (ag1, f1) := split_grammar g1 in
        let (ag2, f2) := split_grammar g2 in
          @re_and_fn _ (rCat ag1 ag2)
          (fun p => (f1 (fst p), f2 (snd p)) : interp (Pair_t t1 t2))
    | @Alt t1 t2 g1 g2 =>
      let (ag1, f1) := split_grammar g1 in
        let (ag2, f2) := split_grammar g2 in
          @re_and_fn _ (rAlt ag1 ag2)
          (fun s => match s with
                      | inl x => inl _ (f1 x)
                      | inr y => inr _ (f2 y)
                    end : interp (Sum_t t1 t2))
    | @Star t g =>
      let (ag, f) := split_grammar g in
        @re_and_fn _ (rStar ag) (fun xs => (List.map f xs) : interp (List_t t))
    | @Map t1 t2 f1 g =>
      let (ag, f2) := split_grammar g in
        @re_and_fn _ ag (fun x => f1 (f2 x))
    (* | Xform t1 t2 f g =>  *)
    (*   let (ag, f2) := split_grammar g in  *)
    (*     @re_and_fn _ ag (fun x => (xinterp f) (f2 x)) *)
  end.
Extraction Implicit split_grammar [t].

Definition par2rec t (g:grammar t) : regexp :=
  let (ag, _) := split_grammar g in ag.
Extraction Implicit par2rec [t].

Local Ltac break_split_grammar :=
  repeat
    match goal with
      | [ H : match split_grammar ?g with | existT _ _ _ => _ end |- _ ] =>
        let p := fresh "p" in
        remember (split_grammar g) as p ; destruct p ; simpl in *
    end.

Lemma split_grammar_corr1 t (g:grammar t) :
  let (r,f) := split_grammar g in
    forall s v, in_regexp r s v -> in_grammar g s (f v).
Proof.
  induction g ; simpl ; repeat in_regexp_inv; break_split_grammar; intros;
  dependent induction H ; subst ; simpl ; eauto.
Qed.

(** Correctness of [split_grammar] part 2:  This direction requires a quantifier
    so is a little harder. *)
Lemma split_grammar_corr2 t (g:grammar t) :
  let (r, f) := split_grammar g in
    forall s v, in_grammar g s v -> exists v', in_regexp r s v' /\ v = f v'.
Proof.
  induction g; simpl ; repeat in_grammar_inv ; repeat in_regexp_inv;
  break_split_grammar; intros.
  Case "Cat".
    repeat in_grammar_inv. crush_hyp.
  Case "Alt".
    in_grammar_inv. intros. crush_hyp.
  Case "Star".
    dependent induction H.
    SCase "InStar_eps". crush.
    SCase "InStar_cons".
      use_lemma IHg by eassumption.
      destruct H2 as [v' [H2 H4]].
      clear IHin_grammar1.
      specialize (IHin_grammar2 _ g f Heqp IHg v2 (eq_refl _)
                    (JMeq_refl _) (JMeq_refl _)).
      destruct IHin_grammar2 as [v'' [H6 H8]].
      exists (v'::v''). crush.
  Case "Map". in_grammar_inv. intros. crush_hyp.
  (* Case "Xform". in_grammar_inv. intros. crush_hyp. *)
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Reals.
Require Import Rsequence_def.
Require Import Rsequence_facts.

Require Import Lra.
Open Scope Rseq_scope.
Open Scope nat_scope.
(** printing ~	~ *)
Definition is_extractor (phi : nat -> nat) := forall n, phi n < phi (S n).

Definition extractor := {phi | is_extractor phi}.

Definition extracted {X : Type} (phi : extractor) (Un : nat -> X) n := Un ((proj1_sig phi) n).

(** printing ⋅ #•# *)
Notation "Un ⋅ phi" := (extracted phi Un) (at level 40, left associativity) : Rseq_scope.

Definition subsequence {X : Type} (Un Vn : nat -> X) :=
  {phi | forall n, Un n = (Vn ⋅ phi) n}.

Lemma subsequence_helper {u v : Rseq} (f : nat -> nat) :
  (forall n, f n < f (1 + n))%nat ->
  (forall n, u n = v (f n)) ->
  subsequence u v.
Proof.
  intros Hf.
  hnf. unfold extractor.
  exists (exist is_extractor f Hf).
  eauto.
Qed.

(** Properties on nat -> nat sequences *)

(* Growing sequence *)
Lemma nat_seq_growing_trans : forall an : nat -> nat, (forall x, an x <= an (S x)) ->
  forall y x, x <= y -> an x <= an y.
Proof.
induction y.
 intros x Hx0; rewrite (le_n_O_eq x Hx0).
 apply le_refl.

 intros x Hxy.
 destruct (Compare.le_decide _ _ Hxy) as [Hyx|Hyx].
  apply le_trans with (an y).
   apply IHy.
   apply gt_S_le.
   apply Hyx.

   apply H.

  subst; apply le_refl.
Qed.

(* Strictly growing sequence *)
Lemma nat_seq_strict_growing_trans : forall an, (forall x, an x < an (S x)) ->
  forall y x, x < y -> an x < an y.
Proof.
induction y.
 intros x Hx0. inversion Hx0.

 intros x Hxy.
 destruct (Compare.le_decide _ _ Hxy) as [Hyx|Hyx].
  apply le_trans with (an y).
   apply IHy.
   apply gt_S_le.
   apply Hyx.
   apply lt_le_weak.
   apply H.

  rewrite <- Hyx.
  apply H.
Qed.

(* Inverse of stricty growing is growing *)
Lemma nat_seq_growing_trans_converse : forall an, (forall x, an x < an (S x)) ->
  forall x y, an x <= an y -> x <= y.
Proof.
intros an H x y Hxy.
destruct (le_le_S_dec x y).
 assumption.

 pose proof (nat_seq_strict_growing_trans an H x y).
 intuition.
Qed.

(** Properties on extractors *)
Lemma Rsubseq_n_le_extractor_n : forall phi n, is_extractor phi -> n <= phi n.
Proof.
intros phi n Hphi.
induction n.
 apply le_O_n.

 eapply le_trans with (S (phi n)).
 apply (le_n_S _ _ IHn).
 apply Hphi.
Qed.

(** Convergence compatible with subsequence *)
Lemma Rseq_subseq_cv_compat : forall Un Vn l, subsequence Un Vn -> Rseq_cv Vn l -> Rseq_cv Un l.
Proof.
intros Un Vn l Hsub Hcv eps Heps.
destruct (Hcv eps Heps) as [N HN].
exists N; intros n Hn.
destruct Hsub as [phi Hphi].
unfold extracted in *; simpl in Hphi.
rewrite Hphi.
apply HN.
apply le_trans with n.
 apply Hn.
 apply Rsubseq_n_le_extractor_n; destruct phi; auto.
Qed.

(** Divergence compatible with subsequence *)
Lemma Rseq_subseq_cv_pos_infty_compat :
  forall Un Vn, subsequence Un Vn ->
    Rseq_cv_pos_infty Vn -> Rseq_cv_pos_infty Un.
Proof.
intros Un Vn Hsub Hdv M.
destruct (Hdv M) as [N HN].
exists N; intros n Hn.
destruct Hsub as [phi Hphi].
rewrite Hphi.
apply HN.
apply le_trans with n.
 apply Hn.
 apply Rsubseq_n_le_extractor_n; destruct phi; auto.
Qed.

(** An extractor defines a partition of N *)
Lemma Rseq_extractor_partition : forall phi, is_extractor phi ->
  forall n, phi 0 <= n -> exists p, phi p <= n < phi (S p).
Proof.
intros phi ephi.
induction n.
 exists 0.
 split.
  assumption.
  apply (Rsubseq_n_le_extractor_n _ 1 ephi).

 destruct (le_le_S_dec (phi 0) n).
  intros _.
  destruct (IHn l) as [p [Hpn Hnsp]].
  destruct (Compare.le_decide _ _ Hnsp).
   exists p.
   split; [constructor|]; assumption.

   exists (S p).
   rewrite e.
   intuition.

  intro l'; rewrite (le_antisym _ _ l l').
  exists 0.
  split.
   constructor.
   apply ephi.
Qed.

(** Composition of extractors *)

Lemma extractor_comp : forall phi1 phi2,
  is_extractor phi1 -> is_extractor phi2 -> is_extractor (fun n => phi1 (phi2 n)).
Proof.
intros phi1 phi2 H1 H2 n.
apply nat_seq_strict_growing_trans; trivial.
Qed.

(** Common extractors *)
Definition Rseq_iter_S k := plus k.

Lemma extractor_S : is_extractor S.
Proof.
intro n.
constructor.
Qed.

Lemma extractor_Rseq_iter_S : forall k, is_extractor (Rseq_iter_S k).
Proof.
intros k n.
unfold Rseq_iter_S.
apply plus_lt_compat_l; constructor.
Qed.

Lemma is_extractor_mult_2 : is_extractor (mult 2).
Proof.
intros n; omega.
Qed.

Definition extractor_mult_2 := exist _ (mult 2) is_extractor_mult_2.

(** Rseq_zip can be inversed thanks to extractors *)

Lemma Rseq_zip_extract_evens : forall Un Vn,
  Rseq_zip Un Vn ⋅ extractor_mult_2 == Un.
Proof.
intros Un Vn n ; unfold Rseq_zip, extracted, extractor_mult_2 ;
 simpl ; case (n_modulo_2 (n + (n + 0))) ; intros [p Hp].
  f_equal ; omega.
  apply False_ind ; omega.
Qed.

(** Convergence of subsequence implies convergence of the growing sequence *)
Open Scope R_scope.

(* begin hide *)
Lemma R_dist_bounded_in_segment : forall a b c e, a <= b <= c -> R_dist a c < e ->
  R_dist b c < e.
Proof.
intros a b c e [ab bc] ace.
unfold R_dist in *.
assert (forall x y, x <= y -> Rabs (x - y) = y - x).
 intros.
 rewrite Rabs_minus_sym.
 apply Rabs_right.
 lra.

 pose proof (Rle_trans _ _ _ ab bc) as ac.

  repeat rewrite H; rewrite H in ace; intuition;
  apply Rle_lt_trans with (c - a);
   lra.
Qed.
(* end hide *)

Lemma Rseq_subseq_growing_cv_compat :
  forall Un Vn l, subsequence Un Vn -> Rseq_cv Un l -> Rseq_growing Vn -> Rseq_cv Vn l.
Proof.
intros un vn l [phi ephi] uncv vngrow eps epspos.
destruct phi as [phi Hphi]; unfold extracted in *; simpl in *.
assert (spliteps : (eps / 3 > 0)%R) by lra.
destruct (uncv (eps / 3) spliteps) as [Nu Hu].
exists (phi Nu).
intros n nNu.
destruct (Rseq_extractor_partition phi Hphi n) as [N Hpart].
 apply le_trans with (phi Nu).
  apply nat_seq_growing_trans.
   intros x.
   apply lt_le_weak.
   apply Hphi.

   apply le_O_n.

  exact nNu.

 assert (HNuN : (Nu <= N)%nat).
  destruct (le_le_S_dec Nu N) as [goal|Hinv].
   exact goal.

   destruct Hpart as [HNn HnSN].
   pose proof (nat_seq_growing_trans phi (fun x => lt_le_weak _ _ (Hphi _)) Nu (S N) Hinv).
   pose proof (le_trans _ _ _ H nNu).
   pose proof (lt_le_trans _ _ _ HnSN H).
   intuition.

 pose proof (Hu N HNuN) as Hun.
 pose proof (Hu (S N) (le_S _ _ HNuN)) as Husn.
 rewrite ephi in Hun.
 rewrite ephi in Husn.
 assert (vn (phi N) <= vn n <= vn (phi (S N)))%R.
  split; apply (Rseq_growing_trans _ vngrow); intuition.
 rewrite R_dist_sym in Husn.
 replace eps with (eps / 3 + eps / 3 + eps / 3) by field.
 eapply Rle_lt_trans.
  apply (R_dist_tri _ _ (vn (phi (S N)))).
  apply Rplus_lt_compat.
   eapply R_dist_bounded_in_segment.
    apply H.
    eapply Rle_lt_trans.
     apply (R_dist_tri _ _ l).
     apply Rplus_lt_compat.
      apply Hun.
      apply Husn.
   rewrite R_dist_sym .
   apply Husn.
Qed.

(** u(2n) → l and u growing implies u → l *)

Corollary Rseq_even_growing_compat : forall un l, Rseq_growing un ->
 Rseq_cv (fun i => un (2*i)%nat) l -> Rseq_cv un l.
Proof.
intros.
apply Rseq_subseq_growing_cv_compat with (fun i : nat => un (2 * i)%nat).
 assert (Hex : is_extractor (mult 2)).
   intros n; omega.
 pose (phi := exist _ (mult 2) Hex).
 exists phi; reflexivity.
 assumption.
 assumption.
Qed.

(** Link with Landau's relations *)
Section Landau.

Variables Un Vn : nat -> R.

(** Subsequence and big-O. *)

(**********)
Lemma Rseq_big_O_subseq_compat :
  forall phi, Un = O (Vn) -> (Un ⋅ phi) = O(Vn ⋅ phi).
Proof.
intros phi Heq.
destruct Heq as [N [HN [N0 HN0]]].
exists N; split.
assumption.
exists N0; intros n Hn.
apply HN0.
apply le_trans with n.
assumption.
apply Rsubseq_n_le_extractor_n; destruct phi; assumption.
Qed.

(** Subsequence and little-O. *)

(**********)
Lemma Rseq_little_O_subseq_compat :
  forall phi, Un = o (Vn) -> (Un ⋅ phi) = o(Vn ⋅ phi).
Proof.
intros [phi Hphi] Heq.
intros eps Heps.
destruct (Heq eps Heps) as [N HN].
exists N.
intros n Hn; unfold Rseq_minus.
apply HN.
apply le_trans with (phi N).
apply Rsubseq_n_le_extractor_n; assumption.
apply nat_seq_growing_trans; auto with *.
Qed.

(** Subsequence and equivalence. *)

(**********)
Lemma Rseq_equiv_subseq_compat :
  forall phi, Un ~ Vn -> (Un ⋅ phi) ~ (Vn ⋅ phi).
Proof.
intros [phi Hphi] Heq.
intros eps Heps.
destruct (Heq eps Heps) as [N HN].
exists N.
intros n Hn; unfold Rseq_minus.
apply HN.
apply le_trans with (phi N).
apply Rsubseq_n_le_extractor_n; assumption.
apply nat_seq_growing_trans;auto with *.
Qed.

End Landau.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj4synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (mult lv0 (Succ Zero)) (plus lv1 (mult lv2 lv3))).
Admitted.
QuickChick conj4synthconj2.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.

Open Scope morphism_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Epic (C: Category): Category := {|
  Obj := C ;
  Mor A B := {f: C A B | ∀ (Z:C) (x y: C B Z), (x ∘ f == y ∘ f) → x == y} ;
  Mor_Setoid _ _ := {| equiv x y := (x :>) == (y :>) |} ;

  id := @id _ ;
  compose := @compose _ ;
|}.

Next Obligation.
Proof.
  exists.
  - intro.
    reflexivity.
  - intros ? ? ?.
    symmetry.
    auto.
  - intros ? ? ? p q.
    rewrite p, q.
    reflexivity.
Qed.

Next Obligation.
Proof.
  repeat rewrite compose_id_right in H.
  assumption.
Qed.

Next Obligation.
Proof.
  repeat rewrite compose_assoc in H.
  apply (H1 _ _ _ (H0 _ _ _ H)).
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q.
  cbn in *.
  rewrite p, q.
  reflexivity.
Qed.