From Coq Require Import Strings.String.
Require Import ZArith.
Open Scope nat_scope.
Open Scope list_scope.
From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical_Pred_Type.
From Coq Require Import Logic.Classical_Prop.
From Coq Require Import Structures.OrderedTypeEx.
From SE Require Export Model.
Import ListNotations.
Close Scope string_scope.

(** Link to our repo:
https://github.com/kakiryan/790-132-final-project *)

(** Table of Contents:
  - Definition Symbolic Execution Concepts (Minimum goal)
  - General Proof of Property 1 (Standard Goal)
  - Proof of Property 2 for:  (Standard Goal)
      * Figure 1 in King Paper
      * Modified Figure 2 in King Paper
      * While loop example
  - Proof of Property 2 for: (Reach Goal)
      * Figure 1 in King Paper
      * Modified Figure 2 in King Paper
      * While loop example

    Property 1: Path condition is never identically false.
    Property 2: All leaf nodes in a symbolic execution tree are distinct.
    Property 3: Symbolic execution is commutative. *)

(** The following relation is our representation of symbolic execution of a program.
    It relates a given program, and a node corresponding to a particular statement,
    to a resultant execution tree. As defined here, the relation will generate
    nodes for unsatisfiable path conditions (i.e. false path conditions) but
    will not progress execution past these nodes. *)

Inductive node_eval (prog: Program) : TreeNode -> list TreeNode -> Prop :=
  | E_Empty:
    let st := (emptySt prog) in
    node_eval prog <<st, nil, 0>> [<<st, nil, 0>>]

  | E_Assign : forall x ie st pc n path,
    let se := (makeSymbolicInt st ie) in
    let parent := <<st, pc, n>> in
    let child := <<(x, se) :: st, pc, (nextInstruction (stmts prog) n)>> in
    (findStatement (stmts prog) n) = <{x := ie}> ->
    node_eval prog parent path ->
    node_eval prog child (child :: path)

   | E_IfThen : forall be then_body else_body st pc n path,
    let sbe := (makeSymbolicBool st be) in
    let parent := <<st, pc, n>> in
    let child := <<st, sbe::pc, (n+1)>> in
    (findStatement (stmts prog) n) = <{if be then then_body else else_body end}> ->
    (makeSymbolicBool st be) = sbe ->
    (SAT (sbe::pc)) ->
    node_eval prog parent path ->
    node_eval prog child (child :: path)

  | E_IfElse : forall be then_body else_body st pc n path,
    let sbe := (makeSymbolicBool st be) in
    let parent := <<st, pc, n>> in
    let child := << st, (<[~sbe]>)::pc, (n + (progLength then_body) + 1)>> in
    (findStatement (stmts prog) n) = <{if be then then_body else else_body end}> ->
    (SAT (<[~sbe]>::pc)) ->
    node_eval prog parent path ->
    node_eval prog child (child :: path)

   | E_GoTo: forall pos st pc n path,
    let parent := << st, pc, n>> in
    let child := <<st, pc, pos>> in
    (findStatement (stmts prog) n) = <{go_to pos}> ->
    node_eval prog parent path ->
    node_eval prog child (child :: path)

  | E_WhileBody: forall be body st pc n path,
    let sbe := (makeSymbolicBool st be) in
    let parent := <<st, pc, n>> in
    let child := <<st, sbe::pc, (n + 1)>> in
    (findStatement (stmts prog) n) = <{while be do body end}> ->
    (SAT (sbe:: pc)) ->
    node_eval prog parent path ->
    node_eval prog child (child :: path)

 | E_WhileSkip: forall be body st pc n path,
    let sbe := (makeSymbolicBool st be) in
    let parent := <<st, pc, n>> in
    let child := << st, (<[~sbe]>:: pc), (n + (progLength body) + 1)>> in
    (findStatement (stmts prog) n) = <{while be do body end}> ->
    (SAT (<[~sbe]>:: pc)) ->
    node_eval prog parent path ->
    node_eval prog child (child :: path).

(** This is stating
    that if a superset of a condition is satisfiable, then the condition itself is
    satisfiable. *)
Theorem superset_SAT : forall (p: PathCond) (sbe : SBoolExp),
  SAT (sbe::p) -> SAT p.
Proof. intros. destruct H. unfold SAT. exists x. simpl in H. destruct (eval_pc p x).
 - reflexivity.
 - rewrite andb_comm in H. simpl in H. apply H.
Qed.

Lemma eval_pc_false : forall p cs,
  eval_pc p cs = false ->
  exists sbe, In sbe p /\ (substituteBool sbe cs) = false.
Proof.
  intros. induction p.
  discriminate.
  simpl in H. remember (substituteBool a cs).
  destruct b.
  - simpl in H. apply IHp in H. destruct H as [sbe [H1 H2]].
    exists sbe. split. right. apply H1. apply H2.
  - exists a. split. left. reflexivity. easy.
Qed.

Lemma SAT_terms : forall p,
  SAT p <-> exists cs, forall sbe, (In sbe p -> (substituteBool sbe cs) = true).
Proof.
  split; intros.
  - unfold SAT in H. destruct H. exists x. induction p.
    + intros. destruct H0.
    + intros. simpl in H. destruct H0.
      * subst. destruct (substituteBool sbe x).
        reflexivity. discriminate.
      * apply IHp. destruct (substituteBool a x).
        simpl in H. destruct (eval_pc p x).
        reflexivity. discriminate. discriminate.
        apply H0.
  - destruct H as [cs H]. induction p.
    + exists nil. reflexivity.
    + exists cs. simpl. assert (substituteBool a cs = true).
    { apply (H a). left; reflexivity. } rewrite H0. simpl.
    remember (eval_pc p cs). destruct b.
    * reflexivity.
    * symmetry in Heqb. apply eval_pc_false in Heqb.
      destruct Heqb as [sbe [H1 H2]].
      assert (substituteBool sbe cs = true).
      { apply (H sbe). right. apply H1. }
      rewrite H2 in H3. apply H3.
Qed.

Lemma SAT_comm : forall p1 p2,
  SAT (p1 ++ p2) -> SAT (p2 ++ p1).
Proof.
  intros. apply SAT_terms. apply SAT_terms in H.
  destruct H as [cs H]. exists cs; intros.
  apply in_app_or in H0. destruct H0.
  - destruct p2. destruct H0.
    apply H. apply in_or_app. right. apply H0.
  - destruct p1. destruct H0.
    apply H. apply in_or_app. left. apply H0.
Qed.

Lemma superset_SAT_paths : forall p1 p2,
  SAT (p1 ++ p2) -> SAT p2.
Proof.
  intros. induction p1.
  - easy.
  - apply (superset_SAT (p1 ++ p2) a) in H.
    apply IHp1 in H. apply H.
Qed.

(* ================== End: Definition Symbolic Execution Concepts. ==================*)

(* ========================= Start: Proof of Property 1. ============================*)

(** The path condition never becomes identically false.  *)
Theorem property_1 : forall prog node path,
  node_eval prog node path ->
  SAT (extractPathCond node).
Proof.
  intros. induction H; subst; simpl; try auto.
  - exists nil. reflexivity.
Qed.

(* ========================= End: Proof of Property 1. ==============================*)

(* Definition prog_1 := <{ X := A + B ;
                        Y := B + C ;
                        W := X + Y - B }>.

Definition empty_st := [(A, sA); (B, sB); (C, sC)]. *)

(**Example prog_1_ex : node_eval prog_1 <<[(Z, <[sA + sB + (sB + sC) - sB]>); (Y, <[sB + sC]>); (X, <[sA + sB]>); (A, sA); (B, sB); (C, sC)], nil, 3>>.
Proof.
  assert (H: node_eval prog_1 <<empty_st, nil, 0>>). { apply E_Empty. reflexivity. }
  apply E_Assign with (x := X) (ie := <{A + B}>) (st := empty_st) (n := 0%nat) (pc := nil) in H; try reflexivity.
  apply E_Assign with (x := Y) (ie := <{B + C}>) (st := (X, <[sA + sB]>) :: empty_st) (n := 1%nat) (pc := nil) in H; try reflexivity.
  apply E_Assign with (x := Z) (ie := <{X + Y - B}>) (st := (Y, <[sB + sC]>) :: (X, <[sA + sB]>) :: empty_st) (n := 2%nat) (pc := nil) in H; try reflexivity.
  simpl in H. apply H.
Qed.*)

(* ====================== Start: Proof of Property 2. ===================*)

Lemma node_path : forall prog node path,
  node_eval prog node path ->
  In node path.
Proof.
  intros. induction H; left; easy.
Qed.

Lemma path_not_empty : forall prog node path,
  node_eval prog node path ->
  exists tail, path = node :: tail.
Proof.
  intros; inversion H;
  try (exists nil; reflexivity);
  try (exists path0; reflexivity).
Qed.

Lemma base_path : forall prog node path,
  node_eval prog node path ->
  In <<(emptySt prog), nil, 0>> path.
Proof.
  intros. induction H;
  try (left; reflexivity);
  try (right; apply IHnode_eval).
Qed.

(* Definition ancestor (prog: Program) (node1 node2: TreeNode) (path2: list TreeNode): Prop :=
  node_eval prog node2 path2 /\ In node1 path2. *)

Definition ancestor (prog: Program) (node1 node2: TreeNode) (path2: list TreeNode): Prop :=
  node_eval prog node2 path2 /\ In node1 path2.

Lemma ancestor_eval : forall prog node1 node2 path2,
  ancestor prog node1 node2 path2 -> exists path1, node_eval prog node1 path1.
Proof.
  intros. destruct H as [H H0]. remember H as E. clear HeqE.
  induction H; destruct H0;
  try (exists (child :: path); rewrite <- H0; easy);
  try (apply IHnode_eval; easy).
  - exists [<<st, [], 0>>]. rewrite <- H. apply E_Empty.
  - destruct H.
Qed.

Lemma pathcond_extend : forall prog node1 node2 path2,
  (ancestor prog node1 node2 path2) ->
  exists path_subset, extractPathCond node2 = path_subset ++ extractPathCond node1.
Proof. Abort.
(* intros. destruct H. induction H; destruct H0; try (rewrite <- H0);
    try (exists nil; simpl; unfold node; reflexivity);
    try (apply IHnode_eval in H0; apply H0).
  - exists [sbe]; reflexivity.
  - apply IHnode_eval in H0. destruct H0 as [p Hp].
    exists (sbe :: p). unfold node in Hp; simpl in *. rewrite Hp; reflexivity.
  - exists [<[~sbe]>]; reflexivity.
  - apply IHnode_eval in H0. destruct H0 as [p Hp].
    exists (<[~sbe]> :: p). unfold node in Hp; simpl in *. rewrite Hp; reflexivity.
  - exists [sbe]; reflexivity.
  - apply IHnode_eval in H0. destruct H0 as [p Hp].
    exists (sbe :: p). unfold node in Hp; simpl in *. rewrite Hp; reflexivity.
  - exists [<[~sbe]>]; reflexivity.
  - apply IHnode_eval in H0. destruct H0 as [p Hp].
    exists (<[~sbe]> :: p). unfold node in Hp; simpl in *. rewrite Hp; reflexivity.
Qed. *)

(* Lemma path_extend : forall prog node node' path,
  node_eval prog node' (node' :: node :: path) ->
  node_eval prog node (node :: path).
Proof.
  intros. inversion H;
  try (subst; remember H4 as H5; clear HeqH5;
    apply node_path_2 in H4; simpl in H4;
    rewrite <- H4 in H5; apply H5).
  - subst. remember H3 as H4. clear HeqH4.
    apply node_path_2 in H3. destruct H3. injection H0; intros.
    rewrite <- H3 in H4. apply H4.
  - subst. remember H5 as H6. clear HeqH6.
    apply node_path_2 in H5. simpl in H5.
    rewrite <- H5 in H6. apply H6.
  - subst. remember H3 as H4. clear HeqH4.
    apply node_path_2 in H3. simpl in H3.
    rewrite <- H3 in H4. apply H4.
Qed. *)

Lemma not_ancestor_not_path : forall prog node1 path1 node2 path2,
  node_eval prog node1 path1 ->
  node_eval prog node2 path2 ->
  ~(ancestor prog node1 node2 path2) ->
  ~(ancestor prog node2 node1 path1) ->
  ~(In node1 path2) /\ ~(In node2 path1).
Proof.
  intros. unfold ancestor in *. split.
  - intro. apply H1. split.
    apply H0. apply H3.
  - intro. apply H2. split.
    apply H. apply H3.
Qed.

Lemma pc_ancestor : forall prog node1 node2 path2 sbe,
  ancestor prog node1 node2 path2 ->
  In sbe (extractPathCond node1) ->
  In sbe (extractPathCond node2).
Proof.
  intros. destruct H as [H H1]. induction H; destruct H1;
  try (rewrite <- H in H0; simpl in H0; apply H0; apply H);
  try (subst; apply H0);
  try (simpl; right);
  auto.
Qed.

Lemma unique_path_head : forall prog node1 node2 path,
  node_eval prog node1 path ->
  node_eval prog node2 path ->
  node1 = node2.
Proof.
  intros. apply path_not_empty in H. apply path_not_empty in H0.
  destruct H. destruct H0.
  rewrite H in H0. injection H0; intros; easy.
Qed.

Lemma unique_child : forall prog parent path,
  let stmt := (findStatement (stmts prog) (extractIndex parent)) in
  ((exists n, stmt = <{Go_To n}>) \/
  (exists x ie, stmt = <{x := ie}>)) ->
  node_eval prog parent path ->
  exists! child, node_eval prog child (child :: path).
Proof.
  intros. destruct H.
  - destruct H as [n H]. destruct parent.
    exists <<s, pc, n>>. split.
    + simpl in *. Abort. (* admit.
    + intros child Hchild.
      inversion Hchild.
      * apply base_path in H0. rewrite <- H3 in H0. destruct H0.
      * simpl in *. assert (parent = <<s, pc, index>>).
        { apply (unique_path_head prog _ _ path); easy. }
        simpl in *. subst. unfold parent in H5. injection H5. intros.
        subst. unfold stmt in H. rewrite H in H2. inversion H2.
Admitted. *)

Lemma pc_differ : forall prog node1 node2 path1 path2,
  let pc1 := (extractPathCond node1) in
  let pc2 := (extractPathCond node2) in
  node_eval prog node1 path1 ->
  node_eval prog node2 path2 ->
  ~ ancestor prog node1 node2 path2 ->
  ~ ancestor prog node2 node1 path1 ->
  exists sbe, (In sbe pc1 /\ In <[~sbe]> pc2) \/
    (In sbe pc2 /\ In <[~sbe]> pc1).
Proof.
  intros. unfold ancestor in H1. apply not_and_or in H1.
  destruct H1. apply H1 in H0. destruct H0.
  unfold ancestor in H2. apply not_and_or in H2.
  destruct H2. apply H2 in H. destruct H. remember H as E. clear HeqE.

  induction H.
  - simpl in *. apply base_path in H0. apply H1 in H0. destruct H0.
  - assert (exists! child', node_eval prog child' (child' :: path)).
  (* { apply (unique_child _ parent _); try auto. right. exists x, ie; easy. }
  destruct H4 as [child' H4]. destruct H4.

  apply IHnode_eval; auto. *)
Abort.

Lemma hope : forall prog node1 node2 path1 path2,
  node_eval prog node1 path1 ->
  node_eval prog node2 path2 ->
  SAT (extractPathCond node1 ++ extractPathCond node2) ->
  In node1 path2 \/ In node2 path1.
Proof.
  intros. induction H.
  - left. apply (base_path prog node2). auto.
  (*- right. apply IHnode_eval in H1. right. destruct H1 as [H5 | H6].
    + admit.
    +  *)
Abort.

  (*remember H as E. clear HeqE.
  induction H.
  - intros. left. apply (base_path prog node2). apply H.
  - intro. induction H1; intros.
    + right. apply (base_path prog child). auto.
    + assert (In parent (child0 :: path0) \/ In child0 path).
      { admit. }
      destruct H4.
      assert (In child path0 \/ In parent0 (child :: path)).
      { admit. }
      destruct H5.
      left. right. auto.
      admit.
      right. right. apply H4.*)

(* Axiom excluded_middle : forall P, P \/ ~P. *)

Theorem property_2 : forall prog node1 node2 path1 path2,
(node_eval prog node1 path1) ->
(node_eval prog node2 path2) ->
  ~(ancestor prog node1 node2 path2) ->
  ~(ancestor prog node2 node1 path1) ->
  ~ (SAT (( extractPathCond node1) ++ (extractPathCond node2))).
Proof.

  intros. intros H4. unfold ancestor in H1. apply not_and_or in H1.
  (** Since we have assumed that both nodes are in the relation, we need to
      unfold the ancestor definition to get that neither node is in the other's path. *)
  destruct H1. apply H1. apply H0.
  unfold ancestor in H2. apply not_and_or in H2.
  destruct H2. apply H2. apply H. remember H as E. clear HeqE.
  induction H.
  (** Now we can proceed by induction on H. *)

  (* apply SAT_terms in H4. destruct H4 as [cs H4]. *)
    (* - apply base_path in H0. apply H1 in H0. apply H0.
    - assert (In parent path2 \/ ~ In parent path2).
      { apply excluded_middle. }
      destruct H5.
      + clear IHnode_eval.
    apply IHnode_eval; auto.
      clear IHnode_eval. clear H4.
      + intro.
      + intro. assert (exists! child', node_eval prog child' (child' :: path)).
      { apply (unique_child _ parent _). right. exists x, ie; easy. easy. }
      destruct H5 as [child' [H5 H6]].
      apply (H6 child) in E. subst.
      assert (parent = node2).
      (** We know path2 = node2 :: tail, so then destruct H4 and show that parent has to be at the head or there's a contradiction with H1. *)
      { destruct path2 as [|h t]. apply base_path in H0. destruct H0.
        destruct H4.
        - admit. (* easy case *)
        - clear H. clear H2. admit.
      }
      rewrite <- H7 in H2. simpl in H2. apply not_or_and in H2.
      destruct H2. apply node_path in H3. apply H8 in H3. destruct H3.
      + simpl in H2. apply not_or_and in H2. destruct H2. auto.
    - simpl in *. apply superset_SAT in H4. apply IHnode_eval; auto.
      intro. clear IHnode_eval. clear H4. clear H5.
      apply not_or_and in H2. destruct H2.*)
Abort.

(* ==================== End: Proof of Property 2 ===================== *)

(* ==================== Start: Proof of Property 3 ===================== *)

Fixpoint populateParams (params : list string) (args : list Z) : concreteState :=
  match params with
  | nil => nil
  | h :: t =>
    match args with
    | nil => (h, 0) :: (populateParams t nil)
    | h' :: t' => (h, h') :: (populateParams t t')
    end
  end.

Definition populate (prog : Program) (args : list Z) : concreteState :=
  match prog with
  | P stmts params => populateParams params args
 end.

Inductive concrete_eval (prog: Program) : ConcreteNode -> list ConcreteNode -> Prop :=
  | CE_Empty:
    forall args,
    let cs := populate prog args in
    concrete_eval prog {{cs, 0}} [{{cs, 0}}]

  | CE_Assign : forall x ie cs n path,
    let parent := {{cs, n}} in
    let result := inteval ie cs in
    let child := {{(x, result) :: cs, (nextInstruction (stmts prog) n)}} in
    (findStatement (stmts prog) n) = <{x := ie}> ->
    concrete_eval prog parent path ->
    concrete_eval prog child (child :: path)

   | CE_IfThen : forall be then_body else_body cs n path,
    let parent := {{cs, n}} in
    let child := {{cs, (n+1)}} in
    (findStatement (stmts prog) n) = <{if be then then_body else else_body end}> ->
    beval be cs = true ->
    concrete_eval prog parent path ->
    concrete_eval prog child (child :: path)

  | CE_IfElse : forall be then_body else_body cs n path,
    let parent := {{cs, n}} in
    let child :=  {{cs, (n + (progLength then_body)) + 1}} in
    (findStatement (stmts prog) n) = <{if be then then_body else else_body end}> ->
    beval be cs = false ->
    concrete_eval prog parent path ->
    concrete_eval prog child (child :: path)

   | CE_GoTo: forall pos cs n path,
    let parent := {{ cs, n}} in
    let child := {{ cs, pos}} in
    (findStatement (stmts prog) n) = <{go_to pos}> ->
    concrete_eval prog parent path ->
    concrete_eval prog child (child :: path)

  | CE_WhileBody: forall be body cs n path,
    let parent := {{ cs, n }} in
    let child :=  {{ cs, (n + 1)}} in
    (findStatement (stmts prog) n) = <{while be do body end}> ->
    beval be cs = true ->
    concrete_eval prog parent path ->
    concrete_eval prog child (child :: path)

 | CE_WhileSkip: forall be body cs n path,
    let parent := {{cs, n}} in
    let child := {{cs, (n + (progLength body) + 1)}} in
    (findStatement (stmts prog) n) = <{while be do body end}> ->
    beval be cs = false ->
    concrete_eval prog parent path ->
    concrete_eval prog child (child :: path).

Fixpoint fillState (cs: concreteState) (st: state) : concreteState :=
 match st with
  | nil => nil
  | h::t => match h with
      | (x,se) => (x, (substituteInt se cs)) :: (fillState cs t)
      end
  end.

Lemma int_exp_equiv : forall ie st initial_cs,
let se := makeSymbolicInt st ie in
let cs := fillState initial_cs st in
(substituteInt se initial_cs) = (inteval ie cs).
Proof.
intros. induction ie.
- simpl. reflexivity.
- simpl. rewrite IHie1. rewrite IHie2. reflexivity.
- simpl. rewrite IHie1. rewrite IHie2. reflexivity.
- simpl. rewrite IHie1. rewrite IHie2. reflexivity.
- simpl in *. unfold se. simpl. induction st.
  + simpl in *. reflexivity.
  + destruct a as [k v]. simpl. destruct (string_dec k x).
    * reflexivity.
    * apply IHst.
Qed.

Lemma bool_exp_equiv : forall be st inital_cs,
let se := makeSymbolicBool st be in
let cs := fillState inital_cs st in
(substituteBool se inital_cs) = (beval be cs).
Proof.
intros. induction be.
- simpl. reflexivity.
- simpl. reflexivity.
- simpl. rewrite IHbe. reflexivity.
- simpl. assert ((substituteInt (makeSymbolicInt st n) inital_cs) = inteval n cs).
 * apply int_exp_equiv.
 * rewrite H. reflexivity.
Qed.

(* LOL this is from class *)
Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  - destruct c eqn:Ec.
      + reflexivity.
      + intros H. rewrite <- H.
      { destruct b eqn:Eb.
        * reflexivity.
        * reflexivity.
      }
  Qed.

(* Theorem property_3 : forall prog node path cs final_cs' n',
 let final_cs := fillState cs (extractState node) in
 node_eval prog node path ->
 eval_pc (extractPathCond node) cs = true ->
 concrete_eval prog {{final_cs' n'}}
 *)

Fixpoint initial_state (cpath : list ConcreteNode) : concreteState :=
  match cpath with
  | nil => nil
  | h :: t => match t with
    | nil => extractConcreteState h
    | h' :: t' => (initial_state t)
    end
  end.

Lemma fillEmptySt : forall prog cs,
  fillState cs (emptySt prog) = cs.
Proof. Admitted.

(*  intros. generalize dependent args. destruct prog. induction params; intros.
  - reflexivity.
  - destruct args.
    + unfold cs in *. simpl in *. destruct (string_dec a a).
      * assert (fillState ((a, 0) :: populateParams params []) (paramsToEmptySt params) =
                populateParams params []).
      { clear e. Admitted. *)

(* induction params.
  - simpl. unfold cs. simpl in *. reflexivity.
  - simpl in *. unfold cs. unfold applyCState. simpl. destruct args.
    * unfold cs. injection. rewrite <- IHparams.
Abort. *)

Lemma concrete_path_head : forall prog cnode cpath,
  concrete_eval prog cnode cpath ->
  exists tail, cpath = cnode :: tail.
Proof.
  intros. inversion H; try (exists path; reflexivity).
  - exists nil. reflexivity.
Qed.

Lemma superset_pc_true : forall pc cs sbe,
eval_pc (sbe :: pc) cs = true ->
eval_pc pc cs = true.
Proof.
intros. induction pc.
- simpl. reflexivity.
- simpl in H. simpl. destruct (substituteBool sbe cs).
  * simpl in H. apply H.
  * discriminate.
Qed.

Lemma initial_state_match : forall prog parent child cpath,
  concrete_eval prog parent cpath ->
  concrete_eval prog child (child :: cpath) ->
  initial_state cpath = initial_state (child :: cpath).
Proof.
  intros. inversion H; try reflexivity.
Qed.

Theorem property_3 : forall prog node path,
  node_eval prog node path ->
  forall cs cpath final_cs final_cs' n n',
  eval_pc (extractPathCond node) cs = true ->
  concrete_eval prog {{final_cs', n'}} cpath ->
  initial_state cpath = cs ->
  length path = length cpath ->
  n = (extractIndex node) ->
  final_cs = fillState cs (extractState node) ->
  final_cs = final_cs' /\ n = n'.
Proof.
  intros prog node path H. induction H; intros.
  - simpl in *. subst. clear H. inversion H0;
    try (destruct cpath; try discriminate;
      try (injection H5); try (injection H4); intros; subst;
      simpl in H2; injection H2; intros;
      try (apply concrete_path_head in H6);
      try (apply concrete_path_head in H5);
      try (destruct H6); try (destruct H5); subst; discriminate).
    + split; try easy. simpl. subst. apply fillEmptySt.
  - inversion H2.
    + subst. simpl in *. injection H4; intros. apply path_not_empty in H0.
      destruct H0. subst. discriminate.
    + assert ((fillState cs (extractState parent)) = cs0 /\ n = n1).
      { apply (IHnode_eval cs path0 (fillState cs (extractState parent)) cs0 n n1); auto. subst. apply (initial_state_match _ _ _ _ H11 H2). subst. injection H4; intros. easy. } subst. split.
      * destruct H12. simpl. simpl in H3. rewrite H3.
        subst. rewrite H9 in H. injection H; intros; subst.
        f_equal. f_equal. clear H. clear IHnode_eval.
        unfold se. unfold result. rewrite_strat outermost <- H3.
        apply int_exp_equiv.
      * simpl. destruct H12. rewrite H5. reflexivity.
    + assert ((fillState cs (extractState parent)) = cs0 /\ n = n1).
      { apply (IHnode_eval cs path0 (fillState cs (extractState parent)) cs0 n n1); auto. subst. easy. subst. apply (initial_state_match _ _ _ _ H12 H2). subst. injection H4; intros. easy. }
      destruct H13. subst n1. rewrite H9 in H. discriminate.
    + assert ((fillState cs (extractState parent)) = cs0 /\ n = n1).
      { apply (IHnode_eval cs path0 (fillState cs (extractState parent)) cs0 n n1); auto. subst. easy. subst. apply (initial_state_match _ _ _ _ H12 H2). subst. injection H4; intros. easy. }
      destruct H13. subst n1. rewrite H9 in H. discriminate.
    + assert ((fillState cs (extractState parent)) = cs0 /\ n = n1).
      { apply (IHnode_eval cs path0 (fillState cs (extractState parent)) cs0 n n1); auto. subst. easy. subst. apply (initial_state_match _ _ _ _ H11 H2). subst. injection H4; intros. easy. }
      destruct H12. subst n1. rewrite H9 in H. discriminate.
    + assert ((fillState cs (extractState parent)) = cs0 /\ n = n1).
      { apply (IHnode_eval cs path0 (fillState cs (extractState parent)) cs0 n n1); auto. subst. easy. subst. apply (initial_state_match _ _ _ _ H12 H2). subst. injection H4; intros. easy. }
      destruct H13. subst n1. rewrite H9 in H. discriminate.
    + assert ((fillState cs (extractState parent)) = cs0 /\ n = n1).
      { apply (IHnode_eval cs path0 (fillState cs (extractState parent)) cs0 n n1); auto. subst. easy. subst. apply (initial_state_match _ _ _ _ H12 H2). subst. injection H4; intros. easy. }
      destruct H13. subst n1. rewrite H9 in H. discriminate.
  -

(** Ltac wrong H := apply concrete_path_head in H; destruct H; discriminate.

Ltac auto_wrong :=
  match goal with
    H: concrete_eval ?P ?N []
    |- _ => wrong H
  end.

Ltac wrong_ind IH A B C D final_cs' n0 path0 prog parent0 child1 :=
  apply (IH final_cs' n0 path0 A B (initial_state path0));
  try reflexivity; simpl;
  apply (initial_state_match prog parent0 child1 path0 A) in C;
  rewrite C; try (apply superset_pc_true in D); apply D.

Ltac wrong_ind_auto :=
  match goal with
  | IH: forall (final_cs' : concreteState) (n' : nat)
      (cpath : list ConcreteNode),
       concrete_eval ?prog {{final_cs', n'}} cpath ->
       Datatypes.length ?path = Datatypes.length cpath ->
       forall cs : concreteState,
       initial_state cpath = cs ->
       eval_pc (extractPathCond ?parent) cs = true -> n' = extractIndex ?parent,
    A: concrete_eval ?prog ?parent0 ?path0,
    B: Datatypes.length ?path = Datatypes.length ?path0,
    C: concrete_eval ?prog ?child0 (?child0 :: ?path0),
    D: eval_pc (extractPathCond ?child) (initial_state (?child0 :: ?path0)) = true,
    n0: nat,
    final_cs': concreteState,
    path0: list ConcreteNode,
    prog: Program,
    parent0: ConcreteNode,
    child0: ConcreteNode

  |- _ => wrong_ind IH A B C D final_cs' n0 path0 prog parent0 child0
  end.

Lemma prog_index_match : forall prog node path cs cpath final_cs' n',
  node_eval prog node path ->
  concrete_eval prog {{final_cs', n'}} cpath ->
  initial_state cpath = cs ->
  eval_pc (extractPathCond node) cs = true ->
  length path = length cpath ->
  n' = extractIndex node.
Proof.
  intros. generalize dependent cs. generalize dependent cpath.
  generalize dependent n'. generalize dependent final_cs'.
  induction H; intros.
  - simpl in *. clear H2. destruct cpath. inversion H3.
    destruct cpath.
    + inversion H0; try auto_wrong.
      * reflexivity.
    + inversion H3.
  - inversion H1;
      (* For all inductive cases where constructors don't match, we can
         find the same contradiction. *)
      try (subst; assert (n0 = n);
      simpl in H3; injection H3; intro Hnew; fold child1 in H1;
      try wrong_ind_auto; subst; rewrite H7 in H; discriminate).
      (* For the concrete_eval base case, we can show that the
         path is too short. *)
    + subst. simpl in *. injection H3; intros.
      apply (path_not_empty prog parent path) in H0. destruct H0.
      subst. inversion H2.
      (* When the constructors match, applying the IH doesn't create
         a contradiction in the context. *)
    +subst; assert (n0 = n);
      simpl in H3; injection H3; intro Hnew; fold child0 in H1;
      try wrong_ind_auto; subst; simpl in *; reflexivity.
  - inversion H3;
     try (subst; assert (n0 = n);
      simpl in H4; injection H4; intro Hnew; fold child0 in H3;
      try wrong_ind_auto; subst; rewrite H9 in H; discriminate).
    + subst. simpl in *. injection H4; intros.
      apply (path_not_empty prog parent path) in H2. destruct H2.
      subst. inversion H5.
     (* true case *)
    + subst; assert (n0 = n);
      simpl in H4; injection H4; intro Hnew; fold child1 in H3;
      try wrong_ind_auto. subst. unfold child. reflexivity.
    + subst; assert (n0 = n);
      simpl in H4; injection H4; intro Hnew; fold child1 in H3;
      try wrong_ind_auto. subst. unfold child. simpl. rewrite H9 in H.
      injection H; intros. subst. clear IHnode_eval. clear H. clear H9. clear H4. clear Hnew.

Admitted.

Theorem property_3 : forall prog node path cs cpath final_cs' n',
  (* with some concrete state that we get by symbolically executing and then
  substituting...*)
  (* this may depend on property 2? *)
  let final_cs := fillState cs (extractState node) in
  node_eval prog node path ->
  (*... and assuming the operations are valid/the path is satisfiable ..**)
  eval_pc (extractPathCond node) cs = true ->
  (*... then we have some concrete node in the relation with internal final_cs'
  that is the result of taking some concrete path, cpath. **)
  concrete_eval prog {{final_cs', n'}} cpath ->
  (* additionally, the inital state of our concrete path is equal to the same
   concrete state as before.. *)
  initial_state cpath = cs ->
  (* ... if the lengths of the paths are the same ... *)
  length path = length cpath ->
  (* then the final concrete state that we arrived at via substitution is the
   same one we arrived at via directly executing the program concretely. *)
  final_cs = final_cs'.
Proof.
  intros. generalize dependent cs. generalize dependent cpath.
  generalize dependent final_cs'. generalize dependent n'.
  remember H as E. clear HeqE. induction H; intros.

  (* Base case *)
  - simpl in *. destruct cpath. inversion H3.
    destruct cpath.
      + simpl in *.
        apply (concrete_path_head prog {{final_cs', n'}} [c]) in H1.
        destruct H1. injection H; intros. rewrite H4 in H2. simpl in *.
        subst. clear H. clear H0. clear H3.
        unfold final_cs. unfold st. apply fillEmptySt.
      + simpl in *. inversion H3.

  (* *)
  - inversion H1.
    + subst. destruct path.
      * apply path_not_empty in H0. destruct H0. discriminate.
      * simpl in H3. discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child0).
        { unfold child0. f_equal. easy. easy. } subst.
        apply (initial_state_match prog parent0 child0 path0 H9 H1).
        subst. injection H3; intros. auto. }

      subst. simpl in H7. rewrite H7 in H. injection H; intros; subst.
      simpl in H3. injection H3; intros. clear H3. clear H.
      rewrite <- (initial_state_match prog parent0 child0 path0 H9 H1) in H2.
      assert ((fillState (initial_state path0) (extractState parent)) = cs0).
      { unfold final_cs.
        apply (IHnode_eval H0 n cs0 path0 H9 H4
                           (initial_state path0) H2). reflexivity. }
      subst. clear IHnode_eval. unfold final_cs.
      rewrite <- (initial_state_match prog parent0 child0 path0 H9 H1). simpl.
      f_equal. f_equal. unfold result.
      apply (int_exp_equiv ie (extractState parent) (initial_state path0)).

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child1).
        { unfold child1. f_equal. easy. } subst. easy. subst.
        apply (initial_state_match prog parent0 child1 path0 H10 H1).
        subst. injection H3; intros. auto. }

      subst. simpl in H7. rewrite H7 in H. discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child1).
        { unfold child1. f_equal. easy. } subst. easy. subst.
        apply (initial_state_match prog parent0 child1 path0 H10 H1).
        subst. injection H3; intros. auto. }

      subst. simpl in H7. rewrite H7 in H. discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child1).
        { unfold child1. f_equal. easy. } subst. easy. subst.
        apply (initial_state_match prog parent0 child1 path0 H9 H1).
        subst. injection H3; intros. auto. }

      subst. simpl in H7. rewrite H7 in H. discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child1).
        { unfold child1. f_equal. easy. } subst. easy. subst.
        apply (initial_state_match prog parent0 child1 path0 H10 H1).
        subst. injection H3; intros. auto. }

      subst. simpl in H7. rewrite H7 in H. discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child1).
        { unfold child1. f_equal. easy. } subst. easy. subst.
        apply (initial_state_match prog parent0 child1 path0 H10 H1).
        subst. injection H3; intros. auto. }

      subst. simpl in H7. rewrite H7 in H. discriminate.

  - inversion H3.
    + simpl in *. subst. injection H4; intros.
      apply path_not_empty in H2. destruct H2. subst.
      discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child0).
        { unfold child0. f_equal. rewrite H7. easy. easy. } subst. simpl.
        destruct path0. inversion H11. easy. subst.
        simpl. simpl in H5. destruct (substituteBool sbe
       match path0 with
       | [] => (x, result) :: cs0
       | _ :: _ => initial_state path0
       end). simpl in H5. easy. discriminate.
        subst. injection H4; intros. auto. }

      subst. simpl in H9. rewrite H9 in H. discriminate.

    + assert (n0 = extractIndex parent).
      { apply (prog_index_match prog parent path cs path0 cs0 n0); auto.
        subst cpath. assert ({{final_cs', n'}} = child1).
        { unfold child1. f_equal. rewrite H8. easy. } subst. simpl.
        destruct path0. inversion H11. easy. subst.
        simpl. simpl in H5. destruct (substituteBool sbe
       match path0 with
       | [] => extractConcreteState c
       | _ :: _ => initial_state path0
       end). simpl in H5. easy. discriminate.
        subst. apply (initial_state_match prog parent0 child1 path0 H12 H3).
        subst. injection H4; intros. auto. }

Theorem property_3 : forall prog node path cs,
 let final_cs := fillState cs (extractState node) in
 node_eval prog node path ->
 eval_pc (extractPathCond node) cs = true ->
 exists cpath, concrete_eval prog {{final_cs, (extractIndex node)}} cpath.
Proof.
intros. remember H as E. clear HeqE. induction H; intros.
- simpl. exists [{{final_cs, 0}}]. apply CE_Empty.
- unfold final_cs. simpl in *. apply IHnode_eval in H0. clear IHnode_eval.
  apply (CE_Assign _ x ie) in H0.
  assert (inteval ie (fillState cs st) = substituteInt se cs).
  { unfold se. symmetry. apply int_exp_equiv. }
  rewrite <- H2. apply H0. easy. easy.
- unfold final_cs. apply IHnode_eval in H3.
  apply (CE_IfThen _ be then_body else_body) in H3. simpl in *.
  * easy.
  * easy.
  * simpl. rewrite <- bool_exp_equiv. clear IHnode_eval.
    simpl in H0. rewrite andb_comm in H0.
    apply andb_true_elim2 in H0. easy.
  * simpl. simpl in H0. apply andb_true_elim2 in H0. apply H0.
-
Admitted. *)

(* Setting up new variable names for example 2. *)
Definition J: string := "J".
Definition sJ := Constant 1.
Definition sY := Symbol Y.
Definition sZ2 := Constant 1.
Definition sX := Symbol X.

(** The following program is slightly modified from the program in figure 2 of the King
    paper. Instead of Y >= J, we have Y >=0 since the paper claims that their only
    boolean operation is >= 0. *)
Definition prog_2 := [<{Z := IntLit 1}>;
                      <{J := IntLit 1}>;
                      <{if Y >= 0
                        then [<{Z := Z * X }>;
                              <{Y := Y - J}>;
                                Go_To 2;
                                Finish]
                        else [Finish]
                        end}>;
                        Finish].

(* A satisfying assignment for taking the true branch *)
Definition SAT_assign_prog_2_true_branch: concreteState := (X !-> 1; Y !-> 0 ; _ !-> 0).

(* A satisfying assignment for taking the true branch *)
Definition SAT_assign_prog_2_false_branch: concreteState :=
  (X !-> 1 ; Y !-> -2; _ !-> 0).

(* Starting symbolic state for this example.*)
Definition empty_st_2 := (A !-> sA; B !-> sB; C !-> sC; J !-> sJ; Z !-> sZ2; Y !-> sY;
  X !-> sX; _ !-> (Constant 0)).

(** This symbolic execution tree ends with two leaves. *)
Definition prog_2_leaves :=
  [ Pand (SBnot (SBge0 <{sY s- sJ}>)) (Pand (SBge0 sY) nil); Pand (SBnot (SBge0 sY)) nil ].

(** This proves that the first leaf node does not appear later in the  list of
    leaves. This is sufficient for this case where we just have two leaves, but the
    idea of the proof would be the same for more leaves, just having to repeat for
    the subsequent sublists of leaves.*)
Theorem property_2_ex_2 : forall (pc : PathCond),
  (get_head_pc prog_2_leaves) = pc -> ~ (In pc (tl prog_2_leaves)).
Proof.
  intros. unfold not. unfold prog_2_leaves. intros. inversion H0. simpl in H.
  rewrite <- H in H1. discriminate H1. simpl in H1. destruct H1.
Qed.

(* ===================  End:  Proof of Property 2 for Program 2. ==================== *)


(** * Combi.hook.Frobenius_ident : Frobenius identity *)
(******************************************************************************)
(*      Copyright (C) 2015-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * A proof of Frobenius identity:

The goal of this file is to prove the following identities:
[[
Frobenius_ident n :
    n`! = \sum_(p : 'P_n) (n`! %/ (hook_length_prod p))^2.
]]
and
[[
Theorem Frobenius_ident_rat n :
    1 / (n`!)%:Q = \sum_(p : 'P_n) 1 / (hook_length_prod p)%:Q ^+ 2.
]]
 ******)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype choice ssrnat seq
        ssrint div rat fintype finset bigop path ssralg ssrnum order.
(* Import bigop before ssralg/ssrnum to get correct printing of \sum \prod*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import ordtype partition tableau Schensted std stdtab hook.

Section Identity.

Variable n : nat.

Local Notation stpn := (stdtabn n * stdtabn n)%type.
Lemma card_stpn_shape :
  #|[set p : stpn | shape p.1 == shape p.2]| =
    \sum_(sh : 'P_n) #|{:stdtabsh sh}|^2.
Proof.
pose pairsh (sh : intpartn n) :=
  [set p : stpn | (shape_deg p.1 == sh) && (shape_deg p.2 == sh)].
have pairshP (sh : intpartn n) :
  {t : stdtabsh sh | (stdtabn_of_sh t, stdtabn_of_sh t) \in pairsh sh}.
  by exists (hyper_stdtabsh sh); rewrite inE /= !shape_deg_stdtabn_of_sh eqxx.
pose shpart := [set pairsh sh | sh : intpartn n].
have /card_partition -> :
    partition shpart [set p : stpn | shape_deg p.1 == shape_deg p.2].
  apply/and3P; split.
  - apply/eqP/setP => /= [[t1 t2]]; rewrite inE /=.
    apply/bigcupP/eqP => /= [[S /imsetP [/= sh _ ->{S}]] | eqsh].
    + by rewrite inE => /= /andP [/eqP-> /eqP->].
    + exists [set p : stpn | (shape_deg p.1 == shape_deg t1) &&
                             (shape_deg p.2 == shape_deg t1)].
      apply/imsetP; exists (shape_deg t1) => //.
      by rewrite inE /= eqxx /=; apply/eqP; rewrite /= eqsh.
  - apply/trivIsetP=> /= S1 S2 /imsetP[sh1 _ ->{S1}] /imsetP[sh2 _ ->{S2}] neq.
    have {neq} neqsh : sh1 != sh2 by move: neq; apply contra => /eqP ->.
    rewrite -setI_eq0; apply/set0Pn => /=[[[t1 t2]]].
    rewrite !inE /= -!andbA => /and4P [/eqP ->] _ /eqP eqsh _.
    by rewrite eqsh eqxx in neqsh.
  - apply/negP=> /imsetP [/= sh _] Heq.
    by have [t] := pairshP sh; rewrite -Heq inE.
rewrite big_imset /=; first last.
  move=> sh1 sh2 _ _ eqsh; have [t] := pairshP sh1.
  by rewrite eqsh inE /= shape_deg_stdtabn_of_sh => /andP[/eqP].
apply eq_bigr => sh _; rewrite -mulnn -!cardsT -cardsX.
rewrite [RHS](eq_card (B := setT)) /=; last by move=> p; rewrite !inE.
pose to_stpn (p : (stdtabsh sh) * (stdtabsh sh)) : stpn :=
  (stdtabn_of_sh p.1, stdtabn_of_sh p.2).
have /card_imset <- : injective to_stpn.
  by rewrite /to_stpn => [[t1 t2] [u1 u2]] /= [/val_inj-> /val_inj->].
apply: eq_card => [[/= t1 t2]]; rewrite !inE /=.
apply/andP/imsetP => /= [[/eqP sht1 /eqP sht2] | [[u1 u2] _ [->{t1}->{t2}]]];
  last by rewrite !shape_deg_stdtabn_of_sh.
have t1sh : is_stdtab_of_shape sh t1.
  by rewrite /= stdtabnP /=; have /= -> := (congr1 val sht1).
have t2sh : is_stdtab_of_shape sh t2.
  by rewrite /= stdtabnP /=; have /= -> := (congr1 val sht2).
exists (@StdtabSh sh t1 t1sh, @StdtabSh sh t2 t2sh); first by [].
rewrite /to_stpn /=.
by apply/eqP; rewrite xpair_eqE; apply/andP; split; apply/eqP/val_inj.
Qed.

Lemma card_stpn_shape_hook :
  #|[set p : stpn | shape p.1 == shape p.2]| =
    \sum_(sh : 'P_n) (n`! %/ (hook_length_prod sh))^2.
Proof using.
rewrite card_stpn_shape; apply eq_bigr => sh _; congr (_ ^ 2).
by rewrite HookLengthFormula sumn_intpartn.
Qed.

Theorem Frobenius_ident :
  n`! = \sum_(p : 'P_n) (n`! %/ (hook_length_prod p))^2.
Proof using.
rewrite -{1}card_stdwordn -card_stpn_shape_hook.
have rst1 (w : stdwordn n) : is_stdtab_of_n n (RStabmap w).1.
  by rewrite RStabmapE /= RSstdE stdwordnP /= size_RS size_sdtn.
have rst2 (w : stdwordn n) : is_stdtab_of_n n (RStabmap w).2.
  rewrite /= is_stdtab_RStabmap2 /size_tab -shape_RStabmapE.
  by rewrite RStabmapE -/(size_tab _) size_RS size_sdtn eqxx.
pose to_pair (w : stdwordn n) := (StdtabN (rst1 w), StdtabN (rst2 w)).
pose stdrspair (p : stpn) :=
  if shape p.1 == shape p.2 then (val p.1, val p.2)
  else (val p.1, val p.1) (* Unused *).
have stdrspairP p : is_RStabpair (stdrspair p).
  rewrite /is_RStabpair/stdrspair.
  by case: eqP => /= [-> |_]; rewrite stdtabnP eqxx stdtabP.
pose stdrsinv p := RStabinv (RSTabPair (stdrspairP p)).
have from_pairP p : is_std_of_n n (stdrsinv p).
  case: p => [t1 t2]; rewrite /= /stdrsinv /= -RSstdE -size_RS -RStabmapE.
  rewrite -[RStabmap _]/(val (RStab _)) RStabinvK /stdrspair /=.
  rewrite [(_).1](_ : _ = val t1); last by case (altP (shape t1 =P shape t2)).
  by rewrite stdtabnP /= size_tab_stdtabn.
pose from_pair p := StdWordN (from_pairP p).
have to_pairK : cancel to_pair from_pair.
  move=> w; apply val_inj; rewrite /= /stdrsinv /= /stdrspair /to_pair.
  rewrite [RSTabPair _](_ : _ = RStab w) ?RStabK //.
  apply val_inj; rewrite /= /stdrspair /= shape_RStabmapE eqxx.
  by case: RStabmap.
rewrite -(card_imset _ (can_inj to_pairK)); apply eq_card => [[/= t1 t2]].
rewrite inE /=; apply/imsetP/idP=>/= [[w _ [->{t1}->{t2}/=]] | eqsh].
  by rewrite shape_RStabmapE.
exists (from_pair (t1, t2)); first by [].
apply/eqP; rewrite xpair_eqE /= -!val_eqE /= /stdrsinv.
by rewrite -[RStabmap _]/(val (RStab _)) RStabinvK /= /stdrspair eqsh !eqxx.
Qed.

Local Open Scope ring_scope.

Import GRing.Theory.
Import Num.Theory.

Theorem Frobenius_ident_rat :
  1 / (n`!)%:Q = \sum_(p : 'P_n) 1 / (hook_length_prod p)%:Q ^+ 2.
Proof using.
rewrite -[RHS]mulr1.
have Hfn0 : n`!%:Q != 0 by rewrite intr_eq0 eqz_nat -lt0n fact_gt0.
rewrite -{5}(@divff _ ((n`!%:Q) ^+ 2)); last by rewrite sqrf_eq0.
rewrite mulrA mulr_suml.
rewrite (eq_bigr (fun p : 'P_n => ((n`! %/ (hook_length_prod p)) ^ 2)%N%:Q));
  first last.
  move=> p _; rewrite PoszM intrM.
  have -> : (n`! %/ hook_length_prod p)%:Q = (n`!)%:Q / (hook_length_prod p)%:Q.
    rewrite -[LHS]mulr1 -{2}(@divff _ (hook_length_prod p)%:Q); first last.
      by rewrite intr_eq0 eqz_nat /=; apply: (hook_length_prod_non0 p).
    rewrite !mulrA -intrM -PoszM.
    have:= hook_length_prod_div p.
    by rewrite sumn_intpartn dvdn_eq => /eqP ->.
  by rewrite -expr2 expr_div_n mulrC mul1r.
rewrite -!(big_morph intr (@intrD _) (id2 := 0)) //=.
rewrite -!(big_morph Posz PoszD (id2 := 0%N)) //=.
rewrite -Frobenius_ident expr2.
by rewrite invfM mulrA divff.
Qed.

End Identity.


Require Import Arith Bool List.
Require Import Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Fixpoint happend ls1 ls2 (mls1 : hlist ls1) (mls2 : hlist ls2) : hlist (ls1 ++ ls2) :=
    match mls1 with
    | HNil => mls2
    | HCons _ _ x mls1' => HCons x (happend mls1' mls2)
    end.

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
    | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                        | nil => B elm
                                        | _ :: _ => unit
                                        end) with
        | HFirst _ => tt
        | HNext _ _ _ => tt
        end
    | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                        | nil => Empty_set
                                        | x' :: ls'' =>
                                          B x' -> (member ls'' -> B elm) -> B elm
                                        end) with
        | HFirst _ => fun x _ => x
        | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.
End hlist.

Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].
Implicit Arguments HFirst [A elm ls].
Implicit Arguments HNext [A elm x ls].

Section hmap.
  Variable A : Type.
  Variables B C : A -> Type.
  Variable f : forall x, B x -> C x.

  Fixpoint hmap ls (mls : hlist B ls) : hlist C ls :=
    match mls with
    | HNil => HNil
    | HCons _ _ x mls' => HCons (f x) (hmap mls')
    end.
End hmap.

Implicit Arguments hmap [A B C ls].

Inductive type : Type :=
| Bool : type
| Sum : type -> type -> type.

Fixpoint typeDenote (t : type) : Set :=
  match t with
  | Bool => bool
  | Sum t1 t2 => typeDenote t1 + typeDenote t2
  end%type.

(* pat ts t is a pattern that contains variables of types ts and that
can be used to pattern-match values of type t *)
Inductive pat : list type -> type -> Type :=
| PConst : bool -> pat nil Bool
| PVar : forall t, pat (t :: nil) t
| PInl : forall ts t1 t2, pat ts t1 -> pat ts (Sum t1 t2)
| PInr : forall ts t1 t2, pat ts t2 -> pat ts (Sum t1 t2).

Inductive exp : list type -> type -> Type :=
| Const : forall ts, bool -> exp ts Bool
| Var : forall ts t, member t ts -> exp ts t
| Inl : forall ts t1 t2, exp ts t1 -> exp ts (Sum t1 t2)
| Inr : forall ts t1 t2, exp ts t2 -> exp ts (Sum t1 t2)
| Case : forall ts tin tout tss,
    exp ts tin
    -> hlist
         (* case expression can refer to the variables from the
         enclosing scope as well as to the variables brought into
         scope by pattern-matching *)
         (fun ts' => (pat ts' tin * exp (ts' ++ ts) tout)%type)
         tss
    -> exp ts tout
    -> exp ts tout.

Fixpoint patDenote ts t (p : pat ts t) : typeDenote t -> option (hlist typeDenote ts) :=
  match p with
  | PConst b => fun v =>
      if Bool.bool_dec b v then Some HNil else None
  | PVar _ => fun v =>
      Some (HCons v HNil)
  | PInl _ _ _ p' => fun v =>
      match v with
      | inl v' => patDenote p' v'
      | inr _ => None
      end
  | PInr _ _ _ p' => fun v =>
      match v with
      | inl _ => None
      | inr v' => patDenote p' v'
      end
  end.

Fixpoint case t tss A (v : typeDenote t) (cases : hlist (fun ts' => (pat ts' t * (hlist typeDenote ts' -> A))%type) tss) (default : A) : A :=
  match cases with
  | HNil => default
  | HCons _ _ (p, f) cases' =>
    match patDenote p v with
    | None => case v cases' default
    | Some s => f s
    end
  end.

Fixpoint expDenote ts t (e : exp ts t) : hlist typeDenote ts -> typeDenote t :=
  match e with
  | Const _ b => fun _ => b
  | Var _ _ mem => fun s => hget s mem
  | Inl _ _ _ e => fun s => inl (expDenote e s)
  | Inr _ _ _ e => fun s => inr (expDenote e s)
  | Case _ _ _ _ scrutinee cases default => fun s =>
      case
        (expDenote scrutinee s)
        (hmap
           (fun _ case =>
              (fst case,
               fun s' => expDenote (snd case) (happend s' s)))
           cases)
        (expDenote default s)
  end.

Example ex1 :=
  Case
    (Var (HFirst (ls := nil)))
    (HCons
       (PInl Bool (PVar Bool), Inr Bool (Var HFirst))
       (HCons
          (PInr Bool (PVar Bool), Inl Bool (Var HFirst))
          HNil))
    (Var HFirst).

Print ex.

Eval simpl in expDenote ex1 (HCons (x := Sum Bool Bool) (inl true) HNil).
Eval simpl in expDenote ex1 (HCons (x := Sum Bool Bool) (inr false) HNil).

Example ex2 :=
  Case
    (Var (HFirst (ls := nil)))
    (HCons
       (PInl Bool (PVar Bool), Inr (Sum Bool Bool) (Var (HNext HFirst)))
       (HCons
          (PInr Bool (PVar Bool), Inr (Sum Bool Bool) (Inl Bool (Var HFirst)))
          HNil))
    (Inl (Sum Bool Bool) (Var HFirst)).

Eval simpl in expDenote ex2 (HCons (x := Sum Bool Bool) (inl true) HNil).
Eval simpl in expDenote ex2 (HCons (x := Sum Bool Bool) (inr false) HNil).


Require Import Coq.Strings.String.
Require Import fun_util.
Require Import util.

Theorem theo_string_dec :
  forall (s1 s2 : string),
    string_dec s1 s2 <->
    bstring_dec s1 s2 = true.
Proof.
  intros. unfold string_dec, bstring_dec.
  destruct (String.string_dec s1 s2) ; split ;
  (intro H' ; try reflexivity) ;
  inversion H'.
Qed.

Theorem theo_all_true :
  forall (T : Type) (l : list T)
    (f1 : T -> Prop) (f2 : T -> bool),
    (forall (t : T), f1 t <-> f2 t = true)
    -> (all_true f1 l <-> ball_true f2 l = true).
Proof.
  intros. split.
  - induction l.
    + simpl. intro H'. reflexivity.
    + simpl. intro H'. destruct H' as [H1 H2].
      rewrite H in H1. rewrite H1.
      apply IHl. apply H2.
  - induction l.
    + simpl. intro H'. reflexivity.
    + simpl. intro H'. destruct (f2 a) eqn:H''.
      * split.
        { rewrite <- H in H''. apply H''. }
        { apply IHl. apply H'. }
      * inversion  H'.
Qed.

Lemma lemm_in_list :
  forall (T1 T2 : Type)
         (x : T1) (l : list T2)
         (comp : T1 -> T2 -> Prop)
         (bcomp : T1 -> T2 -> bool),
    (forall (v1 : T1) (v2 : T2),
      comp v1 v2 <-> bcomp v1 v2 = true)
    -> (in_list x l comp <->
        bin_list x l bcomp = true).
Proof.
  intros. split.
  - induction l.
    + simpl. intro H'. inversion H'.
    + simpl. intro H'. destruct H' as [H' | H'].
      * apply H in H'. rewrite H'. reflexivity.
      * apply IHl in H'. destruct (bcomp x a).
        { reflexivity. }
        { apply H'. }
  - induction l.
    + simpl. intro H'. inversion H'.
    + simpl. intro H'. destruct (bcomp x a) eqn:H''.
      * left. apply H in H''. apply H''.
      * right. apply IHl. apply H'.
Qed.

Theorem lemm_list_in_list :
  forall (T : Type) (l1 l2 : list T)
         (comp : T -> T -> Prop)
         (bcomp : T -> T -> bool),
    (forall (v1 v2 : T), comp v1 v2 <-> bcomp v1 v2 = true)
    -> (list_in_list l1 l2 comp <-> blist_in_list l1 l2 bcomp = true).
Proof.
  intros. split.
  - induction l1.
    + simpl. intros. reflexivity.
    + intro H1. simpl in H1. destruct H1 as [H1 H2].
      simpl. rewrite lemm_in_list in H1. rewrite H1.
      * apply IHl1. apply H2.
      * apply H.
  - induction l1.
    + simpl. intros. reflexivity.
    + intro H1. simpl in H1. simpl. split.
      destruct (bin_list a l2 bcomp) eqn:H2.
      * rewrite lemm_in_list.
        { apply H2. }
        { apply H. }
      * inversion H1.
      * apply IHl1. destruct (bin_list a l2 bcomp) eqn:H2.
        { apply H1. }
        { inversion H1. }
Qed.

Theorem lemm_same_list :
  forall (T : Type) (l1 l2 : list T)
         (comp : T -> T -> Prop)
         (bcomp : T -> T -> bool),
    (forall (v1 v2 : T), comp v1 v2 <-> bcomp v1 v2 = true)
    -> (same_list l1 l2 comp <-> bsame_list l1 l2 bcomp = true).
Proof.
  intros. split.
  - induction l1.
    + simpl. intro H'. destruct H'.
      * rewrite lemm_list_in_list in H1.
        { rewrite H1. reflexivity. }
        { intros. apply H. }
    + simpl. intro H'. destruct H'. destruct H0.
      rewrite lemm_list_in_list in H2.
      rewrite lemm_in_list in H0.
      * rewrite H0. rewrite H2. rewrite lemm_list_in_list in H1.
        { rewrite H1. reflexivity. }
        { apply H. }
      * apply H.
      * apply H.
  - induction l1.
    + simpl. intro. split.
      * reflexivity.
      * rewrite lemm_list_in_list. rewrite H0. reflexivity.
        apply H.
    + simpl. intro. split.
      * split.
        { destruct (bin_list a l2 bcomp) eqn:H1.
          - rewrite lemm_in_list. rewrite H1. reflexivity.
            + apply H.
          - rewrite lemm_in_list. simpl in H0. inversion H0.
            + apply H. }
        { destruct (blist_in_list l1 l2 bcomp) eqn:H1.
          - destruct (bin_list a l2 bcomp).
            + rewrite lemm_list_in_list.
              * rewrite H1. reflexivity.
              * apply H.
            + rewrite lemm_list_in_list.
              * rewrite H1. reflexivity.
              * apply H.
          - destruct (bin_list a l2 bcomp).
            + simpl in H0. inversion H0.
            + simpl in H0. inversion H0. }
      * destruct (blist_in_list l2 (a :: l1) bcomp) eqn:H1.
        { destruct (bin_list a l2 bcomp).
          - rewrite lemm_list_in_list.
            + rewrite H1. reflexivity.
            + apply H.
          - simpl in H0. inversion H0. }
        { destruct (bin_list a l2 bcomp).
          - destruct (blist_in_list l1 l2 bcomp).
            + simpl in H0. inversion H0.
            + simpl in H0. inversion H0.
          - simpl in H0. inversion H0. }
Qed.

Theorem theo_is_function :
  forall (T : Type) (l : list T)
         (comp : T -> T -> Prop)
         (bcomp : T -> T -> bool),
    (forall (v1 v2 : T), comp v1 v2 <-> bcomp v1 v2 = true)
    -> (is_function l comp <-> bis_function l bcomp = true).
Proof.
  intros. split.
  - induction l.
    + simpl. intro H'. reflexivity.
    + simpl. intro H'. destruct H' as [H1 H2].
      destruct (bin_list a l bcomp) eqn:H3.
      * rewrite <- lemm_in_list in H3.
        unfold not in H1. apply H1 in H3.
        inversion H3. apply H.
      * apply IHl. apply H2.
  - induction l.
    + simpl. intro H'. reflexivity.
    + simpl. intro H'. destruct (bin_list a l bcomp) eqn:H2.
      * inversion H'.
      * split.
        { unfold not. intro H''.
          rewrite lemm_in_list in H''.
          rewrite H2 in H''. inversion H''.
          apply H. }
        { apply IHl. apply H'. }
Qed.


Require Import Relations.

Class REWRITING_SYSTEM (configuration : Set) :=
{
    transition : configuration -> configuration -> Prop
}.

Notation "`( rw ) c1 → c2"  := (@transition _ rw c1 c2)
                                         (no associativity, at level 70, c1 at level 69).
Notation "`( rw ) c1 →+ c2" := (clos_trans_1n _ (@transition _ rw) c1 c2)
                                         (no associativity, at level 70, c1 at level 69).
Notation "`( rw ) c1 →* c2" := (clos_refl_trans_1n _ (@transition _ rw) c1 c2)
                                         (no associativity, at level 70, c1 at level 69).

Notation "c1 → c2"  := (transition c1 c2)                (no associativity, at level 70).
Notation "c1 →+ c2" := (clos_trans_1n _ transition c1 c2)
                                                         (no associativity, at level 70).
Notation "c1 →* c2" := (clos_refl_trans_1n _ transition c1 c2)
                                                         (no associativity, at level 70).

Class LABELED_REWRITING_SYSTEM (label configuration : Set) :=
{
    ltransition : label -> configuration -> configuration -> Prop
}.

Notation "`( rw ) l |~ c1 → c2"  := (@ltransition _ _ rw l c1 c2)
                                      (no associativity, at level 70, c1, l at level 69).
Notation "`( rw ) l |~ c1 →+ c2" := (clos_trans_1n _ (@ltransition _ _ rw l) c1 c2)
                                      (no associativity, at level 70, c1, l at level 69).
Notation "`( rw ) l |~ c1 →* c2" := (clos_refl_trans_1n _ (@ltransition _ _ rw l) c1 c2)
                                      (no associativity, at level 70, c1, l at level 69).

Notation "l |~ c1 → c2"  := (ltransition l c1 c2)
                                         (no associativity, at level 70, c1 at level 69).
Notation "l |~ c1 →+ c2" := (clos_trans_1n _ (ltransition l) c1 c2)
                                         (no associativity, at level 70, c1 at level 69).
Notation "l |~ c1 →* c2" := (clos_refl_trans_1n _ (ltransition l) c1 c2)
                                         (no associativity, at level 70, c1 at level 69).

Instance RWS_is_LRWS                                                               {conf}
    `(REWRITING_SYSTEM conf) : LABELED_REWRITING_SYSTEM unit conf :=
{
    ltransition := fun (_ : unit) => transition
}.

Module Paths.

  Require Import Program.
  Require Export Fin2 Vector2.
  Open Local Scope vector.

Section RWS.

  Context {conf : Set}.
  Context `(REWRITING_SYSTEM conf).

  Definition path_in                                                                  {n}
      (cs : Vector.t conf n) : Prop :=

      match cs with
      | []          => False
      | @cons _ c n cs => forall m : Fin.t n, (c::cs)[@m] → cs[@m]
      end.

  Lemma path_in_snoc :                           forall {n} (cs : Vector.t conf (S n)) c,
      path_in cs -> (last cs) → c -> path_in (cs ++ [c]).

  Proof.
    intros n cs c H0 H1.
    dependent destruction cs.
    revert h H0 H1.
    induction cs;
        intros c0 H0 H1 m.
    - dependent destruction m.
      + auto.
      + inversion m.
    - dependent destruction m.
      + apply (H0 Fin.F1).
      + apply IHcs.
        * intro m0; apply (H0 (Fin.FS m0)).
        * auto.
  Qed.

End RWS.

Section LRWS.

  Context {label : Set} {conf : Set}.
  Context `(LABELED_REWRITING_SYSTEM label conf).

  Definition lpath_in                                                                 {n}
      (cs : Vector.t conf (S n)) (ls : Vector.t label n) : Prop :=

      match cs in Vector.t _ n return Vector.t label (pred n) -> Prop with
      | []          => fun _  => False
      | @cons _ c n cs => fun ls => forall m : Fin.t n, ls[@m] |~ (c::cs)[@m] → cs[@m]
      end ls.

  Lemma lpath_in_snoc :                             forall {n} (cs : Vector.t conf (S n))
                                                             (ls : Vector.t label n) l c,
      lpath_in cs ls  ->  l |~ (last cs) → c  ->  lpath_in (cs ++ [c]) (ls ++ [l]).

  Proof.
    intros n cs ls l c H0 H1.
    dependent destruction cs.
    revert h H0 H1.
    induction cs;
        intros c0 H0 H1 m;
        dependent destruction ls.
    - dependent destruction m.
      + auto.
      + inversion m.
    - dependent destruction m.
      + apply (H0 Fin.F1).
      + apply IHcs.
        * intro m0; apply (H0 (Fin.FS m0)).
        * auto.
  Qed.

End LRWS.

  Definition path  := @path_in.   Arguments path  {conf}         {rws}  {n} _   : rename.
  Definition lpath := @lpath_in.  Arguments lpath {label} {conf} {lrws} {n} _ _ : rename.
  Definition path_snoc := @path_in_snoc.   Arguments path_snoc
                                                       {conf} {rws} {n} _ _ _ _ : rename.
  Definition lpath_snoc := @lpath_in_snoc. Arguments lpath_snoc
                                                {conf} {lrws} {n} _ _ _ _ _ _ _ : rename.

End Paths.


Require Export Coq.Unicode.Utf8.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

(******************************************************************************)
(* Representation of types.                                                   *)
(******************************************************************************)

Inductive Kind : Set :=
  | star
  | karr (K1 K2 : Kind).

Inductive Ty : Set :=
  | tvar (X : nat)
  | tabs (K : Kind) (T : Ty)
  | tapp (T1 T2 : Ty)
  | tarr (T1 T2 : Ty).

(******************************************************************************)
(* Representation of terms.                                                   *)
(******************************************************************************)

Inductive Tm : Set :=
  | var   (x  : nat)
  | abs   (T  : Ty) (t  : Tm)
  | app   (t1 t2 : Tm).

(******************************************************************************)
(* Representation of contexts.                                                *)
(******************************************************************************)

Inductive Env : Set :=
  | empty
  | evar  (Γ : Env) (T : Ty)
  | etvar (Γ : Env) (K : Kind).


Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms Coq.Relations.Relation_Definitions.

Lemma PER_valid_l {A} {R : relation A} {HS : Symmetric R} {HT : Transitive R} x y (H : R x y) : Proper R x.
Proof. hnf; etransitivity; eassumption || symmetry; eassumption. Qed.
Lemma PER_valid_r {A} {R : relation A} {HS : Symmetric R} {HT : Transitive R} x y (H : R x y) : Proper R y.
Proof. hnf; etransitivity; eassumption || symmetry; eassumption. Qed.
Global Hint Extern 10 (Proper ?R ?x) => simple eapply (@PER_valid_l _ R); [ | | solve [ auto with nocore ] ] : typeclass_instances.
Global Hint Extern 10 (Proper ?R ?x) => simple eapply (@PER_valid_r _ R); [ | | solve [ auto with nocore ] ] : typeclass_instances.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                Yokouchi.v                                *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

         (* Theoreme utilise pour la preuve de
            confluence du lambda-sigma-lift-calcul *)

Require Import sur_les_relations.

Section YokouchiS.
 Variable A : Set.
 Variable R S : A -> A -> Prop.
 Hypothesis C : explicit_confluence _ R.
 Hypothesis N : explicit_noetherian _ R.
 Hypothesis SC : explicit_strong_confluence _ S.
 Definition Rstar_S_Rstar :=
   explicit_comp_rel _ (explicit_star _ R)
     (explicit_comp_rel _ S (explicit_star _ R)).
 Hypothesis
   commut1 :
     forall f g h : A,
     R f h ->
     S f g -> exists k : A, explicit_star _ R g k /\ Rstar_S_Rstar h k.

   Goal
forall f g h : A,
explicit_star _ R f g -> Rstar_S_Rstar g h -> Rstar_S_Rstar f h.
   intros f g h H1 H2.
   elim
    (comp_case A (explicit_star _ R)
       (explicit_comp_rel _ S (explicit_star _ R)) g h H2).
   intros f' H3; elim H3; intros H4 H5.
   red in |- *; apply comp_2rel with f'.
   apply star_trans with g; assumption.
   assumption.
   Save comp_l.

   Goal
forall f g h : A,
Rstar_S_Rstar f g -> explicit_star _ R g h -> Rstar_S_Rstar f h.
   intros f g h H1 H2.
   elim
    (comp_case A (explicit_star _ R)
       (explicit_comp_rel _ S (explicit_star _ R)) f g H1).
   intros f' H3; elim H3; intros H4 H5.
   elim (comp_case A S (explicit_star _ R) f' g H5).
   intros f'' H6; elim H6; intros H7 H8.
   red in |- *; apply comp_2rel with f'.
   assumption.
   apply comp_2rel with f''.
   assumption.
   apply star_trans with g; assumption.
   Save comp_r.

   Goal
forall f g h : A,
explicit_star _ R f h ->
S f g -> exists k : A, explicit_star _ R g k /\ Rstar_S_Rstar h k.
   intro f; pattern f in |- *; apply (noetherian_induction A R N);
    intros f0 H g h H1 H2.
   elim (star_case A R f0 h H1); intro H3.
   (* cas f0=h *)
   exists g; split.
   apply star_refl.
   elim H3; red in |- *; apply comp_2rel with f0.
   apply star_refl.
   apply comp_2rel with g; [ assumption | apply star_refl ].
   (* cas f0 R f1 R* h *)
   elim H3; intros f1 H4; elim H4; intros H5 H6.
   cut (exists k : A, explicit_star _ R g k /\ Rstar_S_Rstar f1 k).
   intro H7; elim H7; intros g1 H8; elim H8; intros H9 H10.
   2: apply commut1 with f0; assumption.
   cut
    (exists f2 : A,
       explicit_star _ R f1 f2 /\
       explicit_comp_rel _ S (explicit_star _ R) f2 g1).
   2: apply comp_case; assumption.
   intro H11; elim H11; intros f2 H12; elim H12; intros H13 H14.
   cut (exists f3 : A, S f2 f3 /\ explicit_star _ R f3 g1).
   2: apply comp_case; assumption.
   intro H15; elim H15; intros f3 H16; elim H16; intros H17 H18.
   elim (C f1 h f2 H6 H13); intros h1 H19; elim H19; intros H20 H21.
   elim (H f2) with f3 h1.
   2: apply comp_relplus; apply comp_2rel with f1; assumption.
   2: assumption.
   2: assumption.
   intros h2 H22; elim H22; intros H23 H24.
   elim (C f3 h2 g1 H23 H18); intros k H25; elim H25; intros H26 H27.
   exists k; split.
   apply star_trans with g1; assumption.
   apply comp_l with h1.
   assumption.
   apply comp_r with h2; assumption.
   Save commut2.

   Theorem Yokouchi : explicit_strong_confluence _ Rstar_S_Rstar.
   unfold explicit_strong_confluence in |- *; intro f; pattern f in |- *;
    apply (noetherian_induction1 A R N).
   intros f0 H; unfold strong_confluence_en in |- *; intros g h H1 H2.
   cut
    (exists u : A,
       explicit_star _ R f0 u /\
       explicit_comp_rel _ S (explicit_star _ R) u h).
   2: apply comp_case; assumption.
   intro H3; elim H3; intros f1 H4; elim H4; intros H5 H6.
   cut
    (exists u : A,
       explicit_star _ R f0 u /\
       explicit_comp_rel _ S (explicit_star _ R) u g).
   2: apply comp_case; assumption.
   intro H7; elim H7; intros g1 H8; elim H8; intros H9 H10.
   elim (star_case A R f0 f1 H5); intro H11.
   elim (star_case A R f0 g1 H9); intro H12.
   (* cas f0 SR* h et f0 SR* h *)
   generalize H6; elim H11; intro H6'.
   generalize H10; elim H12; intro H10'.
   elim (comp_case A S (explicit_star _ R) f0 h H6'); intros f2 H13.
   elim H13; intros H14 H15.
   elim (comp_case A S (explicit_star _ R) f0 g H10'); intros g2 H16.
   elim H16; intros H17 H18.
   elim (SC f0 f2 g2 H14 H17); intros k1 H19; elim H19; intros H20 H21.
   elim (commut2 g2 k1 g H18 H21); intros k2 H22; elim H22; intros H23 H24.
   elim (commut2 f2 k1 h H15 H20); intros h1 H25; elim H25; intros H26 H27.
   elim (C k1 h1 k2 H26 H23); intros k H28; elim H28; intros H29 H30.
   exists k; split.
   apply comp_r with k2; assumption.
   apply comp_r with h1; assumption.
   (* cas f0 R* g1 SR* g et f0 SR* h *)
   elim H12; intros g2 H13; elim H13; intros H14 H15.
   generalize H6; elim H11; intro H6'.
   elim (comp_case A S (explicit_star _ R) f0 h H6'); intros f2 H16.
   elim H16; intros H17 H18.
   elim (commut1 f0 f2 g2 H14 H17); intros k1 H19; elim H19; intros H20 H21.
   elim (C f2 h k1 H18 H20); intros h1 H22; elim H22; intros H23 H24.
   elim (H g2 H14 g h1).
   2: red in |- *; apply comp_2rel with g1; assumption.
   2: apply comp_r with k1; assumption.
   intros k H25; elim H25; intros H26 H27.
   exists k; split.
   assumption.
   apply comp_l with h1; assumption.
   (* cas f0 RR* f1 SR* h et f0 R*SR* g *)
   elim H11; intros f2 H12; elim H12; intros H13 H14.
   elim (C f0 f2 g1).
   2: apply star_trans1 with f2.
   2: assumption.
   2: apply star_refl.
   2: assumption.
   intros k1 H15; elim H15; intros H16 H17.
   elim (comp_case A S (explicit_star _ R) g1 g H10); intros g2 H18.
   elim H18; intros H19 H20.
   elim (commut2 g1 g2 k1 H17 H19); intros k2 H21; elim H21; intros H22 H23.
   elim (C g2 k2 g H22 H20); intros k3 H24; elim H24; intros H25 H26.
   elim (H f2 H13 h k3).
   2: red in |- *; apply comp_2rel with f1; assumption.
   2: apply comp_l with k1.
   2: assumption.
   2: apply comp_r with k2; assumption.
   intros k H27; elim H27; intros H28 H29.
   exists k; split.
   apply comp_l with k3; assumption.
   assumption.
   Qed.

End YokouchiS.


Require Import Lists.List Lists.ListSet Vector Arith.PeanoNat Util.

Module Type REL.
  Parameter R : nat -> Type.
  Parameter V : Type.
  Definition T := Vector.t V.
  Parameter memb   : forall n, R n -> T n -> nat.
  Parameter plus  : forall n, R n -> R n -> R n.
  Parameter minus : forall n, R n -> R n -> R n.
  Parameter inter : forall n, R n -> R n -> R n.
  Parameter times : forall m n, R m -> R n -> R (m + n).
  Parameter sum   : forall m n, R m -> (T m -> T n) -> R n.
  Parameter rsum  : forall m n, R m -> (T m -> R n) -> R n.
  Parameter sel   : forall n, R n -> (T n -> bool) -> R n.
  Parameter flat  : forall n, R n -> R n.
  Parameter supp  : forall n, R n -> list (T n).

  Implicit Arguments memb [n].
  Implicit Arguments plus [n].
  Implicit Arguments minus [n].
  Implicit Arguments inter [n].
  Implicit Arguments times [m n].
  Implicit Arguments sum [m n].
  Implicit Arguments rsum [m n].
  Implicit Arguments sel [n].
  Implicit Arguments flat [n].
  Implicit Arguments supp [n].

  Definition card := fun n S => memb (@sum n 0 S (fun _ => Vector.nil _)) (Vector.nil _).
  Implicit Arguments card [n].

  Parameter Rnil : forall n, R n.
  Parameter Rone : R 0.
  Parameter Rsingle : forall n, T n -> R n.

  Implicit Arguments Rnil [n].
  Implicit Arguments Rsingle [n].

  (* generalized cartesian product of m relations, each taken with its arity n *)
  Fixpoint prod (Rl : list { n : nat & R n })
    : R (list_sum (List.map (projT1 (P := fun n => R n)) Rl)) :=
  match Rl as r return R (list_sum (List.map (projT1 (P := fun n => R n)) r)) with
  | List.nil => Rone
  | List.cons (existT _ x R) l0 => times R (prod l0)
  end.

  Hypothesis V_eqb : V -> V -> bool.
  Parameter T_eqb : forall n, T n -> T n -> bool.
  Implicit Arguments T_eqb [n].

  Definition flatnat := fun n => match n with 0 => 0 | _ => 1 end.

  Hypothesis V_dec : forall (v w : V), {v = w} + {v <> w}.
  Hypothesis V_eqb_eq : forall (v w : V), V_eqb v w = true <-> v = w.
  Parameter T_dec : forall n, forall (x y : T n), {x = y} + {x <> y}.

  Parameter T_eqb_eq : forall n, forall (v w : T n), T_eqb v w = true <-> v = w.

  Parameter p_fs : forall n, forall r : R n, forall t, memb r t > 0 -> List.In t (supp r).
  Parameter p_fs_r : forall n, forall r : R n, forall t, List.In t (supp r) -> memb r t > 0.
  Parameter p_nodup : forall n, forall r : R n, NoDup (supp r).
  Parameter p_plus : forall n, forall r1 r2 : R n, forall t, memb (plus r1 r2) t = memb r1 t + memb r2 t.
  Parameter p_minus : forall n, forall r1 r2 : R n, forall t, memb (minus r1 r2) t = memb r1 t - memb r2 t.
  Parameter p_inter : forall n, forall r1 r2 : R n, forall t, memb (inter r1 r2) t = min (memb r1 t) (memb r2 t).
  Parameter p_times : forall m n, forall r1 : R m, forall r2 : R n, forall t t1 t2,
                      t = Vector.append t1 t2 -> memb (times r1 r2) t = memb r1 t1 * memb r2 t2.
  Parameter p_sum : forall m n, forall r : R m, forall f : T m -> T n, forall t,
                    memb (sum r f) t = list_sum (List.map (memb r) (filter (fun x => T_eqb (f x) t) (supp r))).
  Parameter p_rsum : forall m n, forall r : R m, forall f : T m -> R n, forall t,
                    memb (rsum r f) t = list_sum (List.map (fun t0 => memb r t0 * memb (f t0) t) (supp r)).
  Parameter p_self : forall n, forall r : R n, forall p t, p t = false -> memb (sel r p) t = 0.
  Parameter p_selt : forall n, forall r : R n, forall p t, p t = true -> memb (sel r p) t = memb r t.
  Parameter p_flat : forall n, forall r : R n, forall t, memb (flat r) t = flatnat (memb r t).
  Parameter p_nil : forall n (t : T n), memb Rnil t = 0.
  Parameter p_one : forall t, memb Rone t = 1.
  Parameter p_single : forall n (t : T n), memb (Rsingle t) t = 1.
  Parameter p_single_neq : forall n (t1 t2 : T n), t1 <> t2 -> memb (Rsingle t1) t2 = 0.

  Parameter p_ext : forall n, forall r s : R n, (forall t, memb r t = memb s t) -> r = s.

End REL.


Set Nested Proofs Allowed.
Require Import Utf8 Reals.
Require Import Main.RingLike.

Canonical Structure reals_ring_like_op : ring_like_op R :=
  {| rngl_zero := R0;
     rngl_one := R1;
     rngl_add := Rplus;
     rngl_mul := Rmult;
     rngl_opt_opp_or_subt := Some (inl Ropp);
     rngl_opt_inv_or_quot := Some (inl Rinv);
     rngl_opt_eqb := None;
     rngl_opt_le := Some Rle |}.

Theorem Rplus_assoc' : ∀ a b c : R, (a + (b + c))%R = (a + b + c)%R.
Proof. intros; now rewrite Rplus_assoc. Qed.

Theorem Rmult_assoc' : ∀ a b c : R, (a * (b * c))%R = (a * b * c)%R.
Proof. intros; now rewrite Rmult_assoc. Qed.

Theorem Rcharacteristic_prop :
  let ror := reals_ring_like_op in
  ∀ i : nat, rngl_of_nat (S i) ≠ 0%L.
Proof.
intros.
assert (H : ∀ n, rngl_of_nat n = INR n). {
  intros.
  induction n; [ easy | cbn ].
  destruct n; [ apply Rplus_0_r | ].
  rewrite IHn.
  apply Rplus_comm.
}
rewrite H.
now apply not_0_INR.
Qed.

Theorem Ropt_mul_le_compat_nonneg :
  let ror := reals_ring_like_op in
  ∀ a b c d : R, (0 ≤ a ≤ c)%L → (0 ≤ b ≤ d)%L → (a * b ≤ c * d)%L.
Proof.
intros * Hac Hbd.
now apply Rmult_le_compat.
Qed.

Theorem Ropt_mul_le_compat_nonpos :
  let ror := reals_ring_like_op in
  ∀ a b c d : R, (c ≤ a ≤ 0)%L → (d ≤ b ≤ 0)%L → (a * b ≤ c * d)%L.
Proof.
intros * Hca Hdb; cbn.
apply Rle_trans with (r2 := (a * d)%R). {
  now apply Rmult_le_compat_neg_l.
}
rewrite (Rmult_comm a), (Rmult_comm c).
apply Rmult_le_compat_neg_l; [ | easy ].
now apply Rle_trans with (r2 := b).
Qed.

Theorem Ropt_not_le :
  let ror := reals_ring_like_op in
  ∀ a b : R, ¬ (a ≤ b)%L → a = b ∨ (b ≤ a)%L.
Proof.
intros * Hab.
cbn in Hab |-*.
apply Rnot_le_lt in Hab.
specialize (Rle_or_lt b a) as H1.
destruct H1 as [| Hba]; [ now right | left ].
now apply Rlt_asym in Hba.
Qed.

Canonical Structure reals_ring_like_prop : ring_like_prop R :=
  {| rngl_mul_is_comm := true;
     rngl_has_dec_le := false;
     rngl_is_integral := true;
     rngl_is_alg_closed := false;
     rngl_characteristic := 0;
     rngl_add_comm := Rplus_comm;
     rngl_add_assoc := Rplus_assoc';
     rngl_add_0_l := Rplus_0_l;
     rngl_mul_assoc := Rmult_assoc';
     rngl_mul_1_l := Rmult_1_l;
     rngl_mul_add_distr_l := Rmult_plus_distr_l;
     rngl_opt_mul_comm := Rmult_comm;
     rngl_opt_mul_1_r := NA;
     rngl_opt_mul_add_distr_r := NA;
     rngl_opt_add_opp_l := Rplus_opp_l;
     rngl_opt_add_sub := NA;
     rngl_opt_sub_sub_sub_add := NA;
     rngl_opt_mul_sub_distr_l := NA;
     rngl_opt_mul_sub_distr_r := NA;
     rngl_opt_mul_inv_l := Rinv_l;
     rngl_opt_mul_inv_r := NA;
     rngl_opt_mul_div := NA;
     rngl_opt_mul_quot_r := NA;
     rngl_opt_eqb_eq := NA;
     rngl_opt_le_dec := NA;
     rngl_opt_integral := Rmult_integral;
     rngl_opt_alg_closed := NA;
     rngl_characteristic_prop := Rcharacteristic_prop;
     rngl_opt_le_refl := Rle_refl;
     rngl_opt_le_antisymm := Rle_antisym;
     rngl_opt_le_trans := Rle_trans;
     rngl_opt_add_le_compat := Rplus_le_compat;
     rngl_opt_mul_le_compat_nonneg := Ropt_mul_le_compat_nonneg;
     rngl_opt_mul_le_compat_nonpos := Ropt_mul_le_compat_nonpos;
     rngl_opt_mul_le_compat := NA;
     rngl_opt_not_le := Ropt_not_le |}.

(* experiment, to make, perhaps, an implementation of algebraic numbers
   where a first step is to generate all monic polynomials with values
   in ℕ; since monic, it is not required to append the coefficient 1 to
   the list representing the polynomial, so we have to generate all
   lists of nat *)

Require Import Arith.
Import List List.ListNotations.
Require Import Main.Misc Main.IterAdd Main.NatRingLike.

(* I don't know how to call that; I temporarily call it "step". It is
   a number associated with a list; the next list must have a "step"
   whose value is nat successor (next of a step 42 must have a step 43 *)
Definition step l :=
  let ron := nat_ring_like_op in
  length l + ∑ (i = 1, length l), l.(i).

(* I implemented that some years ago (hott.v in my reals) *)

Fixpoint nat_of_list_nat l :=
  match l with
  | [] => 0
  | a :: l => 2 ^ a * (2 * nat_of_list_nat l + 1)
  end.

Fixpoint how_many_times_div_by_2_aux iter n :=
  match iter with
  | 0 => 0
  | S i =>
      match n with
      | 0 => 0
      | S m =>
          if Nat.even n then
            1 + how_many_times_div_by_2_aux i (Nat.div2 n)
          else 0
      end
  end.

Definition how_many_times_div_by_2 n := how_many_times_div_by_2_aux n n.

Fixpoint odd_part_of_nat_aux it n :=
  match it with
  | 0 => 42
  | S it' =>
      match n with
      | 0 => 0
      | S m =>
          if Nat.even n then odd_part_of_nat_aux it' (Nat.div2 n)
          else n
      end
  end.

Definition odd_part_of_nat n := odd_part_of_nat_aux n n.

Fixpoint list_nat_of_nat_aux it n :=
  match it with
  | 0 => [42]
  | S it' =>
      if n =? 0 then []
      else
        how_many_times_div_by_2 n ::
        list_nat_of_nat_aux it' (Nat.div2 (odd_part_of_nat n))
  end.

Definition list_nat_of_nat n := list_nat_of_nat_aux (n + 1) n.

Require Import ZArith.

Definition Z_of_nat n :=
  if Nat.odd n then (- Z.of_nat (Nat.div2 (n + 1)))%Z
  else Z.of_nat (Nat.div2 (n + 1)).
Definition list_Z_of_nat n := map Z_of_nat (list_nat_of_nat n).

(*
Compute (list_nat_of_nat 2023).
Compute (nat_of_list_nat [0; 0; 0; 2; 0; 0; 0; 0; 0]%nat).
Compute (map list_nat_of_nat (seq 0 100)).
Open Scope Z_scope.
Compute (map Z_of_nat (seq 0 10)).
Compute (map list_Z_of_nat (seq 0 100)).
Close Scope Z_scope.
Compute (map (λ l, (l, step l, nat_of_list_nat l)) (map list_nat_of_nat (seq 0 100))).
Compute (nat_of_list_nat [6]).
...
Compute (nat_of_list_Z [6]).
*)