Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Inductive multInd (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall (i:I) (b:B i), Set  :=
mlind : forall a, multInd A I B f g (f a) (g (f a)).

Require Import SquiggleEq.UsefulTypes.

(*
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I I₂ : Set)
   (I_R : I -> I₂ -> Prop) (B : I -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
          B_R i i₂ i_R (g i) (g₂ i₂)) (a : A) (a₂ : A₂)
   (i_R : I_R (f a) (f₂ a₂))
   (b_R : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)))
   (sigt_R : {a_R : A_R a a₂ &
             Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B
               B₂ B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂)
               (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂))
               (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R})
   (retTyp_R : forall (i_R0 : I_R (f a) (f₂ a₂))
                 (b_R0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))),
               {a_R : A_R a a₂ &
               Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R
                 B B₂ B_R f f₂ f_R g g₂ g_R (f a)
                 (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                 (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R0 b_R0} ->
               Set)
   (rett_R : forall a_R : A_R a a₂,
             retTyp_R (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
               (existT
                  (fun a_R0 : A_R a a₂ =>
                   Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂
                     I_R B B₂ B_R f f₂ f_R g g₂ g_R
                     (f a) (f₂ a₂) (f_R a a₂ a_R0)
                     (g (f a)) (g₂ (f₂ a₂))
                     (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0))
                     (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))) a_R
                  (Top_multIndices2_multInd_pmtcty_RR0_indicesc A A₂ A_R I I₂
                     I_R B B₂ B_R f f₂ f_R g g₂ g_R
                     (f a) (f₂ a₂) (f_R a a₂ a_R)
                     (g (f a)) (g₂ (f₂ a₂))
                     (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))))) =>
 sigT_rec
   (fun
      sigt_R0 : {a_R : A_R a a₂ &
                Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R
                  B B₂ B_R f f₂ f_R g g₂ g_R (f a)
                  (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                  (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R} =>
    retTyp_R i_R b_R sigt_R0)
   (fun a_R : A_R a a₂ =>
    match
      sigt_R in
      (Top_multIndices2_multInd_pmtcty_RR0_indices _ _ _ _ _ _ _ _ _ _ _ _ _
       _ _ _ _ _ _ _ _ i_R0 b_R0)
      return
        (fun
           sigt_R1 : Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I
                       I₂ I_R B B₂ B_R f f₂ f_R g g₂ g_R
                       (f a) (f₂ a₂) (f_R a a₂ a_R)
                       (g (f a)) (g₂ (f₂ a₂))
                       (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R0 b_R0 =>
         retTyp_R i_R0 b_R0
           (existT
              (fun a_R0 : A_R a a₂ =>
               Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R
                 B B₂ B_R f f₂ f_R g g₂ g_R (f a)
                 (f₂ a₂) (f_R a a₂ a_R0) (g (f a))
                 (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) i_R0 b_R0)
              a_R sigt_R1))
    with
    | Top_multIndices2_multInd_pmtcty_RR0_indicesc _ _ _ _ _ _ _ _ _ _ _ _ _
      _ _ _ _ _ _ _ _ => rett_R a_R
    end))

*)

Run TemplateProgram (genParamInd [] true true "Top.multIndices2.multInd").

(*
(fix
 Top_multIndices2_multInd_pmtcty_RR0 (A A₂ : Set)
                                     (A_R : A -> A₂ -> Prop)
                                     (I I₂ : Set)
                                     (I_R : I -> I₂ -> Prop)
                                     (B : I -> Set)
                                     (B₂ : I₂ -> Set)
                                     (B_R : forall (H : I) (H0 : I₂),
                                            I_R H H0 ->
                                            B H -> B₂ H0 -> Prop)
                                     (f : A -> I)
                                     (f₂ : A₂ -> I₂)
                                     (f_R : forall (H : A) (H0 : A₂),
                                            A_R H H0 -> I_R (f H) (f₂ H0))
                                     (g : forall i : I, B i)
                                     (g₂ : forall i₂ : I₂, B₂ i₂)
                                     (g_R : forall
                                              (i : I)
                                              (i₂ : I₂)
                                              (i_R : I_R i i₂),
                                            B_R i i₂ i_R (g i) (g₂ i₂))
                                     (i : I) (i₂ : I₂)
                                     (i_R : I_R i i₂)
                                     (b : B i) (b₂ : B₂ i₂)
                                     (b_R : B_R i i₂ i_R b b₂)
                                     (H : multInd A I B f g i b)
                                     (H0 : multInd A₂ I₂ B₂ f₂ g₂ i₂ b₂)
                                     {struct H} : Prop :=
   match
     H in (multInd _ _ _ _ _ i0 b0)
     return (forall i_R0 : I_R i0 i₂, B_R i0 i₂ i_R0 b0 b₂ -> Prop)
   with
   | mlind _ _ _ _ _ a =>
       match
         H0 in (multInd _ _ _ _ _ i₂0 b₂0)
         return
           (forall i_R0 : I_R (f a) i₂0,
            B_R (f a) i₂0 i_R0 (g (f a)) b₂0 -> Prop)
       with
       | mlind _ _ _ _ _ a₂ =>
           fun (i_R0 : I_R (f a) (f₂ a₂))
             (b_R0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))) =>
           {a_R : A_R a a₂ &
           Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B
             B₂ B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂)
             (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂))
             (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R0 b_R0}
       end
   end i_R b_R)
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I I₂ : Set)
   (I_R : I -> I₂ -> Prop) (B : I -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
          B_R i i₂ i_R (g i) (g₂ i₂)) (a : A) (a₂ : A₂)
   (i_R : I_R (f a) (f₂ a₂))
   (b_R : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)))
   (sigt_R : {a_R : A_R a a₂ &
             Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R
               B B₂ B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂)
               (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂))
               (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R})
   (retTyp_R : forall (i_R0 : I_R (f a) (f₂ a₂))
                 (b_R0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))),
               {a_R : A_R a a₂ &
               Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂
                 I_R B B₂ B_R f f₂ f_R g g₂ g_R (f a)
                 (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                 (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R0 b_R0} ->
               Set)
   (rett_R : forall a_R : A_R a a₂,
             retTyp_R (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
               (existT
                  (fun a_R0 : A_R a a₂ =>
                   Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I
                     I₂ I_R B B₂ B_R f f₂ f_R g g₂ g_R
                     (f a) (f₂ a₂) (f_R a a₂ a_R0)
                     (g (f a)) (g₂ (f₂ a₂))
                     (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0))
                     (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)))
                  a_R
                  (Top_multIndices2_multInd_pmtcty_RR0_indicesc A A₂ A_R I
                     I₂ I_R B B₂ B_R f f₂ f_R g g₂ g_R
                     (f a) (f₂ a₂) (f_R a a₂ a_R)
                     (g (f a)) (g₂ (f₂ a₂))
                     (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))))) =>
 sigT_rec
   (fun
      sigt_R0 : {a_R : A_R a a₂ &
                Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂
                  I_R B B₂ B_R f f₂ f_R g g₂ g_R
                  (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                  (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R}
    => retTyp_R i_R b_R sigt_R0)
   (fun (a_R : A_R a a₂)
      (sigt_R0 : Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂
                   I_R B B₂ B_R f f₂ f_R g g₂ g_R
                   (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a))
                   (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R)
    =>
    match
      sigt_R0 as sigt_R1 in
      (Top_multIndices2_multInd_pmtcty_RR0_indices _ _ _ _ _ _ _ _ _ _ _ _
       _ _ _ _ _ _ _ _ _ i_R0 b_R0)
      return
        (retTyp_R i_R0 b_R0
           (existT
              (fun a_R0 : A_R a a₂ =>
               Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂
                 I_R B B₂ B_R f f₂ f_R g g₂ g_R (f a)
                 (f₂ a₂) (f_R a a₂ a_R0) (g (f a))
                 (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) i_R0
                 b_R0) a_R sigt_R1))
    with
    | Top_multIndices2_multInd_pmtcty_RR0_indicesc _ _ _ _ _ _ _ _ _ _ _ _
      _ _ _ _ _ _ _ _ _ => rett_R a_R
    end) sigt_R)
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I I₂ : Set)
   (I_R : I -> I₂ -> Prop) (B : I -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
          B_R i i₂ i_R (g i) (g₂ i₂)) (a : A) (a₂ : A₂)
   (a_R : A_R a a₂) =>
 existT
   (fun a_R0 : A_R a a₂ =>
    Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂ B_R
      f f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)
      (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0))
      (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))) a_R
   (Top_multIndices2_multInd_pmtcty_RR0_indicesc A A₂ A_R I I₂ I_R B B₂
      B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
      (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))))

*)

Print multInd_rect.
Print nat_rect.

Definition multInd_recs :=
fun (A I : Set) (B : I -> Set) (f : A -> I) (g : forall i : I, B i)
  (P : forall (i : I) (b : B i), multInd A I B f g i b -> Set)
  (ff : forall a : A, P (f a) (g (f a)) (mlind A I B f g a)) (i : I)
  (a : B i) (m : multInd A I B f g i a) =>
match m as m0 in (multInd _ _ _ _ _ i0 a0) return (P i0 a0 m0) with
| mlind _ _ _ _ _ x => ff x
end.

(*
Parametricity Recursive multInd_recs.
*)

Notation multInd_RR:=Top_multIndices2_multInd_pmtcty_RR0.

SearchAbout multInd.
Definition mlind_RR : forall (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set)
         (I_R : I₁ -> I₂ -> Prop) (B₁ : I₁ -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I₁) (H0 : I₂), I_R H H0 -> B₁ H -> B₂ H0 -> Prop)
         (f₁ : A₁ -> I₁) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (f₁ H) (f₂ H0))
         (g₁ : forall i : I₁, B₁ i) (g₂ : forall i : I₂, B₂ i)
         (g_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂), B_R i₁ i₂ i_R (g₁ i₁) (g₂ i₂))
         (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂),
       multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R
         (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R) (g₁ (f₁ a₁)) (g₂ (f₂ a₂))
         (g_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R)) (mlind A₁ I₁ B₁ f₁ g₁ a₁)
         (mlind A₂ I₂ B₂ f₂ g₂ a₂):=
         Top_multIndices2_multInd_pmtcty_RR0_constr_0.

Run TemplateProgram (mkIndEnv "indTransEnv" ["Top.multIndices2.multInd"]).

Run TemplateProgram (genParam indTransEnv false true "multInd_recs"). (* success!*)

Definition mutInd_CRRinv (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I I₂ : Set)
   (I_R : I -> I₂ -> Prop) (B : I -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂), B_R i i₂ i_R (g i) (g₂ i₂))
   (a : A) (a₂ : A₂) (i_R : I_R (f a) (f₂ a₂))
   (b_R : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)))
   (sigt_R : {a_R : A_R a a₂ &
             Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂
               B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
               (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R b_R})
   (retTyp_R : forall (i_R0 : I_R (f a) (f₂ a₂))
                 (b_R0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))),
               {a_R : A_R a a₂ &
               Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂
                 B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂)
                 (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂))
                 (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) i_R0 b_R0} -> Set)
   (ff : forall a_R : A_R a a₂,
        retTyp_R (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
          (existT
             (fun a_R0 : A_R a a₂ =>
              Top_multIndices2_multInd_pmtcty_RR0_indices A A₂ A_R I I₂ I_R B B₂
                B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)
                (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0))
                (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))) a_R
             (Top_multIndices2_multInd_pmtcty_RR0_indicesc A A₂ A_R I I₂ I_R B B₂
                B_R f f₂ f_R g g₂ g_R (f a) (f₂ a₂) (f_R a a₂ a_R)
                (g (f a)) (g₂ (f₂ a₂)) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))))) :
  (retTyp_R i_R b_R sigt_R).
Proof.
  Show Proof.
  revert sigt_R.
  Show Proof.
  apply sigT_rec.
  Show Proof.
Arguments sigT_rec : clear implicits.
  Show Proof. intros a_R.
  intros peq.
  destruct peq.
  exact (ff a_R).
  Print sigT_rec.
Defined.
  Arguments existT {A} {P} x p.
  Arguments sigT_rec {A} {P} P0 f s.
Definition multIndices_recs:
forall (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set)
         (I_R : I₁ -> I₂ -> Prop) (B₁ : I₁ -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I₁) (H0 : I₂), I_R H H0 -> B₁ H -> B₂ H0 -> Prop)
         (f₁ : A₁ -> I₁) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (f₁ H) (f₂ H0))
         (g₁ : forall i : I₁, B₁ i) (g₂ : forall i : I₂, B₂ i)
         (g_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂), B_R i₁ i₂ i_R (g₁ i₁) (g₂ i₂))
         (P₁ : forall (i : I₁) (b : B₁ i), multInd A₁ I₁ B₁ f₁ g₁ i b -> Set)
         (P₂ : forall (i : I₂) (b : B₂ i), multInd A₂ I₂ B₂ f₂ g₂ i b -> Set)
         (P_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂) (b₁ : B₁ i₁)
                  (b₂ : B₂ i₂) (b_R : B_R i₁ i₂ i_R b₁ b₂)
                  (H : multInd A₁ I₁ B₁ f₁ g₁ i₁ b₁) (H0 : multInd A₂ I₂ B₂ f₂ g₂ i₂ b₂),
                multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R i₁ i₂ i_R b₁ b₂
                  b_R H H0 -> P₁ i₁ b₁ H -> P₂ i₂ b₂ H0 -> Prop)
         (f0₁ : forall a : A₁, P₁ (f₁ a) (g₁ (f₁ a)) (mlind A₁ I₁ B₁ f₁ g₁ a))
         (f0₂ : forall a : A₂, P₂ (f₂ a) (g₂ (f₂ a)) (mlind A₂ I₂ B₂ f₂ g₂ a)),
       (forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂),
        P_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R) (g₁ (f₁ a₁)) (g₂ (f₂ a₂))
          (g_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R)) (mlind A₁ I₁ B₁ f₁ g₁ a₁)
          (mlind A₂ I₂ B₂ f₂ g₂ a₂)
          (mlind_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R a₁ a₂ a_R)
          (f0₁ a₁) (f0₂ a₂)) ->
       forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂) (a₁ : B₁ i₁)
         (a₂ : B₂ i₂) (a_R : B_R i₁ i₂ i_R a₁ a₂) (m₁ : multInd A₁ I₁ B₁ f₁ g₁ i₁ a₁)
         (m₂ : multInd A₂ I₂ B₂ f₂ g₂ i₂ a₂)
         (m_R : multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R i₁ i₂ i_R a₁ a₂
                  a_R m₁ m₂),
       P_R i₁ i₂ i_R a₁ a₂ a_R m₁ m₂ m_R (multInd_recs A₁ I₁ B₁ f₁ g₁ P₁ f0₁ i₁ a₁ m₁)
         (multInd_recs A₂ I₂ B₂ f₂ g₂ P₂ f0₂ i₂ a₂ m₂)

         := multInd_recs_pmtcty_RR.
(*
Proof using.
  intros. apply multInd_recs_RR.
  rename a_R into b_R.
  revert m_R.
  destruct m₁.
  destruct m₂.
  intros ?.
  simpl in *.
  unfold mlind_RR in H.
  destruct m_R as [a_R peq].
  (* do the remaining in a separate C_RRinv construct? *)
  specialize (H _ _ a_R).
  (* here, peq needs to change to eq_refl *)
  generalize peq.
  generalize b_R.
  generalize i_R.
  apply eq_rect_sigtI.
  simpl.
  exact H.
Defined.
*)
(* see the exact below
  exact ( eq_rect_sigt (I_R (f₁ a) (f₂ a0))
           (fun ir : I_R (f₁ a) (f₂ a0) => B_R (f₁ a) (f₂ a0) ir (g₁ (f₁ a)) (g₂ (f₂ a0)))
           (existT (f_R a a0 a_R) (g_R (f₁ a) (f₂ a0) (f_R a a0 a_R)))
           (fun (a1 : I_R (f₁ a) (f₂ a0))
              (p : B_R (f₁ a) (f₂ a0) a1 (g₁ (f₁ a)) (g₂ (f₂ a0)))
              (e : existT (f_R a a0 a_R) (g_R (f₁ a) (f₂ a0) (f_R a a0 a_R)) = existT a1 p)
            =>
            P_R (f₁ a) (f₂ a0) a1 (g₁ (f₁ a)) (g₂ (f₂ a0)) p (mlind A₁ I₁ B₁ f₁ g₁ a)
              (mlind A₂ I₂ B₂ f₂ g₂ a0) (existT a_R e) (f0₁ a)
              (f0₂ a0)) (H _ _ a_R) i_R b_R peq).
*)


Require Import RelationClasses.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Axioms.
Require Import List.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Syntax.
From PromisingLib Require Import Language.

From sflib Require Import sflib.
From Paco Require Import paco.

Set Implicit Arguments.

Module RegFile.
  Definition t := RegFun.t Const.t.

  Definition init := RegFun.init Const.zero.

  Definition eval_value (rf:t) (val:Value.t): Const.t :=
    match val with
    | Value.reg r => RegFun.find r rf
    | Value.const c => c
    end.

  Definition eval_expr (rf:t) (rhs:Instr.expr): Const.t :=
    match rhs with
    | Instr.expr_val val => eval_value rf val
    | Instr.expr_op1 op op1 => Op1.eval op (eval_value rf op1)
    | Instr.expr_op2 op op1 op2 => Op2.eval op (eval_value rf op1) (eval_value rf op2)
    end.

  Definition eval_rmw (rf:t) (rmw:Instr.rmw) (val:Const.t): Const.t * option Const.t :=
    match rmw with
    | Instr.fetch_add addendum =>
      (Const.add val (eval_value rf addendum), Some (Const.add val (eval_value rf addendum)))
    | Instr.cas o n =>
      if Const.eq_dec (eval_value rf o) val
      then (1, Some (eval_value rf n))
      else (0, None)
    end.

  Inductive eval_instr: forall (rf1:t) (i:Instr.t) (e:ProgramEvent.t) (rf2:t), Prop :=
  | eval_skip
      rf:
      eval_instr
        rf
        Instr.skip
        ProgramEvent.silent
        rf
  | eval_assign
      rf lhs rhs:
      eval_instr
        rf
        (Instr.assign lhs rhs)
        ProgramEvent.silent
        (RegFun.add lhs (eval_expr rf rhs) rf)
  | eval_load
      rf lhs rhs ord val:
      eval_instr
        rf
        (Instr.load lhs rhs ord)
        (ProgramEvent.read rhs val ord)
        (RegFun.add lhs val rf)
  | eval_store
      rf lhs rhs ord:
      eval_instr
        rf
        (Instr.store lhs rhs ord)
        (ProgramEvent.write lhs (eval_value rf rhs) ord)
        rf
  | eval_update_success
      rf lhs loc rmw ordr ordw valr valret valw
      (RMW: eval_rmw rf rmw valr = (valret, Some valw)):
      eval_instr
        rf
        (Instr.update lhs loc rmw ordr ordw)
        (ProgramEvent.update loc valr valw ordr ordw)
        (RegFun.add lhs valret rf)
  | eval_update_fail
      rf lhs loc rmw ordr ordw valr valret
      (RMW: eval_rmw rf rmw valr = (valret, None)):
      eval_instr
        rf
        (Instr.update lhs loc rmw ordr ordw)
        (ProgramEvent.read loc valr ordr)
        (RegFun.add lhs valret rf)
  | eval_fence
      rf ordr ordw:
      eval_instr
        rf
        (Instr.fence ordr ordw)
        (ProgramEvent.fence ordr ordw)
        rf
  | eval_syscall
      rf lhs rhses lhs_val:
      eval_instr
        rf
        (Instr.syscall lhs rhses)
        (ProgramEvent.syscall (Event.mk lhs_val (map (eval_value rf) rhses)))
        (RegFun.add lhs lhs_val rf)
  .

  Definition eq_except (regs:RegSet.t) (rs_src rs_tgt:RegFile.t): Prop :=
    forall reg (REG: ~ RegSet.In reg regs), rs_src reg = rs_tgt reg.

  Global Program Instance eq_except_Equivalence regs: Equivalence (eq_except regs).
  Next Obligation.
    ii. auto.
  Qed.
  Next Obligation.
    ii. rewrite H; auto.
  Qed.
  Next Obligation.
    ii. rewrite H; auto.
  Qed.

  Lemma eq_except_nil rs_src rs_tgt:
    rs_src = rs_tgt <-> eq_except RegSet.empty rs_src rs_tgt.
  Proof.
    econs; i; subst; auto.
    - econs.
    - apply RegFun.ext. i. apply H.
      ii. eapply RegSet.Facts.empty_iff; eauto.
  Qed.

  Lemma eq_except_mon regs1 regs2
        (SUB: RegSet.Subset regs1 regs2):
    eq_except regs1 <2= eq_except regs2.
  Proof.
    ii. specialize (PR reg). apply PR. contradict REG.
    apply SUB. auto.
  Qed.

  Lemma eq_except_singleton r v rs:
    eq_except (RegSet.singleton r) (RegFun.add r v rs) rs.
  Proof.
    ii. unfold RegFun.add, RegFun.find. condtac; auto. subst.
    contradict REG. apply RegSet.Facts.singleton_iff. auto.
  Qed.

  Lemma eq_except_add
        regs rs_src rs_tgt lhs val
        (EQ: eq_except regs rs_src rs_tgt):
    eq_except regs (RegFun.add lhs val rs_src) (RegFun.add lhs val rs_tgt).
  Proof.
    ii. unfold RegFun.add. condtac; ss.
    apply EQ. ss.
  Qed.

  Lemma eq_except_value
        rs_src rs_tgt regs v
        (REGS: RegSet.disjoint regs (Value.regs_of v))
        (RS: eq_except regs rs_src rs_tgt):
    RegFile.eval_value rs_src v = RegFile.eval_value rs_tgt v.
  Proof.
    destruct v; auto. ss. apply RS. ii.
    eapply REGS; eauto.
    apply RegSet.Facts.singleton_iff. auto.
  Qed.

  Lemma eq_except_value_list
        rs_src rs_tgt regs vl
        (REGS: RegSet.disjoint regs (Value.regs_of_list vl))
        (RS: eq_except regs rs_src rs_tgt):
    map (RegFile.eval_value rs_src) vl = map (RegFile.eval_value rs_tgt) vl.
  Proof.
    revert REGS. induction vl; ss. i. f_equal.
    - eapply eq_except_value; eauto.
      ii. eapply REGS; eauto.
      destruct a; ss.
      + apply RegSet.singleton_spec in RHS. subst.
        apply RegSet.add_spec. auto.
      + inv RHS.
    - apply IHvl.
      ii. eapply REGS; eauto.
      destruct a; ss.
      apply RegSet.add_spec. auto.
  Qed.

  Lemma eq_except_expr
        rs_src rs_tgt regs e
        (REGS: RegSet.disjoint regs (Instr.regs_of_expr e))
        (RS: eq_except regs rs_src rs_tgt):
    RegFile.eval_expr rs_src e = RegFile.eval_expr rs_tgt e.
  Proof.
    destruct e; ss.
    - erewrite eq_except_value; eauto.
    - erewrite eq_except_value; eauto.
    - erewrite (eq_except_value op1); eauto.
      + erewrite (eq_except_value op2); eauto.
        ii. eapply REGS; eauto.
        apply RegSet.union_spec. auto.
      + ii. eapply REGS; eauto.
        apply RegSet.union_spec. auto.
  Qed.

  Lemma eq_except_rmw
        rs_src rs_tgt regs rmw val
        (REGS: RegSet.disjoint regs (Instr.regs_of_rmw rmw))
        (RS: eq_except regs rs_src rs_tgt):
    RegFile.eval_rmw rs_src rmw val = RegFile.eval_rmw rs_tgt rmw val.
  Proof.
    destruct rmw; ss.
    - erewrite ? (@eq_except_value rs_src rs_tgt); eauto.
    - erewrite ? (@eq_except_value rs_src rs_tgt); eauto.
      + ii. eapply REGS; eauto.
        apply RegSet.union_spec. auto.
      + ii. eapply REGS; eauto.
        apply RegSet.union_spec. auto.
  Qed.

  Lemma eq_except_instr
        rs1_src rs1_tgt rs2_tgt regs instr e
        (TGT: RegFile.eval_instr rs1_tgt instr e rs2_tgt)
        (REGS: RegSet.disjoint regs (Instr.regs_of instr))
        (RS: eq_except regs rs1_src rs1_tgt):
    exists rs2_src,
      <<SRC: RegFile.eval_instr rs1_src instr e rs2_src>> /\
      <<RS: eq_except regs rs2_src rs2_tgt>>.
  Proof.
    inv TGT; ss.
    - eexists. splits; eauto. econs.
    - eexists. splits; [econs|].
      ii. generalize (RS reg). i.
      unfold RegFun.add, RegFun.find. condtac; auto. subst.
      eapply eq_except_expr; eauto.
      ii. eapply REGS; eauto.
      apply RegSet.add_spec. auto.
    - eexists. splits; [econs|].
      ii. specialize (RS reg).
      unfold RegFun.add, RegFun.find. condtac; auto.
    - erewrite <- eq_except_value; eauto.
      eexists. splits; [econs|].
      ii. eauto.
    - erewrite <- eq_except_rmw in RMW; eauto.
      + eexists. splits.
        * econs. eauto.
        * ii. unfold RegFun.add. condtac; auto.
          eapply RS; eauto.
      + ii. eapply REGS; eauto.
        apply RegSet.add_spec. auto.
    - erewrite <- eq_except_rmw in RMW; eauto.
      + eexists. splits.
        * econs. eauto.
        * ii. unfold RegFun.add. condtac; auto.
          eapply RS; eauto.
      + ii. eapply REGS; eauto.
        apply RegSet.add_spec. auto.
    - eexists. splits; [econs|]. auto.
    - erewrite <- eq_except_value_list; eauto.
      + eexists. splits; [econs|].
        ii. specialize (RS reg).
        unfold RegFun.add, RegFun.find. condtac; auto.
      + ii. eapply REGS; eauto.
        apply RegSet.add_spec. auto.
  Qed.

  Lemma instr_ord_eval_instr
        rf1 instr_src instr_tgt e_tgt rf2
        (ORD: Instr.ord instr_src instr_tgt)
        (EVAL: RegFile.eval_instr rf1 instr_tgt e_tgt rf2):
    exists e_src,
      <<EVAL: RegFile.eval_instr rf1 instr_src e_src rf2>> /\
      <<ORD: ProgramEvent.ord e_src e_tgt>>.
  Proof.
    inv ORD; inv EVAL; esplits; try by repeat (econs; eauto).
  Qed.
End RegFile.

Module State.
  Structure t := mk {
    regs: RegFile.t;
    stmts: list Stmt.t;
  }.

  Definition init (text:list Stmt.t): t :=
    mk RegFile.init text.

  Definition is_terminal (s:t): Prop :=
    stmts s = nil.

  Inductive step: forall (e:ProgramEvent.t) (s1:t) (s1:t), Prop :=
  | step_instr
      rf1 i e rf2 stmts
      (INSTR: RegFile.eval_instr rf1 i e rf2):
      step e
           (mk rf1 ((Stmt.instr i)::stmts))
           (mk rf2 stmts)
  | step_ite
      rf cond s1 s2 stmts:
      step ProgramEvent.silent
           (mk rf ((Stmt.ite cond s1 s2)::stmts))
           (mk rf ((if RegFile.eval_expr rf cond
                    then s1
                    else s2) ++ stmts))
  | step_dowhile
      rf s cond stmts:
      step ProgramEvent.silent
           (mk rf ((Stmt.dowhile s cond)::stmts))
           (mk rf (s ++ (Stmt.ite cond ((Stmt.dowhile s cond)::nil) nil) :: stmts))
  .
End State.

Program Definition lang :=
  Language.mk
    State.init
    State.is_terminal
    State.step.


From iris.program_logic Require Export language ectx_language ectxi_language.
From Autosubst Require Export Autosubst.

Module stlc.
  Inductive expr :=
    | Rec (e : {bind 2 of expr})
    | Var (x : var)
    | Lam (e : {bind 1 of expr})
    | App (e1 e2 : expr)
    (* Unit *)
    | Unit
    (* Products *)
    | Pair (e1 e2 : expr)
    | Fst (e : expr)
    | Snd (e : expr)
    (* Sums *)
    | InjL (e : expr)
    | InjR (e : expr)
    | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
    (* Recursive Types *)
    | Fold (e : expr)
    | Unfold (e : expr).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  Inductive val :=
    | RecV (e : {bind 1 of expr})
    | LamV (e : {bind 1 of expr})
    | UnitV
    | PairV (v1 v2 : val)
    | InjLV (v : val)
    | InjRV (v : val)
    | FoldV (v : val).

  Fixpoint of_val (v : val) : expr :=
    match v with
    | RecV e => Rec e
    | FoldV v => Fold (of_val v)
    | LamV e => Lam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Rec e => Some (RecV e)
    | Fold e => v ← to_val e; Some (FoldV v)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | FoldCtx
  | UnfoldCtx.

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | FoldCtx => Fold e
    | UnfoldCtx => Unfold e
    end.

  Definition state : Type := ().

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  | BetaS e1 e2 v2 σ :
        to_val e2 = Some v2 →
        head_step (App (Rec e1) e2) σ [] e1.[(Rec e1), e2/] σ []
  | LamBetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  (* Recursive Types *)
  | Unfold_Fold e v σ :
      to_val e = Some v →
      head_step (Unfold (Fold e)) σ [] e σ []
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κ e2 σ2 ef :
    head_step e1 σ1 κ e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κ e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.
End stlc.

(** Language *)
Canonical Structure stlc_ectxi_lang := EctxiLanguage stlc.lang_mixin.
Canonical Structure stlc_ectx_lang := EctxLanguageOfEctxi stlc_ectxi_lang.
Canonical Structure stlc_lang := LanguageOfEctx stlc_ectx_lang.

Export stlc.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.
Local Hint Resolve language.val_irreducible : core.
Local Hint Resolve to_of_val : core.
Local Hint Unfold language.irreducible : core.


Require Import DataTypes Channel Cache Coq.Logic.Classical Hier Coq.Relations.Relation_Operators Coq.Relations.Operators_Properties MsiState.

Module Type CompatBehavior (dt: DataTypes) (ch: ChannelPerAddr dt).
  Import dt ch.
  Section Node.
    Context {n: Cache}.
    Context {a: Addr}.
    Context {t: Time}.
    Axiom sendPCond: forall {p}, defined n -> defined p -> parent n p ->
                                 forall {m},
                                   mark mch n p a t m ->
                                   forall {c}, defined c -> parent c n ->
                                               sle (dir n c a t) (to m).
    Axiom sendCCond: forall {c}, defined n -> defined c ->
                       parent c n ->
                       forall {m},
                         mark mch n c a t m ->
                         sle (to m) (state n a t) /\
                         forall {c'}, defined c' ->
                                      c' <> c -> parent c' n -> sle (dir n c' a t)
                                      match to m with
                                        | Mo => In
                                        | Sh => Sh
                                        | In => Mo
                                      end.
    Axiom oneRespC: forall {c1 c2}, defined n -> defined c1 -> defined c2 ->
                      parent c1 n -> parent c2 n ->
                      forall {m1}, (mark mch n c1 a t m1 \/ recv mch c1 n a t m1) ->
                                   forall {m2},
                                     (mark mch n c2 a t m2 \/ recv mch c2 n a t m2) -> c1 = c2.
    Axiom respPNoRespC: forall {p}, defined n -> defined p -> parent n p ->
                                    forall {m},
                                      (mark mch n p a t m \/ recv mch p n a t m) ->
                                      forall {c}, defined c -> parent c n -> forall mc,
                                        ~ (mark mch n c a t mc \/ recv mch c n a t mc).
  End Node.
  Axiom initCompat:
    forall {n c}, defined n -> defined c -> parent c n -> forall a, dir n c a 0 = In.
End CompatBehavior.

Module Type CompatTheorem (dt: DataTypes) (ch: ChannelPerAddr dt).
  Import dt ch.
  Parameter compatible:
    forall {n}, defined n -> forall a t {c}, defined c -> parent c n ->
                        sle (dir n c a t) (state n a t) /\
                        forall {c'}, defined c' -> c' <> c -> parent c' n -> sle (dir n c' a t)
                                                                   match dir n c a t with
                                                                     | Mo => In
                                                                     | Sh => Sh
                                                                     | In => Mo
                                                                   end.
  Parameter compat:
    forall {n}, defined n -> forall a t {c}, defined c -> parent c n ->
                        sle (state c a t) (state n a t) /\
                        forall {c'}, defined c' -> c' <> c -> parent c' n -> sle (state c' a t)
                                                                   match state c a t with
                                                                     | Mo => In
                                                                     | Sh => Sh
                                                                     | In => Mo
                                                                   end.
  Parameter descSle: forall {c p}, defined c ->
                                   defined p -> descendent c p ->
                                   forall {a t},
                                     sle (state c a t) (state p a t).

  Parameter nonDescCompat: forall {c1 c2},
                           defined c1 -> defined c2 ->
                           ~ descendent c1 c2 -> ~ descendent c2 c1 ->
                           forall {a t},
                             sle (state c2 a t)
                                 match state c1 a t with
                                   | Mo => In
                                   | Sh => Sh
                                   | In => Mo
                                 end.

  Parameter allDirLower: forall {p}, defined p ->
                                     forall {co a t s},
                                       (forall c, defined c -> parent c p
                                                  -> sle (dir p c a t) s) ->
                                       co <> p -> descendent co p -> sle (state co a t) s.
End CompatTheorem.

Module mkCompat (dt: DataTypes) (ch: ChannelPerAddr dt) (cb: CompatBehavior dt ch) (ba: BehaviorAxioms dt ch)
                : CompatTheorem dt ch.
  Module mbt := mkBehaviorTheorems dt ch ba.
  Module hr := mkHierProperties dt.
  Import dt ch cb ba mbt hr.

  Theorem compatible:
    forall {n}, defined n -> forall a t {c}, defined c -> parent c n ->
                        sle (dir n c a t) (state n a t) /\
                        forall {c'}, defined c' -> c' <> c -> parent c' n -> sle (dir n c' a t)
                                                                   match dir n c a t with
                                                                     | Mo => In
                                                                     | Sh => Sh
                                                                     | In => Mo
                                                                   end.
  Proof.
    intros n nDef a t.
    induction t.
    intros c cDef cond.
    constructor.
    pose proof @initCompat n c nDef cDef cond a as c2.
    rewrite c2.
    unfold sle; destruct (state n a 0); auto.
    intros c' c'Def c'_ne_c c'Child.
    pose proof @initCompat n c' nDef c'Def c'Child a as c2.
    rewrite c2; destruct (dir n c a 0); unfold sle; auto.
    destruct (classic (exists p m, defined p /\
                           parent n p /\
                           (mark mch n p a t m \/ recv mch p n a t m))) as [respP|noRespP].
    destruct respP as [p [m [pDef [p_parent markOrRecv]]]].
    pose proof @respPNoRespC n a t p nDef pDef p_parent m markOrRecv as noChild.
    assert (sameDir: forall c, defined c -> parent c n -> dir n c a t = dir n c a (S t)).
    intros c cDef c_child.
    pose proof respPNoRespC nDef pDef p_parent markOrRecv cDef c_child as noRespC.
    assert (st_eq: dir n c a t = dir n c a (S t)).
    assert (stuff: {dir n c a t = dir n c a (S t)} + {dir n c a t <> dir n c a (S t)})
      by decide equality.
    destruct stuff as [eq|neq].
    assumption.
    assert (neq': dir n c a (S t) <> dir n c a t) by auto.
    pose proof (change (@dt n c nDef cDef c_child) neq') as resp.
    generalize noRespC resp; clear; firstorder.
    assumption.
    intros c cDef c_child.
    pose proof (sameDir c cDef c_child) as dir_eq.
    rewrite <- dir_eq in *.
    assert (sameC': forall c', defined c' -> c' <> c -> parent c' n -> dir n c' a t = dir n c' a (S t))
           by (generalize sameDir; clear; firstorder).
    destruct markOrRecv as [markm | recvm].
    pose proof (sendPCond nDef pDef p_parent markm cDef c_child) as dir_le_to_m.
    pose proof (sendmChange (@st p n pDef nDef p_parent) markm) as sth.
    constructor.

    rewrite <- sth in dir_le_to_m.
    assumption.

    intros c' c'Def. intros.
    specialize (sameC' c' c'Def H H0).
    rewrite <- sameC'.
    generalize IHt c cDef c_child c'Def H H0; clear; firstorder.
    constructor.
    pose proof (cRecvUpgrade pDef nDef p_parent recvm) as st_lt.
    generalize (IHt c cDef c_child) st_lt; clear; intros.
    destruct H as [stuff _].
    unfold sle in *; unfold sle in *; destruct (dir n c a t); destruct (state n a t);
    destruct (state n a (S t)); auto.
    intros c' c'Def c'Ne c'_child.
    specialize (sameDir c' c'Def c'_child).
    rewrite <- sameDir.
    generalize IHt c'_child c'Def c'Ne cDef c_child; clear; firstorder.
    assert (noRespP': forall p, defined p -> parent n p -> ~ ((exists m, mark mch n p a t m)
                                                   \/ (exists m, recv mch p n a t m)))
      by (
          generalize noRespP; clear; firstorder).
    assert (st_eq: state n a (S t) = state n a t).
    destruct (classic (exists p, defined p /\ parent n p)) as [[p [pDef p_parent]] | nop].
    specialize (noRespP' p pDef p_parent).
    assert (eqOrNot: {state n a (S t) = state n a t} + {state n a (S t) <> state n a t}) by
        decide equality.
    destruct eqOrNot as [eq|not].
    assumption.
    pose proof (noRespP' (change (@st p n pDef nDef p_parent) not)) as done.
    firstorder.
    assert (noP: forall p, defined p -> ~ parent n p) by firstorder.
    apply (@noParentSame n a t nDef noP).
    rewrite st_eq in *.

    destruct (classic (exists c m, defined c /\ parent c n /\ (mark mch n c a t m \/ recv mch c n a t m))) as [ex|notEx].
    destruct ex as [c [m [cDef [c_child resp]]]].
    assert (noneElse: forall c', defined c' -> c' <> c -> parent c' n ->
                       ~ ((exists m, mark mch n c' a t m) \/ exists m, recv mch c' n a t m)).
    intros c' c'Def c'_ne_c c'_child.
    destruct (classic (exists m', mark mch n c' a t m' \/ recv mch c' n a t m'))
      as [ex|notEx].
    destruct ex as [m' sth].
    pose proof (oneRespC nDef cDef c'Def c_child c'_child resp sth) as sth2.
    assert (c' = c) by auto.
    firstorder.
    firstorder.
    assert (stEq: forall c', defined c' -> c' <> c -> parent c' n -> dir n c' a (S t) = dir n c' a t).
    intros c' c'Def c'_ne_c c'_child.
    specialize (noneElse c' c'Def c'_ne_c c'_child).
    assert (eqOrNot: {dir n c' a (S t) = dir n c' a t}
                     + {dir n c' a (S t) <> dir n c' a t}) by decide equality.
    destruct eqOrNot as [eq|not].
    assumption.
    specialize (noneElse (change (@dt n c' nDef c'Def c'_child) not)).
    firstorder.
    intros c0 c0Def c0_child.
    destruct (classic (c0 = c)) as [c0_eq_c|c0_ne_c].
    rewrite c0_eq_c in *.
    destruct resp as [markm | recvm].
    pose proof (sendmChange (@dt n c nDef cDef c_child) markm) as toM.
    rewrite toM.
    pose proof (sendCCond nDef cDef c_child markm) as [stuff rest].
    constructor.
    intuition.
    intros c' c'Def. intros.
    specialize (stEq c' c'Def H H0).
    rewrite stEq.
    specialize (rest c' c'Def H H0).
    intuition.
    pose proof (pRecvDowngrade nDef cDef c_child recvm) as sth_gt.
    constructor.
    destruct (IHt c cDef c_child) as [good bad].
    unfold slt in *; unfold sle in *; destruct (dir n c a (S t)); destruct (dir n c a t);
    destruct (state n a t); auto.
    clear c0 c0_child c0_eq_c.
    intros c' c'Def c'_ne_c c'_child.
    specialize (stEq c' c'Def c'_ne_c c'_child).
    rewrite stEq in *; clear stEq.
    destruct (IHt c cDef c_child) as [_ rest]; clear IHt.
    specialize (rest c' c'Def c'_ne_c c'_child).
    unfold slt in *; unfold sle in *; destruct (dir n c a (S t)); destruct (dir n c a t);
    destruct (dir n c' a t); auto.

    pose proof (stEq c0 c0Def c0_ne_c c0_child) as stEq'.
    rewrite stEq'.
    constructor.
    generalize IHt c0Def c0_child; clear; firstorder.
    intros c' c'Def c'_ne_c0 c'_child.
    destruct (classic (c' = c)) as [c'_eq_c | c'_ne_c].
    rewrite c'_eq_c in *.
    destruct resp as [markm | recvm].
    pose proof (sendCCond nDef cDef c_child markm) as [_ toMOld].
    assert (c_ne_c0: c0 <> c) by auto.
    specialize (toMOld c0 c0Def c_ne_c0 c0_child).
    rewrite <- c'_eq_c in *; clear c'_eq_c.
    pose proof (sendmChange (dt nDef c'Def c'_child) markm) as sth.
    rewrite sth.
    destruct (dir n c0 a t); destruct (to m); unfold sle in *; auto.

    pose proof (pRecvDowngrade nDef cDef c_child recvm) as sth_gt.
    assert (gtz: slt In (dir n c a t)) by
        (destruct (dir n c a (S t)); destruct (dir n c a t); unfold slt in *; auto).
    pose proof (IHt c0 c0Def c0_child) as [_ sth1].
    specialize (sth1 c c'Def c'_ne_c0 c_child).
    unfold slt in *; unfold sle in *; destruct (dir n c a (S t));
    destruct (dir n c0 a t); destruct (dir n c a t); auto.

    specialize (stEq c' c'Def c'_ne_c c'_child).
    rewrite stEq.
    generalize IHt c0_child c'Def c0Def c'_ne_c0 c'_child; clear; firstorder.

    assert (same: forall c, defined c -> parent c n -> dir n c a (S t) = dir n c a t).
    intros c cDef c_child.
    assert (eqOrNot: {dir n c a (S t) = dir n c a t} + {dir n c a (S t) <> dir n c a t})
           by decide equality.
    destruct eqOrNot as [eq|not].
    assumption.
    pose proof (change (@dt n c nDef cDef c_child) not) as ppp.
    generalize notEx nDef cDef c_child ppp; clear; firstorder.

    intros c cDef c_child.
    constructor.
    specialize (same c cDef c_child).
    rewrite same.
    generalize IHt cDef c_child; clear; firstorder.

    intros c' c'Def. intros.
    pose proof (same c' c'Def H0) as dunk.
    rewrite dunk.
    pose proof (same c cDef c_child) as dukn.
    rewrite dukn in *.
    generalize IHt cDef c'Def c_child H H0; clear; firstorder.
  Qed.

  Theorem compat:
    forall {n}, defined n -> forall a t {c}, defined c -> parent c n ->
                        sle (state c a t) (state n a t) /\
                        forall {c'}, defined c' -> c' <> c -> parent c' n -> sle (state c' a t)
                                                                   match state c a t with
                                                                     | Mo => In
                                                                     | Sh => Sh
                                                                     | In => Mo
                                                                   end.
  Proof.
    intros n nDef a t c cDef c_child.
    pose proof (compatible nDef a t cDef c_child) as base.
    constructor.
    destruct base as [dr _].
    pose proof (conservative nDef cDef c_child a t) as dLe.
    apply (sle_sle_sle dLe dr).
    destruct base as [_ others].
    intros c' c'Def c'_ne p_c'.
    specialize (others c' c'Def c'_ne p_c').
    pose proof (conservative nDef cDef c_child a t) as st.
    pose proof (conservative nDef c'Def p_c' a t) as st'.
    unfold sle in *; destruct (state c' a t); destruct (state c a t);
    destruct (dir n c' a t); destruct (dir n c a t); auto.
  Qed.

  Theorem descSle: forall {c p}, defined c -> defined p -> descendent c p -> forall {a t},
                                                                               sle (state c a t) (state p a t).
  Proof.
    intros c p defC defP c_p a t.
    induction c_p.
    pose proof (compat defP a t defC H) as [use _].
    assumption.
    assert (eq: state x a t = state x a t) by reflexivity.
    apply (sle_eq eq).
    pose proof (rt_trans Tree parent y z hier c_p2 defP) as defY.
    specialize (IHc_p1 defC defY).
    specialize (IHc_p2 defY defP).
    apply (sle_sle_sle IHc_p1 IHc_p2).
  Qed.

  Theorem nonDescCompat: forall {c1 c2},
                           defined c1 -> defined c2 ->
                           ~ descendent c1 c2 -> ~ descendent c2 c1 ->
                           forall {a t},
                             sle (state c2 a t)
                                 match state c1 a t with
                                   | Mo => In
                                   | Sh => Sh
                                   | In => Mo
                                 end.
  Proof.
    intros c1 c2 defC1 defC2 c1_no_c2 c2_no_c1.
    pose proof (hasFork defC1 defC2 c1_no_c2 c2_no_c1) as forkFull.
    destruct forkFull as [fork [defF [[d1 [defD1 [d1_fork [c1_d1 c2_no_d1]]]] [d2 [defD2 [d2_fork [c1_no_d2 c2_d1]]]]] ]].
    intros a t.
    assert (le1: sle (state c1 a t) (state d1 a t)) by (apply descSle; firstorder).
    assert (le2: sle (state c2 a t) (state d2 a t)) by (apply descSle; firstorder).
    assert (d1_ne_d2: d2 = d1 -> False) by (
             intros d1_eq_d2; rewrite d1_eq_d2 in *; firstorder).
    pose proof (compat defF a t defD1 d1_fork) as [_ useful].
    specialize (useful d2 defD2 d1_ne_d2 d2_fork).
    unfold sle in *; destruct (state c1 a t); destruct (state c2 a t);
    destruct (state d1 a t); destruct (state d2 a t); auto.
  Qed.

  Theorem allDirLower: forall {p},
                         defined p ->
                         forall {co a t s},
                           (forall c, defined c -> parent c p -> sle (dir p c a t) s) ->
                           co <> p -> descendent co p -> sle (state co a t) s.
  Proof.
    intros p defP co a t s noDir co_ne_p co_p.
    pose proof (clos_rt_rtn1 Tree parent co p co_p) as trans.
    destruct trans.
    assert (co = co) by reflexivity; firstorder.
    pose proof (clos_rtn1_rt Tree parent co y trans) as co_y.
    clear trans; fold descendent in *.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as y_hier.
    specialize (noDir y y_hier H).
    pose proof (rt_trans Tree parent co y hier co_y y_hier) as co_hier.
    pose proof (@descSle co y co_hier y_hier co_y a t) as useful.
    pose proof (conservative defP y_hier H a t) as final.
    pose proof (sle_sle_sle useful final) as f2.
    apply (sle_sle_sle f2 noDir).
  Qed.
End mkCompat.


Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.Lists.List. Import ListNotations.
Require Import coqutil.Word.Bitwidth32.
Require Import coqutil.Map.Interface coqutil.Map.OfFunc.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Utility.runsToNonDet.
Require riscv.Utility.InstructionNotations.
Require bedrock2.Hexdump.
Require riscv.Spec.PseudoInstructions.
Require Import compiler.SeparationLogic.
Require Import bedrock2.ZnWords.
Require Import riscv.Utility.Encode.
Require Import riscv.Platform.MaterializeRiscvProgram.
Require Import compiler.regs_initialized.
Require Import bedrock2.BasicC32Semantics.
Require Import riscv.Platform.MinimalCSRs.
Require Import coqutil.Map.Z_keyed_SortedListMap.
Require Import compilerExamples.SoftmulBedrock2.
Require Import compilerExamples.SoftmulCompile.
Require Import compilerExamples.Softmul.
Require Import compiler.LowerPipeline.
Require Import bedrock2.ArrayCasts.
Require Import bedrock2.SepAutoArray bedrock2.SepAutoExports.
Require Import bedrock2.SepBulletPoints.
Local Open Scope sep_bullets_scope. Undelimit Scope sep_scope.
Require Import bedrock2.bottom_up_simpl_ltac1.

Definition softmul_binary: list byte := Pipeline.instrencode handler_insts.

Module PrintAssembly.
  Import riscv.Utility.InstructionNotations.
  Goal True. let r := eval cbv in handler_insts in idtac (* r *). Abort.
End PrintAssembly.

Module PrintBytes.
  Import bedrock2.Hexdump.
  Local Open Scope hexdump_scope.
  Set Printing Width 100.
  Goal True. let r := eval cbv in softmul_binary in idtac (* r *). Abort.
End PrintBytes.

Notation Registers := (Zkeyed_map BasicC32Semantics.word).
Notation Mem := BasicC32Semantics.mem.
Notation MachineState := (@State 32 BasicC32Semantics.word Mem Registers).
Notation word := BasicC32Semantics.word.

Definition R(r1 r2: MachineState): Prop :=
  r1.(regs) = r2.(regs) /\
  r1.(pc) = r2.(pc) /\
  r1.(nextPc) = r2.(nextPc) /\
  r1.(csrs) = map.empty /\
  basic_CSRFields_supported r2 /\
  regs_initialized r2.(regs) /\
  exists mtvec_base scratch_end,
    map.get r2.(csrs) CSRField.MTVecBase = Some mtvec_base /\
    map.get r2.(csrs) CSRField.MScratch = Some scratch_end /\
    <{ * eq r1.(mem)
       * mem_available (word.of_Z (scratch_end - 256)) (word.of_Z scratch_end)
       * ptsto_bytes (word.of_Z (mtvec_base * 4)) softmul_binary }> r2.(mem).

Lemma bytearray_to_instr_array: forall insts addr,
    Forall (fun i => verify i Decode.RV32I) insts ->
    iff1 (array ptsto (word.of_Z 1) addr (Pipeline.instrencode insts))
         (array (instr idecode) (word.of_Z 4) addr insts).
Proof.
  intros. revert addr. induction H; intros.
  - cbn. reflexivity.
  - rewrite array_cons.
    unfold Pipeline.instrencode in *. cbn [flat_map]. rewrite array_app.
    rewrite IHForall. clear IHForall.
    rewrite LittleEndian.to_list_split.
    rewrite LittleEndianList.length_le_split.
    bottom_up_simpl_in_goal.
    cancel.
    cbn [seps].
    unfold instr, idecode, truncated_scalar, littleendian, ptsto_bytes.ptsto_bytes.
    setoid_rewrite HList.tuple.to_list_of_list.
    unfold iff1, ex1. intro m. split; intro A.
    + exists (encode x).
      extract_ex1_and_emp_in_goal. split; [|split].
      * exact A.
      * eapply DecodeEncode.decode_encode. assumption.
      * apply EncodeBound.encode_range.
    + fwd. extract_ex1_and_emp_in A. fwd.
      rewrite EncodeDecode.encode_decode; auto.
Qed.

Lemma verify_handler_insts : Forall (fun i => verify i Decode.RV32I) handler_insts.
Proof.
  repeat (eapply Forall_cons || eapply Forall_nil).
  all : cbv; ssplit; trivial; try congruence.
Qed.

Lemma byte_list_to_word_list_roundtrip: forall bs,
    Z.of_nat (List.length bs) mod 4 = 0 ->
    ws2bs 4 (bs2ws (word := word) 4 bs) = bs.
Proof.
  intros. refine (bs2ws2bs _ _).
  change (Memory.bytes_per Syntax.access_size.word) with 4%nat.
  change 4 with (Z.of_nat 4) in H.
  rewrite <- Nat2Z.inj_mod in H.
  Lia.lia.
Qed.

Lemma word_array_to_byte_array: forall addr (bs: list byte) (ws: list word),
    ws2bs 4 ws = bs ->
    iff1 (array scalar (word.of_Z 4) addr ws) (array ptsto (word.of_Z 1) addr bs).
Proof.
  intros. subst bs. refine (bytes_of_words _ _).
Qed.

Lemma split_sepclause_convert: forall (all part part': Mem -> Prop) frame (C: Prop),
    iff1 part' part ->
    split_sepclause all part' frame C ->
    split_sepclause all part frame C.
Proof.
  unfold split_sepclause. intros. rewrite <- H. assumption.
Qed.

Lemma bytelist_length_eq: forall bs n,
    Datatypes.length bs = (n * 4)%nat ->
    (Datatypes.length bs = (n * 4)%nat) =
    (Datatypes.length (bs2ws (word := word) 4 bs) = n).
Proof.
  intros. apply PropExtensionality.propositional_extensionality.
  split; intro A. 2: assumption.
  rewrite bs2ws_length' by Lia.lia.
  rewrite A.
  apply List.Nat.div_up_exact.
  Lia.lia.
Qed.

Lemma R_equiv_related: forall r1 r2,
    R r1 r2 <-> related r1 r2.
Proof.
  unfold R, related, mem_available. split; intros; fwd; intuition try congruence.
  - extract_ex1_and_emp_in_hyps.
    unfold ptsto_bytes, softmul_binary in *.
    do 3 eexists.
    split; [eassumption|].
    split; [eassumption|].
    apply and_comm.
    flatten_seps_in_goal.
    extract_ex1_and_emp_in_goal.
    rename Hp6p2 into M.
    rewrite (iff1ToEq (bytearray_to_instr_array _ (word.of_Z (mtvec_base * 4))
                         verify_handler_insts)) in M.
    scancel_asm.
    split_ith_left_and_cancel_with_fst_right 0%nat.
    1: eapply split_sepclause_convert.
    1: symmetry.
    1: eapply word_array_to_byte_array.
    1: eapply byte_list_to_word_list_roundtrip.
    all: cycle 1.
    1: lazymatch goal with
       | |- context [List.length (bs2ws 4 ?B) = 32%nat] =>
           replace (List.length (bs2ws 4 B) = 32%nat) with
           (List.length B = 128%nat)
       end.
    2: eapply bytelist_length_eq with (n := 32%nat).
    1: unshelve (eauto with split_sepclause_goal).
    1: rename H into Sp.
    1: split.
    1: eapply Sp.
    1: solve [solve_split_sepclause_sidecond_or_pose_err].
    1: clear Sp. (* because there's no "after the call" where we want to merge *)
    1: bottom_up_simpl_in_goal.
    1: rewrite (@List.skipn_all2 _ 256%nat) by listZnWords.
    1: impl_ecancel_step_without_splitting.
    1: impl_ecancel_step_without_splitting.
    1: unfold array.
    1: ssplit.
    1: reflexivity.
    1: listZnWords.
    1: listZnWords.
    1: listZnWords.
    1: listZnWords.
  - extract_ex1_and_emp_in_hyps.
    unfold ptsto_bytes, softmul_binary in *.
    do 2 eexists.
    split; [eassumption|].
    split; [eassumption|].
    flatten_seps_in_goal.
    extract_ex1_and_emp_in_goal.
    rewrite (iff1ToEq (bytearray_to_instr_array _ (word.of_Z (mtvec_base * 4))
                         verify_handler_insts)).
    (* somewhat unusual: hyp is split, goal is more merged *)
    rename Hp6p3 into M.
    seprewrite_in (word_array_to_byte_array (word.of_Z (stack_hi - 128))) M.
    1: reflexivity.
    rewrite (array_app
               anybytes
               (ws2bs 4 stacktrash)
               (word.of_Z (stack_hi - 256))).
    flatten_seps_in_goal. cbn [seps].
    rewrite Hp6p3_emp0.
    bottom_up_simpl_in_goal. bottom_up_simpl_in_hyps.
    (* TODO why doesn't word_simpl canonicalize this? *)
    replace (word.add (word.of_Z (stack_hi - 256)) (word.of_Z 128))
      with (word.of_Z (word := word) (stack_hi - 128)) by ring.
    scancel_asm.
    pose proof (ws2bs_length 4 stacktrash).
    listZnWords.
Qed.

Lemma softmul_correct: forall initialH initialL post,
    runsTo (mcomp_sat (run1 mdecode)) initialH post ->
    R initialH initialL ->
    runsTo (mcomp_sat (run1 idecode)) initialL (fun finalL =>
               exists finalH, R finalH finalL /\ post finalH).
Proof.
  intros.
  eapply R_equiv_related in H0.
  eapply runsTo_weaken.
  1: eapply Softmul.softmul_correct. 1,2: eassumption.
  cbv beta. intros.
  fwd. eapply R_equiv_related in H1p0. eauto.
Qed.

(*
Print Assumptions softmul_correct.
Only two standard axioms:
PropExtensionality.propositional_extensionality : forall P Q : Prop, P <-> Q -> P = Q
FunctionalExtensionality.functional_extensionality_dep
  : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x),
    (forall x : A, f x = g x) -> f = g
*)


From LF Require Export Tactics.

Theorem combine_split' : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [ | [x y] l'].
  - intros l1 l2 H. simpl in H. injection H as H1 H2.
  rewrite <- H1. rewrite <- H2. reflexivity.
  - intros l1 l2 H. simpl in H. destruct (split) as [ t1 t2 ].
  inversion H. simpl. rewrite IHl'.
    + reflexivity.
    + reflexivity.
Qed.

Theorem split_combine' : forall X Y (l1 : list X) (l2 : list Y) (l : list (X*Y)),
  length l1 = length l2 -> combine l1 l2 = l -> split l = (l1, l2).
Proof.
  intros X Y l1 l2 l. generalize dependent l1. generalize dependent l2.
  induction l as [| h t IHl].
  - intros l1 l2 H1 H2. destruct l1 as [| h1 t1].
    + simpl in H1. destruct l2.
      * simpl. reflexivity.
      * rewrite <- H2. inversion H1.
    + simpl. destruct l2 as [| h2 t2].
      * inversion H1.
      * inversion H1. inversion H2.
  - intros l1 l2 H1 H2. destruct l1 as [| h1 t1].
    + destruct l2.
      * inversion H2.
      * inversion H2.
    + destruct l2.
      * inversion H2.
      * simpl. inversion H1. simpl. inversion H2. rewrite H4. destruct split as [g j]. inversion H2.
inversion H2. rewrite H0. rewrite H3. apply IHl in H1.
rewrite <- H1. rewrite <- H3. rewrite <- H3 in H2. simpl in H2. discriminate H1. rewrite <- H2. rewrite <- H3. rewrite H3.
rewrite H2. simpl in H2. rewrite H3 in H2. rewrite <- H2.

rewrite H3. rewrite H3 in H2. rewrite H2. destruct split as [a b].  inversion H0. rewrite H.
    Abort.