From Coq.Init Require Import Notations Datatypes.
Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun seq.
From mathcomp Require Import eqtype choice fintype bigop generic_quotient tuple finfun.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Algebras Submodule Classes Morphism.
Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Include GRing.

Open Scope  lmod_scope.

Section Helpers.
  Variable (R : ringType).
  Section LinearSumSimpl.
    Variable (A B C D E : lmodType R) (Ty : finType) (f : {linear A -> B}) (g : {linear B -> C}) (h : {linear C -> D}) (k : {linear D -> E}) (x : Ty -> A).
    Lemma linear2_sum :
    g (f (\sum_(i : Ty) (x i))) = \sum_(i : Ty) g (f (x i)).
    Proof. by rewrite !linear_sum. Qed.
  End LinearSumSimpl.

  Section LinearSumSimpl.
    Variable (S : finType) (X : lmodType R) (f : S*S -> X).
    Lemma big_pair_diag_eq :
      \sum_(i : S*S | i.2 == i.1)f i
        = \sum_(i : S) f (i, i).
    Proof.
      have : forall (i : S) (_ : true), f (i, i) = \sum_(j : S) if (j == i) then f (i, j) else 0
      by move=>i _;
      rewrite -big_mkcond (big_pred1 i).
      move=> H; rewrite (eq_bigr _ H); clear H.
      by rewrite pair_bigA -big_mkcond
      (eq_bigr (fun i => f (i.1,i.2)) _)=>/=;
        [|move=>i _; destruct i=>/=].
    Qed.
  End LinearSumSimpl.

End Helpers.

Reserved Notation "\bigoplus_ i F"
(at level 36, F at level 36, i at level 50,
  right associativity,
        format "'[' \bigoplus_ i '/ ' F ']'").

Reserved Notation "\bigoplus F"
(at level 36, F at level 36,
  right associativity,
        format "'[' \bigoplus F ']'").

Reserved Notation "\bigoplus_ ( i : t ) F"
(at level 36, F at level 36, i at level 50,
        format "'[' \bigoplus_ ( i : t ) '/ ' F ']'").

Reserved Notation "\bigoplus_ ( i < n ) F"
(at level 36, F at level 36, i, n at level 50,
        format "'[' \bigoplus_ ( i < n ) F ']'").

Reserved Notation "\bigoplus_ ( i 'in' A ) F"
(at level 36, F at level 36, i, A at level 50,
        format "'[' \bigoplus_ ( i 'in' A ) '/ ' F ']'").

Reserved Notation "\proj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj^( I )_ f ']'").

Reserved Notation "\inj^( I )_ f "
(at level 36, f at level 36, I at level 36,
  format "'[' \inj^( I )_ f ']'").

Reserved Notation "\proj_ f ^( I ) "
(at level 36, f at level 36, I at level 36,
  format "'[' \proj_ f '^(' I ) ']'").

Reserved Notation "\inj_ f ^( I )"
(at level 36, f at level 36, I at level 36,
  format "'[' \inj_ f '^(' I ) ']'").

Module dsLmod.
  Module Pair.
    Section Def.
      Variable (R : ringType) (m1 m2 : lmodType R).

      Section Submodule.
        Definition in1 : predPredType (m1*m2) := fun x => x.2 == 0.
        Lemma factor1_subModule : submod_closed (subLmod.qualSubElem in1).
          Proof. split=>[|r x y]; rewrite qualifE !unfold_in; [by rewrite eq_refl| rewrite -!(rwP eqP)=>/=Hx Hy];
          by rewrite Hx Hy scaler0 addr0. Qed.
        Definition sub1 := subLmodPack factor1_subModule.

        Definition in2 : predPredType (m1*m2) := fun x => x.1 == 0.
        Lemma factor2_subModule : submod_closed (subLmod.qualSubElem in2).
          Proof. split=>[|r x y]; rewrite qualifE !unfold_in; [by rewrite eq_refl| rewrite -!(rwP eqP)=>/=Hx Hy];
          by rewrite Hx Hy scaler0 addr0. Qed.
        Definition sub2 := subLmodPack factor1_subModule.
      End Submodule.

      Section Injection.
        Definition inj1_raw := fun x : m1 => (x,zero m2) : pair_lmodType m1 m2.
        Definition inj2_raw := fun x : m2 => (zero m1, x) : pair_lmodType m1 m2.

        Lemma inj1_lin : linear inj1_raw.
        Proof. rewrite /(additive (pair^~0%R))/morphism_2=>r x y.
          rewrite /scale/add=>/=.
          by rewrite /add_pair/scale_pair scaler0 addr0. Qed.
        Lemma inj2_lin : linear inj2_raw.
        Proof. rewrite /(additive (pair^~0%R))/morphism_2=>r x y.
          rewrite /scale/add=>/=.
          by rewrite /add_pair/scale_pair scaler0 addr0. Qed.

        Lemma inj1_injective : injective inj1_raw.
        Proof. by move=>x y H; inversion H. Qed.
        Lemma inj2_injective : injective inj2_raw.
        Proof. by move=>x y H; inversion H. Qed.

        Definition inj1 := Linear inj1_lin.
        Definition inj2 := Linear inj2_lin.

        Lemma inj1_unraw x : inj1_raw x = inj1 x. Proof. by []. Qed.
        Lemma inj2_unraw x : inj2_raw x = inj2 x. Proof. by []. Qed.
      End Injection.

      Section Projection.
        Definition proj1_raw := fun x : pair_lmodType m1 m2 => x.1.
        Definition proj2_raw := fun x : pair_lmodType m1 m2 => x.2.

        Lemma proj1_lin : linear proj1_raw.
        Proof. by rewrite /morphism_2. Qed.
        Lemma proj2_lin : linear proj2_raw.
        Proof. by rewrite /morphism_2. Qed.

        Definition proj1 := Linear proj1_lin.
        Definition proj2 := Linear proj2_lin.

        Lemma proj1_unraw x : proj1_raw x = proj1 x. Proof. by []. Qed.
        Lemma proj2_unraw x : proj2_raw x = proj2 x. Proof. by []. Qed.

        Lemma proj1_inj1K x : proj1 (inj1 x) = x. Proof. by []. Qed.
        Lemma proj2_inj2K x : proj2 (inj2 x) = x. Proof. by []. Qed.
        Lemma proj1_inj20 x : proj1 (inj2 x) = 0. Proof. by []. Qed.
        Lemma proj2_inj10 x : proj2 (inj1 x) = 0. Proof. by []. Qed.
      End Projection.

      Lemma inj_proj_sum x : x = inj1 (proj1 x) + inj2 (proj2 x).
      Proof.
        rewrite /inj1/proj1/inj2/proj2/(add _)=>/=;
        rewrite /add_pair addr0 add0r;
        by destruct x.
      Qed.
    End Def.

    Section MorphismsToDS.
      Variable (R : ringType) (M N1 N2 : lmodType R)
        (f1 : {linear M -> N1}) (f2 : {linear M -> N2}).

      Definition to_ds_raw : M -> (pair_lmodType N1 N2)
        := fun x => (inj1 _ _ (f1 x)) + (inj2  _ _ (f2 x)).

      Lemma to_ds_lin : linear to_ds_raw.
      Proof. rewrite/to_ds_raw=>r x y.
      by rewrite !linearP addrACA scalerDr. Qed.
      Definition to_ds : {linear M -> (pair_lmodType N1 N2)}
        := Linear to_ds_lin.

    End MorphismsToDS.

    Section MorphismsFromDS.
      Variable (R : ringType) (M1 M2 N : lmodType R)
        (f1 : {linear M1 -> N}) (f2 : {linear M2 -> N}).

      Definition from_ds_raw : (pair_lmodType M1 M2) -> N
        := fun x => (f1 (proj1 _ _ x)) + (f2 (proj2  _ _ x)).

      Lemma from_ds_lin : linear from_ds_raw.
      Proof. rewrite/from_ds_raw=>r x y.
      by rewrite !linearP addrACA scalerDr. Qed.

      Definition from_ds : {linear (pair_lmodType M1 M2) -> N}
        := Linear from_ds_lin.

    End MorphismsFromDS.

    Section MorphismsDiag.
      Variable (R : ringType) (M1 M2 N1 N2 : lmodType R)
        (f1 : {linear M1 -> N1}) (f2 : {linear M2 -> N2}).

      Definition diag_raw : (pair_lmodType M1 M2) -> (pair_lmodType N1 N2)
        := fun x => (inj1 _ _ (f1 (proj1 _ _ x))) + (inj2 _ _ (f2 (proj2  _ _ x))).

      Lemma diag_lin : linear diag_raw.
      Proof. rewrite/diag_raw=>r x y.
      by rewrite !linearP addrACA scalerDr. Qed.

      Definition diag : {linear (pair_lmodType M1 M2) -> (pair_lmodType N1 N2)}
        := Linear diag_lin.

    End MorphismsDiag.
    Section MorphismsDiag.
    Variable (R : ringType) (M1 M2 N1 N2 O1 O2 : lmodType R)
      (f1 : {linear M1 -> N1}) (f2 : {linear M2 -> N2})
      (g1 : {linear N1 -> O1}) (g2 : {linear N2 -> O2}).
      Lemma diag_comp : (diag g1 g2) \o (diag f1 f2) = diag (g1 \oLin f1) (g2 \oLin f2).
      Proof. simpl. rewrite/diag_raw=>/=. Admitted.
    End MorphismsDiag.

    Module Exports.
      (*Canonical proj1 {R : ringType} {m1 m2 : lmodType R}
        := locked (proj1 m1 m2).
      Canonical proj2 {R : ringType} {m1 m2 : lmodType R}
        := proj2 m1 m2.

      Canonical inj1 {R : ringType} {m1 m2 : lmodType R}
        := inj1 m1 m2.
      Canonical inj2Lin {R : ringType} {m1 m2 : lmodType R}
        := inj2Lin m1 m2.*)

      Notation lmodDSPairType := pair_lmodType.
      Infix "\oplus" := (pair_lmodType) (at level 35).
      Infix "\linPlusDiag" := (diag) (at level 35).
      Infix "\linPlusRow" := (from_ds) (at level 35).
      Infix "\linPlusCol" := (to_ds) (at level 35).
    End Exports.
  End Pair.
  Export Pair.Exports.

  Module Seq.
    Section Ring.
    Variable (R : ringType).
    Section Environment.
      Variable (T : eqType) (I : T -> lmodType R).

      Section Def.
        Definition Nth := (fun L n
         => match (seq.nth None (map Some L) n) with
         |Some t => I t
         |None => lmodZero.type R
         end).

        Fixpoint DS (L : seq T) : lmodType R
        := match L with
          |nil => lmodZero.type R
          |a'::L' => (I a') \oplus (DS L')
        end.
      End Def.

      Section Submodule.
        Variable (L : seq T) (n : 'I_(size L)).
      End Submodule.

      Section Injection.
      Fixpoint inj_raw (L : seq T) (n : nat) {struct n} :
        Nth L n -> DS L
      := match L as LL return Nth LL n -> DS LL with
        |nil => fun _ => tt
        |a::L' => match n as nn return Nth (a::L') nn -> DS (a::L') with
          |0    => fun x => @Pair.inj1 R (I a) (DS L') x
          |S n' => fun x => @Pair.inj2 R (I a) (DS L') ((@inj_raw L' n') x)
          end
        end.

        Lemma inj_lin (L : seq T) (n : nat) : linear (@inj_raw L n).
        Proof. rewrite /morphism_2.
          move: n; induction L=>//=. {
          induction n=>//=. }{
          move : L IHL; induction n=>//=.
          move=> r x y; apply (linearP (@Pair.inj1 R (I a) (DS L))).
          move=> r x y; rewrite -(linearP (@Pair.inj2 R (I a) (DS L)))=>/=.
          by rewrite (IHL n)=>/=. }
        Qed.

        Lemma inj_injective
          (L : seq T) (n : nat) : injective (@inj_raw L n).
        Proof.
          move: n.
          induction L=>//=. { induction n; by move=> x y; destruct x, y. }
          move: L IHL.
          induction n; move=>/= x y H.
          apply (@Pair.inj1_injective R _ _ x y H).
          apply (IHL n x y (@Pair.inj2_injective R _ _ (@inj_raw L n x) (@inj_raw L n y) H)).
        Qed.
      End Injection.
      Definition inj (L : seq T) (n : nat)
        := Linear (@inj_lin L n).

      Lemma inj_unraw (L : seq T) (n : nat) x : inj_raw x = inj L n x. Proof. by []. Qed.

      Section Projection.
        Fixpoint proj_raw (L : seq T) (n : nat) {struct n} :
        DS L -> Nth L n
      := match L as LL return DS LL -> Nth LL n with
        |nil => match n as nn return lmodZero.type R -> Nth nil nn with
          |0    => fun _ => tt
          |S n' => fun _ => tt
          end
        |a::L' => match n as nn return DS (a::L') -> Nth (a::L') nn with
          |0    => fun x => @Pair.proj1 R (I a) (DS L') x
          |S n' => fun x => (@proj_raw L' n') (@Pair.proj2 R (I a) (DS L') x)
          end
        end.

        Lemma proj_lin (L : seq T) (n : nat) : linear (@proj_raw L n).
        Proof. rewrite /morphism_2.
          move: n.
          induction L=>//=. { induction n=>//=. }
          move: L IHL; induction n=>//=; move=> r x y.
          rewrite !Pair.proj2_unraw linearP.
          by rewrite -(IHL n).
        Qed.
      End Projection.
      Definition proj (L : seq T) (n : nat)
        := Linear (@proj_lin L n).

      Lemma proj_unraw (L : seq T) (n : nat) x : proj_raw n x = proj L n x. Proof. by []. Qed.

      Section Results.
        Section Lemmas.
          Variable (L : seq T).
          Lemma nth_cons {a d} {n : nat} : seq.nth d (a::L) (S n) = seq.nth d L n.
          Proof. by induction n. Qed.

          Lemma inj_cons n a x : @inj (a::L) (S n) x = Pair.inj2 (I a) _ (@inj L n x).
          Proof. by []. Qed.

          Lemma proj_cons n a x : @proj (a::L) (S n) (Pair.inj2 (I a) _ x) = @proj L n x.
          Proof. by []. Qed.

          Lemma proj_inj_cons (n n' : nat) a x
          : @proj (a::L) (n.+1) (@inj (a::L) (n'.+1) x) = @proj L n (@inj L n' x).
          Proof. by []. Qed.
        End Lemmas.
        Variable (L : seq T).

        (* The following two lemmas are used for cancellation *)
        Lemma proj_injK_ofsize (n : 'I_(size L)) x : @proj L (nat_of_ord n) (@inj L (nat_of_ord n) x) = x.
        Proof.
          induction L=>/=. induction n=>//=.
          destruct n as [n N].
          induction n=>//=; simpl in x, IHl, N.
          rewrite -ltn_predRL in N; simpl in N.
          unlock Pair.proj2 Pair.inj2=>/=.
          apply (IHl (Ordinal N) x).
        Qed.

        Lemma proj_inj0_ofsize (n n' : 'I_(size L)) x : (nat_of_ord n) != n' -> @proj L n (@inj L n' x) = 0.
        Proof.
          induction L=>/=.
            induction n=>//=.
          destruct n as [n N], n' as [n' N'].
          simpl in x, IHl, N, N'=>/=H.
          induction n.
            apply (rwP negP) in H.
            by induction n'=>/=; [contradiction H|].
          induction n'=>/=.
            by rewrite proj_unraw linear0.
          rewrite eqSS in H;
          rewrite ltnS in N;
          rewrite ltnS in N';
          by apply (IHl (Ordinal N) (Ordinal N') x H).
        Qed.

        (* The following two lemmas are the same as above but more versitile,
        in that they don't require the index to be an ordinal of size L, simply
        that they are naturals less than size L *)
        Lemma proj_injK (n : nat) x (M : n < size L) : @proj L n (@inj L n x) = x.
        Proof. apply (@proj_injK_ofsize (Ordinal M)). Qed.

        Lemma proj_inj0 m1 m2 (n : 'I_m1) (n' : 'I_m2) x (M1 : m1 <= (size L)) (M2 : m2 <= (size L))
          : (nat_of_ord n) != n' -> @proj L n (@inj L n' x) = 0.
        Proof. apply (@proj_inj0_ofsize (widen_ord M1 n) (widen_ord M2 n')). Qed.

        (* this lemma expresses any element as a sum of projections *)
        Lemma inj_proj_sum x : x = \sum_(n < size L) inj L (nat_of_ord n) (@proj L (nat_of_ord n) x).
        Proof.
          induction L.
          by rewrite /size big_ord0; case x.
          destruct x as [Ia DSl].
          by rewrite big_ord_recl {1}(IHl DSl)
          (Pair.inj_proj_sum (Ia, _)) linear_sum.
        Qed.
      End Results.

      (* Given a direct sum indexed by a seq, we define a function to reform
      the direct sum into the direct sum of two smaller direct sums. *)
      Section Operations.
        Variable (L1 L2 : seq T).
        (*Tr = truncate, Ap = Append, R = right, L = left*)
        Section L1.
          Variable (n : 'I_(size L1)).
          Lemma catTrR_eq : (Nth (L1 ++ L2) n) = (Nth L1 n).
          Proof. destruct n as [n' H].
          by rewrite/Nth map_cat nth_cat size_map H. Qed.

          Definition catTrR : (Nth (L1 ++ L2) n) -> (Nth L1 n).
          Proof. by rewrite catTrR_eq. Defined.

          Definition catApR : (Nth L1 n) -> (Nth (L1 ++ L2) n).
          Proof. by rewrite catTrR_eq. Defined.

          Lemma catTrApR_lin : linear catTrR /\ linear catApR.
          Proof. split; rewrite/catTrR/catApR=>r x y; by destruct(catTrR_eq). Qed.

          Lemma catApTrRK : cancel catTrR catApR /\ cancel catApR catTrR.
          Proof. split; rewrite/catApR/catTrR=>x; by destruct(catTrR_eq). Qed.

          Definition catR : lmodIsomType (Nth (L1 ++ L2) n) (Nth L1 n)
           := lmodIsomBuildPack catTrApR_lin catApTrRK.
        End L1.
        Section L2.
          Variable (n : 'I_(size L2)).

          Lemma catTrL_eq : (Nth (L1 ++ L2) (rshift (size L1) n)) = (Nth L2 n).
          Proof. by simpl; rewrite/Nth map_cat nth_cat size_map
          -{2}(addn0 (size L1)) ltn_add2l addnC addnK. Qed.

          Definition catTrL : (Nth (L1 ++ L2) (rshift (size L1) n)) -> (Nth L2 n).
          Proof.  by rewrite catTrL_eq. Defined.

          Definition catApL : (Nth L2 n) -> (Nth (L1 ++ L2) (rshift (size L1) n)).
          Proof. by rewrite catTrL_eq. Defined.

          Lemma catTrApL_lin : linear catTrL /\ linear catApL.
          Proof. split; rewrite/catTrL/catApL=>r x y;by destruct (catTrL_eq). Qed.

          Lemma catApTrLK : cancel catTrL catApL /\ cancel catApL catTrL.
          Proof. split; rewrite/catApL/catTrL=>x; by destruct(catTrL_eq). Qed.

          Definition catL : lmodIsomType (Nth (L1 ++ L2) (rshift (size L1) n)) (Nth L2 n)
           := lmodIsomBuildPack catTrApL_lin catApTrLK.
        End L2.

        Definition split_raw : DS (L1 ++ L2) -> DS L1 \oplus DS L2
          := fun x =>
          (\sum_(n < size L1)(inj L1 n \oLin catR n \oLin proj (L1 ++ L2) n ) x,
           \sum_(n < size L2)(inj L2 n \oLin catL n \oLin proj (L1 ++ L2) (rshift (size L1) n)) x).

        Definition unsplit_raw : DS L1 \oplus DS L2 -> DS (L1 ++ L2)
        := fun x =>
          \sum_(n < size L1)((inj (L1 ++ L2) n                     \oLin inv(catR n) \oLin proj L1 n) x.1) +
          \sum_(n < size L2)((inj (L1 ++ L2) (rshift (size L1) n)  \oLin inv(catL n) \oLin proj L2 n) x.2).

        Lemma split_lin : linear split_raw.
        Proof. rewrite/split_raw=>r x y/=.
          by rewrite (rwP eqP)/eq_op -(rwP andP) -!(rwP eqP)=>/=;
          rewrite !scaler_sumr -!big_split !(eq_bigr _ (fun i _ => linearP _ _ _ _)).
        Qed.

        Lemma unsplit_lin : linear unsplit_raw.
        Proof. rewrite/unsplit_raw=>r x y/=.
          by rewrite !(eq_bigr _ (fun i _ => linearP _ _ _ _)) !big_split=>/=;
          rewrite -!scaler_sumr scalerDr !addrA (addrC _ (r *: _)) !addrA (addrC (r *: _) (r *: _)).
        Qed.

        Definition split := Linear split_lin.
        Definition unsplit := Linear unsplit_lin.

        Lemma splitsK : cancel split unsplit.
        Proof. simpl; rewrite /unsplit_raw/split_raw=>x.
          rewrite (eq_bigr _ (fun i _ => linear_sum _ _ _ _))
                  (eq_bigr _ (fun i _ => linear_sum _ _ _ _))
          !pair_bigA.
          rewrite (eq_bigr (fun p : 'I_(size L1)*'I_(size L1)
           => if p.2 == p.1
            then inj (L1 ++ L2) p.1 (proj (L1 ++ L2) p.1 x)
            else 0 ) _).
          rewrite (eq_bigr (fun p : 'I_(size L2)*'I_(size L2)
            => if p.2 == p.1
            then inj (L1 ++ L2) (rshift (size L1) p.2) (proj (L1 ++ L2) (rshift (size L1) p.2) x)
            else 0 ) _).
          rewrite -!big_mkcond !big_pair_diag_eq.
          rewrite (eq_bigr (fun p : 'I_(size L1) => inj _  _ (proj _ p x)) _);[|by move].
          rewrite (eq_bigr (fun p : 'I_(size L2) => inj _ _ (proj _ (rshift (size L1) p) x)) _);[|by move].
          by rewrite {3}(@inj_proj_sum _ x) size_cat (@big_split_ord _ _ _ (size L1) (size L2)).
          by move=>p _;
          case (p.2 == p.1) as []eqn:E; rewrite -!linCompChain;
          [apply (rwP eqP) in E; rewrite E proj_injK_ofsize (isomlK (catL p.1)) |
           rewrite proj_inj0_ofsize; [rewrite !linear0|
             rewrite eq_sym/eq_op in E; simpl in E; rewrite E]].
          by move=>p _;
          case (p.2 == p.1) as []eqn:E; rewrite -!linCompChain;
          [ apply (rwP eqP) in E; rewrite E proj_injK_ofsize (isomlK (catR p.1))|
          rewrite proj_inj0_ofsize; [rewrite !linear0|
            rewrite eq_sym/eq_op in E; simpl in E; rewrite E]].
        Qed.

        Lemma splitKs : cancel unsplit split.
        Proof. simpl; rewrite /unsplit_raw/split_raw=>x.
        rewrite (eq_bigr (fun n : 'I_(size L1)
        => (inj _ n \oLin catR n \oLin proj _ n)
            (\sum_(n0 < _) (inj _ n0 \oLin inv(catR n0) \oLin proj _ n0) x.1)
         + (inj _ n \oLin catR n \oLin proj _ n)
            (\sum_(n0 < _) (inj _ (rshift _ n0) \oLin inv(catL n0) \oLin proj _ n0) x.2))
        ); [|by move=>p _; rewrite !raddfD].

        rewrite (eq_bigr (fun n : 'I_(size L2)
        => (inj _ n \oLin catL n \oLin proj _ (rshift _ n))
            (\sum_(n0 < _) (inj _ n0 \oLin inv(catR n0) \oLin proj _ n0) x.1)
         + (inj _ n \oLin catL n \oLin proj _ (rshift _ n))
            (\sum_(n0 < _) (inj _ (rshift _ n0) \oLin inv(catL n0) \oLin proj _ n0) x.2))
        ); [|by move=>p _; rewrite !raddfD].

        rewrite !big_split !(eq_bigr _ (fun i _ => linear_sum _ _ _ _)) !pair_bigA.
        rewrite (eq_bigr (fun p : 'I_(size L1)*'I_(size L1)
         => if(p.2 == p.1)
          then inj L1 p.1 (proj L1 p.1 x.1)
          else 0) _).
        rewrite (eq_bigr (fun p : 'I_(size L2)*'I_(size L2)
         => if(p.2 == p.1)
          then inj L2 p.2 (proj L2 p.2 x.2)
          else 0) _).
        {
          destruct x as [x1 x2];
          rewrite -!big_mkcond !big_pair_diag_eq
          (eq_bigr (fun p : 'I_(size L1) => inj _ p (proj _ p x1)) _);[|by move].
          rewrite (eq_bigr (fun p : 'I_(size L2) => inj _ p (proj _ p x2)) _); [| by []].
          rewrite {4}(inj_proj_sum x1) {4}(inj_proj_sum x2) (rwP eqP) /eq_op -(rwP andP).
          split; rewrite -subr_eq0.

          rewrite {1}addrC addrA addNr add0r (eq_bigr (fun _ => 0) _).
          rewrite big_const cardE /iter enumT;
          induction(Finite.enum _)=>//=; by rewrite add0r.

          move =>[[p1 H1] [p2 H2]] _;
          rewrite -!linCompChain proj_inj0;[by rewrite !linear0 |by rewrite size_cat leq_addr|by rewrite size_cat|];
          rewrite -(rwP negP)/not -(rwP eqP)=>/=N;
          by rewrite N -{2}(addn0 (size L1)) ltn_add2l in H1.

          rewrite -addrA addrN addr0 (eq_bigr (fun _ => 0) _).
          rewrite big_const cardE /iter enumT;
          induction(Finite.enum _)=>//=; by rewrite add0r.

          move =>[[p1 H1] [p2 H2]] _;
          rewrite -!linCompChain proj_inj0;[by rewrite !linear0 |by rewrite size_cat|by rewrite size_cat leq_addr|];
          rewrite -(rwP negP)/not -(rwP eqP)=>/=N.
          by rewrite -N -{2}(addn0 (size L1)) ltn_add2l in H2.
        }
        move=>p _; case(p.2 == p.1) as []eqn:E.
        apply (rwP eqP) in E; rewrite E -!linCompChain.
        rewrite proj_injK; [by rewrite isomKl|].
        destruct p as [[p1 H1] [p2 H2]].
        by rewrite size_cat ltn_add2l.
        rewrite -!linCompChain proj_inj0; [by rewrite !linear0|by rewrite size_cat|by rewrite size_cat|].
        rewrite /eq_op in E; simpl in E.
        by rewrite /rshift eqn_add2l eq_sym E.

        move=>p _; case(p.2 == p.1) as []eqn:E.
        apply (rwP eqP) in E; rewrite -E -!linCompChain.
        rewrite proj_injK; [by rewrite isomKl|].
        destruct p as [[p1 H1] [p2 H2]]=>/=.
        by rewrite size_cat addnC (ltn_addl _ H2).
        rewrite -!linCompChain proj_inj0; [by rewrite !linear0|by rewrite size_cat leq_addr|by rewrite size_cat leq_addr|].
        rewrite /eq_op in E; simpl in E.
        by rewrite eq_sym E.
        Qed.
      End Operations.
    End Environment.

    Section Hom.
    Variable (S T : eqType) (I : T -> lmodType R) (T_S : S -> T).

    Fixpoint hom_raw (L : seq S) : DS (fun s => I (T_S s)) L -> DS I (map T_S L)
      := match L with
      |nil => id
      |a::l => fun x => (x.1 , hom_raw x.2)
      end.
    Fixpoint unhom_raw (L : seq S) : DS I (map T_S L) -> DS (fun s => I (T_S s)) L
      := match L with
      |nil => id
      |a::l => fun x => (x.1 , unhom_raw x.2)
      end.

    Variable (L : seq S).
    Lemma hom_lin : linear (@hom_raw L) /\ linear (@unhom_raw L).
    Proof. split; induction L=>//=r x y;
      by rewrite IHl/hom_raw/unhom_raw.
    Qed.
    Lemma homK : cancel (@hom_raw L) (@unhom_raw L) /\ cancel (@unhom_raw L) (@hom_raw L).
    Proof. split; induction L=>//=x; destruct x;
      by rewrite IHl.
    Qed.
    Definition hom := lmodIsomBuildPack hom_lin homK.
    End Hom.

    Section Bijection.
      Variable (S T : eqType) (I : T -> lmodType R)
          (T_S : S -> T) (S_T : T -> S) (Inj : cancel S_T T_S) (Surj : cancel T_S S_T).
      Fixpoint bij_raw (L : seq T) : DS I L -> DS (fun s => I (T_S s)) (map S_T L)
      := match L with
      |nil => id
      |a::l => fun x => (eq_rect_r (fun t : T => I t) x.1 (Inj a), bij_raw x.2)
      end.

      Fixpoint bijI_raw (L : seq T) : DS (fun s => I (T_S s)) (map S_T L) -> DS I L
      := match L with
      |nil => id
      |a::l => fun x => (eq_rect_r (fun t : T => I t -> I a)
        id (Inj a) x.1, bijI_raw x.2)
      end.

      Variable (L : seq T).
      Lemma bijIK : cancel (@bij_raw L) (@bijI_raw L).
      Proof. induction L=>x//=.
        rewrite /eq_rect_r/eq_rect IHl=>/=.
        by destruct(Logic.eq_sym (Inj a)), x=>/=.
      Qed.

      Lemma bijKI : cancel (@bijI_raw L) (@bij_raw L).
      Proof. induction L=>x//=;
        rewrite /eq_rect_r/eq_rect IHl=>/=;
        by destruct x, (Logic.eq_sym (Inj a))=>/=.
      Qed.

      Lemma bij_lin : linear (@bij_raw L).
      Proof. induction L=>r x y//=; rewrite /eq_rect_r/eq_rect IHl;
      by destruct (Logic.eq_sym (Inj a)). Qed.

      Lemma bijInv_lin : linear (@bijI_raw L).
      Proof. induction L=>r x y//=; rewrite /eq_rect_r/eq_rect IHl.
      by destruct (Inj a). Qed.

      Definition bij := Linear bij_lin.
      Definition bijI := Linear bijInv_lin.
      Definition bijection := Bijective bijIK bijKI.
    End Bijection.
    End Ring.
  End Seq.

  Section General.
    Variable (R : ringType).
    Section Def.
      Variable (F : finType) (I : F -> lmodType R).

      Definition DS : lmodType R := Seq.DS I (enum F).

      Section Components.
        Variable (f : F).

        Lemma cardElt : nat_of_ord (enum_rank f) < size (enum F).
        Proof. rewrite -cardE; apply ltn_ord. Qed.

        Definition Ord := Ordinal cardElt.
        Definition Nth := Seq.Nth I (enum F) Ord.

        Section TypeConversion.
          Lemma Nth_If_eq : Nth = I f.
          Proof. by rewrite /Nth/Seq.Nth
            -codomE nth_codom enum_rankK. Qed.
          Lemma If_Nth_eq : I f = Nth.
          Proof. by rewrite Nth_If_eq. Qed.

          Definition NthToIf : Nth -> I f := (fun fn : Nth
            -> Nth => eq_rect_r (fun M : lmodType R => Nth -> M)
              fn If_Nth_eq) id.

          Definition IfToNth : I f -> Nth := (fun fn : Nth
            -> Nth => eq_rect_r (fun M : lmodType R => M -> Nth)
              fn If_Nth_eq) id.

          Lemma NthToIf_lin : linear NthToIf /\ linear IfToNth.
          Proof. split; by rewrite /NthToIf/IfToNth=>r x y; destruct If_Nth_eq. Qed.

          Lemma Nth_IfK : cancel NthToIf IfToNth /\ cancel IfToNth NthToIf.
          Proof. split; by rewrite/IfToNth/NthToIf; destruct (If_Nth_eq). Qed.

        Definition Nth_If := lmodIsomBuildPack NthToIf_lin Nth_IfK.

        End TypeConversion.

        Section Projection.
          Definition proj_raw : DS -> I f
          := Nth_If \oLin (@Seq.proj R F I (enum F) Ord).

          Lemma proj_lin : linear proj_raw.
          Proof. rewrite/proj_raw=> r x y; by rewrite !linearPZ. Qed.

          Definition proj : {linear DS -> I f} := Linear proj_lin.
          Lemma proj_unraw x : proj_raw x = proj x. Proof. by []. Qed.
        End Projection.

        Section Injection.
          Definition inj_raw : I f -> DS
          := (@Seq.inj R F I (enum F) Ord) \oLin inv(Nth_If).

          Lemma inj_lin : linear inj_raw.
          Proof. rewrite/inj_raw=> r x y; by rewrite !linearPZ. Qed.

          Lemma inj_injective : injective inj_raw.
          Proof. rewrite/inj_raw; unlock linConcat.map =>/= x y H.
            pose (A := Seq.inj_injective H).
            have : (Nth_If (inv(Nth_If) x) = Nth_If (inv(Nth_If) y))
            by simpl; rewrite A.
            by rewrite !(isomKl Nth_If).
          Qed.

          Definition inj : {linear I f -> DS} := Linear inj_lin.
          Lemma inj_unraw x : inj_raw x = inj x. Proof. by []. Qed.
        End Injection.
      End Components.

      Section Results.
        Lemma proj_injK (f : F) x : proj f (inj f x) = x.
        Proof. simpl;
          rewrite /proj_raw/inj_raw -!linCompChain.
          rewrite Seq.proj_injK; [rewrite -{2}(isomKf (Nth_If f) x) | apply cardElt].
          by rewrite /lmodIsom.isom_map/lmodIsom.isom_mapI.
        Qed.

        Lemma proj_inj0 (f f' : F) x : f != f' -> @proj f (@inj f' x) = 0.
        Proof. simpl.
          rewrite/proj_raw/inj_raw-(rwP negP)/not -!linCompChain=>H.
          case((nat_of_ord (enum_rank f) != enum_rank f')) as []eqn:E.
          rewrite (@Seq.proj_inj0_ofsize _ _ _ _ (Ord f) (Ord f') _ E).
          by rewrite linear0.
          assert (E' := contraFeq (fun B : enum_rank f != enum_rank f' => B) E).
          apply enum_rank_inj in E'.
          rewrite E' eq_refl in H.
          by assert (H' := H is_true_true).
        Qed.

        Lemma inj_proj_sum x : x = \sum_(f : F) inj f (proj f x).
        Proof.
          rewrite big_enum_val=>/=.
          rewrite {1}(Seq.inj_proj_sum x) -!big_enum  -cardT=>/=.
          refine (eq_bigr _ _).
          move=> i _; rewrite /inj_raw/proj_raw/Seq.inj/Seq.proj
          -!linCompChain (isomlK (Nth_If _))/Ord=>/=.
          by rewrite enum_valK.
        Qed.

        Lemma inj_proj_idem x : \sum_(f : F) inj f (proj f (\sum_(f : F) inj f (proj f x))) = \sum_(f : F) inj f (proj f x).
        Proof. by rewrite -inj_proj_sum. Qed.
      End Results.
    End Def.
    Section Bijection.
      Variable (F G : finType) (I : F -> lmodType R) (J : G -> lmodType R)
        (F_G : G -> F) (G_F : F -> G)
        (I_J : I = fun f => J (G_F f)) (J_I : J = fun g => I (F_G g))
        (Inj : cancel F_G G_F) (Surj : cancel G_F F_G) (enumB : enum F = map F_G (enum G)).
    End Bijection.

    Section Operations.
      Variable (F G H : finType) (I : F -> lmodType R)
        (F_GH : G + H -> F) (B : bijective F_GH)
        (enumB : enum F = map F_GH (enum (sum_finType G H))).

      Definition Jj : G -> F := fun g : G => F_GH (inl g).
      Definition Kk : H -> F := fun h : H => F_GH (inr h).

      Lemma enumF_cat : enum F = (map Jj (enum G)) ++ (map Kk (enum H)).
      Proof. rewrite enumB (enumT (sum_finType _ _))  (unlock _)=>/=.
      by rewrite /sum_enum/Jj/Kk -!map_comp map_cat -!map_comp.
      Qed.

      Definition J : G -> lmodType R := fun g : G => I (Jj g).
      Definition K : H -> lmodType R := fun h : H => I (Kk h).

      Definition cat_raw : DS I -> Seq.DS I ((map Jj (enum G)) ++ (map Kk (enum H))).
        by rewrite -enumF_cat.
      Defined.
      Definition uncat_raw : Seq.DS I ((map Jj (enum G)) ++ (map Kk (enum H))) -> DS I.
        by rewrite -enumF_cat.
      Defined.
      Lemma cat_lin : linear cat_raw /\ linear uncat_raw.
      Proof. split; rewrite/cat_raw/uncat_raw=>r x y;
      by destruct enumF_cat. Qed.
      Lemma catK : cancel cat_raw uncat_raw /\ cancel uncat_raw cat_raw.
      Proof. split; rewrite/cat_raw/uncat_raw=>x;
      by destruct enumF_cat. Qed.
      Definition cat := lmodIsomBuildPack cat_lin catK.
(*
      Definition unspl : (DS J) \oplus (DS K) -> (Seq.DS I (map Jj (enum G)) \oplus (Seq.DS I (map Kk (enum H)))).
        rewrite /J/K/Jj/Kk/DS.
        induction (enum G)=>//x.
        induction (enum H)=>//=.
        apply (x.1, (x.2.1, (IHl (x.1,x.2.2)).2)).
        apply((x.1.1, (IHl (x.1.2, x.2)).1), (IHl (x.1.2, x.2)).2).
      Defined.

      Definition unspl2 : (Seq.DS I (map Jj (enum G)) \oplus (Seq.DS I (map Kk (enum H)))) -> (DS J) \oplus (DS K).
        rewrite /J/K/Jj/Kk/DS.
        induction (enum G)=>//x.
        induction (enum H)=>//=.
        apply (x.1, (x.2.1, (IHl (x.1,x.2.2)).2)).
        apply((x.1.1, (IHl (x.1.2, x.2)).1), (IHl (x.1.2, x.2)).2).
      Defined.
      Lemma unspl_lin : linear unspl /\ linear unspl2.
      Proof.
        split; rewrite/unspl/unspl2/list_rect=>r x y/=.
      Admitted.

      Lemma unsplK : cancel unspl unspl2 /\ cancel unspl2 unspl.
      Proof.
        split; rewrite/unspl/unspl2/list_rect=>x/=.
      by destruct enumF_cat. Qed.
*)
      Definition split : {linear DS I -> DS J \oplus DS K}
       := Pair.diag
            (inv(Seq.hom I Jj _))
            (inv(Seq.hom I Kk _))
          \oLin (Seq.split I _ _) \oLin cat.

      Definition unsplit : {linear DS J \oplus DS K -> DS I}
      := inv(cat) \oLin (Seq.unsplit I _ _) \oLin
        Pair.diag
          (Seq.hom I Jj _)
          (Seq.hom I Kk _).
(*
      Lemma split_lin : linear split_raw.
        Proof. rewrite /split_raw=>r x y; by rewrite !linearP.
      Qed.

      Lemma unsplit_lin : linear unsplit_raw.
        Proof. rewrite /unsplit_raw=>r x y.
        destruct x, y.
        rewrite linearP.
        rewrite linearP.
        rewrite Seq.unsplit_lin.
      Qed.
  *)
      (*
      Definition split_raw : DS I -> DS J \oplus DS K
(*       := Seq.split I (map Jj (enum G)) (map Kk (enum H)).
         := fun x => (Seq.split (fun gh => I (F_GH gh)) (map (@inl G H) (enum G)) (map (@inr G H) (enum H)) x).
 *)    := fun x =>
         (\sum_(g : G)(inj J g) (proj I (F_GH (inl g)) x),
          \sum_(h : H)(inj K h) (proj I (F_GH (inr h)) x)).

      Definition unsplit_raw : DS J \oplus DS K -> DS I
        := fun x =>
          \sum_(g : G) inj I (F_GH (inl g)) (proj J g x.1) +
          \sum_(h : H) inj I (F_GH (inr h)) (proj K h x.2).

      Lemma split_lin : linear split_raw.
      Proof. rewrite/split_raw=>r x y.
        rewrite (rwP eqP)/eq_op -(rwP andP) -!(rwP eqP).
        (have:forall p1 p2, (p1,p2).1 = p1 by []);
        (have:forall p1 p2, (p1,p2).2 = p2 by [])=> H2 H1.
        rewrite !H1 !H2
        !(eq_bigr _ (fun i _ => linCompChain _ _ _))
        !(eq_bigr _ (fun i _ => linearP _ _ _ _));
        by rewrite !scaler_sumr !big_split.
      Qed.

      Lemma unsplit_lin : linear unsplit_raw.
      Proof. rewrite/unsplit_raw=>r x y.
        rewrite !(eq_bigr _ (fun i _ => linCompChain _ _ _))
        !(eq_bigr _ (fun i _ => linearP _ _ _ _))
        !big_split  -!scaler_sumr.
        by rewrite scalerDr !addrA (addrC _ (r *: _)) !addrA (addrC (r *: _) (r *: _)).
      Qed.

      Definition split := Linear split_lin.
      Definition unsplit := Linear unsplit_lin.*)

      Lemma unsplitK : cancel split unsplit.
      Proof. rewrite /unsplit/split=>x.
      rewrite -!linCompChain.
      rewrite (linCompChain (_ \linPlusDiag _) (_ \linPlusDiag _)). Admitted.

      Lemma splitK : cancel unsplit split.
      Proof. rewrite /unsplit/split=>x.
      rewrite -!linCompChain isomKl Seq.splitKs.
      Admitted.
  (*
      Lemma split_unsplitK : cancel split unsplit.
        Proof.destruct B=>/=.
        rewrite /unsplit_raw/split_raw/J/K=>x.
        rewrite !(eq_bigr _ (fun i _ => linCompChain _ _ _))
         !(eq_bigr _ (fun i _ => linear_sum _ _ _ _))
         !pair_bigA/Ord.
        rewrite (eq_bigr (fun p : G*G => if p.2 == p.1 then
          Seq.inj _ _ (enum_rank (F_GH (inl p.1)))
            (Seq.proj _ _ (enum_rank (F_GH (inl p.1))) x)
            else 0) _).
        rewrite (eq_bigr (fun p : H*H => if p.2 == p.1 then
          Seq.inj _ _ (enum_rank (F_GH (inr p.1)))
            (Seq.proj _ _ (enum_rank (F_GH (inr p.1))) x)
            else 0) _).
        {
          rewrite -!big_mkcond {3}(inj_proj_sum x)
          big_pair_diag_eq big_pair_diag_eq=>/=.
          rewrite (@reindex _ _ _ _ _ F_GH _ (fun f => inj _ _ (proj _ f x)))=>/=.
          rewrite /inj_raw/proj_raw/Ord big_sumType=>/=; symmetry.
          rewrite (eq_bigr (fun i : G => Seq.inj _ _ _ (Seq.proj _ _ (enum_rank (F_GH (inl i))) x)) _); [|move=>p _; by rewrite -!linCompChain (isomlK (Nth_If _ _))];
          by rewrite (eq_bigr (fun i : H => Seq.inj _ _ _ (Seq.proj _ _ (enum_rank (F_GH (inr i))) x)) _); [|move=>p _; by rewrite -!linCompChain (isomlK (Nth_If _ _))].
          apply (onW_bij _ B).
        }
        move=>p _; case (p.2 == p.1) as []eqn:E.
        apply (rwP eqP) in E.
        rewrite E /inj_raw/proj_raw/Seq.inj/Seq.proj -!linCompChain
        Seq.proj_injK;
        [ by rewrite (isomKl (Nth_If _ _))(isomlK (Nth_If _ _))|
          by destruct (enum_rank p.2)=>/=; rewrite -cardE].
        rewrite /inj_raw/proj_raw/Seq.inj/Seq.proj -!linCompChain.
        rewrite Seq.proj_inj0;
        [by rewrite !linear0|
          destruct (enum_rank p.2)=>/=; by rewrite -cardE|
          destruct (enum_rank p.2)=>/=; by rewrite -cardE|].
        rewrite -(rwP negP)/not-(rwP eqP)=>N.
        have/eqP X: enum_rank p.1 == enum_rank p.2
        by rewrite /eq_op; apply/eqP.
        by rewrite (enum_rank_inj X) eq_refl in E.

        move=>p _; case (p.2 == p.1) as []eqn:E.
        apply (rwP eqP) in E.
        rewrite E /inj_raw/proj_raw/Seq.inj/Seq.proj -!linCompChain
        Seq.proj_injK;
        [ by rewrite (isomKl (Nth_If _ _))(isomlK (Nth_If _ _))|
          by destruct (enum_rank p.2)=>/=; rewrite -cardE].
        rewrite /inj_raw/proj_raw/Seq.inj/Seq.proj -!linCompChain Seq.proj_inj0;
          [by rewrite !linear0|
            destruct (enum_rank p.2)=>/=; by rewrite -cardE|
            destruct (enum_rank p.2)=>/=; by rewrite -cardE|].
        rewrite -(rwP negP)/not-(rwP eqP)=>N.
        have/eqP X : enum_rank p.1 == enum_rank p.2
        by rewrite /eq_op; apply/eqP.
        by rewrite (enum_rank_inj X) eq_refl in E.
      Qed.

      Lemma enum_rank_GH_lt_F (gh : G + H) : enum_rank (F_GH gh) < size (enum F).
      Proof.
        rewrite enumB size_map/enum_rank/enum_rank_in/insubd/odflt/oapp/insub.
        destruct(idP).
        assert(ii := i).
        by rewrite cardT {2}enumB size_map in ii.
        rewrite -cardT -(rwP (card_gt0P _)).
        apply(ex_intro _ gh is_true_true).
      Qed.

      Lemma unsplit_splitK : cancel unsplit split.
      Proof.
      destruct B=>/=.
      rewrite /unsplit_raw/split_raw=>x.
      rewrite (eq_bigr (fun g : G =>
          inj J g (proj I (F_GH (inl g)) (\sum_g1
            inj I (F_GH (inl g1)) (proj J g1 x.1)))
        + inj J g (proj I (F_GH (inl g)) (\sum_h
            inj I (F_GH (inr h)) (proj K h x.2)))) _);
        [rewrite big_split|move=>p _; by rewrite !raddfD].
      rewrite (eq_bigr (fun h : H =>
          inj K h (proj I (F_GH (inr h)) (\sum_g1
            inj I (F_GH (inl g1)) (proj J g1 x.1)))
        + inj K h (proj I (F_GH (inr h)) (\sum_h
        inj I (F_GH (inr h)) (proj K h x.2)))) _);
        [rewrite big_split|move=>p _; by rewrite !raddfD].

      rewrite !(eq_bigr _ (fun i _ => linear2_sum _ _ _)) !pair_bigA.
      destruct x as [x1 x2].
      rewrite {5}(inj_proj_sum x1) {5}(inj_proj_sum x2).
      rewrite (eq_bigr (fun p : G*G
      => if(p.2 == p.1)
      then inj J p.1 (proj J p.1 x1)
      else 0)).
      rewrite (eq_bigr (fun p : H*H
      => if(p.2 == p.1)
      then inj K p.1 (proj K p.1 x2)
      else 0)).
      {
        rewrite (eq_bigr (fun _ : G*H => 0)).
          rewrite big_const cardE /iter enumT;
          induction(Finite.enum _)=>//=; [rewrite addr0| by rewrite add0r IHl].
        rewrite (eq_bigr (fun _ : H*G => 0)).
          rewrite big_const cardE /iter enumT;
          induction(Finite.enum _)=>//=; [rewrite add0r| by rewrite add0r IHl].
        by rewrite -!big_mkcond !big_pair_diag_eq.

        move=>hg _.
        rewrite !inj_unraw !proj_unraw proj_inj0; [by rewrite !linear0|].
        rewrite /Ord -(rwP negP)/not -(rwP eqP)=>/=N.
        have: (enum_rank (F_GH (inr hg.1)) = enum_rank (F_GH (inl hg.2)))
        by rewrite (rwP eqP)/eq_op=>/=; rewrite N. clear N=>N.
        assert(V := f_equal g (enum_rank_inj N)).
        rewrite !H0 in V.
        by inversion V.

        move=>gh _.
        rewrite proj_inj0; [by rewrite !linear0|].
        rewrite /Ord -(rwP negP)/not -(rwP eqP)=>/=N.
        have: (enum_rank (F_GH (inl gh.1)) = enum_rank (F_GH (inr gh.2)))
        by rewrite (rwP eqP)/eq_op=>/=; rewrite -N. clear N=>N.
        assert(V := f_equal g (enum_rank_inj N)).
        rewrite !H0 in V.
        by inversion V.
      }
      all:move=>p _; case (p.2 == p.1) as []eqn:E; [
        by apply (rwP eqP) in E;
        rewrite E proj_injK
        |  ];
        rewrite  proj_inj0; [by rewrite !linear0|];
        rewrite /Ord -(rwP negP)/not -(rwP eqP)=>/=N.

      have: (enum_rank (F_GH (inr p.1)) = enum_rank (F_GH (inr p.2)))
      by rewrite (rwP eqP)/eq_op=>/=; rewrite -N. clear N=>N.
      assert(V := f_equal g (enum_rank_inj N));
      rewrite !H0 in V;
      inversion V;
      by rewrite H3 eq_refl in E.

      have: (enum_rank (F_GH (inl p.1)) = enum_rank (F_GH (inl p.2)))
        by rewrite (rwP eqP)/eq_op=>/=; rewrite -N. clear N=>N.
      assert(V := f_equal g (enum_rank_inj N));
      rewrite !H0 in V;
      inversion V;
      by rewrite H3 eq_refl in E.
    Qed.*)
    End Operations.

  End General.
End dsLmod.

Definition dsProj (R : ringType) (F : finType) (I : F -> (lmodType R)) (f : F) := @dsLmod.proj R F I f.
Definition dsInj (R : ringType) (F : finType) (I : F -> (lmodType R)) (f : F) := @dsLmod.inj R F I f.

Export dsLmod.Pair.Exports.
Notation "\bigoplus_ i F" := (dsLmod.DS (fun i => F i)) : lmod_scope.
Notation "\bigoplus F" := (dsLmod.DS F) : lmod_scope.
Notation "\bigoplus_ ( i : t ) F" := (dsLmod.DS (fun i : t => F i)) : lmod_scope.
Notation "\bigoplus_ ( i 'in' A ) F" := (dsLmod.Seq.DS (filter F (fun i => i \in A))) : lmod_scope.
Notation "\proj^( I )_ f " := (dsLmod.proj I f ) : lmod_scope.
Notation "\inj^( I )_ f " := (dsLmod.inj I f ) : lmod_scope.
Notation "\proj_ f ^( I )" := (dsLmod.proj I f ) : lmod_scope.
Notation "\inj_ f ^( I )" := (dsLmod.inj I f ) : lmod_scope.

Theorem DS_cat_theory (R : ringType) (F : finType)
  (I : F -> (lmodType R))
    : forall (f : forall i : F, {linear \bigoplus I -> (I i)}),
      exists (g : forall i : F, {linear (I i) -> (I i)}),
        forall i : F, f i \oLin \inj_i^(I) = g i.
Proof. move=> f.
  by refine(ex_intro _ (fun i => f i \oLin \inj_i^(I)) _ ).
Qed.

Close Scope  lmod_scope.
Close Scope  ring_scope.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem2: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem2. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (rev (append x y))) (append (rev (rev x)) (rev (rev y))).
Proof.
  intros. rewrite lem.
  lfind. Admitted.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import TableAux.Specs.granule_fill_table.
Require Import TableAux.LowSpecs.granule_fill_table.
Require Import TableAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       pgte_write_spec
       barrier_spec
    .

  Lemma mul_ge:
    forall a b c, 0 <= a -> 0 <= b -> b <= c -> a * b <= a * c.
  Proof.
    intros. auto with zarith.
  Qed.

  Lemma granule_fill_table_spec_exists:
    forall habd habd'  labd pte pte_val pte_inc
           (Hspec: granule_fill_table_spec pte pte_val pte_inc habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', granule_fill_table_spec0 pte pte_val pte_inc labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata. destruct pte.
    unfold granule_fill_table_spec, granule_fill_table_spec0 in *. autounfold in *.
    repeat simpl_hyp Hspec; inv Hspec.
    assert(forall n table' i' pte_val'
             (Hfill: fill_table n (g_data (gnorm (gs (share labd)) @ z2)) 0 z0 z1 = (table', i', pte_val'))
             (Hn: 0 <= Z.of_nat n <= PGTES_PER_TABLE),
              let gn := (gs (share labd)) @ z2 in
              let g' := gn {gnorm : (gnorm gn) {g_data : table'}} in
              granule_fill_table_loop0 n 0 (p, z) z0 z1 labd = Some (i', pte_val', labd {share : (share labd) {gs : (gs (share labd)) # z2 == g'}}) /\
              i' = Z.of_nat n /\
              pte_val' = z0 + z1 * (Z.of_nat n)).
    { clear C8. induction n.
      - simpl. intros. inv Hfill. repeat (simpl_field; simpl_htarget).
        split. reflexivity. split. reflexivity. omega.
      - rewrite Nat2Z.inj_succ, succ_plus_1 in *. intros until pte_val'. simpl. intros.
        repeat simpl_hyp Hfill. exploit IHn. reflexivity. omega.
        simpl in *. intros. destruct H as (T1 & T2 & T3). repeat grewrite. autounfold in *.
        solve_bool_range. grewrite. repeat destruct_con.
        assert(0 <= Z.of_nat n < 512). omega.
        assert(z1 * 0 <= z1 * Z.of_nat n <= z1 * 512).
        split; bool_rel. destruct Hn. apply mul_ge; omega. apply mul_ge; omega.
        solve_bool_range. grewrite. repeat (simpl_htarget; grewrite; simpl in * ).
        inversion Hfill; grewrite. split. repeat (simpl_field; simpl_htarget; simpl).
        rewrite <- H2. rewrite <- H3, <- H4, T2, T3. reflexivity.
        split. omega. rewrite <- H4, T3. rewrite  Z.mul_add_distr_l. omega. }
    exploit (H _ _ _ _ C8). autounfold. simpl. omega. intros.
    destruct H0 as (T1 & T2 & T3). rewrite T1. grewrite; simpl.
    grewrite. eexists; split. reflexivity. constructor. reflexivity.
  Qed.

End Refine.


(**********************************************************************************

 The two-sided displayed category of spans

 A span in a category `C` is a diagram `x₁ <-- y --> x₂`. We construct a two-sided
 displayed category whose displayed objects are spans.

 Contents
 1. The definition
 2. The univalence

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.Constant.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Examples.DispCatOnTwoSidedDispCat.

Local Open Scope cat.

Section Spans.
  Context (C : category).

  (**
   1. The definition
   *)
  Definition spans_ob
    : twosided_disp_cat C C
    := constant_twosided_disp_cat C C C.

  Definition spans_mor_left_ob_mor
    : disp_cat_ob_mor (total_twosided_disp_category spans_ob).
  Proof.
    simple refine (_ ,, _).
    - exact (λ xyz, pr22 xyz --> pr1 xyz).
    - exact (λ xyz₁ xyz₂ l₁ l₂ fgh,
             l₁ · pr1 fgh
             =
             pr22 fgh · l₂).
  Defined.

  Definition spans_mor_left_id_comp
    : disp_cat_id_comp
        (total_twosided_disp_category spans_ob)
        spans_mor_left_ob_mor.
  Proof.
    split.
    - intros xyz fgh ; cbn.
      rewrite id_left, id_right.
      apply idpath.
    - intros xyz₁ xyz₂ xyz₃ fgh₁ fgh₂ h₁ h₂ h₃ p₁ p₂ ; cbn in *.
      rewrite !assoc.
      rewrite p₁.
      rewrite !assoc'.
      rewrite p₂.
      apply idpath.
  Qed.

  Definition spans_mor_left_data
    : disp_cat_data (total_twosided_disp_category spans_ob).
  Proof.
    simple refine (_ ,, _).
    - exact spans_mor_left_ob_mor.
    - exact spans_mor_left_id_comp.
  Defined.

  Definition spans_mor_left_axioms
    : disp_cat_axioms
        (total_twosided_disp_category spans_ob)
        spans_mor_left_data.
  Proof.
    repeat split.
    - intro ; intros.
      apply homset_property.
    - intro ; intros.
      apply homset_property.
    - intro ; intros.
      apply homset_property.
    - intro ; intros.
      apply isasetaprop.
      apply homset_property.
  Qed.

  Definition spans_mor_left
    : disp_cat (total_twosided_disp_category spans_ob).
  Proof.
    simple refine (_ ,, _).
    - exact spans_mor_left_data.
    - exact spans_mor_left_axioms.
  Defined.

  Definition spans_mor_right_ob_mor
    : disp_cat_ob_mor (total_twosided_disp_category spans_ob).
  Proof.
    simple refine (_ ,, _).
    - exact (λ xyz, pr22 xyz --> pr12 xyz).
    - exact (λ xyz₁ xyz₂ l₁ l₂ fgh,
             l₁ · pr12 fgh
             =
             pr22 fgh · l₂).
  Defined.

  Definition spans_mor_right_id_comp
    : disp_cat_id_comp
        (total_twosided_disp_category spans_ob)
        spans_mor_right_ob_mor.
  Proof.
    split.
    - intros xyz fgh ; cbn.
      rewrite id_left, id_right.
      apply idpath.
    - intros xyz₁ xyz₂ xyz₃ fgh₁ fgh₂ h₁ h₂ h₃ p₁ p₂ ; cbn in *.
      rewrite !assoc.
      rewrite p₁.
      rewrite !assoc'.
      rewrite p₂.
      apply idpath.
  Qed.

  Definition spans_mor_right_data
    : disp_cat_data (total_twosided_disp_category spans_ob).
  Proof.
    simple refine (_ ,, _).
    - exact spans_mor_right_ob_mor.
    - exact spans_mor_right_id_comp.
  Defined.

  Definition spans_mor_right_axioms
    : disp_cat_axioms
        (total_twosided_disp_category spans_ob)
        spans_mor_right_data.
  Proof.
    repeat split.
    - intro ; intros.
      apply homset_property.
    - intro ; intros.
      apply homset_property.
    - intro ; intros.
      apply homset_property.
    - intro ; intros.
      apply isasetaprop.
      apply homset_property.
  Qed.

  Definition spans_mor_right
    : disp_cat (total_twosided_disp_category spans_ob).
  Proof.
    simple refine (_ ,, _).
    - exact spans_mor_right_data.
    - exact spans_mor_right_axioms.
  Defined.

  Definition spans_mors
    : disp_cat (total_twosided_disp_category spans_ob)
    := dirprod_disp_cat
         spans_mor_left
         spans_mor_right.

  Definition twosided_disp_cat_of_spans
    : twosided_disp_cat C C
    := sigma_twosided_disp_cat _ spans_mors.

  (**
   2. The univalence
   *)
  Definition is_univalent_disp_spans_mor_left
    : is_univalent_disp spans_mor_left.
  Proof.
    intros x y p l₁ l₂.
    induction p.
    use isweqimplimpl.
    - intro f ; cbn in *.
      pose (p := pr1 f) ; cbn in p.
      rewrite id_left, id_right in p.
      exact p.
    - apply homset_property.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_z_iso_disp.
      + intros.
        apply homset_property.
  Qed.

  Definition is_univalent_disp_spans_mor_right
    : is_univalent_disp spans_mor_right.
  Proof.
    intros x y p l₁ l₂.
    induction p.
    use isweqimplimpl.
    - intro f ; cbn in *.
      pose (p := pr1 f) ; cbn in p.
      rewrite id_left, id_right in p.
      exact p.
    - apply homset_property.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_z_iso_disp.
      + intros.
        apply homset_property.
  Qed.

  Definition is_univalent_spans_twosided_disp_cat
             (HC : is_univalent C)
    : is_univalent_twosided_disp_cat twosided_disp_cat_of_spans.
  Proof.
    use is_univalent_sigma_of_twosided_disp_cat.
    - use is_univalent_constant_twosided_disp_cat.
      exact HC.
    - use dirprod_disp_cat_is_univalent.
      + exact is_univalent_disp_spans_mor_left.
      + exact is_univalent_disp_spans_mor_right.
  Defined.
End Spans.


(** * Interpreting STLC syntax into a cartesian-closed category *)

(** The interpretation is fairly standard (see e.g. Andrew Pitts. "Brief Notes on the Category Theoretic Semantics of Simply Typed Lambda Calculus" for a concise introduction), but ways of representing syntax might vary. The way we encode intrinsic syntax and syntactic substitutions comes from an approach commonly used in Agda (see, e.g. Programming Language Foundations in Agda. Part 2. DeBruijn. https://plfa.github.io/DeBruijn/) *)

From Categories Require Import Category.Main Basic_Cons.CCC
     Basic_Cons.Product Notations.
From Equations Require Import Equations.
Require Import List HList.
Require Import CalcNotations CalcNotationsTactic.

Import ListNotations.

(** We allow definitions produced by the Equations plugin to be transparent, i.e. we can compute with them *)
Set Equations Transparent.

Definition cprod {C : Category} {HP : @Has_Products C} (A B : C) : Product A B := HP A B.

Notation "⟨ f ; g ⟩" := (@Prod_morph_ex _ _ _ (cprod _ _) _ f g) (at level 50): morphism_scope.

(** A (proof-relevant) membership predicate (taken from the Equations tutorial) *)
Reserved Notation " x ∈ s " (at level 70, s at level 10).

Inductive In {A} (x : A) : list A -> Type :=
| here {xs} : x ∈ (x :: xs)
| there {y xs} : x ∈ xs -> x ∈ (y :: xs)
where " x ∈ s " := (In x s).

Arguments here {_ _ _}.
Arguments there {_ _ _ _}.
Hint Constructors In.
Derive Signature NoConfusion for In.
Derive NoConfusion for list.

(** ** The intrinsic syntax for STLC *)

(** Types *)
Inductive Ty : Set :=
| tU : Ty
| tArr : Ty -> Ty -> Ty.
Derive NoConfusion for Ty.

Notation "A :-> B" := (tArr A B) (at level 70, right associativity).

(** Contexts are list of types *)
Definition Ctx := list Ty.

Notation "⋄" := (nil : list Ty).
Notation "Γ , τ" := (τ :: Γ : list Ty) (at level 10) : ctx_scope.
Notation "Γ ,, Γ'" := (Γ' ++ Γ : list Ty) (at level 10) : ctx_scope.

(** Intrinsically-typed lambda terms *)

Open Scope ctx_scope.
Inductive Exp : Ctx -> Ty -> Type :=
| Star : forall {Γ}, Exp Γ tU

| Var : forall {Γ τ},

    τ ∈ Γ ->
(* ---------- *)
    Exp Γ τ

| Lam : forall {Γ} {τ σ : Ty},

    Exp (Γ,τ) σ ->
(* ------------------- *)
    Exp Γ (τ :-> σ)

| App : forall {Γ} {τ σ : Ty},

    Exp Γ (τ :-> σ) -> Exp Γ τ ->
(* ----------------------------- *)
    Exp Γ σ.

Derive Signature for Exp.
Derive NoConfusion for Exp.

Declare Custom Entry ty.
Declare Custom Entry lambda.

Notation "` n"  := (Var n) (at level 10) : exp_scope.
Notation "'v0'" := (Var here) : exp_scope.
Notation "'v1'" := (Var (there here)) : exp_scope.
Notation "'v2'" := (Var (there (there here))) : exp_scope.
Notation " 'λ' e " := (Lam e) (at level 10) : exp_scope.
Notation "e1 ⋅ e2" := (App e1 e2) (at level 10) : exp_scope.

Reserved Notation "⟦ τ ⟧" (at level 5).

(** Some extra lemmas about product morphisms which will be useful later *)

Open Scope morphism_scope.

(** We use the "calculational proof" style for the lemma below using the tactic notation allowing for chaining intermediate results in the equational reasoning. *)
Lemma Prod_morph_distr_r {C : Category} `{@CCC C} {A X Y Z  : C}
      {f : A –≻ X} {g : A –≻ Y} {h :  Z –≻ A} :
  ⟨ f ; g ⟩ ∘ h = ⟨ f ∘ h ; g ∘ h ⟩.
Proof.
  apply Prod_morph_unique with (r1:= f ∘ h) (r2:=g ∘ h).
  - calc
      (Pi_1 ∘ ⟨ f; g ⟩ ∘ h) = ((Pi_1 ∘ ⟨ f; g ⟩) ∘ h) by now rewrite <-assoc.
                       _  = (f ∘ h) by now rewrite Prod_morph_com_1
    end.
  - calc
      (Pi_1 ∘ ⟨ f; g ⟩ ∘ h) = ((Pi_2 ∘ ⟨ f; g ⟩) ∘ h) by now rewrite <-assoc.
                       _  = (g ∘ h) by now rewrite Prod_morph_com_2
    end.
  - apply Prod_morph_com_1.
  - apply Prod_morph_com_2.
Qed.

Lemma Exp_morph_com' (C : Category) `{@CCC C}
      (c d : C) (z : C)
      (f : Hom (product z c (cprod z c)) d) :
  f = eval _ ∘ ⟨ (@curry C _ CCC_HEXP _ _ _ f) ∘ Pi_1 ; Pi_2 ⟩.
Proof.
  specialize (Exp_morph_com (CCC_HEXP _ _) _ f) as H1.
  simpl in H1. rewrite id_unit_left in H1.
  exact H1.
Qed.

Open Scope calc_scope.

(** A simple notation allowing to build a term using rewrites in non-interactive mode. It tries to rewrite both left-to-right and right-to-left completing the proof by reflexivity. *)
Notation "{{ f }}" := (ltac:((rewrite f;reflexivity) || (rewrite <-f; reflexivity)|| fail "Could not rewrite with" f)) (at level 70) : calc_scope.

(** We use the "calculational proof" style again, but this time the notation is defined at the term level and not at the tactic level. It allows for the proof style similar to Lean and Agda. The curly braces {{ }} mean that the witness of a step is built by applying the [rewrite] tactic with the given lemma *)
Definition Prod_morph_decompose {C : Category} `{@CCC C} {A X Y : C}
      (f : A –≻ X) (g : A –≻ Y) :
  ⟨ f ∘ Pi_1; Pi_2 ⟩ ∘ ⟨ id ; g ⟩ = ⟨ f; g ⟩ :=
  calc
    ⟨ f ∘ Pi_1; Pi_2 ⟩ ∘ ⟨ id ; g ⟩ =  ⟨ (f ∘ Pi_1) ∘ ⟨ id ; g ⟩ ; Pi_2  ∘ ⟨ id ; g ⟩ ⟩
                                       by Prod_morph_distr_r ;
                              _   =  ⟨ f ∘ (Pi_1 ∘ ⟨ id ; g ⟩) ; Pi_2  ∘ ⟨ id ; g ⟩ ⟩
                                       by {{ @assoc }} ;
                              _   =  ⟨ f ∘ id; Pi_2  ∘ ⟨ id ; g ⟩ ⟩
                                       by {{ @Prod_morph_com_1 }} ;
                              _   =  ⟨ f ∘ id; g ⟩
                                       by {{ @Prod_morph_com_2 }} ;
                              _   =  ⟨ f; g ⟩ by {{ id_unit_right }}
  end.

(** ** Interpreting syntax *)
Open Scope object_scope.
Open Scope morphism_scope.

Fixpoint interpTy {C : Category} `{@CCC C} (τ : Ty) : C :=
    match τ with
    | tU => C.(CCC_term)
    | τ1 :-> τ2 => exponential (e:= CCC_HEXP _ _) ⟦τ1⟧ ⟦τ2⟧
    end
where "⟦ τ ⟧" := (interpTy τ).

Definition Env C := list C.

Equations get {A : Type} {a : A} (l : list A) (p : a ∈ l) : A:=
  get _ here := a;
  get _ (there p') => get _ p'.

Reserved Notation "c⟦ Γ ⟧" (at level 6).

Fixpoint interpCtx {C : Category} `{@CCC C} (Γ : Ctx) : C :=
  match Γ with
  | nil => terminal (CCC_term _)
  | cons τ Δ => product c⟦Δ⟧ ⟦τ⟧ (CCC_HP c⟦Δ⟧ ⟦τ⟧)
  end
where "c⟦ Γ ⟧" := (interpCtx Γ).

Equations varProj {C : Category} `{@CCC C} {τ : Ty} (Γ : Ctx) (m : τ ∈ Γ) : Hom c⟦Γ⟧ ⟦τ⟧ :=
  varProj _ here := Pi_2;
  varProj Γ' (there m0) := compose Pi_1 (varProj _ m0).

Reserved Notation "e⟦ e ⟧" (at level 5).

Open Scope exp_scope.

Equations interpExp {Γ} {τ} {C : Category} `{@CCC C} (e : Exp Γ τ)
  : Hom c⟦Γ⟧ ⟦τ⟧ :=
 { e⟦ Star ⟧ := t_morph _ _; (* the unique morphism to the terminal object *)
   e⟦ `v ⟧ := varProj _ v; (* projection from the context *)
   e⟦ λ b ⟧ := curry _ e⟦b⟧;
   e⟦ e1 ⋅ e2 ⟧ := (eval _) ∘ ⟨ e⟦e1⟧; e⟦e2⟧ ⟩ }
where "e⟦ e ⟧" := (interpExp e).

(** ** Interpreting substitutions  *)

Reserved Notation "Γ ==> Δ" (at level 5).

Open Scope ctx_scope.

Inductive ctx_morph Γ : Ctx -> Type :=
| s_empty : Γ ==> ⋄
| s_ext : forall {Δ τ}, Γ ==> Δ -> Exp Γ τ ->
                   Γ ==> (Δ,τ)
where "Γ ==> Δ " := (ctx_morph Γ Δ).

Inductive rename_morph (Γ : Ctx): Ctx -> Type :=
| r_empty : rename_morph Γ []
| r_cons : forall τ Δ,
    τ ∈ Γ -> rename_morph Γ Δ ->
    rename_morph Γ (Δ,τ).

Arguments r_empty {_}.
Arguments r_cons {_ _ _}.

Equations wkn_ren {Γ Δ τ}: rename_morph Γ Δ -> rename_morph (Γ,τ) Δ :=
  wkn_ren r_empty := r_empty ;
  wkn_ren (r_cons n r) := r_cons (there n) (wkn_ren r).

Equations ext_ren {Γ Δ τ}: rename_morph Γ Δ -> rename_morph (Γ,τ) (Δ,τ) :=
  ext_ren r_empty := r_cons here r_empty ;
  ext_ren (r_cons n r) := r_cons here (r_cons (there n) (wkn_ren r)).

Equations id_ren {Γ}: rename_morph Γ Γ :=
  @id_ren nil := r_empty;
  @id_ren (σ :: Γ') := r_cons here (wkn_ren id_ren).

Equations renF {Γ Δ} : rename_morph Γ Δ -> (forall τ, τ ∈ Δ -> τ ∈ Γ) :=
  renF (r_cons n r) τ here := n;
  renF (r_cons n r) τ (there n) := renF r τ n.

Reserved Notation "t .[ τ ]" (at level 20).

Reserved Notation "r⟦ σ ⟧" (at level 5).
Reserved Notation "s⟦ σ ⟧" (at level 5).

Equations interpRen {C : Category} `{@CCC C} {Γ Δ} (r : rename_morph Γ Δ) : Hom c⟦Γ⟧ c⟦Δ⟧ :=
  { r⟦ r_empty ⟧ := t_morph _ _;
    r⟦ r_cons n r⟧ := ⟨ r⟦r⟧ ; varProj _ n ⟩ }

where "r⟦ r ⟧" := (interpRen r).

Equations interpSubst {C : Category} `{@CCC C} {Γ Δ} (σ : Γ ==> Δ) : Hom c⟦Γ⟧ c⟦Δ⟧ :=
  { s⟦ s_empty ⟧ := t_morph _  c⟦Γ⟧ ;
    s⟦ s_ext _ s t ⟧ := ⟨ s⟦s⟧ ; e⟦t⟧ ⟩ }

where "s⟦ σ ⟧" := (interpSubst σ).

Definition idMap {Γ : Ctx} : forall τ, τ ∈ Γ -> τ ∈ Γ := fun _ n => n.

Equations ext {Γ Δ : Ctx} :
   (forall {τ}, τ ∈ Γ -> τ ∈ Δ) ->
(* ------------------------------------ *)
   (forall σ τ, τ ∈ Γ,σ -> τ ∈ Δ,σ ) :=

  ext f _ _ here := here ;
  ext f _ _ (there n) := there (f _ n).

Equations rename {Γ Δ : Ctx} {τ} :
  (forall {τ}, τ ∈ Γ -> τ ∈ Δ) ->
(* ----------------------------- *)
  (Exp Γ τ -> Exp Δ τ) :=

  rename f Star := Star ;
  rename f (Var n) := Var (f _ n);
  rename f (Lam b) := Lam (rename (ext f _)  b) ;
  rename f (App e1 e2) := App (rename f e1) (rename f e2).

Import FunctionalExtensionality.

Lemma idMap_rename {Γ : Ctx} {τ} (e : Exp Γ τ):
  rename idMap e = e.
Proof.
  induction e;auto.
  - simpl.
    assert (ext (Δ:=Γ) idMap τ = idMap).
    { apply functional_extensionality_dep. intro σ0.
      apply functional_extensionality_dep.
      intros n. funelim (ext _ _ _ _);auto.  }
    rewrite H. rewrite IHe. reflexivity.
  - simpl. congruence.
Qed.

Lemma there_renF : ∀ (Γ : Ctx) (xs0 : list Ty) (r : rename_morph Γ xs0)
                     (τ σ: Ty) (i : τ ∈ xs0),
    there (y:=σ) (renF r τ i) = renF (wkn_ren r) τ i.
Proof.
  intros Γ Δ r τ σ n.
  funelim (renF r τ n);auto.
  simp wkn_ren.
Qed.

Lemma ext_ext_ren {Γ Δ τ} (r : rename_morph Γ Δ) :
  ext (renF r) τ = renF (ext_ren r).
Proof.
  apply functional_extensionality_dep. intros σ.
  apply functional_extensionality_dep. intros n.
  funelim (ext _ _ _ _).
  - simp ext. destruct r;auto.
  - simp ext. funelim (renF _ _ _);auto.
    simp ext_ren. simp renF.
    apply there_renF.
Qed.

Lemma wkn_ren_interp {C : Category} `{@CCC C} {Γ Δ} {τ : Ty}
  (r : rename_morph Γ Δ) :
  r⟦wkn_ren (τ:=τ) r⟧ = r⟦r⟧ ∘ Pi_1.
Proof.
  funelim (wkn_ren r).
  - apply t_morph_unique.
  - simpl. rewrite H. symmetry. apply Prod_morph_distr_r.
Qed.

Lemma varProj_renF:
      ∀ (C : Category) (H : CCC C) (Γ : list Ty)
        (τ : Ty) (i : τ ∈ Γ) (Δ : Ctx) (f : rename_morph Δ Γ),
        varProj Δ (renF f τ i) = varProj Γ i ∘ r⟦ f ⟧.
Proof.
  intros C H Γ τ i Δ f.
  funelim (renF _ _ _).
  - simp renF. simp varProj. simp interpRen.
    symmetry. apply Prod_morph_com_2.
  - simp renF. simp varProj. simp interpRen.
    rewrite H by reflexivity.
    rewrite assoc. refine (f_equal2 _ _ eq_refl).
    symmetry. apply Prod_morph_com_1.
Qed.

Lemma rename_interp {C : Category} `{@CCC C} {Γ Δ} {τ : Ty}
         {f : rename_morph Δ Γ}
         (e : Exp Γ τ) :
  e⟦rename (renF f) e⟧ = e⟦e⟧ ∘ r⟦f⟧.
Proof.
  revert dependent Δ.
  induction e;fold interpTy;intros.
  - apply t_morph_unique.
  - apply varProj_renF.
  - simpl. specialize (IHe (Δ,τ)).
    rewrite ext_ext_ren. rewrite IHe.
    rewrite curry_compose. repeat f_equal.
    funelim (ext_ren f). simpl. apply f_equal2.
    apply t_morph_unique.
    reflexivity.
    simpl. apply f_equal2;auto.
    rewrite wkn_ren_interp.
    symmetry. apply Prod_morph_distr_r.
  - simpl. fold interpTy. rewrite assoc. apply f_equal2.
    rewrite IHe1. rewrite IHe2.
    symmetry. apply Prod_morph_distr_r. reflexivity.
Qed.

Lemma id_ren_id_morph {C : Category} `{@CCC C} {Γ} :
  r⟦id_ren (Γ:=Γ)⟧ = Category.id.
Proof.
  induction Γ;simpl.
  - apply t_morph_unique.
  - rewrite wkn_ren_interp. rewrite IHΓ.
    rewrite id_unit_left.
    apply (Prod_morph_unique _ _ Pi_1 Pi_2).
    + apply Prod_morph_com_1.
    + apply Prod_morph_com_2.
    + apply id_unit_right.
    + apply id_unit_right.
Qed.

(** Since context morphisms are "lists" of well-typed expressions, we "map" a weakening renaming (which is basically [+1] for de Bruijn indices) over the "list" to get a "weakened" context morphism [Γ,τ ==> Δ], s.t. expressions in Δ are well-typed in the extended context [Γ,τ] *)
Equations wkn {Γ Δ τ} : Γ ==> Δ -> (Γ,τ) ==> Δ :=
  wkn (s_empty _) := (s_empty _);
  wkn (s_ext _ f e) := s_ext _ (wkn f) (rename (renF (wkn_ren id_ren)) e) .

Lemma wkn_interp {C : Category} `{@CCC C} {Γ Δ} (s : Γ ==> Δ) (τ : Ty) :
  s⟦ wkn (τ:=τ) s ⟧ = s⟦s⟧ ∘ Pi_1.
Proof.
  funelim (wkn s).
  - apply t_morph_unique.
  - simpl. rewrite H by reflexivity.
    erewrite (rename_interp (τ:=τ0)). rewrite wkn_ren_interp.
    rewrite id_ren_id_morph. rewrite id_unit_left.
    symmetry. apply Prod_morph_distr_r.
Qed.

(** Using the previously defined machinery we can now define the identity context morhism *)
Equations idS Γ : Γ ==> Γ :=
  idS nil := s_empty _ ;
  idS (e :: Γ') := s_ext _ (wkn (idS Γ')) (Var here).

Lemma idS_id_morph {C : Category} `{@CCC C} {Γ} :
  s⟦idS Γ⟧ = Category.id.
Proof.
  induction Γ;simpl.
  - apply t_morph_unique.
  - rewrite wkn_interp. rewrite IHΓ.
    rewrite id_unit_left.
    apply (Prod_morph_unique _ _ Pi_1 Pi_2).
    + apply Prod_morph_com_1.
    + apply Prod_morph_com_2.
    + apply id_unit_right.
    + apply id_unit_right.
Qed.

(** Given a context morphism, returns a function mapping variables in Γ to terms well-typed in Δ *)
Equations substF {Γ Δ} : Δ ==> Γ -> forall τ, τ ∈ Γ -> Exp Δ τ :=
  substF (s_ext _ t) _ here := t ;
  substF (@s_ext _ _ _ s t) _ (there n) := substF s _ n.

Definition extsS {Γ Δ σ} :
  (Γ ==> Δ) ->
(*-------------------------------*)
  (Γ,σ) ==> (Δ,σ)

  := fun s => s_ext _ (wkn s) (Var here).

Equations subst {Γ Δ} :
  Δ ==> Γ ->
(*-------------------------------*)
  (forall τ, Exp Γ τ -> Exp Δ τ) :=

  subst s _ Star := Star ;
  subst s _ (Var n) := (substF s) _ n ;
  subst s _ (Lam b) := Lam (subst (extsS s) _ b) ;
  subst s _ (App e1 e2) => App (subst s _ e1) (subst s _ e2).

Arguments Prod_morph_unique {_ _ _ _ _} _ _ {_ _}.
Arguments Prod_morph_com_1 {_ _ _ _ _}.
Arguments Prod_morph_com_2 {_ _ _ _ _}.

Lemma varProj_commutes {C : Category} `{@CCC C} {Γ Δ : Ctx} {τ} n (s : Γ ==> Δ)
  : varProj Δ n ∘ s⟦ s ⟧ = e⟦ substF s τ n ⟧.
Proof.
  funelim (substF s τ n).
  + rewrite substF_equation_2. simpl.
    rewrite Prod_morph_com_2. reflexivity.
  + rewrite substF_equation_3. simpl.
    rewrite <- H by reflexivity.
    rewrite assoc.
    rewrite Prod_morph_com_1. reflexivity.
Qed.

Lemma subst_semantics {C : Category} `{@CCC C} {Γ Δ τ}
       (s : Γ ==> Δ) (t : Exp Δ τ) :
  e⟦ subst s _ t ⟧ = e⟦t⟧ ∘ s⟦s⟧.
Proof.
  revert s.
  revert dependent Γ.
  induction t;intros Γ' s.
  - apply t_morph_unique.
  - symmetry. apply varProj_commutes.
  - simpl. rewrite IHt. simpl.
    rewrite wkn_interp.
    symmetry. apply curry_compose.
  - simpl. fold interpTy.
    rewrite assoc.
    rewrite IHt1.
    rewrite IHt2.
    apply f_equal2;auto.
    symmetry. apply Prod_morph_distr_r.
Qed.

Definition munit : [tU;tU] ==> [tU;tU].
  constructor. constructor. apply s_empty.
  constructor. constructor. Defined.

Definition singleSubstMorph {Γ τ} : Exp Γ τ -> Γ ==> (Γ,τ) :=
  fun e => s_ext _ (idS Γ) e.

Definition singleSubst {Γ τ σ} :

  Exp (Γ,σ) τ -> Exp Γ σ ->
(*--------------------------*)
  Exp Γ τ

  := fun e1 e2 => subst (singleSubstMorph e2) _ e1.

Notation "e1 .[ e2 ]" := (singleSubst e1 e2) (at level 20).

Lemma single_subst_semantics {C : Category} `{@CCC C} {Γ τ σ}
       (e1 : Exp (Γ,τ) σ)(e2 : Exp Γ τ) :
  e⟦e1.[e2]⟧ = e⟦e1⟧ ∘ ⟨id ; e⟦e2⟧ ⟩.
Proof.
  refine
    (calc e⟦e1.[e2]⟧ = e⟦e1⟧ ∘ ⟨s⟦idS _⟧ ; e⟦e2⟧ ⟩ by subst_semantics _ _;
                  _  = e⟦e1⟧ ∘ ⟨id ; e⟦e2⟧ ⟩ by {{ @idS_id_morph }}
          end ).
Qed.

(** Examples of how we can use the notation and apply substitutions *)

Definition id_unit_syn : Exp nil (tU :-> tU) :=
  λ v0.

Definition ex_syn : Exp [tU;tU :-> tU] (tU :-> tU) :=
  λ (v2 ⋅ v1).

Example ex_syn_subst : ex_syn.[Star] = λ (v1 ⋅ Star).
Proof. reflexivity. Qed.

(** ** Interpreting equations  *)

Reserved Notation "e1 ≡β e2" (at level 22).

(** We define β-equal terms using the following inductive relation *)
Inductive StlcEq : forall {Γ : Ctx} {τ : Ty}, Exp Γ τ -> Exp Γ τ -> Type :=
| seq_refl : forall {Γ τ} (e : Exp Γ τ),

    e ≡β e

| seq_sym : forall {Γ τ} (e1 : Exp Γ τ) (e2 : Exp Γ τ),

    e1 ≡β e2 ->
 (* ---------  *)
    e2 ≡β e1

| seq_beta : forall {Γ τ σ} (e1 : Exp (Γ,τ) σ) (e2 : Exp Γ τ),

    (λ e1) ⋅ e2 ≡β e1.[e2]

| seq_app_cong_eq : forall {Γ τ σ} (e1 e1' : Exp Γ (τ :-> σ)) (e2 e2' : Exp Γ τ),

    e1 ≡β e1'  ->  e2 ≡β e2' ->
 (* ---------------------------- *)
    (e1 ⋅ e2) ≡β (e1' ⋅ e2')

where "e1 ≡β e2" := (StlcEq e1 e2).

Arguments eval {_ _ _ _ _}.
Arguments curry {_ _ _ _ _ _}.

(** Interpreting the intrinsically-typed β-equality also shows soundness *)
Equations interpEq {C : Category} `{@CCC C} {Γ τ} {e1 e2 : Exp Γ τ} :
  e1 ≡β e2 -> e⟦e1⟧ = e⟦e2⟧ :=

  interpEq (seq_refl e) := eq_refl;
  interpEq (seq_sym e1 e2 eq1) := eq_sym (interpEq eq1);
  interpEq (seq_app_cong_eq e1 e1' e2 e2' eq1 eq2) :=
       f_equal2 _ (f_equal2 _ (interpEq eq1) (interpEq eq2)) eq_refl;
  interpEq (seq_beta (Γ:=Γ) (τ:=τ) (σ:=σ) e1 e2) :=
    calc
      eval ∘ ⟨ curry e⟦ e1 ⟧; e⟦ e2 ⟧ ⟩
        = eval ∘ ⟨ curry e⟦ e1 ⟧ ∘ Pi_1; Pi_2 ⟩ ∘ ⟨ id ; e⟦ e2 ⟧ ⟩ by {{ @Prod_morph_decompose }};
      _ = (eval ∘ ⟨ curry e⟦ e1 ⟧ ∘ Pi_1; Pi_2 ⟩) ∘ ⟨ id ; e⟦ e2 ⟧ ⟩ by {{ @assoc }} ;
      _ = e⟦ e1 ⟧ ∘ ⟨ id; e⟦ e2 ⟧ ⟩ by  {{ Exp_morph_com' }} ;
      _ = e⟦ e1 .[ e2] ⟧ by {{ @single_subst_semantics }}
   end.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Notation "W ↓" := (compile_whole _ _ _ W) (at level 50).

Section Preservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "W ↓" := (cmp W) (at level 50).

  Variable σ : prop__T -> prop__S.
  Variable τ : prop__S -> prop__T.

  Definition σP (W : prg__S) (π__T : (trace__T -> Prop)) :=
    sat__S W (σ π__T) -> sat__T (W ↓) π__T.

  Definition σTP := forall W π__T, σP W π__T.

  Lemma contra_σP (W : prg__S) (π__T : prop__T) :
    (σP W π__T) <->  ((exists t, sem__T (W ↓) t /\ ~ (π__T t)) ->
                  (exists s, sem__S W s /\ ~ (σ π__T) s)).
  Proof.
    rewrite /σP. by rewrite [_ -> _] contra !neg_sat.
  Qed.

  Lemma contra_σTP :
    σTP <-> (forall W π__T, (exists t, sem__T (W ↓) t /\ ~ (π__T t)) ->
                   (exists s, sem__S W s /\ ~ (σ π__T) s)).
  Proof.
    rewrite /σTP.
    split => H W π__T; by move/contra_σP: (H W π__T).
  Qed.

  Definition τP (W : prg__S) (π__S : prop__S) :=
    sat__S W π__S -> sat__T (W ↓) (τ π__S).

  Definition τTP := forall W π__S, τP W π__S.

  Lemma contra_τP (W : prg__S) (π__S : prop__S) :
    (τP W π__S) <-> ((exists t, sem__T (W ↓) t /\ ~ (τ π__S) t) ->
                 (exists s, sem__S W s /\ ~ π__S s)).
  Proof.
    rewrite /τP. by rewrite [_ -> _] contra !neg_sat.
  Qed.

  Lemma contra_τTP :
    τTP <-> (forall W π__S, (exists t, sem__T (W ↓) t /\ ~ (τ π__S) t) ->
                   (exists s, sem__S W s /\ ~ π__S s)).
  Proof.
    rewrite /τTP.
    split => H W π__S; by move/contra_τP: (H W π__S).
  Qed.

  Theorem G_σTP_iff_τTP :
    (Galois_fst τ σ) -> (Galois_snd τ σ) -> (σTP <-> τTP).
  Proof.
    move => G1 G2. split.
    - move => Hσ P πs Hsat_src. apply: (Hσ P (τ πs)).
      apply: sat_upper_closed. exact Hsat_src. by apply: G1.
    - move => Hτ P πt Hrsat_tgt.
      have H : sat__T (P ↓) (τ (σ πt)) by apply: Hτ.
      apply: sat_upper_closed. exact H. by apply: G2.
  Qed.

  Corollary Adj_σTP_iff_τTP :
    Adjunction_law τ σ -> (σTP <-> τTP).
  Proof.
    rewrite Galois_equiv. move => [ms [mt [G1 G2]]].
      by apply: G_σTP_iff_τTP.
  Qed.

End Preservation.


(* begin hide *)
From Coq Require Import
     List.
Import ListNotations.

From Vellvm Require Import
     Numeric.Coqlib
     Utilities
     Syntax.

From ExtLib Require Import List.

Set Implicit Arguments.
Set Strict Implicit.
(* end hide *)

Lemma app_snoc_app : forall {A} (l l' : list A) x,
    (l ++ [x]) ++ l' = l ++ (x :: l').
Proof.
  intros.
  rewrite <- app_assoc; reflexivity.
Qed.

Section LABELS_THEORY.

  Context {T : Set}.

  Lemma inputs_app: forall (l l' : ocfg T),
      @inputs T (l ++ l') = inputs l ++ inputs l'.
  Proof.
    intros.
    unfold inputs at 1.
    rewrite map_app; auto.
  Qed.

  Lemma inputs_cons: forall b (l : ocfg T),
      @inputs T (b :: l) = blk_id b :: inputs l.
  Proof.
    intros.
    rewrite list_cons_app, inputs_app; reflexivity.
  Qed.

  Lemma outputs_acc: forall (bks: ocfg T) acc,
      fold_left (fun acc bk => acc ++ successors bk) bks acc =
      acc ++ fold_left (fun acc bk => acc ++ successors bk) bks [].
  Proof.
    induction bks using list_rev_ind; intros; cbn.
    - rewrite app_nil_r; reflexivity.
    - rewrite 2 fold_left_app, IHbks.
      cbn.
      rewrite app_assoc.
      reflexivity.
  Qed.

  Lemma outputs_app: forall (l l' : ocfg T),
      @outputs T (l ++ l') = outputs l ++ outputs l'.
  Proof.
    intros.
    unfold outputs at 1.
    rewrite fold_left_app, outputs_acc.
    reflexivity.
  Qed.

  Lemma outputs_cons: forall b (l : ocfg T),
      @outputs T (b :: l) = successors b ++ outputs l.
  Proof.
    intros.
    rewrite list_cons_app, outputs_app; reflexivity.
  Qed.

  Lemma wf_ocfg_bid_nil:
    wf_ocfg_bid (T := T) [].
  Proof.
    intros; apply list_norepet_nil.
  Qed.

  Lemma wf_ocfg_bid_cons :
    forall (b : block T) (bs : ocfg T),
      wf_ocfg_bid (b :: bs) ->
      wf_ocfg_bid bs.
  Proof.
    intros * NOREP; inv NOREP; eauto.
  Qed.

  Lemma wf_ocfg_bid_cons_not_in :
    forall (b : block T) (bs : ocfg T),
      wf_ocfg_bid (b :: bs) ->
      not (In (blk_id b) (inputs bs)).
  Proof.
    intros * NOREP; inv NOREP; eauto.
  Qed.

  Lemma wf_ocfg_bid_app_r :
    forall (bs1 bs2 : ocfg T),
      wf_ocfg_bid (bs1 ++ bs2) ->
      wf_ocfg_bid bs2.
  Proof.
    intros * NR.
    eapply list_norepet_append_right.
    unfold wf_ocfg_bid in NR.
    rewrite inputs_app in NR.
    eauto.
  Qed.

  Lemma wf_ocfg_bid_app_l :
    forall (bs1 bs2 : ocfg T),
      wf_ocfg_bid (bs1 ++ bs2) ->
      wf_ocfg_bid bs1.
  Proof.
    intros * NR.
    eapply list_norepet_append_left.
    unfold wf_ocfg_bid in NR.
    rewrite inputs_app in NR.
    eauto.
  Qed.

  Lemma wf_ocfg_commut :
    forall (G G' : ocfg T),
      wf_ocfg_bid (G ++ G') ->
      wf_ocfg_bid (G' ++ G).
  Proof.
    intros.
    red; rewrite inputs_app; apply Coqlib.list_norepet_append_commut; rewrite <- inputs_app; apply H.
  Qed.

  Lemma wf_ocfg_commut_hd :
    forall (bk bk' : block T) G,
      wf_ocfg_bid (bk::bk'::G) ->
      wf_ocfg_bid (bk'::bk::G).
  Proof.
    intros * WF.
    inv WF.
    inv H2.
    constructor.
    2: constructor; auto.
    - intros [EQ | IN]; auto.
      apply H1; left; auto.
    - intros IN; auto.
      eapply H1; right; auto.
  Qed.

  Lemma wf_ocfg_map : forall (f : block T -> block T) (G : ocfg T),
      (forall bk, blk_id (f bk) = blk_id bk) ->
      wf_ocfg_bid G <-> wf_ocfg_bid (map f G).
  Proof.
    intros.
    unfold wf_ocfg_bid, inputs.
    rewrite List.map_map.
    replace (map (fun x : block T => blk_id (f x)) G) with (map blk_id G); [reflexivity |].
    apply map_ext.
    intros; rewrite H; auto.
  Qed.

  Lemma blk_id_convert_typ :
    forall env b,
      blk_id (convert_typ env b) = blk_id b.
  Proof.
    intros ? []; reflexivity.
  Qed.

  (* TODO: Show symmetric case *)
  Lemma wf_ocfg_bid_app_not_in_l :
    forall id (bs bs' : ocfg T),
      In id (inputs bs) ->
      wf_ocfg_bid (bs' ++ bs) ->
      not (In id (inputs bs')).
  Proof.
    intros. destruct bs.
    inversion H.
    inv H.
    apply wf_ocfg_bid_cons_not_in.
    unfold wf_ocfg_bid in *.
    rewrite inputs_app in H0.
    rewrite inputs_cons. rewrite inputs_cons in H0.
    rewrite list_cons_app in H0.
    rewrite app_assoc in H0.
    apply list_norepet_append_left in H0.
    rewrite list_cons_app.
    rewrite list_norepet_app in *.
    intuition. apply list_disjoint_sym. auto.
    unfold wf_ocfg_bid in H0.
    rewrite inputs_app in H0. rewrite inputs_cons in H0. rewrite list_cons_app in H0.
    apply list_norepet_append_commut in H0. rewrite <- app_assoc in H0.
    apply list_norepet_append_right in H0.
    rewrite list_norepet_app in H0.
    destruct H0 as (? & ? & ?).
    red in H2. intro. eapply H2; eauto.
  Qed.

  (* TODO: Show symmetric case *)
  Lemma wf_ocfg_app_not_in_r :
    forall id (bs bs' : ocfg T),
      In id (inputs bs) ->
      wf_ocfg_bid (bs' ++ bs) ->
      not (In id (inputs bs')).
  Proof.
    intros. destruct bs.
    inversion H.
    inv H.
    apply wf_ocfg_bid_cons_not_in.
    unfold wf_ocfg_bid in *.
    rewrite inputs_app in H0.
    rewrite inputs_cons. rewrite inputs_cons in H0.
    rewrite list_cons_app in H0.
    rewrite app_assoc in H0.
    apply list_norepet_append_left in H0.
    rewrite list_cons_app.
    rewrite list_norepet_app in *.
    intuition. apply list_disjoint_sym. auto.
    unfold wf_ocfg_bid in H0.
    rewrite inputs_app in H0. rewrite inputs_cons in H0. rewrite list_cons_app in H0.
    apply list_norepet_append_commut in H0. rewrite <- app_assoc in H0.
    apply list_norepet_append_right in H0.
    rewrite list_norepet_app in H0.
    destruct H0 as (? & ? & ?).
    red in H2. intro. eapply H2; eauto.
  Qed.

  Lemma In_bk_outputs: forall bid br (b: block T) (l : ocfg T),
      In br (successors b) ->
      find_block l bid = Some b ->
      In br (outputs l).
  Proof.
    induction l as [| ? l IH].
    - cbn; intros ? abs; inv abs.
    - intros IN FIND.
      cbn in FIND.
      flatten_hyp FIND; inv FIND.
      + flatten_hyp Heq; inv Heq.
        rewrite outputs_cons.
        apply in_or_app; left; auto.
      + flatten_hyp Heq; inv Heq.
        rewrite outputs_cons.
        apply in_or_app; right.
        auto.
  Qed.

  Lemma find_block_in_inputs :
    forall to (bks : ocfg T),
      In to (inputs bks) ->
      exists bk, find_block bks to = Some bk.
  Proof.
    induction bks as [| id ocfg IH]; cbn; intros IN; [inv IN |].
    flatten_goal; flatten_hyp Heq; intuition; eauto.
  Qed.

  Lemma no_reentrance_not_in (bks1 bks2 : ocfg T) :
    no_reentrance bks1 bks2 ->
    forall x, In x (outputs bks2) -> ~ In x (inputs bks1).
  Proof.
    intros; eauto using Coqlib.list_disjoint_notin.
  Qed.

  Lemma no_reentrance_app_l :
    forall (bks1 bks1' bks2 : ocfg T),
      no_reentrance (bks1 ++ bks1') bks2 <->
      no_reentrance bks1 bks2 /\ no_reentrance bks1' bks2.
  Proof.
    intros; unfold no_reentrance; split; [intros H | intros [H1 H2]].
    - rewrite inputs_app, list_disjoint_app_r in H; auto.
    - rewrite inputs_app, list_disjoint_app_r; auto.
  Qed.

  Lemma no_reentrance_app_r :
    forall (bks1 bks2 bks2' : ocfg T),
      no_reentrance bks1 (bks2 ++ bks2')%list <->
      no_reentrance bks1 bks2 /\ no_reentrance bks1 bks2'.
  Proof.
    intros; unfold no_reentrance; split; [intros H | intros [H1 H2]].
    - rewrite outputs_app,list_disjoint_app_l in H; auto.
    - rewrite outputs_app, list_disjoint_app_l; auto.
  Qed.

  Lemma no_duplicate_bid_not_in_l (bks1 bks2 : ocfg T) :
    no_duplicate_bid bks1 bks2 ->
    forall x, In x (inputs bks2) -> ~ In x (inputs bks1).
  Proof.
    intros; eauto using Coqlib.list_disjoint_notin, Coqlib.list_disjoint_sym.
  Qed.

  Lemma no_duplicate_bid_not_in_r (bks1 bks2 : ocfg T) :
    no_duplicate_bid bks1 bks2 ->
    forall x, In x (inputs bks1) -> ~ In x (inputs bks2).
  Proof.
    intros; eauto using Coqlib.list_disjoint_notin, Coqlib.list_disjoint_sym.
  Qed.

  Lemma independent_flows_no_reentrance_l (bks1 bks2 : ocfg T):
    independent_flows bks1 bks2 ->
    no_reentrance bks1 bks2.
  Proof.
    intros INDEP; apply INDEP; auto.
  Qed.

  Lemma independent_flows_no_reentrance_r (bks1 bks2 : ocfg T):
    independent_flows bks1 bks2 ->
    no_reentrance bks2 bks1.
  Proof.
    intros INDEP; apply INDEP; auto.
  Qed.

  Lemma independent_flows_no_duplicate_bid (bks1 bks2 : ocfg T):
    independent_flows bks1 bks2 ->
    no_duplicate_bid bks1 bks2.
  Proof.
    intros INDEP; apply INDEP; auto.
  Qed.

  Lemma find_block_not_in_inputs:
    forall bid (l : ocfg T),
      ~ In bid (inputs l) ->
      find_block l bid = None.
  Proof.
    induction l as [| bk l IH]; intros NIN; auto.
    cbn.
    flatten_goal.
    - exfalso.
      flatten_hyp Heq; [| inv Heq].
      apply NIN.
      left; rewrite e; reflexivity.
    - flatten_hyp Heq; [inv Heq |].
      apply IH.
      intros abs; apply NIN.
      right; auto.
  Qed.

  Lemma wf_ocfg_bid_singleton : forall (b : _ T), wf_ocfg_bid [b].
  Proof.
    intros.
    red.
    eapply list_norepet_cons; eauto.
    eapply list_norepet_nil.
  Qed.

  Lemma wf_ocfg_bid_cons' : forall (b : _ T) (bks : ocfg T),
      not (In (blk_id b) (inputs bks)) ->
      wf_ocfg_bid bks ->
      wf_ocfg_bid (b :: bks).
  Proof.
    intros.
    eapply list_norepet_cons; eauto.
  Qed.

  Lemma free_in_cfg_cons:
    forall b (bs : ocfg T) id,
      free_in_cfg (b::bs) id ->
      free_in_cfg bs id .
  Proof.
    intros * FR abs; apply FR; cbn.
    destruct (Eqv.eqv_dec_p (blk_id b) id); [rewrite e; auto | right; auto].
  Qed.

  Lemma free_in_cfg_app : forall (bks1 bks2 : ocfg T) b,
      free_in_cfg (bks1 ++ bks2) b <->
      (free_in_cfg bks1 b /\ free_in_cfg bks2 b).
  Proof.
    intros; split; unfold free_in_cfg; intro FREE.
    - split; intros abs; eapply FREE; rewrite inputs_app; eauto using in_or_app.
    - rewrite inputs_app; intros abs; apply in_app_or in abs; destruct FREE as [FREEL FREER]; destruct abs; [eapply FREEL | eapply FREER]; eauto.
  Qed.

  Lemma wf_ocfg_bid_distinct_labels :
    forall (bks1 bks2 : ocfg T) b1 b2,
      wf_ocfg_bid (bks1 ++ bks2) ->
      In b1 (inputs bks1) ->
      In b2 (inputs bks2) ->
      b1 <> b2.
  Proof.
    intros * WF IN1 IN2.
    eapply wf_ocfg_bid_app_not_in_l in IN2; eauto.
    destruct (Eqv.eqv_dec_p b1 b2).
    rewrite e in IN1; contradiction IN2; auto.
    auto.
  Qed.

  Lemma predecessors_app :
    forall (bks bks' : ocfg T) f,
      predecessors f (bks ++ bks') = predecessors f bks' ++ predecessors f bks.
  Proof.
    induction bks' as [| bk bks' IH] using rev_ind.
    - intros; cbn; rewrite !app_nil_r; reflexivity.
    - intros.
      unfold predecessors.
      rewrite app_assoc.
      rewrite 2 (fold_left_app _ _ [bk]).
      simpl.
      break_match_goal.
      + cbn; f_equal.
        apply IH.
      + apply IH.
  Qed.

  Lemma predecessors_cons :
    forall (bks : ocfg T) bk f,
      predecessors f (bk :: bks) = predecessors f bks ++ predecessors f [bk].
  Proof.
    intros.
    rewrite list_cons_app, predecessors_app.
    reflexivity.
  Qed.

  Lemma find_block_In : forall G (bk : block T),
      find_block G bk.(blk_id) = Some bk ->
      In bk G.
  Proof.
    induction G as [| x G IH]; intros * FIND; [inv FIND |].
    cbn in FIND; break_match_hyp; auto.
    inv FIND; left; reflexivity.
    right; apply IH; auto.
  Qed.

  Lemma successor_predecessor :
    forall (G : ocfg T) (source : block T) target,
      In target (successors source) ->
      find_block G source.(blk_id) = Some source ->
      In source.(blk_id) (predecessors target G).
  Proof.
    intros * IN FIND.
    apply find_block_In in FIND; revert FIND.
    induction G as [| bki G IH]; intros * FIND.
    - inv FIND.
    - destruct FIND as [EQ | FIND].
      + subst.
        clear IH.
        rewrite predecessors_cons.
        apply in_or_app; right.
        cbn.
        unfold successors in IN.
        unfold is_predecessor.
        break_match_goal.
        left; auto.
        break_match_hyp; intuition.
      + rewrite predecessors_cons.
        apply in_or_app; left.
        apply IH; auto.
  Qed.

  Definition predecessors_aux (b : block_id) (G : ocfg T) acc :=
    fold_left (fun acc bk => if is_predecessor b bk then bk.(blk_id) :: acc else acc) G acc.

  Lemma In_predecessors_is_predecessor_aux :
    forall (G : ocfg T) acc (src tgt : block_id),
      In src (predecessors_aux tgt G acc) ->
      (In src acc \/ exists bk, In bk G /\ src = bk.(blk_id) /\ is_predecessor tgt bk = true).
  Proof.
    intros *; revert acc; induction G as [| bk G IH]; intros acc IN; [left; auto |].
    cbn in IN.
    break_match_hyp.
    - edestruct IH as [INACC | (bk' & INbk & -> & PRED)]; eauto.
      + destruct INACC as [<- | ?]; [| left; auto].
        right; exists bk; intuition.
      + right.
        exists bk'; intuition.
    - edestruct IH as [INACC | (bk' & INbk & -> & PRED)]; eauto.
      right; exists bk'; intuition.
  Qed.

  Lemma In_predecessors_is_predecessor :
    forall (G : ocfg T) (src tgt : block_id),
      In src (predecessors tgt G) ->
      exists bk, In bk G /\ src = bk.(blk_id) /\ is_predecessor tgt bk = true.
  Proof.
    intros * IN.
    edestruct In_predecessors_is_predecessor_aux as [INACC | (bk' & INbk & -> & PRED)]; eauto.
    inv INACC.
  Qed.

  Lemma find_block_nil:
    forall b,
      @find_block T [] b = None.
  Proof.
    reflexivity.
  Qed.

  Lemma find_block_eq:
    forall x (b : block T) (bs : ocfg T),
      blk_id b = x ->
      find_block (b:: bs) x = Some b.
  Proof.
    intros; cbn.
    rewrite H.
    destruct (Eqv.eqv_dec_p x x).
    reflexivity.
    contradiction n; reflexivity.
  Qed.

  Lemma find_block_ineq:
    forall x (b : block T) (bs : ocfg T),
      blk_id b <> x ->
      find_block (b::bs) x = find_block bs x.
  Proof.
    intros; cbn.
    destruct (Eqv.eqv_dec_p (blk_id b)) as [EQ | INEQ].
    unfold Eqv.eqv, AstLib.eqv_raw_id in *; intuition.
    reflexivity.
  Qed.

  Lemma wf_ocfg_bid_In_is_found :
    forall (bks : ocfg T) bk,
      wf_ocfg_bid bks ->
      In bk bks ->
      find_block bks bk.(blk_id) = Some bk.
  Proof.
    induction bks as [| x bks IH]; intros * WF IN; [inv IN |].
    destruct (Eqv.eqv_dec_p x.(blk_id) bk.(blk_id)).
    - rewrite find_block_eq; auto.
      destruct IN as [-> | IN]; auto.
      apply wf_ocfg_bid_cons_not_in in WF.
      exfalso; apply WF.
      do 2 red in e; rewrite e.
      eapply in_map; auto.
    - rewrite find_block_ineq; [| auto].
      apply IH.
      eapply wf_ocfg_bid_cons; eauto.
      destruct IN; auto.
      exfalso; subst; eapply n; reflexivity.
  Qed.

  Lemma predecessor_successor :
    forall (G : ocfg T) (source target : block_id) (bk : block T),
      wf_ocfg_bid G ->
      In source (predecessors target G) ->
      find_block G source = Some bk ->
      In target (successors bk).
  Proof.
    intros * WF IN FIND.
    pose proof In_predecessors_is_predecessor _ _ _ IN as (bk' & IN' & -> & ISPRED).
    apply wf_ocfg_bid_In_is_found in IN'; auto.
    rewrite FIND in IN'; inv IN'.
    unfold is_predecessor in ISPRED.
    break_match_hyp; intuition.
  Qed.

  Lemma find_block_app_r_wf :
    forall (x : block_id) (b : block T) (bs1 bs2 : ocfg T),
      wf_ocfg_bid (bs1 ++ bs2)  ->
      find_block bs2 x = Some b ->
      find_block (bs1 ++ bs2) x = Some b.
  Proof.
    intros x b; induction bs1 as [| hd bs1 IH]; intros * NOREP FIND.
    - rewrite app_nil_l; auto.
    - cbn; break_inner_match_goal.
      + cbn in NOREP; apply wf_ocfg_bid_cons_not_in in NOREP.
        exfalso; apply NOREP.
        rewrite e.
        apply find_some in FIND as [FIND EQ].
        clear - FIND EQ.
        rewrite inputs_app; eapply in_or_app; right.
        break_match; [| intuition].
        rewrite <- e.
        eapply in_map; auto.
      + cbn in NOREP; apply wf_ocfg_bid_cons in NOREP.
        apply IH; eauto.
  Qed.

  Lemma find_block_app_l_wf :
    forall (x : block_id) (b : block T) (bs1 bs2 : ocfg T),
      wf_ocfg_bid (bs1 ++ bs2)  ->
      find_block bs1 x = Some b ->
      find_block (bs1 ++ bs2) x = Some b.
  Proof.
    intros x b; induction bs1 as [| hd bs1 IH]; intros * NOREP FIND.
    - inv FIND.
    - cbn in FIND |- *.
      break_inner_match; auto.
      apply IH; eauto.
      eapply wf_ocfg_bid_cons, NOREP.
  Qed.

  Lemma find_block_tail_wf :
    forall (x : block_id) (b b' : block T) (bs : ocfg T),
      wf_ocfg_bid (b :: bs)  ->
      find_block bs x = Some b' ->
      find_block (b :: bs) x = Some b'.
  Proof.
    intros.
    rewrite list_cons_app.
    apply find_block_app_r_wf; auto.
  Qed.

  Lemma find_block_free_id :
    forall (cfg : ocfg T) id,
      free_in_cfg cfg id ->
      find_block cfg id = None.
  Proof.
    induction cfg as [| b bs IH]; cbn; intros * FREE; auto.
    break_inner_match_goal.
    + exfalso; eapply FREE.
      cbn; rewrite e; auto.
    + apply IH.
      apply free_in_cfg_cons in FREE; auto.
  Qed.

  Lemma find_block_none_app:
    forall (bks1 bks2 : ocfg T) bid,
      find_block bks1 bid = None ->
      find_block (bks1 ++ bks2) bid = find_block bks2 bid.
  Proof.
    intros; apply find_none_app; auto.
  Qed.

  Lemma find_block_some_app:
    forall (bks1 bks2 : ocfg T) (bk : block T) bid,
      find_block bks1 bid = Some bk ->
      find_block (bks1 ++ bks2) bid = Some bk.
  Proof.
    intros; apply find_some_app; auto.
  Qed.

  Lemma find_block_Some_In_inputs : forall (bks : ocfg T) b bk,
      find_block bks b = Some bk ->
      In b (inputs bks).
  Proof.
    induction bks as [| hd bks IH].
    - intros * H; inv H.
    - intros * FIND.
      destruct (Eqv.eqv_dec_p (blk_id hd) b).
      cbn; rewrite e; auto.
      right; eapply IH.
      erewrite <- find_block_ineq; eauto.
  Qed.

  Lemma wf_ocfg_bid_find_None_app_l :
    forall (bks1 bks2 : ocfg T) b bk,
      wf_ocfg_bid (bks1 ++ bks2)%list ->
      find_block bks2 b = Some bk ->
      find_block bks1 b = None.
  Proof.
    induction bks1 as [| b bks1 IH]; intros * WF FIND.
    reflexivity.
    destruct (Eqv.eqv_dec_p (blk_id b) b0).
    - exfalso.
      cbn in WF; eapply wf_ocfg_bid_cons_not_in in WF.
      apply WF.
      rewrite inputs_app.
      apply in_or_app; right.
      rewrite e.
      apply find_block_Some_In_inputs in FIND; auto.
    - rewrite find_block_ineq; auto.
      eapply IH; eauto using wf_ocfg_bid_cons.
  Qed.

  Lemma find_block_has_id : forall (G : ocfg T) b bk,
      find_block G b = Some bk ->
      b = bk.(blk_id).
  Proof.
    induction G as [| bkh G IH].
    - intros * LU; inv LU.
    - intros * LU.
      cbn in LU.
      break_match_hyp.
      + inv LU; break_match_hyp; intuition.
      + apply IH.
        apply LU.
  Qed.

  Lemma find_block_map_some :
    forall (f : block T -> block T) G b bk,
      (forall bk, blk_id (f bk) = blk_id bk) ->
      find_block G b = Some bk ->
      find_block (map f G) b = Some (f bk).
  Proof.
    intros * ID; induction G as [| hd G IH]; intros FIND ; [inv FIND |].
    cbn in *.
    rewrite ID.
    break_match_goal; break_match_hyp; intuition.
    inv FIND; auto.
  Qed.

  Lemma find_block_map_none :
    forall (f : block T -> block T) G b,
      (forall bk, blk_id (f bk) = blk_id bk) ->
      find_block G b = None ->
      find_block (map f G) b = None.
  Proof.
    intros * ID; induction G as [| hd G IH]; intros FIND; [reflexivity |].
    cbn in *.
    rewrite ID.
    break_match_goal; break_match_hyp; intuition.
    inv FIND; auto.
  Qed.

  Lemma wf_ocfg_bid_find_block_unique :
    forall (bks : ocfg T) bk1 b1 bk2,
      wf_ocfg_bid bks ->
      find_block bks b1 = Some bk1 ->
      find_block bks b1 = Some bk2 ->
      bk1 = bk2.
  Proof.
    induction bks as [| bk bks IH]; intros * WF FIND1 FIND2; [inv FIND1 |].
    cbn in *.
    break_match_hyp.
    inv FIND1; inv FIND2; auto.
    break_match_hyp; intuition.
    eapply IH; eauto.
    eapply wf_ocfg_bid_cons; eauto.
  Qed.

  Lemma find_block_In' : forall G b (bk : block T),
      find_block G b = Some bk ->
      In bk G.
  Proof.
    intros * LU; pose proof find_block_has_id _ _ LU; subst; apply find_block_In; auto.
  Qed.

  Lemma wf_ocfg_cons_not_in_tail :
    forall (bk : block T) G,
      wf_ocfg_bid (bk :: G) ->
      find_block G bk.(blk_id) = None.
  Proof.
    induction G as [| x G IH]; intros; [reflexivity |].
    cbn; break_match_goal.
    - break_match_hyp; intuition.
      do 2 red in e.
      exfalso; clear Heqb.
      red in H.
      cbn in H.
      rewrite e in H.
      inv H.
      eapply H2; left; reflexivity.
    - break_match_hyp; intuition.
      apply IH.
      apply wf_ocfg_commut_hd in H.
      eapply wf_ocfg_bid_cons; eauto.
  Qed.

  Lemma In_find_block :
    forall (bks : ocfg T) bk,
      In bk bks ->
      exists bk', find_block bks bk.(blk_id) = Some bk'.
  Proof.
    induction bks as [| x bks IH]; intros * IN; [inv IN | ].
    destruct (Eqv.eqv_dec_p x.(blk_id) bk.(blk_id)).
    - do 2 red in e; exists x; rewrite find_block_eq; auto.
    - rewrite find_block_ineq; [| auto].
      apply IH.
      destruct IN; auto.
      exfalso; subst; eapply n; reflexivity.
  Qed.

  Lemma find_block_map :
    forall (f : block T -> block T) G b,
      (forall bk, blk_id (f bk) = blk_id bk) ->
      find_block (map f G) b = option_map f (find_block G b).
  Proof.
    intros.
    destruct (find_block G b) eqn:EQ.
    eapply find_block_map_some in EQ; eauto.
    eapply find_block_map_none in EQ; eauto.
  Qed.

End LABELS_THEORY.

Lemma free_in_convert_typ :
  forall env (bs : list (LLVMAst.block typ)) id,
    free_in_cfg bs id ->
    free_in_cfg (convert_typ env bs) id.
Proof.
  induction bs as [| b bs IH]; intros * FR.
  - red; cbn; auto.
  - cbn.
    intros abs.
    eapply FR.
    destruct (Eqv.eqv_dec_p (blk_id b) id).
    left; rewrite e; auto.
    destruct abs.
    + cbn in H; unfold Traversal.endo, Traversal.Endo_id in H; cbn in H.
      exfalso; apply n; rewrite H; reflexivity.
    + apply IH in H; intuition.
      eapply free_in_cfg_cons; eauto.
Qed.

From Vellvm Require Import Syntax.TypToDtyp.

Section DTyp.

  Lemma convert_typ_terminator_outputs : forall t,
    terminator_outputs (convert_typ [] t) = terminator_outputs t.
  Proof.
    intros []; cbn; try reflexivity.
    - induction brs as [| [τ i] brs IH]; cbn; auto.
      do 2 f_equal.
      inv IH; auto.
    - induction brs; cbn; auto; f_equal; auto.
  Qed.

  Lemma convert_typ_outputs : forall (bks : ocfg typ),
      outputs (convert_typ [] bks) = outputs bks.
  Proof.
    induction bks as [| bk bks IH]; [reflexivity |].
    unfold convert_typ.
    simpl ConvertTyp_list.
    rewrite !outputs_cons, <- IH.
    f_equal.
    destruct bk; cbn.
    unfold successors.
    rewrite <- convert_typ_terminator_outputs.
    reflexivity.
  Qed.

  Lemma inputs_convert_typ : forall env bs,
      inputs (convert_typ env bs) = inputs bs.
  Proof.
    induction bs as [| b bs IH]; cbn; auto.
    f_equal; auto.
  Qed.

  Lemma wf_ocfg_bid_convert_typ :
    forall env (bs : ocfg typ),
      wf_ocfg_bid bs ->
      wf_ocfg_bid (convert_typ env bs).
  Proof.
    induction bs as [| b bs IH].
    - cbn; auto.
    - intros NOREP.
      change (wf_ocfg_bid (convert_typ env b :: convert_typ env bs)).
      apply list_norepet_cons.
      + apply wf_ocfg_bid_cons_not_in in NOREP.
        cbn.
        rewrite inputs_convert_typ; auto.
      + eapply IH, wf_ocfg_bid_cons; eauto.
  Qed.

End DTyp.


Add LoadPath ".." as SMTCoq.
Require Import SMTCoq.
Require Import Bool PArray Int31 List ZArith.

Local Open Scope int31_scope.

Require Import Trace2.
Import String. Import Resource.

Time Trim_dimacs erdos60 "erdos1161_60.cnf".

Lemma erdos60th :  forall rho : Valuation.t,
       Valuation.wf rho -> ~ Sat_Checker.valid rho erdos60.
apply (@Sat_Checker.checker_correct erdos60 "erdos1161_60.reso"%string).
native_cast_no_check (refl_equal true).
Time Qed.