(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

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

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

  You should have received a copy of the GNU General Public License
  along with CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export AlphaEquality.
Require Export SwapProps.

Set Implicit Arguments.

(** (re)defining it this way enables coq to successfully
    match the statement of [alphaEqTransitive]
    with the lemma [GAlphaInd] *)
Definition transRel {T : [univ]} (R : bin_rel T) :=
forall x y : T,
  R x y
  -> forall z : T,
     R y z -> R x z.

Lemma MakeAbsPnodeSame : forall
  {G : CFGV} {vc : VarSym G}
  (lps : list (GSym G))
  (m: Mixture (map (fun x : GSym G => (true, x)) (lps))),
  (MakeAbstractionsPNode vc m)
    = (MakeAbstractionsTNodeAux vc [] m).
Proof.
  induction m; cpx.
Qed.

Ltac remAlphaRight Hyp name :=
  match type of Hyp with
  | pAlphaEq _ _ ?r => remember r as name
  | tAlphaEq _ _ ?r => remember r as name
  end.

Ltac remAlphaLeft Hyp name :=
  match type of Hyp with
  | pAlphaEq _ ?l _ => remember l as name
  | tAlphaEq _ ?l _ => remember l as name
  end.

Section AlphaProps.
Context {G : CFGV} {vc  : VarSym G}.

Lemma alphaEquiVariant :
(
  (forall (s : GSym G) ,
      EquiVariantRelSame (@tSwap G vc s) (tAlphaEq vc))
   *
  (forall (s : GSym G),
      EquiVariantRelSame (@pSwap G vc s) (pAlphaEq vc))
  *
  (EquiVariantRelSame (@swapAbs G vc) (@AlphaEqAbs G vc))
  *
  (EquiVariantRelSame (@swapLAbs G vc) (@lAlphaEqAbs G vc))
).
Proof.
  intros. GAlphaInd; introns Hyp; intros;
  allsimpl; try (econstructor; eauto; fail);[| | |].
- Case "tnode". constructor.
  unfold allBndngVars.
  rw <- swapLBoundVarsCommute.
  rw <- swapLBoundVarsCommute.
  rewrite <- MakeLAbsSwapCommute.
  rewrite <- MakeLAbsSwapCommute.
  cpx.
- Case "pnode". constructor.
  rewrite <- MakeAbsPNodeCommute.
  rewrite <- MakeAbsPNodeCommute.
  cpx.
- Case "termAbs".
  specialize (Hyp4 sw).
  rewrite (tcase swap_app) in Hyp4.
  rewrite (tcase swap_app) in Hyp4.
  rewrite (tcase swap_prop_e1Stronger) in Hyp4.
  match type of Hyp4 with
  tAlphaEq _ _ ?b => pattern b in Hyp4
  end.
  rewrite (tcase swap_prop_e1Stronger) in Hyp4.
  rewrite <- (tcase swap_app) in Hyp4.
  rewrite <- (tcase swap_app) in Hyp4.

  unfold swapSwap in Hyp4. rewrite map_combine in Hyp4.
  rewrite map_combine in Hyp4.
  fold (swapLVar sw lbva) in Hyp4.
  fold (swapLVar sw lbvb) in Hyp4.
  fold (swapLVar sw lbnew) in Hyp4.
  remember (swapLVar sw lbnew) as lbns.
  repnud Hyp1.
  allsimpl.
  eapply  alAbT with (lbnew := lbns); eauto;
  try ( subst; unfold swapLVar;
    autorewrite with fast; congruence; fail); cpx;
  subst;[unfolds_base; allsimpl;
  dands|];repeat (disjoint_reasoning);[ | | | | ].
  + rewrite <- (tcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + rewrite <- (tcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + apply NoRepeatsEquivariant; trivial.
  + apply DisjointEquivariant; trivial.
  + apply DisjointEquivariant; trivial.

- Case "patAbs".
  specialize (Hyp4 sw).
  rewrite (pcase swap_app) in Hyp4.
  rewrite (pcase swap_app) in Hyp4.
  rewrite (pcase swap_prop_e1Stronger) in Hyp4.
  match type of Hyp4 with
  pAlphaEq _ _ ?b => pattern b in Hyp4
  end.
  rewrite (pcase swap_prop_e1Stronger) in Hyp4.
  rewrite <- (pcase swap_app) in Hyp4.
  rewrite <- (pcase swap_app) in Hyp4.

  unfold swapSwap in Hyp4. rewrite map_combine in Hyp4.
  rewrite map_combine in Hyp4.
  fold (swapLVar sw lbva) in Hyp4.
  fold (swapLVar sw lbvb) in Hyp4.
  fold (swapLVar sw lbnew) in Hyp4.
  remember (swapLVar sw lbnew) as lbns.
  repnud Hyp1.
  allsimpl.
  eapply  alAbP with (lbnew := lbns); eauto;
  try ( subst; unfold swapLVar;
    autorewrite with fast; congruence; fail); cpx;
  subst;[unfolds_base; allsimpl;
  dands|];repeat (disjoint_reasoning);[ | | | | ].
  + rewrite <- (pcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + rewrite <- (pcase AllVarsEquivariant).
    apply DisjointEquivariant; trivial.
  + apply NoRepeatsEquivariant; trivial.
  + apply DisjointEquivariant; trivial.
  + apply DisjointEquivariant; trivial.
Qed.

Lemma tAlphaEqEquivariantRev : forall
  (sw : Swapping vc) s (ta tb : Term s),
  tAlphaEq vc (tSwap ta sw) (tSwap tb sw)
  -> tAlphaEq vc ta tb.
Proof.
  introv Hd.
  apply (tcase alphaEquiVariant) in Hd.
  specialize (Hd (rev sw)).
  autorewrite with SwapAppR in Hd.
  autorewrite with fast in Hd.
  trivial.
Qed.

Lemma pAlphaEqEquivariantRev : forall
  (sw : Swapping vc) s (ta tb : Pattern s),
  pAlphaEq vc (pSwap ta sw) (pSwap tb sw)
  -> pAlphaEq vc ta tb.
Proof.
  introv Hd.
  apply (tcase alphaEquiVariant) in Hd.
  specialize (Hd (rev sw)).
  autorewrite with SwapAppR in Hd.
  autorewrite with fast in Hd.
  trivial.
Qed.

(** todo : better name .. [lv] is not nil anymore *)
Lemma AlphaEqNilAbsT : forall
(gs : GSym G) (tma tmb : Term gs)
(lv : list (vType vc)),
tAlphaEq vc tma tmb
-> AlphaEqAbs (termAbs vc lv tma) (termAbs vc lv tmb).
Proof.
  introv Ha.
  pose proof (GFreshDistRenWSpec vc lv
  (tAllVars tma++tAllVars tmb++lv))
    as XX.
  exrepnd. repeat (disjoint_reasoning).
  eapply  alAbT with (lbnew := lvn); eauto;
  unfold tFresh; dands;allsimpl;
  repeat(disjoint_reasoning); auto;[].
  apply alphaEquiVariant; cpx.
Qed.

Lemma AlphaEqNilAbsP : forall
(gs : GSym G) (tma tmb : Pattern gs)
(lv : list (vType vc)),
pAlphaEq vc tma tmb
-> AlphaEqAbs (patAbs vc lv tma) (patAbs vc lv tmb).
Proof.
  introv Ha.
  pose proof (GFreshDistRenWSpec vc lv
  (pAllVars tma++pAllVars tmb++lv))
    as XX.
  exrepnd. repeat (disjoint_reasoning).
  eapply  alAbP with (lbnew := lvn); eauto;
  unfold pFresh; dands;allsimpl;
  repeat(disjoint_reasoning); auto;[].
  apply alphaEquiVariant; cpx.
Qed.

Notation vcType := (vType vc).
Notation vcAbstraction := (@Abstraction G vc).

Lemma alphaEqRefl :
     (  (forall (s : GSym G) (t : Term s),
            tAlphaEq vc t t)
         *
        (forall (s : GSym G) (pt : Pattern s),
            pAlphaEq vc pt pt)
         *
        (forall (l : MixtureParam) (m : Mixture l)
        (lbv : list (list (vType vc))),
           lAlphaEqAbs (MakeAbstractions vc m lbv)
                       (MakeAbstractions vc m lbv))).
Proof.
  GInduction; introns Hyp; intros; cpx; allsimpl;
  try dlist_len lbv;  try (econstructor; eauto with slow; fail).
- Case "mtcons". econstructor; eauto;[].
  remember (lhead lbv) as lbvh.
  apply AlphaEqNilAbsT;cpx.
- Case "mpcons". econstructor; eauto;[].
  remember (lhead lbv) as lbvh.
  apply AlphaEqNilAbsP;cpx.
Qed.

Hint Resolve
(tcase alphaEqRefl)
(pcase alphaEqRefl)
(mcase alphaEqRefl)
  AlphaEqNilAbsT
  AlphaEqNilAbsP

 : Alpha.

Lemma talphaEqRefl : forall (s : GSym G)
  (ta tb : Term s),
  ta=tb -> tAlphaEq vc ta tb.
Proof.
  intros. subst. eauto with Alpha.
Qed.

Require Import Eqdep_dec.

Hint Resolve deqMixP: Deq.

Lemma alphaEqSym :
(  (forall (s : GSym G) (ta tb : Term s),
      tAlphaEq vc ta tb -> tAlphaEq vc tb ta)
   *
  (forall (s : GSym G) (pta ptb : Pattern s),
      pAlphaEq vc pta ptb -> pAlphaEq vc ptb pta)
   *
  (forall (aa ab : Abstraction G vc),
      AlphaEqAbs aa ab -> AlphaEqAbs ab aa)
   *
  (forall (la lb : list (Abstraction G vc)),
      lAlphaEqAbs la lb -> lAlphaEqAbs lb la)).
Proof.
  intros. GAlphaInd; introns Hyp; intros;
    try (econstructor; eauto; fail);[|].
- Case "termAbs".  eapply  alAbT with (lbnew := lbnew); eauto;
  [eauto with SetReasoning | repeat(disjoint_reasoning)].
- Case "patAbs".  eapply  alAbP with (lbnew := lbnew); eauto;
  [eauto with SetReasoning | repeat(disjoint_reasoning)].
Qed.

Lemma AlphaEqAbsTSameParam : forall (gsa gsb : GSym G)
  (lbva lbvb: list vcType)
  (tma : Term gsa) (tmb : Term gsb),
  AlphaEqAbs
      (termAbs vc lbva tma)
      (termAbs vc lbvb tmb)
  -> gsa =gsb.
Proof.
  introv Hal.
  inversion Hal.
  auto.
Qed.

Lemma AlphaEqAbsPSameParam : forall (gsa gsb : GSym G)
  (lbva lbvb: list vcType)
  (tma : Pattern gsa) (tmb : Pattern gsb),
  AlphaEqAbs
      (patAbs vc lbva tma)
      (patAbs vc lbvb tmb)
  -> gsa =gsb.
Proof.
  introv Hal.
  inversion Hal.
  auto.
Qed.

Lemma betterAbsTElim : forall (gs : GSym G)
  (lbva lbvb lvAvoid: list vcType)
  (tma tmb : Term gs),
  AlphaEqAbs
      (termAbs vc lbva tma)
      (termAbs vc lbvb tmb)
->{lbnew : list vcType $
      let swapa := combine lbva lbnew in
      let swapb := combine lbvb lbnew in
      length lbva = length lbnew #
      length lbvb = length lbnew #
      tFresh lbnew [tma, tmb] #
      (** naive elimination does not give the [lvAvoid] in the
         next hypothesis *)
      disjoint (lvAvoid++lbva++lbvb) lbnew #
      tAlphaEq vc (tSwap tma swapa) (tSwap tmb swapb)}.
Proof.
  introv Hab.
  inversion Hab. clear Hab.
  EqDecSndEq. subst.
  subst swapa. subst swapb.
  pose proof (GFreshDistRenWSpec vc lbnew
              (tAllVars tma++tAllVars tmb++
                    lbnew ++lbva ++ lbvb++ lvAvoid))
    as Hfr.
  exrepnd. exists lvn. simpl.
  dands; try congruence; unfold tFresh;
  allsimpl; dands; repeat(disjoint_reasoning);[].
  rename X0 into Htal.
  apply (tcase alphaEquiVariant ) in Htal.
  specialize (Htal (combine lbnew lvn)).
  rewrite (tcase swap_app) in Htal.
  rewrite (tcase swap_app) in Htal.
  unfold tFresh in X.
  allsimpl. repnd.
  autorewrite with slow in Htal; try congruence;
  cpx; repeat (disjoint_reasoning).
Qed.

Lemma betterAbsPElim : forall (gs : GSym G)
  (lbva lbvb lvAvoid: list vcType)
  (tma tmb : Pattern gs),
  AlphaEqAbs
      (patAbs vc lbva tma)
      (patAbs vc lbvb tmb)
->{lbnew : list vcType $
      let swapa := combine lbva lbnew in
      let swapb := combine lbvb lbnew in
      length lbva = length lbnew #
      length lbvb = length lbnew #
      pFresh lbnew [tma, tmb] #
      (** naive elimination does not give thhe next hypothesis *)
      disjoint (lvAvoid++lbva++lbvb) lbnew #
      pAlphaEq vc (pSwap tma swapa) (pSwap tmb swapb)}.
Proof.
  introv Hab.
  inversion Hab. clear Hab.
  EqDecSndEq. subst.
  subst swapa. subst swapb.
  pose proof (GFreshDistRenWSpec vc lbnew
              (pAllVars tma++pAllVars tmb++
                    lbnew ++lbva ++ lbvb++ lvAvoid))
    as Hfr.
  exrepnd. exists lvn. simpl.
  dands; try congruence; unfold pFresh;
  allsimpl; dands; repeat(disjoint_reasoning);[].
  rename X0 into Htal.
  apply (tcase alphaEquiVariant ) in Htal.
  specialize (Htal (combine lbnew lvn)).
  rewrite (pcase swap_app) in Htal.
  rewrite (pcase swap_app) in Htal.
  unfold pFresh in X.
  allsimpl. repnd.
  autorewrite with slow in Htal; try congruence;
  cpx; repeat (disjoint_reasoning).
Qed.

Lemma alphaEqTransitive :
(
  (forall (s : GSym G) ,
      transRel (@tAlphaEq _ vc s))
   *
  (forall (s : GSym G),
      transRel (@pAlphaEq _ vc s))
  *
      transRel (@AlphaEqAbs G vc)
  *
      transRel (@lAlphaEqAbs G vc)
).
Proof.
  intros.
  GAlphaInd; introns Hyp; intros;
  allsimpl; trivial; try (econstructor; eauto; fail);
    [ | | | | | |].
- Case "tnode". inverts Hyp1.
  EqDecSndEq. subst.
  rename mb0 into mc.
  econstructor; eauto with slow.

- Case "pvleaf".  inverts Hyp.
  EqDecSndEq. subst.
  constructor.

- Case "pembed".  inverts Hyp1;
  EqDecSndEq; subst;
  econstructor; eauto with slow.

- Case "pnode". inverts Hyp1.
  EqDecSndEq. subst.
  rename mb0 into mc.
  econstructor; eauto with slow.

- Case "termAbs".
  destruct z as [ss lbvc tmc|];[|inversion Hyp5].
  duplicate Hyp5 as Htal.
  apply AlphaEqAbsTSameParam in Hyp5.
  symmetry in Hyp5. subst.
  apply (betterAbsTElim (lbnew ++ lbva++ (tAllVars tma))) in Htal.
  allsimpl. exrepnd.
  rename lbnew0 into lbcnew.
  (** we need to prepare lhs of [Htal0] so that it can match
    the inductive hypothessis [Hyp4].
    then we can undo the extra swappings done
    to rhs in this process *)
  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbcnew lbnew)).
  rewrite (tcase swap_app) in Htal0.
  rewrite (tcase swap_app) in Htal0.
  unfold tFresh in Htal3.
  unfold tFresh in Hyp1.
  allsimpl. repnd.
  remAlphaRight Htal0 ll.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  apply Hyp4 in Htal0.  subst.
  (* undo the changes done to RHS of [Htal0]*)
  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbnew lbcnew)).
  remAlphaRight Htal0 ll.
  rewrite (tcase swap_app) in Htal0.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  rewrite (tcase swap_app) in Heqll.
  rw <- app_assoc in Heqll.
  rewrite <- (tcase swap_app) in Heqll.
  rewrite <- (tcase swap_app) in Heqll.
  rewrite (tcase swapSwitch) in Heqll.
  rewrite <- AssociationList.ALSwitchCombine in Heqll.
  rewrite (tcase swapRevNoRep) in Heqll; auto;
  autorewrite with fast; cpx;[| disjoint_reasoning; fail].
  rewrite (tcase swap_app) in Heqll.
  rewrite (tcase swap_prop_s2Stronger) in Heqll.
  subst.
  apply alAbT with (lbnew:=lbcnew); try congruence;
  [unfolds_base; simpl; dands |]; cpx;
  repeat (disjoint_reasoning).
- Case "patAbs".
  destruct z as [|ss lbvc tmc];[inversion Hyp5|];[].
  duplicate Hyp5 as Htal.
  apply AlphaEqAbsPSameParam in Hyp5.
  symmetry in Hyp5. subst.
  apply (betterAbsPElim (lbnew ++ lbva++ (pAllVars tma))) in Htal.
  allsimpl. exrepnd.
  rename lbnew0 into lbcnew.
  (** we need to prepare lhs of [Htal0] so that it can match
    the inductive hypothessis [Hyp4].
    then we can undo the extra swappings done
    to rhs in this process *)
  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbcnew lbnew)).
  rewrite (pcase swap_app) in Htal0.
  rewrite (pcase swap_app) in Htal0.
  unfold pFresh in Htal3.
  unfold pFresh in Hyp1.
  allsimpl. repnd.
  remAlphaRight Htal0 ll.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  apply Hyp4 in Htal0.  subst.

  apply (tcase alphaEquiVariant ) in Htal0.
  specialize (Htal0 (combine lbnew lbcnew)).
  remAlphaRight Htal0 ll.
  rewrite (pcase swap_app) in Htal0.
  autorewrite with slow in Htal0; try congruence;
  cpx; repeat (disjoint_reasoning).
  rewrite (pcase swap_app) in Heqll.
  rw <- app_assoc in Heqll.
  rewrite <- (pcase swap_app) in Heqll.
  rewrite <- (pcase swap_app) in Heqll.
  rewrite (pcase swapSwitch) in Heqll.
  rewrite <- AssociationList.ALSwitchCombine in Heqll.
  rewrite (pcase swapRevNoRep) in Heqll; auto;
  autorewrite with fast; cpx;[| disjoint_reasoning; fail].
  rewrite (pcase swap_app) in Heqll.
  rewrite (pcase swap_prop_s2Stronger) in Heqll.
  subst.
  apply alAbP with (lbnew:=lbcnew); try congruence;
  [unfolds_base; simpl; dands |]; cpx;
  repeat (disjoint_reasoning).
- Case "laCons".  inverts Hyp3.
  subst. constructor; auto.
Qed.

(*
Lemma alphaEqSym :
     (  (forall (s : GSym G) (ta tb : Term s)
        (lvA : list vcType),
            tAlphaEq lvA ta tb -> tAlphaEq lvA tb ta)
         *
        (forall (s : GSym G) (pta ptb : Pattern s)
        (lvA : list vcType),
            pAlphaEq lvA pta ptb -> pAlphaEq lvA ptb pta)
         *
        (forall (l : MixtureParam) (ma mb : Mixture l)
        (lvA : list vcType)
        (lbva lbvb : list (list (vType vc))),
           lAlphaEqAbs lvA (MakeAbstractions ma lbva)
                           (MakeAbstractions mb lbvb)
        -> lAlphaEqAbs lvA (MakeAbstractions mb lbvb)
                           (MakeAbstractions ma lbva))).
Proof.
  GInductionS; introns Hyp; cpx; allsimpl;
  try (inversion Hyp; EqDecSndEq; subst; econstructor; eauto; fail);
  try (inversion Hyp0; EqDecSndEq; subst; inversion Hyp0;
  subst; EqDecSndEq; subst; econstructor; eauto; fail);[|].
- inversion Hyp1. EqDecSndEq. subst. econstructor; eauto.
  inversion X. subst. subst swapa. subst swapb.
  EqDecSndEq. subst. econstructor; eauto.
  + eauto with SetReasoning.
  + apply Hyp; auto; autorewrite with fast. auto.
  + inversion mb. subst. destruct mb;
    inverts H. subst. duplicate X0 as XX.
    inversion X0;subst; cpx.

(* apply Hyp0.

apply Hyp0.
- inversion Hyp1. EqDecSndEq. subst. econstructor; eauto.
  inversion X. subst. subst swapa. subst swapb.
  EqDecSndEq. subst. econstructor; eauto.
  + eauto with SetReasoning.
  + apply Hyp; auto; autorewrite with fast. auto.
Qed.
*)

Abort.
*)

Lemma eqset_subtractv_if_left :
  forall l l1 l2,
    eqset l1 l2 -> eqset (@subtractv G vc l1 l) (subtractv l2 l).
Proof.
  unfold subtractv.
  apply eqset_diff_if_left.
Qed.

Lemma eqset_subtractv_if_right :
  forall l l1 l2,
    eqset l1 l2 -> eqset (@subtractv G vc l l1) (subtractv l l2).
Proof.
  unfold subtractv.
  apply eqset_diff_if_right.
Qed.

Lemma eq_subtractv_if_left :
  forall l l1 l2,
    l1 = l2 -> @subtractv G vc l1 l = subtractv l2 l.
Proof.
  sp; subst; sp.
Qed.

Lemma eq_subtractv_if_right :
  forall l l1 l2,
    l1 = l2 -> @subtractv G vc l l1 = subtractv l l2.
Proof.
  sp; subst; sp.
Qed.

Lemma subtractv_nil :
  forall l,
    @subtractv G vc l [] = l.
Proof.
  unfold subtractv; sp.
Qed.

Lemma subtractv_nil_l :
  forall l,
    @subtractv G vc [] l = [].
Proof.
  unfold subtractv; sp.
  rw diff_nil; auto.
Qed.

Lemma subtractv_app_l :
  forall l1 l2 l,
    @subtractv G vc (l1 ++ l2) l = subtractv l1 l ++ subtractv l2 l.
Proof.
  unfold subtractv; introv.
  rw diff_app_r; auto.
Qed.

Definition freevars_abs (a : Abstraction G vc) :=
  match a with
    | termAbs _ vars t => subtractv (tfreevars vc t) vars
    | patAbs  _ vars p => subtractv (pfreevars vc p) vars
  end.

Fixpoint freevars_labs (l : list (Abstraction G vc)) :=
  match l with
    | [] => []
    | a :: l => freevars_abs a ++ freevars_labs l
  end.

(* bad duplicate: this equality holds unconditionally
    see freevarsEquivariant in SwapProps.v*)
Lemma freevars_swap_eq :
  (
    (forall (gs : GSym G) (t : Term gs),
     forall (l1 l : list vcType),
       length l1 = length l
       -> disjoint l1 l
       -> tFresh l [t]
       -> tfreevars vc (tSwap t (combine l1 l))
          = swapLVar (combine l1 l) (tfreevars vc t))
    *
    (forall (gs : GSym G) (p : Pattern gs),
     forall (l1 l : list vcType),
       length l1 = length l
       -> disjoint l1 l
       -> pFresh l [p]
       -> pfreevars vc (pSwap p (combine l1 l))
          = swapLVar (combine l1 l) (pfreevars vc p))
    *
    (forall (lgs : list (bool * GSym G)) (m : Mixture lgs) lbvars,
     forall (l1 l : list vcType),
       length l1 = length l
       -> disjoint l1 l
       -> mFresh l [m]
       -> mfreevars vc (mSwap m (combine l1 l)) (swapLLVar (combine l1 l) lbvars)
          = swapLVar (combine l1 l) (mfreevars vc m lbvars))
  ).
Proof.
  GInduction; auto; introv;
  try (complete (allsimpl; cpx));
  try (complete (allsimpl; introv f e; DDeqs; cpx; rw subtractv_nil_l; auto)).

  - Case "tnode".
    allsimpl.
    introv M len disj f.
    unfold allBndngVars.
    rewrite lBoundVars_swap.
    rw M; auto.

  - Case "pnode".
    allsimpl.
    introv M len disj f.
    apply (M []); auto.

  - Case "mtcons".
    allsimpl.
    introv T M len disj f.
    destruct lbvars; simpl;
    rewrite swapLVar_app;
    apply app_if.

    + apply T; auto;
      try (complete (unfold mFresh in f; unfold mFresh, tFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply (M []); auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + rewrite swapLVar_subtractv.
      rw T; auto;
      try (complete (unfold mFresh in f; unfold mFresh, tFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply M; auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

  - Case "mpcons".
    allsimpl.
    introv P M len disj f.
    destruct lbvars; simpl;
    rewrite swapLVar_app;
    apply app_if.

    + apply P; auto;
      try (complete (unfold mFresh in f; unfold mFresh, pFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply (M []); auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + rewrite swapLVar_subtractv.
      rw P; auto;
      try (complete (unfold mFresh in f; unfold mFresh, pFresh;
                     allsimpl; allrw disjoint_app_r; sp)).

    + apply M; auto;
      try (complete (unfold mFresh in f; unfold mFresh;
                     allsimpl; allrw disjoint_app_r; sp)).
Qed.

Lemma tFresh_app :
  forall g l (l1 l2 : list (Term g)),
    @tFresh G vc g l (l1 ++ l2) <=> (tFresh l l1 # tFresh l l2).
Proof.
  introv.
  unfold tFresh.
  rw flat_map_app.
  rw disjoint_app_r.
  split; sp.
Qed.

Lemma pFresh_app :
  forall g l (l1 l2 : list (Pattern g)),
    @pFresh G vc g l (l1 ++ l2) <=> (pFresh l l1 # pFresh l l2).
Proof.
  introv.
  unfold pFresh.
  rw flat_map_app.
  rw disjoint_app_r.
  split; sp.
Qed.

(* duplicate *)
Lemma swapVar_unchanged :
  forall v l1 l2,
    !LIn v l1
    -> !LIn v l2
    -> @swapVar G vc (combine l1 l2) v = v.
Proof.
  induction l1; introv ni1 ni2; allsimpl; auto.
  allrw not_over_or; repnd.
  destruct l2; allsimpl; auto.
  allrw not_over_or; repnd.
  DDeqs; sp.
Qed.
(* duplicate *)
Lemma swapVar_in :
  forall l1 l2 v,
    LIn v l1
    -> disjoint l1 l2
    -> length l1 = length l2
    -> no_repeats l2
    -> LIn (@swapVar G vc (combine l1 l2) v) l2.
Proof.
  induction l1 as [|x1 l1]; introv i1 disj len norep; allsimpl; tcsp.
  destruct l2 as [|x2 l2]; allsimpl; cpx.
  allrw disjoint_cons_l; allrw disjoint_cons_r; repnd; allsimpl.
  allrw not_over_or; repnd.
  allrw no_repeats_cons; repnd.
  DDeqs; sp; GC; rw (swapVar_unchanged x2); auto.
Qed.

Lemma eq_subtractv :
  forall vs1 vs2 l1 l2 l,
    disjoint l vs1
    -> disjoint l vs2
    -> disjoint l l1
    -> disjoint l l2
    -> length l = length l1
    -> length l = length l2
    -> no_repeats l
    -> @swapLVar G vc (combine l1 l) vs1 = swapLVar (combine l2 l) vs2
    -> subtractv vs1 l1 = subtractv vs2 l2.
Proof.
  induction vs1; introv disj1 disj2 disj3 disj4 len1 len2 norep e;
  allsimpl; destruct vs2; allsimpl;
  allrw subtractv_nil; allrw subtractv_nil_l; auto; inj.
  allapply cons_inj; repnd.
  repeat (rewrite subtractv_cons).
  allrw disjoint_cons_r; repnd.
  DDeqs; try (complete (eapply IHvs1; eauto)).

  - rw (swapVar_unchanged v) in e0; auto.

    pose proof (@swapVar_in l1 l a) as h;
      repeat (autodimp h hyp);
      try (complete (apply disjoint_sym; auto)).
    rw e0 in h; sp.

  - rw (swapVar_unchanged a) in e0; auto.

    pose proof (@swapVar_in l2 l v) as h;
      repeat (autodimp h hyp);
      try (complete (apply disjoint_sym; auto)).
    rw <- e0 in h; sp.

  - rw (swapVar_unchanged v) in e0; auto.
    rw (swapVar_unchanged a) in e0; auto.
    subst.
    apply eq_cons; auto.
    apply IHvs1 with (l := l); auto.
Qed.

Lemma freevars_in_allvars :
  (
    (forall (gs : GSym G) (t : Term gs),
       subset (tfreevars vc t) (tAllVars t))
    *
    (forall (gs : GSym G) (p : Pattern gs),
       subset (pfreevars vc p) (pAllVars p))
    *
    (forall (lgs : list (bool * GSym G)) (m : Mixture lgs) lbvars,
       subset (mfreevars vc m lbvars) (mAllVars m))
  ).
Proof.
  GInduction; auto; introv;
  try (complete (allsimpl; cpx));
  try (complete (allsimpl; introv f e; DDeqs; cpx; rw subtractv_nil_l; auto)).

  - Case "mtcons".
    allsimpl.
    introv ss M; introv.
    destruct lbvars; allsimpl; apply subset_app_lr; auto.
    unfold subtractv.
    apply subset_diff.
    apply subset_app_r; auto.

  - Case "mpcons".
    allsimpl.
    introv ss M; introv.
    destruct lbvars; allsimpl; apply subset_app_lr; auto.
    unfold subtractv.
    apply subset_diff.
    apply subset_app_r; auto.
Qed.

Lemma alpha_preserves_free_vars :
  (
    (forall (s : GSym G) (t1 t2 : Term s),
       tAlphaEq vc t1 t2 -> tfreevars vc t1 = tfreevars vc t2)
    *
    (forall (s : GSym G) (p1 p2 : Pattern s),
       pAlphaEq vc p1 p2 -> pfreevars vc p1 = pfreevars vc p2)
    *
    (forall a1 a2,
       AlphaEqAbs a1 a2 -> freevars_abs a1 = freevars_abs a2)
    *
    (forall l1 l2,
       lAlphaEqAbs l1 l2 -> freevars_labs l1 = freevars_labs l2)
  ).
Proof.
  intros.
  GAlphaInd; introns Hyp; intros;
  try (complete (allsimpl; auto; ddeq; auto)).

  - Case "tnode".
    allsimpl.
    allunfold MakeAbstractionsTNode.
    allunfold MakeAbstractionsTNodeAux.
    clear Hyp.

    assert (forall ma : Mixture (tpRhsAugIsPat p),
              freevars_labs
                (MakeAbstractions vc ma
                                  (lBoundVars vc (bndngPatIndices p) ma))
              = mfreevars vc ma (lBoundVars vc (bndngPatIndices p) ma)) as eqs.
    (* begin proof of assert *)
    clear ma mb Hyp0.
    introv.
    remember (lBoundVars vc (bndngPatIndices p) ma); clear Heql.
    revert l.
    induction ma; introv; simpl; auto.
    destruct l; allsimpl.
    rw subtractv_nil; apply app_if; auto.
    apply app_if; auto.
    destruct l; allsimpl.
    rw subtractv_nil; apply app_if; auto.
    apply app_if; auto.
    (* end proof of assert *)

    repeat (rw <- eqs); auto.

  - Case "pnode".
    allsimpl.
    allunfold MakeAbstractionsPNode.
    clear Hyp.

    assert (forall ma : Mixture (map (fun x : GSym G => (true, x)) (ppRhsSym p)),
              freevars_labs (MakeAbstractions vc ma [])
              = mfreevars vc ma []) as eqs.
    (* begin proof of assert *)
    clear ma mb Hyp0.
    introv.
    induction ma; introv; simpl; auto.
    rw subtractv_nil; apply app_if; auto.
    apply app_if; auto.
    (* end proof of assert *)

    repeat (rw <- eqs); auto.

  - Case "termAbs".
    allsimpl.
    allrw disjoint_app_l; repnd.
    rw two_as_app in Hyp1.
    apply tFresh_app in Hyp1; repnd.
    repeat (rw (fst (fst freevars_swap_eq)) in Hyp4; auto).

    apply eq_subtractv with (l := lbnew); auto;
    try (complete (apply disjoint_sym; auto));
    unfold tFresh in Hyp1; unfold tFresh in Hyp6; repnd; auto;
    allrw disjoint_flat_map_r;
    pose proof (Hyp7 tmb) as h1; simpl in h1; autodimp h1 hyp;
    pose proof (Hyp8 tma) as h2; simpl in h2; autodimp h2 hyp.

    pose proof (fst (fst freevars_in_allvars) gs tma) as h.
    apply subset_disjoint_r with (l2 := tAllVars tma); auto.

    pose proof (fst (fst freevars_in_allvars) gs tmb) as h.
    apply subset_disjoint_r with (l2 := tAllVars tmb); auto.

  - Case "patAbs".
    allsimpl.
    allrw disjoint_app_l; repnd.
    rw two_as_app in Hyp1.
    apply pFresh_app in Hyp1; repnd.
    repeat (rw (snd (fst freevars_swap_eq)) in Hyp4; auto).

    apply eq_subtractv with (l := lbnew); auto;
    try (complete (apply disjoint_sym; auto));
    unfold pFresh in Hyp1; unfold pFresh in Hyp6; repnd; auto;
    allrw disjoint_flat_map_r;
    pose proof (Hyp7 tmb) as h1; simpl in h1; autodimp h1 hyp;
    pose proof (Hyp8 tma) as h2; simpl in h2; autodimp h2 hyp.

    pose proof (snd (fst freevars_in_allvars) gs tma) as h.
    apply subset_disjoint_r with (l2 := pAllVars tma); auto.

    pose proof (snd (fst freevars_in_allvars) gs tmb) as h.
    apply subset_disjoint_r with (l2 := pAllVars tmb); auto.

  - Case "laCons".
    allsimpl.
    apply app_if; auto.
Qed.

Ltac dvlin v l := destruct (in_deq _ (DeqVtype vc) v l).

(* duplicate : do SearchAbout tFresh app *)
Lemma tFresh_app_l :
  forall g l1 l2 ts,
    @tFresh G vc g (l1 ++ l2) ts
    <=>
    (tFresh l1 ts # tFresh l2 ts # disjoint l1 l2 # no_repeats l1 # no_repeats l2).
Proof.
  unfold tFresh; introv.
  rw disjoint_app_l.
  rw no_repeats_app; split; sp.
Qed.

Lemma simple_combine_app_app :
  forall T (l1 l2 l3 l4 : list T),
    length l1 = length l3
    -> combine (l1 ++ l2) (l3 ++ l4)
       = combine l1 l3 ++ combine l2 l4.
Proof.
  induction l1; simpl; introv len; destruct l3; allsimpl; cpx.
  rw IHl1; sp.
Qed.

End AlphaProps.

Lemma tAlphaEqTransEauto:
 forall
  {G : CFGV} {vc : VarSym G}
   (s : GSym G) (a b c : Term s),
   tAlphaEq vc a b
   -> tAlphaEq vc b c
   -> tAlphaEq vc a c.
Proof.
  introns Hyp.
  pose proof (@alphaEqTransitive G vc) as Hpr.
  repnd. unfold transRel in Hpr2.
  eauto.
Qed.

Lemma pAlphaEqTransEauto:
 forall
  {G : CFGV} {vc : VarSym G}
   (s : GSym G) (a b c : Pattern s),
   pAlphaEq vc a b
   -> pAlphaEq vc b c
   -> pAlphaEq vc a c.
Proof.
  introns Hyp.
  pose proof (@alphaEqTransitive G vc) as Hpr.
  repnd. unfold transRel in Hpr1.
  eauto.
Qed.

Definition ALtcase
  {A B C D} (t:A*B*C*D) : A
  := fst (fst (fst t)).

Definition ALpcase
  {A B C D} (t:A*B*C*D) : B
  := snd (fst (fst t)).

Definition Abcase
  {A B C D} (t:A*B*C*D) : C
  := (snd (fst t)).

Definition LAbcase
  {A B C D} (t:A*B*C*D) : D
  := ((snd t)).

Hint Resolve
(tcase alphaEqRefl)
(pcase alphaEqRefl)
(mcase alphaEqRefl)
  (ALtcase alphaEqSym)
  (ALpcase alphaEqSym)
  (Abcase alphaEqSym)
  (LAbcase alphaEqSym)
  AlphaEqNilAbsT
  AlphaEqNilAbsP
  tAlphaEqTransEauto
  pAlphaEqTransEauto : Alpha.

Lemma pAlphaSwapEmSwap
 : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s), True)
   *
  (forall (s : GSym G) (pta : Pattern s)
  (sw : Swapping vc),
      pAlphaEq vc (pSwapEmbed pta sw)
                  (pSwap pta sw))
   *
  (forall (mp : MixtureParam) (ma: Mixture mp)
  (llbv : list (list (vType vc)))
  (sw : Swapping vc),
  (forall b s, LIn (b,s) mp -> b= true)
   -> lAlphaEqAbs (MakeAbstractions vc (mSwapEmbed ma sw) llbv)
                (MakeAbstractions vc (mSwap ma sw) llbv))).
Proof.
intros.
GInduction; cpx; allsimpl;
  try (econstructor; eauto with Alpha; fail).
- Case "pnode". introns Hyp.
  allsimpl. constructor.
  unfold MakeAbstractionsPNode.
  apply Hyp.
  introv Hin.
  apply in_map_iff in Hin; exrepnd; cpx.
- Case "mtcons". introns Hyp.
   pose proof (Hyp1 _ _ (inl eq_refl)). cpx.
Qed.

(** swapping by swapping that leaves the
    free vars unchanged results in an alpha equal term.
    A swapping with whose both domain and range
    are disjoint from freevars can be used *)
Lemma alphaEqSwapNonFree : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (t : Term s) (sw : Swapping vc),
      leavesLVarUnchanged sw (tfreevars vc t)
      -> tAlphaEq vc t (tSwap t sw))
   *
  (forall (s : GSym G) (pt : Pattern s) (sw : Swapping vc),
     leavesLVarUnchanged sw (pfreevars vc pt)
      -> pAlphaEq vc pt (pSwap pt sw))
   *
  (forall (l : MixtureParam) (m : Mixture l) (sw : Swapping vc)
  (lbv : list (list (vType vc))),
      leavesLVarUnchanged sw (mfreevars vc m lbv)
      -> lAlphaEqAbs
            (MakeAbstractions vc m lbv)
            (MakeAbstractions vc (mSwap m sw) (swapLLVar sw lbv)))).
Proof.
  intros.
  GInduction; introns Hyp; intros; cpx; allsimpl;
  try dlist_len lbv;  try (econstructor; eauto with slow; fail).

- Case "vleaf".
  rewrite DeqSym.
  ddeq; sp;[| eauto with Alpha; fail].
  destruct e. allsimpl.
  repeat (disjoint_reasoning).
  rewrite Hyp; cpx.
  eauto 1 with Alpha.

- Case "tnode". constructor. allunfold mAlphaEq.
  unfold MakeAbstractionsTNode.
  unfold MakeAbstractionsTNodeAux.
  unfold allBndngVars.
   rewrite <- lBoundVars_equivariant.
  cpx.

- Case "pnode". constructor. allunfold mAlphaEq.
  unfold MakeAbstractionsPNode.
  specialize (Hyp sw nil).
  simpl in Hyp. cpx.

- Case "mtcons". destruct lbv; cpx;
  apply lforallApp in Hyp1; repnd;
  [ allsimpl; specialize (Hyp0 sw []); simpl in Hyp0;
    constructor; cpx ;
     apply AlphaEqNilAbsT;
      apply Hyp; cpx|].

    constructor; cpx.
  allsimpl.
  pose proof  (GFreshDistRenWSpec vc l
            (tAllVars ph++tAllVars  (tSwap ph sw)++
              (swapLVar sw l)++ l ++ (tfreevars vc ph)++
                  ALDom sw ++ ALRange sw ++ l))
      as Hfr.
  exrepnd.
  apply alAbT with (lbnew:=lvn);
    try (unfold swapLVar ; autorewrite with fast;
      congruence; fail);
  [unfolds_base; simpl; dands | | ]; cpx;
  try (autorewrite with fast;
  repeat (disjoint_reasoning); fail);[].
  autorewrite with SwapAppR.
  assert (lvn = swapLVar sw lvn ) as XX by
    (symmetry; apply swapLVarNoChange;
        repeat (disjoint_reasoning)).

  remember (combine l lvn) as swt.
  rewrite XX.
  unfold swapLVar. rewrite <- map_combine.
  fold (swapSwap sw (combine l lvn)).
  rewrite <- (tcase swap_prop_e1Stronger).
  subst swt.
  apply tAlphaEqEquivariantRev with
    (sw0:=rev (combine l lvn)).
  autorewrite with SwapAppR.
  autorewrite with fast.
  apply Hyp.
  intros v Hin.
  unfolds_base.
  autorewrite with SwapAppL.
  assert (disjoint l lvn) as Xd by repeat(disjoint_reasoning).
  destruct (in_deq _ (DeqVtype vc) v l) as [Xin | Xnot].
  + dimp (@swapVar_in G vc l lvn v); cpx.
    remember (swapVar (combine l lvn) v) as vs.
    assert (leavesLVarUnchanged sw lvn)  as Xun by
    (apply leavesLVarUnchanged1;repeat (disjoint_reasoning)).
    apply Xun in hyp.
    repnud hyp. rw hyp. subst vs.
    autorewrite with SwapAppR.
    autorewrite with fast. refl.
  + assert (disjoint (tfreevars vc ph) lvn) as Hdiss by
      repeat (disjoint_reasoning).
    assert (LIn v (tfreevars vc ph -- l)) as Hins by
    (apply in_diff; dands; cpx).
    apply Hdiss in Hin.
    pattern ((swapVar (combine l lvn) v)).
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.
    apply Hyp2 in Hins.
    rewrite Hins. apply swapVarNonChangeRev.
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.

(** exactly same as [mtcons] case *)
- Case "mpcons". destruct lbv; cpx;
  apply lforallApp in Hyp1; repnd;
  [ allsimpl; specialize (Hyp0 sw []); simpl in Hyp0;
    constructor; cpx ;
     apply AlphaEqNilAbsP;
      apply Hyp; cpx|].

    constructor; cpx.
  allsimpl.
  pose proof  (GFreshDistRenWSpec vc l
            (pAllVars ph++pAllVars  (pSwap ph sw)++
              (swapLVar sw l)++ l ++ (pfreevars vc ph)++
                  ALDom sw ++ ALRange sw ++ l))
      as Hfr.
  exrepnd.
  apply alAbP with (lbnew:=lvn);
    try (unfold swapLVar ; autorewrite with fast;
      congruence; fail);
  [unfolds_base; simpl; dands | | ]; cpx;
  try (autorewrite with fast;
  repeat (disjoint_reasoning); fail);[].
  autorewrite with SwapAppR.
  assert (lvn = swapLVar sw lvn ) as XX by
    (symmetry; apply swapLVarNoChange;
        repeat (disjoint_reasoning)).

  remember (combine l lvn) as swt.
  rewrite XX.
  unfold swapLVar. rewrite <- map_combine.
  fold (swapSwap sw (combine l lvn)).
  rewrite <- (pcase swap_prop_e1Stronger).
  subst swt.
  apply pAlphaEqEquivariantRev with
    (sw0:=rev (combine l lvn)).
  autorewrite with SwapAppR.
  autorewrite with fast.
  apply Hyp.
  intros v Hin.
  unfolds_base.
  autorewrite with SwapAppL.
  assert (disjoint l lvn) as Xd by repeat(disjoint_reasoning).
  destruct (in_deq _ (DeqVtype vc) v l) as [Xin | Xnot].
  + dimp (@swapVar_in G vc l lvn v); cpx.
    remember (swapVar (combine l lvn) v) as vs.
    assert (leavesLVarUnchanged sw lvn)  as Xun by
    (apply leavesLVarUnchanged1;repeat (disjoint_reasoning)).
    apply Xun in hyp.
    repnud hyp. rw hyp. subst vs.
    autorewrite with SwapAppR.
    autorewrite with fast. refl.
  + assert (disjoint (pfreevars vc ph) lvn) as Hdiss by
      repeat (disjoint_reasoning).
    assert (LIn v (pfreevars vc ph -- l)) as Hins by
    (apply in_diff; dands; cpx).
    apply Hdiss in Hin.
    pattern ((swapVar (combine l lvn) v)).
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.
    apply Hyp2 in Hins.
    rewrite Hins. apply swapVarNonChangeRev.
    rewrite swapVarNoChange; cpx;
    autorewrite with fast; try congruence.
Qed.

Lemma freeVarsSuppAux:
forall {G : CFGV} {vc : VarSym G},
((forall (s : GSym G) (t : Term s),
    forall v, ! LIn v (tfreevars vc t)
      -> (finite
             (fun b => !(tAlphaEq vc t
                              (tSwap t [(v,b)])))))).
Proof.
  introv Hin.
  exists (tfreevars vc t).
  introv Hntal.
  destruct (in_deq _ (DeqVtype vc) a
    (tfreevars vc t)) as [ ? | Hneq]; cpx.
  provefalse.
  apply Hntal.
  apply (tcase alphaEqSwapNonFree).
  apply leavesLVarUnchanged1.
  allsimpl. repeat (disjoint_reasoning); cpx.
Qed.

Lemma freeVarsSuppAux2:
forall {G : CFGV} {vc : VarSym G},
((forall (s : GSym G) (t : Term s),
    forall v, LIn v (tfreevars vc t)
      -> ! (finite
             (fun b => !(tAlphaEq vc t
                              (tSwap t [(v,b)])))))).
Proof.
  introv Hin. introv Hc.
  repnud Hc.
  exrepnd.
  pose proof (vFreshVarSpec
      ([v]++la ++ (tfreevars vc t)) v) as XX.
  remember (vFreshVar ([v]++la ++ tfreevars vc t) v) as vn.
  clear Heqvn.
  rw in_app_iff in XX.
  rw in_app_iff in XX.
  apply XX. right. left.
  apply Hc0. introv Hal.
  apply (ALtcase alpha_preserves_free_vars) in Hal.
  rewrite Hal in Hin. clear Hal.
  rewrite <- (tcase freevarsEquivariant) in Hin.
  rw in_map_iff in Hin.
  exrepnd.
  pose proof (swapVarInOrEq2 [(v,vn)] a) as Hs.
  rewrite <- Hin0 in Hs.
  clear Hin0.
  dimp Hs; simpl; cpx; try (constructor; auto; cpx; fail);

  [|]; cpx;
  repeat (disjoint_reasoning);cpx.
  introv Hc. dorn Hc; cpx.
  subst. clear Hs.
  apply XX. cpx.
Qed.

Lemma freeVarsSupp:
forall {G : CFGV} {vc : VarSym G},
((forall (s : GSym G) (t : Term s),
    forall v, LIn v (tfreevars vc t)
      <=> !(finite
             (fun b => !(tAlphaEq vc t
                              (tSwap t [(v,b)])))))).
Proof.
  intros. split.
  - apply freeVarsSuppAux2.
  - introv Hin. destruct (in_deq _ (DeqVtype vc) v
    (tfreevars vc t)) as [ ? | Hneq]; cpx.
    provefalse. apply Hin.
    apply freeVarsSuppAux.
    trivial.
Qed.

(*

(forall (s : GSym G) (pt : Pattern s) (sw : Swapping vc),
  forall v, LIn v (pfreevars vc pt)
    <=> !(finite
           (fun b => !(pAlphaEq vc pt
                            (pSwap pt [(v,b)])))))
   *
(forall (l : MixtureParam) (m : Mixture l) (sw : Swapping vc)
  (lbv : list (list (vType vc))),
  forall v, LIn v (mfreevars vc m lbv)
    <=> !(finite
           (fun b => !(mAlphaEq vc m
                            (mSwap m [(v,b)])))))
.

*)

(*
*** Local Variables:
*** coq-load-path: ("../")
*** End:
*)


(* This software is governed by the CeCILL license under French law and
 * abiding by the rules of distribution of free software.  You can  use,
 * modify and/ or redistribute the software under the terms of the CeCILL
 * license as circulated by CEA, CNRS and INRIA at the following URL
 * "http://www.cecill.info".

 * As a counterpart to the access to the source code and  rights to copy,
 * modify and redistribute granted by the license, users are provided only
 * with a limited warranty  and the software's author,  the holder of the
 * economic rights,  and the successive licensors  have only  limited
 * liability.

 * In this respect, the user's attention is drawn to the risks associated
 * with loading,  using,  modifying and/or developing or reproducing the
 * software by the user in light of its specific status of free software,
 * that may mean  that it is complicated to manipulate,  and  that  also
 * therefore means  that it is reserved for developers  and  experienced
 * professionals having in-depth computer knowledge. Users are therefore
 * encouraged to load and test the software's suitability as regards their
 * requirements in conditions enabling the security of their systems and/or
 * data to be ensured and,  more generally, to use and operate it in the
 * same conditions as regards security.

 * The fact that you are presently reading this means that you have had
 * knowledge of the CeCILL license and that you accept its terms.
 *)

(* /!\ Proof related content on Jobs are located in proof/JobsAxioms.v *)

From Scheduler.Model Require Import PureFunctionModels.
From Scheduler.Model.Interface.Types Require Import TypesModel.
From Scheduler.Model.Interface.Types Require Import Jobs.
Require Import List.
Module Type JobsAxiomsMod.

  (* job_id -> job *)
  (*Parameter Jobs : nat -> Job.*)

  (* oracle from scheduling plan *)
  Parameter jobs_arriving_at :
    forall (t:nat), list nat.

  Axiom job_duration_gt_0 : forall n, duration (Jobs n) > 0.

  Axiom job_budget_enough : forall n, budget (Jobs n) >= duration (Jobs n).

  Axiom job_arrival_plus_duration_le_deadline :
    forall i,
      arrival (Jobs i) + duration (Jobs i) <= deadline (Jobs i).

  Axiom jobs_id_index : forall i,   jobid (Jobs i) = i.

  (* In should be defined for C lists ? TODO *)
 Axiom jobs_arriving_at_prop : forall  t i,
      In i (jobs_arriving_at t) <-> arrival (Jobs i) = t.

  (* nth should be defined for C lists ? TODO *)

  Axiom jobs_arriving_at_unique : forall i i' t t',
      i < length (jobs_arriving_at t) ->  i' < length (jobs_arriving_at t') ->
      nth i (jobs_arriving_at t) 0 = nth i' (jobs_arriving_at t') 0 ->
      (t = t' /\ i = i').

End JobsAxiomsMod.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require map.Map.
Require list.Append.
Require list.Distinct.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (array a) :=
  (mk_array n (map.Map.const v: (map.Map.map Z a))).

(* Why3 assumption *)
Inductive tree :=
  | Empty : tree
  | Node : tree -> tree -> tree.
Axiom tree_WhyType : WhyType tree.
Existing Instance tree_WhyType.

(* Why3 assumption *)
Fixpoint size (t:tree) {struct t}: Z :=
  match t with
  | Empty => 0%Z
  | (Node l r) => ((1%Z + (size l))%Z + (size r))%Z
  end.

Axiom size_nonneg : forall (t:tree), (0%Z <= (size t))%Z.

Axiom size_left : forall (t:tree), (0%Z < (size t))%Z -> exists l:tree,
  exists r:tree, (t = (Node l r)) /\ ((size l) < (size t))%Z.

(* Why3 assumption *)
Definition all_trees (n:Z) (l:(list tree)): Prop := (list.Distinct.distinct
  l) /\ forall (t:tree), ((size t) = n) <-> (list.Mem.mem t l).

Axiom all_trees_0 : (all_trees 0%Z
  (Init.Datatypes.cons Empty Init.Datatypes.nil)).

Axiom tree_diff : forall (l1:tree) (l2:tree), (~ ((size l1) = (size l2))) ->
  forall (r1:tree) (r2:tree), ~ ((Node l1 r1) = (Node l2 r2)).

(* Why3 goal *)
Theorem WP_parameter_combine : forall (i1:Z) (l1:(list tree)) (i2:Z)
  (l2:(list tree)), ((0%Z <= i1)%Z /\ ((all_trees i1 l1) /\ ((0%Z <= i2)%Z /\
  (all_trees i2 l2)))) -> forall (l11:(list tree)), (list.Distinct.distinct
  l11) -> forall (x:tree) (x1:(list tree)),
  (l11 = (Init.Datatypes.cons x x1)) -> forall (l21:(list tree)),
  (list.Distinct.distinct l21) -> forall (x2:tree) (x3:(list tree)),
  (l21 = (Init.Datatypes.cons x2 x3)) -> ((list.Distinct.distinct x3) ->
  forall (o:(list tree)), ((list.Distinct.distinct o) /\ forall (t:tree),
  (list.Mem.mem t o) <-> exists r:tree, (t = (Node x r)) /\ (list.Mem.mem r
  x3)) -> forall (t:tree), (list.Mem.mem t (Init.Datatypes.cons (Node x
  x2) o)) -> exists r:tree, (t = (Node x r)) /\ (list.Mem.mem r l21)).
intros i1 l1 i2 l2 (h1,(h2,(h3,h4))) l11 h5 x x1 h6 l21 h7 x2 x3 h8
        h9 o (h10,h11) t h12.
subst.
unfold Mem.mem in h12; fold @Mem.mem in h12.
destruct h12.
exists x2; intuition.
red; intuition.
generalize (h11 t). intuition.
destruct H0 as (r,h); exists r; intuition.
red; intuition.
Qed.


Require Import Coq.Sorting.Permutation.
Require Import Coq.Sorting.Sorting.
Require Import Coq.Structures.Orders.
Require Import VST.veric.base.

Require Import compcert.cfrontend.Ctypes.

(* TODO: This is obviously true. Ask Xavior to remove the definition list_norepet.*)
Lemma list_norepet_NoDup: forall {A: Type} (l: list A), list_norepet l <-> NoDup l.
Proof.
intros; split; intro;
induction H; constructor; auto.
Qed.

Lemma PTree_In_fst_elements {A: Type}: forall (T: PTree.t A) i,
  In i (map fst (PTree.elements T)) <-> exists a, PTree.get i T = Some a.
Proof.
  intros.
  split; intros.
  + apply list_in_map_inv in H.
    destruct H as [[i0 a] [? ?]].
    simpl in H; subst i0.
    apply PTree.elements_complete in H0.
    eauto.
  + destruct H as [a ?].
    apply PTree.elements_correct in H.
    apply (in_map fst) in H.
    auto.
Qed.

Lemma PTree_gs {A: Type}: forall (T: PTree.t A) i j x,
  (exists a, PTree.get i T= Some a) ->
  exists a, PTree.get i (PTree.set j x T) = Some a.
Proof.
  intros.
  destruct H.
  destruct (Pos.eq_dec i j).
  + subst.
    rewrite PTree.gss; eauto.
  + rewrite PTree.gso; eauto.
Qed.

Lemma PTree_gs_equiv {A: Type}: forall (T: PTree.t A) i j x,
  (exists a, PTree.get i T= Some a) \/ i = j <->
  exists a, PTree.get i (PTree.set j x T) = Some a.
Proof.
  intros.
  split; intros.
  + destruct H; [apply PTree_gs; auto |].
    subst; rewrite PTree.gss; eauto.
  + destruct (Pos.eq_dec i j); auto.
    rewrite PTree.gso in H by auto.
    auto.
Qed.

Lemma PTree_set_In_fst_elements {A: Type}: forall (T: PTree.t A) i i' a',
  In i (map fst (PTree.elements T)) ->
  In i (map fst (PTree.elements (PTree.set i' a' T))).
Proof.
  intros.
  rewrite PTree_In_fst_elements in H |- *.
  apply PTree_gs; auto.
Qed.

Fixpoint relative_defined_type {A: Type} (l: list (ident * A)) (t: type): Prop :=
  match t with
  | Tarray t' _ _ => relative_defined_type l t'
  | Tstruct id _ => In id (map fst l)
  | Tunion id _ => In id (map fst l)
  | _ => True
  end.

Lemma relative_defined_type_mono: forall {A B: Type} (l1: list (ident * A)) (l2: list (ident * B)) (t: type),
  (forall i, In i (map fst l1) -> In i (map fst l2)) ->
  relative_defined_type l1 t ->
  relative_defined_type l2 t.
Proof.
  intros.
  induction t; auto.
  + simpl in *.
    firstorder.
  + simpl in *.
    firstorder.
Qed.

Lemma relative_defined_type_equiv: forall {A B: Type} (l1: list (ident * A)) (l2: list (ident * B)) (t: type),
  (forall i, In i (map fst l1) <-> In i (map fst l2)) ->
  (relative_defined_type l1 t <-> relative_defined_type l2 t).
Proof.
  intros.
  split; apply relative_defined_type_mono;
  firstorder.
Qed.

Inductive ordered_composite: list (positive * composite) -> Prop :=
| ordered_composite_nil: ordered_composite nil
| ordered_composite_cons: forall i co l,
    Forall (relative_defined_type l) (map snd (co_members co)) ->
    ordered_composite l ->
    ordered_composite ((i, co) :: l).

Module composite_reorder.

(* Use merge sort instead *)
(* Sort rank from higher to lower *)
Module CompositeRankOrder <: TotalLeBool.
  Definition t := (positive * composite)%type.
  Definition leb (x y: t) := Nat.leb (co_rank (snd y)) (co_rank (snd x)).

  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    intros.
    unfold leb.
    rewrite !Nat.leb_le.
    lia.
  Qed.

  Theorem leb_trans: Transitive (fun x y => is_true (leb x y)).
  Proof.
    hnf; intros; unfold leb, is_true in *.
    rewrite !Nat.leb_le in *.
    lia.
  Qed.

End CompositeRankOrder.

Module CompositeRankSort := Sort CompositeRankOrder.

Section composite_reorder.

Context (cenv: composite_env)
        (cenv_consistent: composite_env_consistent cenv).

Definition rebuild_composite_elements := CompositeRankSort.sort (PTree.elements cenv).

Inductive ordered_and_complete: list (positive * composite) -> Prop :=
| ordered_and_complete_nil: ordered_and_complete nil
| ordered_and_complete_cons: forall i co l,
    (forall i' co',
        cenv ! i' = Some co' ->
        (co_rank co' < co_rank co)%nat ->
        In (i', co') l) ->
    ordered_and_complete l ->
    ordered_and_complete ((i, co) :: l).

Theorem RCT_Permutation: Permutation rebuild_composite_elements (PTree.elements cenv).
Proof.
  symmetry.
  apply CompositeRankSort.Permuted_sort.
Qed.

Lemma RCT_ordered_and_complete: ordered_and_complete rebuild_composite_elements.
Proof.
  pose proof RCT_Permutation.
  assert (forall i co, cenv ! i = Some co -> In (i, co) rebuild_composite_elements).
  {
    intros.
    eapply Permutation_in.
    + symmetry; apply RCT_Permutation.
    + apply PTree.elements_correct; auto.
  }
  clear H.
  pose proof CompositeRankSort.StronglySorted_sort (PTree.elements cenv) CompositeRankOrder.leb_trans.
  pose proof app_nil_l rebuild_composite_elements.
  unfold rebuild_composite_elements in *.
  set (l := (CompositeRankSort.sort (PTree.elements cenv))) in H1 at 1 |- *.
  revert H1; generalize (@nil (positive * composite)).
  clearbody l.
  induction l; intros.
  + constructor.
  + specialize (IHl (l0 ++ a :: nil)).
    rewrite <- app_assoc in IHl.
    specialize (IHl H1).
    destruct a as [i co]; constructor; auto.
    intros.
    apply H0 in H2.
    rewrite <- H1 in H2, H.
    clear - H2 H3 H.
    induction l0.
    - destruct H2; auto.
      exfalso; inv H0.
      lia.
    - inv H.
      destruct H2.
      * exfalso.
        subst.
        rewrite Forall_forall in H5.
        specialize (H5 (i, co)).
        rewrite in_app in H5.
        specialize (H5 (or_intror (or_introl eq_refl))).
        unfold is_true in H5.
        rewrite Nat.leb_le in H5; simpl in H5.
        lia.
      * apply IHl0; auto.
Qed.

Theorem RCT_ordered: ordered_composite rebuild_composite_elements.
Proof.
  pose proof RCT_ordered_and_complete.
  assert (forall i co, In (i, co) rebuild_composite_elements -> complete_members cenv (co_members co) = true /\ co_rank co = rank_members cenv (co_members co)).
  {
    intros.
    eapply Permutation_in in H0; [| exact RCT_Permutation].
    apply PTree.elements_complete in H0; auto.
    split.
    + apply co_consistent_complete.
      eapply cenv_consistent; eauto.
    + apply co_consistent_rank.
      eapply cenv_consistent; eauto.
  }
  induction H.
  + constructor.
  + specialize (IHordered_and_complete (fun i co HH => H0 i co (or_intror HH))).
    constructor; auto.
    clear IHordered_and_complete H1.
    specialize (H0 _ _ (or_introl eq_refl)).
    assert (rank_members cenv (co_members co) <= co_rank co)%nat by lia.
    destruct H0 as [? _].
    induction (co_members co) as [| [i0 t0] ?].
    - constructor.
    - simpl in H0; rewrite andb_true_iff in H0; destruct H0.
      simpl in H1; pose proof Max.max_lub_r _ _ _ H1.
      apply Max.max_lub_l in H1.
      constructor; auto; clear IHm H2 H3.
      simpl.
      induction t0; try solve [simpl; auto].
      * (* array *)
        spec IHt0; auto.
        spec IHt0; [simpl in H1; lia |].
        auto.
      * (* struct *)
        simpl in H0, H1 |- *.
        destruct (cenv ! i1) eqn:?H; [| inv H0].
        specialize (H _ _ H2).
        spec H; [lia |].
        apply (in_map fst) in H; auto.
      * (* union *)
        simpl in H0, H1 |- *.
        destruct (cenv ! i1) eqn:?H; [| inv H0].
        specialize (H _ _ H2).
        spec H; [lia |].
        apply (in_map fst) in H; auto.
Qed.

End composite_reorder.

End composite_reorder.

Module type_func.
Section type_func.

Context {A: Type}
        (f_default: type -> A)
        (f_array: A -> type -> Z -> attr -> A)
        (f_struct: A -> ident -> attr -> A)
        (f_union: A -> ident -> attr -> A)
        (f_member: struct_or_union -> list (ident * type * A) -> A).

Fixpoint F (env: PTree.t A) (t: type): A :=
  match t with
  | Tarray t n a => f_array (F env t) t n a
  | Tstruct id a =>
      match env ! id with
      | Some v => f_struct v id a
      | None => f_default t
      end
  | Tunion id a =>
      match env ! id with
      | Some v => f_union v id a
      | None => f_default t
      end
  | _ => f_default t
  end.

Definition Complete (cenv: composite_env) (env: PTree.t A): Prop :=
  forall i,
    (exists co, PTree.get i cenv = Some co) <->
    (exists a, PTree.get i env = Some a).

Definition Consistent (cenv: composite_env) (env: PTree.t A): Prop :=
  forall i co a,
    PTree.get i cenv = Some co ->
    PTree.get i env = Some a ->
    a = f_member (co_su co) (map
                              (fun it0: positive * type =>
                                 let (i0, t0) := it0 in
                                 (i0, t0, F env t0))
                              (co_members co)).

Definition env_rec (i: positive) (co: composite) (env: PTree.t A): PTree.t A :=
  PTree.set i
    (f_member (co_su co) (map
                              (fun it0: positive * type =>
                                 let (i0, t0) := it0 in (i0, t0, F env t0))
                              (co_members co)))
    env.

Definition Env (l: list (positive * composite)): PTree.t A :=
  fold_right
    (fun (ic: positive * composite) =>
       let (i, co) := ic in env_rec i co)
    (PTree.empty A)
    l.

Lemma F_PTree_set: forall t env i a,
  ~ In i (map fst (PTree.elements env)) ->
  relative_defined_type (PTree.elements env) t ->
  F env t = F (PTree.set i a env) t.
Proof.
  intros.
  induction t; auto.
  + simpl.
    apply IHt in H0.
    rewrite H0; auto.
  + simpl in H0 |- *.
    rewrite PTree.gso; auto.
    intro; subst; tauto.
  + simpl in H0 |- *.
    rewrite PTree.gso; auto.
    intro; subst; tauto.
Qed.

Lemma relative_defined_type_PTree_set: forall t (env: PTree.t A) i a,
  relative_defined_type (PTree.elements env) t ->
  relative_defined_type (PTree.elements (PTree.set i a env)) t.
Proof.
  intros.
  revert H; apply relative_defined_type_mono.
  intros; apply PTree_set_In_fst_elements; auto.
Qed.

Section Consistency_Induction_Step.

Context (cenv: composite_env)
        (env: PTree.t A)
        (l: list (positive * composite))
        (i0: positive)
        (co0: composite).

Hypothesis NOT_IN_LIST: ~ In i0 (map fst l).

Hypothesis RDT_list: Forall (relative_defined_type l) (map snd (co_members co0)).

Hypothesis CENV0: PTree.get i0 cenv = Some co0.

Hypothesis IH_In_equiv: forall i, In i (map fst l) <-> In i (map fst (PTree.elements env)).

Hypothesis IH_RDT:
  forall i co a,
    PTree.get i cenv = Some co ->
    PTree.get i env = Some a ->
    Forall (relative_defined_type (PTree.elements env)) (map snd (co_members co)).

Hypothesis IH_main:
  Consistent cenv env.

Lemma NOT_IN: ~ In i0 (map fst (PTree.elements env)).
Proof.
  intros.
  rewrite <- IH_In_equiv; auto.
Qed.

Lemma RDT_PTree: Forall (relative_defined_type (PTree.elements env)) (map snd (co_members co0)).
Proof.
  intros.
  revert RDT_list; apply Forall_impl.
  intros t.
  apply relative_defined_type_mono.
  firstorder.
Qed.

Lemma establish_In_equiv:
  forall i, In i (map fst ((i0, co0) :: l)) <-> In i (map fst (PTree.elements (env_rec i0 co0 env))).
Proof.
  intros.
  specialize (IH_In_equiv i).
  rewrite PTree_In_fst_elements in IH_In_equiv |- *.
  unfold env_rec.
  rewrite <- PTree_gs_equiv.
  simpl In.
  assert (i0 = i <-> i = i0) by (split; intros; congruence).
  tauto.
Qed.

Lemma establish_RDT:
  forall i co a,
    PTree.get i cenv = Some co ->
    PTree.get i (env_rec i0 co0 env) = Some a ->
    Forall (relative_defined_type (PTree.elements (env_rec i0 co0 env))) (map snd (co_members co)).
Proof.
  pose proof RDT_PTree as RDT_PTree.
  intros i co a CENV ENV.
  unfold env_rec in ENV.
  destruct (Pos.eq_dec i i0).
  + subst i0; rewrite CENV in CENV0; inversion CENV0; subst co0; clear CENV0.
    rewrite PTree.gss in ENV.
    inversion ENV; clear a ENV H0.
    revert RDT_PTree.
    apply Forall_impl; intros t.
    apply relative_defined_type_PTree_set.
  + rewrite PTree.gso in ENV by auto.
    specialize (IH_RDT _ _ _ CENV ENV).
    revert IH_RDT.
    apply Forall_impl; intros t.
    apply relative_defined_type_PTree_set.
Qed.

Lemma establish_main:
  Consistent cenv (env_rec i0 co0 env).
Proof.
  pose proof NOT_IN as NOT_IN.
  pose proof RDT_PTree as RDT_PTree.
  intros i co a CENV ENV.
  unfold env_rec in ENV.
  destruct (Pos.eq_dec i i0).
  + subst i0; rewrite CENV in CENV0; inversion CENV0; subst co0; clear CENV0.
    rewrite PTree.gss in ENV.
    inversion ENV; clear a ENV H0.
    f_equal.
    auto.
    apply map_ext_in.
    intros (i1, t1) ?.
    f_equal.
    apply F_PTree_set; auto.
    rewrite Forall_forall in RDT_PTree; apply RDT_PTree.
    apply (in_map snd) in H; auto.
  + rewrite PTree.gso in ENV by auto.
    specialize (IH_main _ _ _ CENV ENV).
    subst a.
    f_equal.
    apply map_ext_in.
    intros (i1, t1) ?.
    f_equal.
    apply F_PTree_set; auto.
    specialize (IH_RDT _ _ _ CENV ENV).
    rewrite Forall_forall in IH_RDT; apply IH_RDT.
    apply (in_map snd) in H; auto.
Qed.

End Consistency_Induction_Step.

Lemma Consistency: forall cenv l,
  Permutation l (PTree.elements cenv) ->
  ordered_composite l ->
  Consistent cenv (Env l).
Proof.
  intros.
  assert (forall i co, In (i, co) l -> PTree.get i cenv = Some co).
  {
    intros.
    apply PTree.elements_complete.
    eapply Permutation_in; eauto.
  }
  assert (NoDup (map fst l)).
  {
    eapply Permutation_NoDup; [symmetry; apply Permutation_map; eassumption |].
    rewrite <- list_norepet_NoDup.
    apply PTree.elements_keys_norepet.
  }
  clear H.
  assert (
    (forall i, In i (map fst l) <-> In i (map fst (PTree.elements (Env l)))) /\
    (forall i co a,
      PTree.get i cenv = Some co ->
      PTree.get i (Env l) = Some a ->
      Forall (relative_defined_type (PTree.elements (Env l))) (map snd (co_members co))) /\
    Consistent cenv (Env l)); [| tauto].
  induction l as [| [i0 co0] l].
  + split; [| split]; hnf; intros.
    - simpl; tauto.
    - unfold Env in H3; simpl in H3.
      rewrite PTree.gempty in H3; inv H3.
    - unfold Env in H3; simpl in H3.
      rewrite PTree.gempty in H3; inv H3.
  + inv H0.
    rename H4 into RDT_list; specialize (IHl H6); clear H6.
    assert (CENV0: PTree.get i0 cenv = Some co0).
    { apply H1; left; auto. }
    spec IHl; [| clear H1].
    { intros; apply H1; right; auto. }
    inv H2.
    rename H1 into NOT_IN_LIST; specialize (IHl H3); clear H3.
    destruct IHl as [IH_In_equiv [IH_RDT IH_main]].
    split; [| split].
    - apply establish_In_equiv; auto.
    - eapply establish_RDT; eauto.
    - eapply establish_main; eauto.
Qed.

Lemma Completeness: forall cenv l,
  Permutation l (PTree.elements cenv) ->
  Complete cenv (Env l).
Proof.
  intros.
  intro.
  rewrite <- !PTree_In_fst_elements.
  pose proof PTree.elements_keys_norepet cenv.
  rewrite list_norepet_NoDup in H0.
  rewrite <- H in H0 |- *; clear H.
  induction l.
  + simpl; tauto.
  + destruct a as [i0 co0].
    inv H0.
    specialize (IHl H3).
    simpl.
    unfold env_rec.
    rewrite PTree_In_fst_elements, <- PTree_gs_equiv, <- PTree_In_fst_elements.
    assert (i = i0 <-> i0 = i) by (split; intros; congruence).
    tauto.
Qed.

End type_func.

End type_func.

Corollary composite_reorder_consistent {A: Type}:
  forall cenv f_default f_array f_struct f_union f_members,
    composite_env_consistent cenv ->
    type_func.Consistent f_default f_array f_struct f_union f_members cenv (@type_func.Env A f_default f_array f_struct f_union f_members (composite_reorder.rebuild_composite_elements cenv)).
Proof.
  intros.
  apply type_func.Consistency.
  + apply composite_reorder.RCT_Permutation.
  + apply composite_reorder.RCT_ordered; auto.
Qed.

Corollary composite_reorder_complete {A: Type}:
  forall cenv f_default f_array f_struct f_union f_members,
    type_func.Complete cenv (@type_func.Env A f_default f_array f_struct f_union f_members (composite_reorder.rebuild_composite_elements cenv)).
Proof.
  intros.
  apply type_func.Completeness.
  apply composite_reorder.RCT_Permutation.
Qed.

Section cuof.

Context (cenv: composite_env).

Fixpoint complete_legal_cosu_type t :=
  match t with
  | Tarray t' _ _ => complete_legal_cosu_type t'
  | Tstruct id _ => match cenv ! id with
                    | Some co => match co_su co with
                                 | Struct => true
                                 | Union => false
                                 end
                    | _ => false
                    end
  | Tunion id _ => match cenv ! id with
                   | Some co => match co_su co with
                                | Struct => false
                                | Union => true
                                end
                   | _ => false
                   end
  | Tfunction _ _ _
  | Tvoid => false
  | _ => true
  end.

Fixpoint composite_complete_legal_cosu_type (m: members): bool :=
  match m with
  | nil => true
  | (_, t) :: m' => complete_legal_cosu_type t && composite_complete_legal_cosu_type m'
  end.

Definition composite_env_complete_legal_cosu_type: Prop :=
  forall (id : positive) (co : composite),
    cenv ! id = Some co -> composite_complete_legal_cosu_type (co_members co) = true.

End cuof.

Lemma complete_legal_cosu_type_complete_type: forall cenv: composite_env,
  forall t,
    complete_legal_cosu_type cenv t = true ->
    complete_type cenv t = true.
Proof.
  intros.
  induction t; auto.
  + simpl in *.
    destruct (cenv ! i); auto.
  + simpl in *.
    destruct (cenv ! i); auto.
Qed.


(* Distributed under the terms of the MIT license. *)

(** Generic transofmations from one language to another,
    preserving an evaluation relation up-to some observational equality. *)

From Coq Require Import Program ssreflect ssrbool.
From Equations Require Import Equations.
From MetaCoq.Utils Require Import utils.
Import bytestring.
Local Open Scope bs.
Local Open Scope string_scope2.

(* Used to show timings of the ML execution *)

Definition time : forall {A B}, string -> (A -> B) -> A -> B :=
  fun A B s f x => f x.

Extract Constant time =>
  "(fun c f x -> let s = Caml_bytestring.caml_string_of_bytestring c in Tm_util.time (Pp.str s) f x)".

Module Transform.
  Section Opt.
     Context {program program' : Type}.
     Context {value value' : Type}.
     Context {eval :  program -> value -> Prop}.
     Context {eval' : program' -> value' -> Prop}.

     Definition preserves_eval pre (transform : forall p : program, pre p -> program') obseq :=
      forall p v (pr : pre p),
        eval p v ->
        let p' := transform p pr in
        exists v', eval' p' v' /\ obseq p p' v v'.

    Record t :=
    { name : string;
      pre : program -> Prop;
      transform : forall p : program, pre p -> program';
      post : program' -> Prop;
      correctness : forall input (p : pre input), post (transform input p);
      obseq : program -> program' -> value -> value' -> Prop;
      preservation : preserves_eval pre transform obseq; }.

    Definition run (x : t) (p : program) (pr : pre x p) : program' :=
      time x.(name) (fun _ => x.(transform) p pr) tt.

  End Opt.
  Arguments t : clear implicits.

  Definition self_transform program value eval eval' := t program program value value eval eval'.

  Section Comp.
    Context {program program' program'' : Type}.
    Context {value value' value'' : Type}.
    Context {eval : program -> value -> Prop}.
    Context {eval' : program' -> value' -> Prop}.
    Context {eval'' : program'' -> value'' -> Prop}.

    Local Obligation Tactic := idtac.
    Program Definition compose (o : t program program' value value' eval eval') (o' : t program' program'' value' value'' eval' eval'')
      (hpp : (forall p, o.(post) p -> o'.(pre) p)) : t program program'' value value'' eval eval'' :=
      {|
        name := (o.(name) ^ " -> " ^ o'.(name))%bs;
        transform p hp := run o' (run o p hp) (hpp _ (o.(correctness) _ hp));
        pre := o.(pre);
        post := o'.(post);
        obseq g g' v v' := exists g'' v'', o.(obseq) g g'' v v'' × o'.(obseq) g'' g' v'' v'
        |}.
    Next Obligation.
      intros o o' hpp inp pre.
      eapply o'.(correctness).
    Qed.
    Next Obligation.
      red. intros o o' hpp.
      intros p v pr ev.
      eapply (o.(preservation) _ _ pr) in ev; auto.
      cbn in ev. destruct ev as [v' [ev]].
      epose proof (o'.(preservation) (o.(transform) p pr) v').
      specialize (H0 (hpp _ (o.(correctness) _ pr)) ev).
      destruct H0 as [v'' [ev' obs']].
      exists v''. constructor => //.
      exists (transform o p pr), v'. now split.
    Qed.
  End Comp.

  Declare Scope transform_scope.
  Bind Scope transform_scope with t.

  Notation " o ▷ o' " := (Transform.compose o o' _) (at level 50, left associativity) : transform_scope.

  Open Scope transform_scope.
End Transform.