(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(* Wrapper of FSetAVL *)

Require FSetAVL FSetFacts.
Require MSetProperties.
Require Import OrderedType ZArith.
Require Import hpattern vgtac.
Require Import VocabA.
Require Import Morphisms.

Module FSetAVL'.

Module Make (X : OrderedType).

Module OrigS := FSetAVL.Make X.
Include OrigS.
Module SF := FSetFacts.Facts OrigS.
Module MSF := MSetProperties.OrdProperties MSet.

Lemma choose_mor : Proper (eq ==> opt_eq X.eq) choose.
Proof.
unfold opt_eq, choose; intros s1 s2 Hs.
remember (MSet.choose s1) as opt_x. remember (MSet.choose s2) as opt_y.
pose (MSF.choose_equal Hs) as Hchoose.
rewrite <- Heqopt_x in Hchoose. rewrite <- Heqopt_y in Hchoose.
destruct opt_x; destruct opt_y; by auto.
Qed.

Definition choose_only (s : t) : option elt :=
  if eq_nat_dec (cardinal s) 1 then choose s else None.

Lemma choose_only_mor : Proper (eq ==> opt_eq X.eq) choose_only.
Proof.
unfold choose_only, cardinal; intros s1 s2 Hs.
rewrite MSF.P.Equal_cardinal with (s':=s2); [|by auto].
destruct (eq_nat_dec (MSet.cardinal s2) 1); [|by auto].
by apply choose_mor.
Qed.

Lemma mset_raw_cardinal_zero :
  forall s (Hs : MSet.Raw.cardinal s = 0), s = MSet.Raw.Leaf.
Proof. destruct s; [by auto|by inversion 1]. Qed.

Lemma mset_raw_choose_only_1 :
  forall s e (Hse : MSet.Raw.choose s = Some e) (Hs : MSet.Raw.cardinal s = 1),
    MSet.Raw.elements s = cons e nil.
Proof.
destruct s; i.
- inversion Hs.
- simpl in Hs. inversion Hs.
  apply plus_is_O in H0. destruct H0 as [Hs1 Hs2].
  apply mset_raw_cardinal_zero in Hs1.
  apply mset_raw_cardinal_zero in Hs2. subst.
  simpl in Hse. inversion Hse. subst. by auto.
Qed.

Lemma mset_choose_only_1 :
  forall s e (Hse : MSet.choose s = Some e) (Hs : MSet.cardinal s = 1),
    MSet.elements s = cons e nil.
Proof. induction s. i. by apply mset_raw_choose_only_1. Qed.

Lemma choose_only_1 :
  forall s e (Hce : choose_only s = Some e), elements s = cons e nil.
Proof.
unfold choose_only; i.
remember (Nat.eq_dec (cardinal s) 1) as Hcar. destruct Hcar; [|discriminate].
by apply mset_choose_only_1.
Qed.

Lemma choose_only_2 :
  forall l1 l2 l' (Hco : choose_only l' = Some l1) (Hmem : mem l2 l' = true),
    X.eq l1 l2.
Proof.
i. unfold mem in Hmem. rewrite MF.elements_b in Hmem.
apply choose_only_1 in Hco.
unfold elements in Hco. rewrite Hco in Hmem.
inversion Hmem.  apply Bool.orb_true_iff in H0.
elim H0; [i|discriminate].
unfold MF.eqb in H. destruct (MF.eq_dec l2 l1); [|discriminate].
by apply X.eq_sym.
Qed.

Local Open Scope bool.

Definition cond_eq (f g : elt -> bool) : Prop :=
  compat_bool X.eq f /\ (X.eq ==> Logic.eq)%signature f g.

Definition cond_eq_mor :
  forall f g (Hf_mor : compat_bool X.eq f)
         (Hfg_mor : (X.eq ==> Logic.eq)%signature f g),
    compat_bool X.eq g.
Proof.
i. intros x y Hxy.
assert (Hx: g x = f x); [symmetry; apply Hfg_mor; by apply X.eq_refl|].
assert (Hy: g y = f y); [symmetry; apply Hfg_mor; by apply X.eq_refl|].
rewrite Hx, Hy. by apply Hf_mor.
Qed.

Definition for_all_mor : Proper (cond_eq ==> eq ==> Logic.eq)%signature for_all.
Proof.
intros f1 f2 Hf s1 s2 Hs.
destruct Hf as [Hf_mor Hfg_eq].
remember (for_all f1 s1) as b1. remember (for_all f2 s2) as b2.
destruct b1, b2; [by auto| | |by auto].
- symmetry in Heqb1. rewrite Heqb2. symmetry.
  apply SF.for_all_iff in Heqb1; [|by auto].
  apply SF.for_all_iff
  ; [eapply cond_eq_mor; [by apply Hf_mor|by apply Hfg_eq]|].
  intros x Hin. symmetry. assert (Hf: f1 x = true).
  + apply Heqb1. by apply Hs.
  + rewrite <- Hf. apply Hfg_eq. by apply X.eq_refl.
- symmetry in Heqb2. rewrite Heqb1.
  apply SF.for_all_iff in Heqb2
  ; [|eapply cond_eq_mor; [by apply Hf_mor|by apply Hfg_eq]].
  apply SF.for_all_iff; [by auto|].
  intros x Hin. assert (Hg: f2 x = true).
  + apply Heqb2. by apply Hs.
  + rewrite <- Hg. apply Hfg_eq. by apply X.eq_refl.
Qed.

Definition for_all' (print : elt -> unit) (cond : elt -> bool) (m : t) : bool :=
  let add_cond v acc := acc && print_when_false print v cond v in
  fold add_cond m true.

Lemma for_all_raw_false (cond : elt -> bool) :
  forall s, MSet.Raw.fold (fun v acc => acc && cond v) s false = false.
Proof.
induction s.
- by auto.
- s; by rewrite IHs1, Bool.andb_false_intro1.
Qed.

Lemma for_all'_1 (print : elt -> unit) (cond : elt -> bool) (m : t) :
  for_all' print cond m = for_all cond m.
Proof.
unfold for_all, MSet.for_all, for_all', fold, MSet.fold, print_when_false.
induction (MSet.this m).
- by auto.
- s; remember (cond t1) as b; destruct b.
  + remember (MSet.Raw.for_all cond t0_1) as b; destruct b.
    * rewrite IHt0_1; s; rewrite IHt0_2; reflexivity.
    * rewrite IHt0_1; rewrite Bool.andb_false_intro1; [|reflexivity].
      by apply for_all_raw_false.
  + rewrite Bool.andb_false_intro2; [by apply for_all_raw_false|reflexivity].
Qed.

Local Close Scope bool.

Lemma elements_eq :
  forall ls1 ls2 (Heq : Equal ls1 ls2),
    eqlistA X.eq (elements ls1) (elements ls2).
Proof.
i. apply MSF.sort_equivlistA_eqlistA.
- by apply MSet.elements_spec2.
- by apply MSet.elements_spec2.
- constructor; i.
  + apply SF.elements_iff; apply Heq; apply SF.elements_iff; by auto.
  + apply SF.elements_iff; apply Heq; apply SF.elements_iff; by auto.
Qed.

End Make.

End FSetAVL'.


From iris.algebra Require Export cmra.
From iris.base_logic Require Import base_logic.
From iris Require Import options.
Local Arguments validN _ _ _ !_ /.
Local Arguments valid _ _  !_ /.

Inductive excl (A : Type) :=
  | Excl : A → excl A
  | ExclBot : excl A.
Arguments Excl {_} _.
Arguments ExclBot {_}.

Instance: Params (@Excl) 1 := {}.
Instance: Params (@ExclBot) 1 := {}.

Notation excl' A := (option (excl A)).
Notation Excl' x := (Some (Excl x)).
Notation ExclBot' := (Some ExclBot).

Instance maybe_Excl {A} : Maybe (@Excl A) := λ x,
  match x with Excl a => Some a | _ => None end.

Section excl.
Context {A : ofeT}.
Implicit Types a b : A.
Implicit Types x y : excl A.

(* Cofe *)
Inductive excl_equiv : Equiv (excl A) :=
  | Excl_equiv a b : a ≡ b → Excl a ≡ Excl b
  | ExclBot_equiv : ExclBot ≡ ExclBot.
Existing Instance excl_equiv.
Inductive excl_dist : Dist (excl A) :=
  | Excl_dist a b n : a ≡{n}≡ b → Excl a ≡{n}≡ Excl b
  | ExclBot_dist n : ExclBot ≡{n}≡ ExclBot.
Existing Instance excl_dist.

Global Instance Excl_ne : NonExpansive (@Excl A).
Proof. by constructor. Qed.
Global Instance Excl_proper : Proper ((≡) ==> (≡)) (@Excl A).
Proof. by constructor. Qed.
Global Instance Excl_inj : Inj (≡) (≡) (@Excl A).
Proof. by inversion_clear 1. Qed.
Global Instance Excl_dist_inj n : Inj (dist n) (dist n) (@Excl A).
Proof. by inversion_clear 1. Qed.

Definition excl_ofe_mixin : OfeMixin (excl A).
Proof.
  apply (iso_ofe_mixin (maybe Excl)).
  - by intros [a|] [b|]; split; inversion_clear 1; constructor.
  - by intros n [a|] [b|]; split; inversion_clear 1; constructor.
Qed.
Canonical Structure exclO : ofeT := OfeT (excl A) excl_ofe_mixin.

Global Instance excl_cofe `{!Cofe A} : Cofe exclO.
Proof.
  apply (iso_cofe (from_option Excl ExclBot) (maybe Excl)).
  - by intros n [a|] [b|]; split; inversion_clear 1; constructor.
  - by intros []; constructor.
Qed.

Global Instance excl_ofe_discrete : OfeDiscrete A → OfeDiscrete exclO.
Proof. by inversion_clear 2; constructor; apply (discrete _). Qed.
Global Instance excl_leibniz : LeibnizEquiv A → LeibnizEquiv (excl A).
Proof. by destruct 2; f_equal; apply leibniz_equiv. Qed.

Global Instance Excl_discrete a : Discrete a → Discrete (Excl a).
Proof. by inversion_clear 2; constructor; apply (discrete _). Qed.
Global Instance ExclBot_discrete : Discrete (@ExclBot A).
Proof. by inversion_clear 1; constructor. Qed.

(* CMRA *)
Instance excl_valid : Valid (excl A) := λ x,
  match x with Excl _ => True | ExclBot => False end.
Instance excl_validN : ValidN (excl A) := λ n x,
  match x with Excl _ => True | ExclBot => False end.
Instance excl_pcore : PCore (excl A) := λ _, None.
Instance excl_op : Op (excl A) := λ x y, ExclBot.

Lemma excl_cmra_mixin : CmraMixin (excl A).
Proof.
  split; try discriminate.
  - by intros n []; destruct 1; constructor.
  - by destruct 1; intros ?.
  - intros x; split. done. by move=> /(_ 0).
  - intros n [?|]; simpl; auto with lia.
  - by intros [?|] [?|] [?|]; constructor.
  - by intros [?|] [?|]; constructor.
  - by intros n [?|] [?|].
  - intros n x [?|] [?|] ? Hx; eexists _, _; inversion_clear Hx; eauto.
Qed.
Canonical Structure exclR := CmraT (excl A) excl_cmra_mixin.

Global Instance excl_cmra_discrete : OfeDiscrete A → CmraDiscrete exclR.
Proof. split. apply _. by intros []. Qed.

(** Internalized properties *)
Lemma excl_equivI {M} x y :
  x ≡ y ⊣⊢@{uPredI M} match x, y with
                      | Excl a, Excl b => a ≡ b
                      | ExclBot, ExclBot => True
                      | _, _ => False
                      end.
Proof.
  uPred.unseal. do 2 split. by destruct 1. by destruct x, y; try constructor.
Qed.
Lemma excl_validI {M} x :
  ✓ x ⊣⊢@{uPredI M} if x is ExclBot then False else True.
Proof. uPred.unseal. by destruct x. Qed.

(** Exclusive *)
Global Instance excl_exclusive x : Exclusive x.
Proof. by destruct x; intros n []. Qed.

(** Option excl *)
Lemma excl_validN_inv_l n mx a : ✓{n} (Excl' a ⋅ mx) → mx = None.
Proof. by destruct mx. Qed.
Lemma excl_validN_inv_r n mx a : ✓{n} (mx ⋅ Excl' a) → mx = None.
Proof. by destruct mx. Qed.

Lemma Excl_includedN n a b  : Excl' a ≼{n} Excl' b ↔ a ≡{n}≡ b.
Proof.
  split; [|by intros ->]. by intros [[c|] Hb%(inj Some)]; inversion_clear Hb.
Qed.
Lemma Excl_included a b : Excl' a ≼ Excl' b ↔ a ≡ b.
Proof.
  split; [|by intros ->]. by intros [[c|] Hb%(inj Some)]; inversion_clear Hb.
Qed.
End excl.

Arguments exclO : clear implicits.
Arguments exclR : clear implicits.

(* Functor *)
Definition excl_map {A B} (f : A → B) (x : excl A) : excl B :=
  match x with Excl a => Excl (f a) | ExclBot => ExclBot end.
Lemma excl_map_id {A} (x : excl A) : excl_map id x = x.
Proof. by destruct x. Qed.
Lemma excl_map_compose {A B C} (f : A → B) (g : B → C) (x : excl A) :
  excl_map (g ∘ f) x = excl_map g (excl_map f x).
Proof. by destruct x. Qed.
Lemma excl_map_ext {A B : ofeT} (f g : A → B) x :
  (∀ x, f x ≡ g x) → excl_map f x ≡ excl_map g x.
Proof. by destruct x; constructor. Qed.
Instance excl_map_ne {A B : ofeT} n :
  Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@excl_map A B).
Proof. by intros f f' Hf; destruct 1; constructor; apply Hf. Qed.
Instance excl_map_cmra_morphism {A B : ofeT} (f : A → B) :
  NonExpansive f → CmraMorphism (excl_map f).
Proof. split; try done; try apply _. by intros n [a|]. Qed.
Definition exclO_map {A B} (f : A -n> B) : exclO A -n> exclO B :=
  OfeMor (excl_map f).
Instance exclO_map_ne A B : NonExpansive (@exclO_map A B).
Proof. by intros n f f' Hf []; constructor; apply Hf. Qed.

Program Definition exclRF (F : oFunctor) : rFunctor := {|
  rFunctor_car A _ B _ := (exclR (oFunctor_car F A B));
  rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := exclO_map (oFunctor_map F fg)
|}.
Next Obligation.
  intros F A1 ? A2 ? B1 ? B2 ? n x1 x2 ??. by apply exclO_map_ne, oFunctor_map_ne.
Qed.
Next Obligation.
  intros F A ? B ? x; simpl. rewrite -{2}(excl_map_id x).
  apply excl_map_ext=>y. by rewrite oFunctor_map_id.
Qed.
Next Obligation.
  intros F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x; simpl. rewrite -excl_map_compose.
  apply excl_map_ext=>y; apply oFunctor_map_compose.
Qed.

Instance exclRF_contractive F :
  oFunctorContractive F → rFunctorContractive (exclRF F).
Proof.
  intros A1 ? A2 ? B1 ? B2 ? n x1 x2 ??. by apply exclO_map_ne, oFunctor_map_contractive.
Qed.


Require Import Util EqDec DecSolve Val CSet Map Envs Option Get MapDefined SetOperations.
Require Import MoreList Option OptionR OptionMap ReplaceIf Filter.

Set Implicit Arguments.

(** * Operations *)

Inductive op :=
  Con : val -> op
| Var : var -> op
| UnOp : unop -> op -> op
| BinOp : binop -> op -> op -> op.

Inductive isVar : op -> Prop :=
  IisVar v : isVar (Var v).

Instance isVar_dec e : Computable (isVar e).
Proof.
  destruct e; try dec_solve.
Defined.

Notation "'IsVar'" := (fun e => B[isVar e]) (at level 0).
Notation "'NotVar'" := (fun e => B[~ isVar e]) (at level 0).

Definition getVar (e:op) :=
  match e with
  | Var y => y
  | _ => default_var
  end.

Instance inst_eq_dec_op : EqDec op eq.
Proof.
  hnf; intros. change ({x = y} + {x <> y}).
  decide equality.
  - eapply inst_eq_dec_val.
  - eapply var_dec.
  - eapply inst_eq_dec_unop.
  - eapply inst_eq_dec_binop.
Defined.

Fixpoint op_eval (E:onv val) (e:op) : option val :=
  match e with
  | Con v => Some v
  | Var x => E x
  | UnOp o e => mdo v <- op_eval E e;
                 unop_eval o v
  | BinOp o e1 e2 => mdo v1 <- op_eval E e1;
                      mdo v2 <- op_eval E e2;
                      binop_eval o v1 v2
  end.

Inductive live_op_sound : op -> set var -> Prop :=
| ConLiveSound v lv : live_op_sound (Con v) lv
| VarLiveSound x lv : x ∈ lv -> live_op_sound (Var x) lv
| UnopLiveSound o e lv :
    live_op_sound e lv
    -> live_op_sound (UnOp o e) lv
| binopLiveSound o e1 e2 lv :
    live_op_sound e1 lv ->
    live_op_sound e2 lv ->
    live_op_sound (BinOp o e1 e2) lv.

Instance live_op_sound_Subset e
  : Proper (Subset ==> impl) (live_op_sound e).
Proof.
  unfold Proper, respectful, impl; intros.
  general induction e; invt live_op_sound; eauto using live_op_sound.
Qed.

Instance live_op_sound_Equal e
  : Proper (Equal ==> iff) (live_op_sound e).
Proof.
  unfold Proper, respectful, impl; split; intros.
  - eapply subset_equal in H. rewrite H in H0; eauto.
  - symmetry in H. eapply subset_equal in H.
    rewrite <- H; eauto.
Qed.

Instance live_op_sound_dec e lv
  : Computable (live_op_sound e lv).
Proof.
  induction e as [c|v| |].
  - dec_solve.
  - decide (v ∈ lv); try dec_solve.
  - edestruct IHe; dec_solve.
  - edestruct IHe1, IHe2; dec_solve.
Defined.

Lemma live_op_sound_incl
  : forall e lv lv', live_op_sound e lv' -> lv' ⊆ lv -> live_op_sound e lv.
Proof.
  intros; general induction H; econstructor; eauto.
Qed.

Fixpoint freeVars (e:op) : set var :=
  match e with
  | Con _ => ∅
  | Var v => {v}
  | UnOp o e => freeVars e
  | BinOp o e1 e2 => freeVars e1 ∪ freeVars e2
  end.

Lemma live_freeVars
  : forall e, live_op_sound e (freeVars e).
Proof.
  intros. general induction e; simpl; econstructor; eauto using live_op_sound_incl with cset.
Qed.

Lemma freeVars_live e lv
  : live_op_sound e lv -> freeVars e ⊆ lv.
Proof.
  intros. general induction H; simpl; cset_tac; intuition.
Qed.

Lemma op_eval_live
  : forall e lv E E', live_op_sound e lv -> agree_on eq lv E E' ->
                 op_eval E e = op_eval E' e.
Proof.
  intros. general induction e; inv H; simpl; eauto.
  - erewrite IHe; eauto.
  - erewrite IHe1, IHe2; eauto.
Qed.

Global Instance eval_op_ext
  : Proper (@feq _ _ eq ==> eq ==> eq) op_eval.
Proof.
  unfold Proper, respectful; intros; subst.
  general induction y0; simpl; eauto.
  - erewrite IHy0; eauto.
  - erewrite IHy0_1, IHy0_2; eauto.
Qed.

Lemma get_live_op_sound Y D n y
  : list_union (freeVars ⊝ Y) ⊆ D
    -> get Y n y
    -> live_op_sound y D.
Proof.
  intros. eapply live_op_sound_incl; [eapply live_freeVars |].
  rewrite <- H. eauto using get_list_union_map with cset.
Qed.

Definition var_to_op : forall x:var, op := Var.
Lemma var_to_op_correct : forall M x,
    op_eval M (var_to_op x) = M x.
Proof.
  reflexivity.
Qed.

Fixpoint rename_op (ϱ:env var) (s:op) : op :=
  match s with
  | Con v => Con v
  | Var v => Var (ϱ v)
  | UnOp o e => UnOp o (rename_op ϱ e)
  | BinOp o e1 e2 => BinOp o (rename_op ϱ e1) (rename_op ϱ e2)
  end.

Lemma rename_op_comp e ϱ ϱ'
  : rename_op ϱ (rename_op ϱ' e) = rename_op (ϱ' ∘ ϱ) e.
Proof.
  unfold comp. general induction e; simpl; eauto.
  - f_equal; eauto.
  - f_equal; eauto.
Qed.

Lemma rename_op_ext
  : forall e (ϱ ϱ':env var), feq (R:=eq) ϱ ϱ' -> rename_op ϱ e = rename_op ϱ' e.
Proof.
  intros. general induction e; simpl; f_equal; eauto.
Qed.

Lemma rename_op_agree ϱ ϱ' e
  : agree_on eq (freeVars e) ϱ ϱ'
    -> rename_op ϱ e = rename_op ϱ' e.
Proof.
  intros; general induction e; simpl in *; f_equal;
    eauto 30 using agree_on_incl, incl_left, incl_right.
Qed.

Lemma rename_op_freeVars
  : forall e ϱ `{Proper _ (_eq ==> _eq) ϱ},
    freeVars (rename_op ϱ e) ⊆ lookup_set ϱ (freeVars e).
Proof.
  intros. general induction e; simpl; eauto using lookup_set_single_fact,
                                      lookup_set_union_incl, incl_union_lr; eauto.
Qed.

Lemma live_op_rename_sound e lv (ϱ:env var)
  : live_op_sound e lv
    -> live_op_sound (rename_op ϱ e) (lookup_set ϱ lv).
Proof.
  intros. general induction H; simpl; eauto using live_op_sound with cset.
Qed.

Fixpoint subst_op (ϱ:env op) (s:op) : op :=
  match s with
  | Con v => Con v
  | Var v => (ϱ v)
  | UnOp o e => UnOp o (subst_op ϱ e)
  | BinOp o e1 e2 => BinOp o (subst_op ϱ e1) (subst_op ϱ e2)
  end.

Lemma subst_op_comp e ϱ ϱ'
  : subst_op ϱ (subst_op ϱ' e) = subst_op (fun x => subst_op ϱ (ϱ' x)) e.
Proof.
  general induction e; simpl; eauto.
  - f_equal; eauto.
  - f_equal; eauto.
Qed.

Lemma subst_op_ext
  : forall e (ϱ ϱ':env op), feq (R:=eq) ϱ ϱ' -> subst_op ϱ e = subst_op ϱ' e.
Proof.
  intros. general induction e; simpl; eauto.
  - f_equal; eauto.
  - f_equal; eauto.
Qed.

Inductive alpha_op : env var -> env var -> op -> op -> Prop :=
| AlphaCon ϱ ϱ' v : alpha_op ϱ ϱ' (Con v) (Con v)
| AlphaVar ϱ ϱ' x y : ϱ x = y -> ϱ' y = x -> alpha_op ϱ ϱ' (Var x) (Var y)
| AlphaUnOp ϱ ϱ' o e e' :
    alpha_op ϱ ϱ' e e'
    -> alpha_op ϱ ϱ' (UnOp o e) (UnOp o e')
| AlphaBinOp ϱ ϱ' o e1 e1' e2 e2' :
    alpha_op ϱ ϱ' e1 e1' ->
    alpha_op ϱ ϱ' e2 e2' ->
    alpha_op ϱ ϱ' (BinOp o e1 e2) (BinOp o e1' e2').

Lemma alpha_op_rename_injective
  : forall e ϱ ϱ',
    inverse_on (freeVars e) ϱ ϱ'
    -> alpha_op ϱ ϱ' e (rename_op ϱ e).
Proof.
  intros. induction e; simpl; eauto using alpha_op.
  econstructor; eauto. eapply H; eauto. simpl; cset_tac; eauto.
  simpl in *. econstructor.
  eapply IHe1. eapply inverse_on_incl; eauto. cset_tac; intuition.
  eapply IHe2. eapply inverse_on_incl; eauto. cset_tac; intuition.
Qed.

Lemma alpha_op_refl : forall e, alpha_op id id e e.
Proof.
  intros; induction e; eauto using alpha_op.
Qed.

Lemma alpha_op_sym : forall ϱ ϱ' e e', alpha_op ϱ ϱ' e e' -> alpha_op ϱ' ϱ e' e.
Proof.
  intros. general induction H; eauto using alpha_op.
Qed.

Lemma alpha_op_trans
  : forall ϱ1 ϱ1' ϱ2 ϱ2' s s' s'',
    alpha_op ϱ1 ϱ1' s s'
    -> alpha_op ϱ2 ϱ2' s' s''
    -> alpha_op (ϱ1 ∘ ϱ2) (ϱ2' ∘ ϱ1') s s''.
Proof.
  intros. general induction H.
  + inversion H0. subst v0 ϱ0 ϱ'0 s''. econstructor.
  + inversion H1. subst x ϱ0 ϱ'0 s''. econstructor; unfold comp; congruence.
  + inversion H0. subst. econstructor; eauto.
  + inversion H1. subst. econstructor; eauto.
Qed.

Lemma alpha_op_inverse_on
  : forall ϱ ϱ' s t, alpha_op ϱ ϱ' s t -> inverse_on (freeVars s) ϱ ϱ'.
Proof.
  intros. general induction H.
  + isabsurd.
  + simpl. hnf; intros.
    eapply In_single in H0.
    rewrite <- H0 at 1. rewrite H. eapply H0.
  + simpl; eauto.
  + simpl. eapply inverse_on_union; eauto.
Qed.

Lemma alpha_op_agree_on_morph
  : forall f g ϱ ϱ' s t,
    alpha_op ϱ ϱ' s t
    -> agree_on _eq (lookup_set ϱ (freeVars s)) g ϱ'
    -> agree_on _eq (freeVars s) f ϱ
    -> alpha_op f g s t.
Proof.
  intros. general induction H; simpl in *;
            eauto 20 using alpha_op, agree_on_incl, lookup_set_union_incl with cset.
  - econstructor.
    + rewrite H2; eauto.
    + eapply H1. lset_tac.
Qed.

Lemma op_rename_renamedApart_all_alpha e e' ϱ ϱ'
  : alpha_op ϱ ϱ' e e'
    -> rename_op ϱ e = e'.
Proof.
  intros. general induction H; simpl; f_equal; eauto.
Qed.

Lemma alpha_op_morph
  : forall (ϱ1 ϱ1' ϱ2 ϱ2':env var) e e',
    @feq _ _ eq ϱ1  ϱ1'
    -> @feq _ _ eq ϱ2 ϱ2'
    -> alpha_op ϱ1 ϱ2 e e'
    -> alpha_op ϱ1' ϱ2' e e'.
Proof.
  intros. general induction H1; eauto using alpha_op.
  econstructor.
  + rewrite <- H1; eauto.
  + rewrite <- H2; eauto.
Qed.

Inductive opLt : op -> op -> Prop :=
| OpLtCon c c'
  : _lt c c'
    -> opLt (Con c) (Con c')
| OpLtConVar c v
  : opLt (Con c) (Var v)
| OpLtConUnOp c o e
  : opLt (Con c) (UnOp o e)
| OpLtConBinop c o e1 e2
  : opLt (Con c) (BinOp o e1 e2)
| OpLtVar v v'
  : _lt v v'
    -> opLt (Var v) (Var v')
| OpLtVarUnOp v o e
  : opLt (Var v) (UnOp o e)
| OpLtVarBinop v o e1 e2
  : opLt (Var v) (BinOp o e1 e2)
| OpLtUnOpBinOp o e o' e1 e2
  : opLt (UnOp o e) (BinOp o' e1 e2)
| OpLtUnOp1 o o' e e'
  : _lt o o'
    -> opLt (UnOp o e) (UnOp o' e')
| OpLtUnOp2 o e e'
  : opLt e e'
    -> opLt (UnOp o e) (UnOp o e')
| OpLtBinOp1 o o' e1 e1' e2 e2'
  : _lt o o'
    -> opLt (BinOp o e1 e2) (BinOp o' e1' e2')
| OpLtBinOp2 o e1 e1' e2 e2'
  : opLt e1 e1'
    -> opLt (BinOp o e1 e2) (BinOp o e1' e2')
| OpLtBinOp3 o e1 e2 e2'
  : opLt e2 e2'
    -> opLt (BinOp o e1 e2) (BinOp o e1 e2').

Lemma _lt_antirefl X `{OrderedType X} x
  : _lt x x -> False.
Proof.
  eapply lt_antirefl.
Qed.

Instance opLt_irr : Irreflexive opLt.
hnf; intros; unfold complement.
- induction x; inversion 1; subst; eauto.
Qed.

Instance opLt_trans : Transitive opLt.
hnf; intros.
general induction H; invt opLt; eauto using opLt.
- econstructor. eapply StrictOrder_Transitive. eapply H. eapply H2.
- econstructor. eapply StrictOrder_Transitive.  eapply H. eapply H2.
- econstructor; eauto. eapply StrictOrder_Transitive. eapply H. eapply H4.
- econstructor; eauto. eapply StrictOrder_Transitive. eapply H. eapply H5.
Qed.

Notation "'Compare' x 'next' y" :=
  (match x with
   | Eq => y
   | z => z
   end) (at level 100).

Fixpoint op_cmp (e e':op) :=
  match e, e' with
  | Con c, Con c' => _cmp c c'
  | Con _, _ => Lt
  | Var v, Var v' => _cmp v v'
  | Var v, UnOp _ _ => Lt
  | Var v, BinOp _ _ _ => Lt
  | UnOp _ _, BinOp _ _ _ => Lt
  | UnOp o e, UnOp o' e' =>
    Compare _cmp o o' next
            Compare op_cmp e e' next Eq
  | BinOp o e1 e2, BinOp o' e1' e2' =>
    Compare _cmp o o' next
            Compare op_cmp e1 e1' next
            Compare op_cmp e2 e2' next Eq
  | _, _ => Gt
  end.

Instance StrictOrder_opLt : OrderedType.StrictOrder opLt eq.
econstructor.
eapply opLt_trans.
intros. intro. eapply opLt_irr. rewrite H0 in H.
eapply H.
Qed.

Instance OrderedType_op : OrderedType op :=
  { _eq := eq;
    _lt := opLt;
    _cmp := op_cmp}.
Proof.
  intros. revert y.
  induction x as [|v| |]; destruct y as [|v'| |];
    simpl; try now (econstructor; eauto using opLt).
- pose proof (_compare_spec v v0).
  inv H.
  + econstructor. eauto using opLt.
  + econstructor. f_equal. eauto.
  + econstructor; eauto using opLt.
- pose proof (_compare_spec v v').
  inv H; (econstructor; eauto using opLt); f_equal; eauto.
- pose proof (_compare_spec u u0).
  specialize (IHx y).
  inv H; try now (econstructor; eauto using opLt).
  eapply unop_eq_eq in H1; subst.
  inv IHx; try now (econstructor; eauto using opLt).
- pose proof (_compare_spec b b0).
  specialize (IHx1 y1). specialize (IHx2 y2).
  inv H; try now (econstructor; eauto using opLt).
  eapply binop_eq_eq in H1.
  inv H1.
  inv IHx1; try now (econstructor; eauto using opLt).
  inv IHx2; try now (econstructor; eauto using opLt).
Defined.

Lemma freeVars_renameOp ϱ e
  : freeVars (rename_op ϱ e) [=] lookup_set ϱ (freeVars e).
Proof.
  general induction e; simpl; try rewrite lookup_set_union; eauto.
  - rewrite IHe1, IHe2; reflexivity.
Qed.

Definition op2bool (e:op) : option bool :=
  mdo r <- op_eval (fun _ => None) e; Some (val2bool r).

Lemma op_eval_mon (E E':onv val) e
  : agree_on (fstNoneOrR eq) (freeVars e) E E'
    -> fstNoneOrR eq (op_eval E e) (op_eval E' e).
Proof.
  intros. general induction e; simpl in *; eauto using fstNoneOrR.
  - exploit IHe as EQ; eauto. inv EQ; simpl; eauto using fstNoneOrR.
    reflexivity.
  - exploit IHe1 as EQ1; eauto with cset.
    inv EQ1; simpl; eauto using fstNoneOrR.
    exploit IHe2 as EQ2; eauto with cset.
    inv EQ2; simpl; eauto using fstNoneOrR.
    reflexivity.
Qed.

Lemma op_eval_op2bool_true V e v
  : op_eval V e = Some v -> val2bool v = true -> op2bool e <> Some false.
Proof.
  intros. unfold op2bool.
  exploit (@op_eval_mon (fun _ => None) V e).
  hnf; intros; eauto using fstNoneOrR.
  rewrite H in H1. inv H1; simpl; congruence.
Qed.

Lemma op_eval_op2bool_false V e v
  : op_eval V e = Some v -> val2bool v = false -> op2bool e <> Some true.
Proof.
  intros. unfold op2bool.
  exploit (@op_eval_mon (fun _ => None) V e).
  hnf; intros; eauto using fstNoneOrR.
  rewrite H in H1. inv H1; simpl; congruence.
Qed.

Lemma op2bool_val2bool E e b
  : op2bool e = Some b
    -> exists v, op_eval E e = Some v /\ val2bool v = b.
Proof.
  intros. unfold op2bool in H. monad_inv H.
  eexists x; split; eauto.
  exploit (@op_eval_mon (fun _ => None) E e); eauto.
  hnf; intros; econstructor.
  inv H; congruence.
Qed.

Lemma op_eval_agree E E' e v
: agree_on eq (freeVars e) E E'
  -> op_eval E e = v
  -> op_eval E' e = v.
Proof.
  intros.
  erewrite <- op_eval_live; eauto.
  eauto using live_op_sound_incl, live_freeVars.
Qed.

Lemma omap_op_eval_agree E E' Y v
: agree_on eq (list_union (List.map freeVars Y)) E E'
  -> omap (op_eval E) Y = v
  -> omap (op_eval E') Y = v.
Proof.
  intros.
  erewrite omap_agree; eauto.
  intros. eapply op_eval_agree; eauto.
  eapply agree_on_incl; eauto.
  eapply incl_list_union; eauto using map_get_1.
Qed.

Lemma op_eval_live_agree E E' e lv v
: live_op_sound e lv
  -> agree_on eq lv E E'
  -> op_eval E e = v
  -> op_eval E' e = v.
Proof.
  intros. erewrite <- op_eval_live; eauto.
Qed.

Lemma omap_op_eval_live_agree E E' lv Y v
: (forall n y, get Y n y -> live_op_sound y lv)
  -> agree_on eq lv E E'
  -> omap (op_eval E) Y = v
  -> omap (op_eval E') Y = v.
Proof.
  intros.
  erewrite omap_agree; eauto.
  intros. eapply op_eval_agree; eauto.
  eapply agree_on_incl; eauto using freeVars_live.
Qed.

Lemma omap_self_update E Z l
:  omap (op_eval E) (List.map Var Z) = ⎣l ⎦
   -> E [Z <-- List.map Some l] [-] E.
Proof.
  general induction Z; simpl in * |- *.
  - reflexivity.
  - monad_inv H; simpl.
    rewrite IHZ; eauto.
    hnf; intros; lud. congruence.
Qed.

Lemma omap_var_defined_on Za lv E
: of_list Za ⊆ lv
  -> defined_on lv E
  -> exists l, omap (op_eval E) (List.map Var Za) = Some l.
Proof.
  intros. general induction Za; simpl.
  - eauto.
  - simpl in *.
    edestruct H0.
    + instantiate (1:=a). cset_tac; intuition.
    + rewrite H1; simpl. edestruct IHZa; eauto.
      cset_tac; intuition.
      rewrite H2; simpl. eauto.
Qed.

Hint Extern 5 =>
match goal with
| [ LV : live_op_sound ?e ?lv, AG: agree_on eq ?lv ?E ?E',
    H1 : op_eval ?E ?e = _, H2 : op_eval ?E' ?e = _ |- _ ] =>
  rewrite (op_eval_live_agree LV AG H1) in H2; try solve [ exfalso; inv H2 ];
    clear_trivial_eqs
end.

Lemma freeVars_live_list Y lv
  : (forall (n : nat) (y : op), get Y n y -> live_op_sound y lv)
    -> list_union (freeVars ⊝ Y) ⊆ lv.
Proof.
  intros H. eapply list_union_incl; intros; inv_get; eauto using freeVars_live with cset.
Qed.

Lemma freeVars_rename_op_list ϱ Y
  : list_union (List.map freeVars (List.map (rename_op ϱ) Y))[=]
               lookup_set ϱ (list_union (List.map freeVars Y)).
Proof.
  rewrite lookup_set_list_union; eauto using lookup_set_empty.
  repeat rewrite map_map. eapply fold_left_union_morphism; [|reflexivity].
  clear_all. general induction Y; simpl; eauto using AllInRel.PIR2, freeVars_renameOp.
Qed.

Lemma op_eval_var Y
  : (forall (n : nat) (y : op), get Y n y -> isVar y)
    -> { xl : list var | Y = Var ⊝ xl }.
Proof.
  intros. general induction Y.
  - eexists nil; eauto.
  - exploit H; eauto using get.
    destruct a as [|v| |]; try now (exfalso; inv H0).
    edestruct IHY; eauto using get; subst.
    exists (v::x); eauto.
Qed.

Lemma of_list_freeVars_vars xl
  : of_list xl [<=] list_union (freeVars ⊝ Var ⊝ xl).
Proof.
  general induction xl; simpl; eauto. rewrite list_union_start_swap.
  rewrite IHxl; eauto. cset_tac.
Qed.

Lemma omap_lookup_vars V xl vl
  : length xl = length vl
    -> NoDupA _eq xl
    -> omap (op_eval (V[xl <-- List.map Some vl])) (List.map Var xl) = Some vl.
Proof.
  intros. eapply length_length_eq in H.
  general induction H; simpl; eauto.
  lud; isabsurd; simpl.
  erewrite omap_op_eval_agree; try eapply IHlength_eq; eauto; simpl in *; intuition.
  instantiate (1:= V [x <- Some y]).
  eapply update_nodup_commute_eq; eauto; simpl; intuition.
Qed.

Lemma omap_replace_if V Y Y' vl0 vl1
  :  omap (op_eval V) (List.filter IsVar Y) = ⎣ vl1 ⎦
     -> omap (op_eval V) Y' = ⎣ vl0 ⎦
     -> omap
         (op_eval V)
         (replace_if NotVar Y Y') = ⎣ merge_cond (IsVar ⊝ Y) vl1 vl0 ⎦.
Proof.
  general induction Y; simpl; eauto.
  simpl in *. cases in H; cases; isabsurd; simpl in *.
  - monad_inv H. rewrite EQ. simpl. erewrite IHY; eauto. eauto.
  - destruct Y'; simpl in *.
    + inv H0; eauto.
    + monad_inv H0. rewrite EQ. simpl.
      erewrite IHY; eauto. simpl; eauto.
Qed.

Definition sid := fun x => Var x.

Instance subst_op_Proper Z Y
  : Proper (_eq ==> _eq) (subst_op (sid [Z <-- Y])).
Proof.
  hnf; intros. inv H. clear H.
  simpl. general induction y; simpl; eauto.
Qed.

Lemma eval_op_subst E y Y Z e
: length Z = length Y
  -> omap (op_eval E) Y = ⎣y ⎦
  -> op_eval (E [Z <-- List.map Some y]) e =
    op_eval E (subst_op (sid [Z <-- Y]) e).
Proof.
  intros.
  general induction e; simpl; eauto.
  - eapply length_length_eq in H.
    general induction H; simpl in * |- *; eauto.
    monad_inv H0. simpl.
    lud; eauto.
  - erewrite IHe; eauto.
  - erewrite IHe1; eauto.
    erewrite IHe2; eauto.
Qed.


Require Export refocusing_lang.

Module Type RED_SEM (R : RED_LANG).

  Parameter dec : R.term -> R.context -> R.decomp -> Prop.

  (** A redex in context will only ever be reduced to itself *)
  Axiom dec_redex_self : forall (r : R.redex) (c : R.context), dec (R.redex_to_term r) c (R.d_red r c).

  Axiom decompose : forall t : R.term, (exists v:R.value, t = R.value_to_term v) \/
      (exists r:R.redex, exists c:R.context, R.plug (R.redex_to_term r) c = t).

  (** dec is left inverse of plug *)
  Axiom dec_correct : forall t c d, dec t c d -> R.decomp_to_term d = R.plug t c.

  Axiom dec_plug : forall c c0 t d, dec (R.plug t c) c0 d -> dec t (R.compose c c0) d.
  Axiom dec_plug_rev : forall c c0 t d, dec t (R.compose c c0) d -> dec (R.plug t c) c0 d.

  Inductive decempty : R.term -> R.decomp -> Prop :=
  | d_intro : forall (t : R.term) (d : R.decomp) (DEC : dec t R.empty d), decempty t d.

  Inductive iter : R.decomp -> R.value -> Prop :=
  | i_val : forall (v : R.value), iter (R.d_val v) v
  | i_red : forall (r : R.redex) (t : R.term) (c : R.context) (d : R.decomp) (v : R.value)
              (CONTR : R.contract r = Some t)
              (D_EM  : decempty (R.plug t c) d)
              (R_IT  : iter d v),
              iter (R.d_red r c) v.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (d : R.decomp) (v : R.value)
                (D_EM : decempty t d)
                (ITER : iter d v),
                eval t v.

End RED_SEM.

Module Type RED_REF_SEM (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 => R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  (** A decomposition function specified in terms of the atomic functions above *)
  Inductive dec : R.term -> R.context -> R.decomp -> Prop :=
  | d_dec  : forall (t : R.term) (c : R.context) (r : R.redex)
               (DT  : dec_term t = R.in_red r),
               dec t c (R.d_red r c)
  | d_v    : forall (t : R.term) (c : R.context) (v : R.value) (d : R.decomp)
               (DT  : dec_term t = R.in_val v)
               (R_C : decctx v c d),
               dec t c d
  | d_term : forall (t t0 : R.term) (c : R.context) (ec : R.elem_context) (d : R.decomp)
               (DT  : dec_term t = R.in_term t0 ec)
               (R_T : dec t0 (ec :: c) d),
               dec t c d
  with decctx : R.value -> R.context -> R.decomp -> Prop :=
  | dc_end  : forall (v : R.value), decctx v R.empty (R.d_val v)
  | dc_dec  : forall (v : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
                (DC  : dec_context ec v = R.in_red r),
                decctx v (ec :: c) (R.d_red r c)
  | dc_val  : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (d : R.decomp)
                (DC  : dec_context ec v = R.in_val v0)
                (R_C : decctx v0 c d),
                decctx v (ec :: c) d
  | dc_term : forall (v : R.value) (ec ec0 : R.elem_context) (c : R.context) (t : R.term) (d : R.decomp)
                (DC  : dec_context ec v = R.in_term t ec0)
                (R_T : dec t (ec0 :: c) d),
                decctx v (ec :: c) d.

  Axiom dec_val_self : forall v c d, dec (R.value_to_term v) c d <-> decctx v c d.
  Declare Module RS : RED_SEM R with Definition dec := dec.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

End RED_REF_SEM.

Module Type PE_REF_SEM (R : RED_LANG).

  Declare Module Red_Sem : RED_REF_SEM R.

  Axiom dec_context_not_val : forall v v0 ec, ~(Red_Sem.dec_context ec v = R.in_val v0).
  Axiom dec_term_value : forall v, Red_Sem.dec_term (R.value_to_term v) = R.in_val v.

End PE_REF_SEM.

Module Type RED_PROP (R : RED_LANG) (RS : RED_REF_SEM(R)).

  Axiom dec_is_function : forall t d d0, RS.RS.decempty t d -> RS.RS.decempty t d0 -> d = d0.
  Axiom iter_is_function : forall d v v0, RS.RS.iter d v -> RS.RS.iter d v0 -> v = v0.
  Axiom eval_is_function : forall t v v0, RS.RS.eval t v -> RS.RS.eval t v0 -> v = v0.
  Axiom dec_correct : forall t c d, RS.RS.dec t c d -> R.decomp_to_term d = R.plug t c.
  Axiom dec_total : forall t, exists d, RS.RS.decempty t d.
  Axiom unique_decomposition : forall t:R.term, (exists v:R.value, t = R.value_to_term v) \/
      (exists r:R.redex, exists c:R.context, R.plug (R.redex_to_term r) c = t /\
	  forall (r0:R.redex) c0, (R.plug (R.redex_to_term r0) c0 = t -> r=r0 /\ c= c0)).

End RED_PROP.

Module Type PRE_ABSTRACT_MACHINE (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  (** A decomposition function specified in terms of the atomic functions above *)
  Inductive dec : R.term -> R.context -> R.decomp -> Prop :=
  | d_dec  : forall (t : R.term) (c : R.context) (r : R.redex)
                 (DT  : dec_term t = R.in_red r),
                 dec t c (R.d_red r c)
  | d_v    : forall (t : R.term) (c : R.context) (v : R.value) (d : R.decomp)
                 (DT  : dec_term t = R.in_val v)
                 (R_C : decctx v c d),
                 dec t c d
  | d_term : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (d : R.decomp)
                 (DT  : dec_term t = R.in_term t0 ec)
                 (R_T : dec t0 (ec :: c) d),
                 dec t c d
  with decctx : R.value -> R.context -> R.decomp -> Prop :=
  | dc_end  : forall (v : R.value), decctx v R.empty (R.d_val v)
  | dc_dec  : forall (v : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
                (DC  : dec_context ec v = R.in_red r),
                decctx v (ec :: c) (R.d_red r c)
  | dc_val  : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (d : R.decomp)
                (DC  : dec_context ec v = R.in_val v0)
                (R_C : decctx v0 c d),
                decctx v (ec :: c) d
  | dc_term : forall (v : R.value) (ec ec0 : R.elem_context) (c : R.context) (t : R.term) (d : R.decomp)
                (DC  : dec_context ec v = R.in_term t ec0)
                (R_T : dec t (ec0 :: c) d),
                decctx v (ec :: c) d.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Inductive iter : R.decomp -> R.value -> Prop :=
  | i_val : forall (v : R.value), iter (R.d_val v) v
  | i_red : forall (r : R.redex) (t : R.term) (c : R.context) (d : R.decomp) (v : R.value)
              (CONTR  : R.contract r = Some t)
              (DEC    : dec t c d)
              (R_ITER : iter d v),
              iter (R.d_red r c) v.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (d : R.decomp) (v : R.value)
                (DEC  : dec t R.empty d)
                (ITER : iter d v),
                eval t v.

End PRE_ABSTRACT_MACHINE.

Module Type STAGED_ABSTRACT_MACHINE (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive dec : R.term -> R.context -> R.value -> Prop :=
  | d_dec  : forall (t : R.term) (c : R.context) (r : R.redex) (v : R.value)
               (DT   : dec_term t = R.in_red r)
               (R_IT : iter (R.d_red r c) v),
               dec t c v
  | d_v    : forall (t : R.term) (c : R.context) (v v0 : R.value)
               (DT   : dec_term t = R.in_val v)
               (R_C  : decctx v c v0),
               dec t c v0
  | d_many : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v : R.value)
               (DT   : dec_term t = R.in_term t0 ec)
               (R_T  : dec t0 (ec :: c) v),
               dec t c v
  with decctx : R.value -> R.context -> R.value -> Prop :=
  | dc_end  : forall (v v0 : R.value)
               (IT_V : iter (R.d_val v) v0),
               decctx v R.empty v0
  | dc_dec  : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
               (DC   : dec_context ec v = R.in_red r)
               (R_IT : iter (R.d_red r c) v0),
               decctx v (ec :: c) v0
  | dc_val  : forall (v v0 v1 : R.value) (ec : R.elem_context) (c : R.context)
               (DC   : dec_context ec v = R.in_val v0)
               (R_C  : decctx v0 c v1),
               decctx v (ec :: c) v1
  | dc_term : forall (v v0 : R.value) (t : R.term) (ec ec0 : R.elem_context) (c : R.context)
               (DC   : dec_context ec v = R.in_term t ec0)
               (R_T  : dec t (ec0 :: c) v0),
               decctx v (ec :: c) v0
  with iter : R.decomp -> R.value -> Prop :=
  | i_val : forall (v : R.value), iter (R.d_val v) v
  | i_red : forall (r : R.redex) (c : R.context) (t : R.term) (v : R.value)
               (CONTR: R.contract r = Some t)
               (R_T  : dec t c v),
               iter (R.d_red r c) v.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop
  with iter_Ind := Induction for iter Sort Prop.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (v : R.value), dec t R.empty v -> eval t v.

End STAGED_ABSTRACT_MACHINE.

Module Type EVAL_APPLY_MACHINE (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive dec : R.term -> R.context -> R.value -> Prop :=
  | d_d_r  : forall (t t0 : R.term) (c : R.context) (r : R.redex) (v : R.value)
               (DT    : dec_term t = R.in_red r)
               (CONTR : R.contract r = Some t0)
               (R_T   : dec t0 c v),
               dec t c v
  | d_v    : forall (t : R.term) (c : R.context) (v v0 : R.value)
               (DT    : dec_term t = R.in_val v)
               (R_C   : decctx v c v0),
               dec t c v0
  | d_term : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v : R.value)
               (DT    : dec_term t = R.in_term t0 ec)
               (R_T   : dec t0 (ec :: c) v),
               dec t c v
  with decctx : R.value -> R.context -> R.value -> Prop :=
  | dc_end : forall (v : R.value), decctx v R.empty v
  | dc_red : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex) (t : R.term)
               (DC    : dec_context ec v = R.in_red r)
               (CONTR : R.contract r = Some t)
               (R_T   : dec t c v0),
               decctx v (ec :: c) v0
  | dc_rec : forall (v v0 v1 : R.value) (ec : R.elem_context) (c : R.context)
               (DC    : dec_context ec v = R.in_val v0)
               (R_C   : decctx v0 c v1),
               decctx v (ec :: c) v1
  | dc_trm : forall (v v0 : R.value) (ec ec0 : R.elem_context) (c : R.context) (t : R.term)
               (DC    : dec_context ec v = R.in_term t ec0)
               (R_T   : dec t (ec0 :: c) v0),
               decctx v (ec :: c) v0.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (v : R.value), dec t R.empty v -> eval t v.

End EVAL_APPLY_MACHINE.

Module Type PROPER_EA_MACHINE (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive configuration : Set :=
  | c_init  : R.term -> configuration
  | c_eval  : R.term -> R.context -> configuration
  | c_apply : R.context -> R.value -> configuration
  | c_final : R.value -> configuration.

  Reserved Notation " a → b " (at level 40, no associativity).

  Inductive transition : configuration -> configuration -> Prop :=
  | t_init : forall (t : R.term), transition (c_init t) (c_eval t R.empty)
  | t_red  : forall (t t0 : R.term) (c : R.context) (r : R.redex)
               (DT    : dec_term t = R.in_red r)
               (CONTR : R.contract r = Some t0),
               (c_eval t c) → (c_eval t0 c)
  | t_val  : forall (t : R.term) (v : R.value) (c : R.context)
      	       (DT    : dec_term t = R.in_val v),
               (c_eval t c) → (c_apply c v)
  | t_term : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context)
               (DT    : dec_term t = R.in_term t0 ec),
               (c_eval t c) → (c_eval t0 (ec :: c))
  | t_cfin : forall (v : R.value),
               (c_apply R.empty v) → (c_final v)
  | t_cred : forall (v : R.value) (t : R.term) (ec : R.elem_context) (c : R.context) (r : R.redex)
               (DC    : dec_context ec v = R.in_red r)
               (CONTR : R.contract r = Some t),
               (c_apply (ec :: c) v) → (c_eval t c)
  | t_cval : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context)
               (DC    : dec_context ec v = R.in_val v0),
               (c_apply (ec :: c) v) → (c_apply c v0)
  | t_cterm: forall (v : R.value) (t : R.term) (ec ec0 : R.elem_context) (c : R.context)
               (DC    : dec_context ec v = R.in_term t ec0),
               (c_apply (ec :: c) v) → (c_eval t (ec0 :: c))
  where " a → b " := (transition a b).

  Declare Module AM : ABSTRACT_MACHINE
    with Definition term := R.term
    with Definition value := R.value
    with Definition configuration := configuration
    with Definition transition := transition
    with Definition c_init := c_init
    with Definition c_final := c_final.

End PROPER_EA_MACHINE.

Module Type PUSH_ENTER_MACHINE (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.
  Axiom dec_term_value : forall (v : R.value), dec_term (R.value_to_term v) = R.in_val v.
  Axiom dec_context_not_val : forall v v0 ec, ~(dec_context ec v = R.in_val v0).

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive dec : R.term -> R.context -> R.value -> Prop :=
  | dec_r    : forall (t t0 : R.term) (c : R.context) (r : R.redex) (v : R.value)
                 (DT    : dec_term t = R.in_red r)
                 (CONTR : R.contract r = Some t0)
                 (R_T   : dec t0 c v),
                 dec t c v
  | dec_val  : forall (t : R.term) (v : R.value)
                 (DT    : dec_term t = R.in_val v),
                 dec t R.empty v
  | dec_v_t  : forall (t t0 : R.term) (ec ec0 : R.elem_context) (c : R.context) (v v0 : R.value)
                 (DT    : dec_term t = R.in_val v)
                 (DC    : dec_context ec v = R.in_term t0 ec0)
                 (R_T   : dec t0 (ec0 :: c) v0),
                 dec t (ec :: c) v0
  | dec_red  : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v v0 : R.value) (r : R.redex)
                 (DT    : dec_term t = R.in_val v)
                 (DC    : dec_context ec v = R.in_red r)
                 (CONTR : R.contract r = Some t0)
                 (R_T   : dec t0 c v0),
                 dec t (ec :: c) v0
  | dec_rec  : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v : R.value)
                 (DT    : dec_term t = R.in_term t0 ec)
                 (R_T   : dec t0 (ec :: c) v),
                 dec t c v.

  Scheme dec_Ind := Induction for dec Sort Prop.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (v : R.value), dec t R.empty v -> eval t v.

End PUSH_ENTER_MACHINE.

Module Type PROPER_PE_MACHINE (R : RED_LANG).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.
  Axiom dec_term_value : forall (v : R.value), dec_term (R.value_to_term v) = R.in_val v.
  Axiom dec_context_not_val : forall v v0 ec, ~(dec_context ec v = R.in_val v0).

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive configuration : Set :=
  | c_init  : R.term -> configuration
  | c_eval  : R.term -> R.context -> configuration
  | c_final : R.value -> configuration.

  Reserved Notation " a → b " (at level 40, no associativity).

  Inductive transition : configuration -> configuration -> Prop :=
  | t_init : forall (t : R.term),
               c_init t → c_eval t R.empty
  | t_red  : forall (t t0 : R.term) (c : R.context) (r : R.redex)
               (DT    : dec_term t = R.in_red r)
               (CONTR : R.contract r = Some t0),
               c_eval t c → c_eval t0 c
  | t_cval : forall (t : R.term) (v : R.value)
               (DT    : dec_term t = R.in_val v),
               c_eval t R.empty → c_final v
  | t_cred : forall (t t0 : R.term) (v : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
               (DT    : dec_term t = R.in_val v)
               (DC    : dec_context ec v = R.in_red r)
               (CONTR : R.contract r = Some t0),
               c_eval t (ec :: c) → c_eval t0 c
  | t_crec : forall (t t0 : R.term) (v : R.value) (ec ec0 : R.elem_context) (c : R.context)
               (DT    : dec_term t = R.in_val v)
               (DC    : dec_context ec v = R.in_term t0 ec0),
               c_eval t (ec :: c) → c_eval t0 (ec0 :: c)
  | t_rec  : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context)
               (DT    : dec_term t = R.in_term t0 ec),
               c_eval t c → c_eval t0 (ec :: c)
  where " a →  b " := (transition a b).

  Declare Module AM : ABSTRACT_MACHINE
    with Definition term := R.term
    with Definition value := R.value
    with Definition configuration := configuration
    with Definition transition := transition
    with Definition c_init := c_init
    with Definition c_final := c_final.

End PROPER_PE_MACHINE.


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

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

Axiom set : forall (a:Type), Type.
Parameter set_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (set a).
Existing Instance set_WhyType.

Parameter mem: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> Prop.

(* Why3 assumption *)
Definition infix_eqeq {a:Type} {a_WT:WhyType a} (s1:(set a)) (s2:(set
  a)): Prop := forall (x:a), (mem x s1) <-> (mem x s2).

Axiom extensionality : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset {a:Type} {a_WT:WhyType a} (s1:(set a)) (s2:(set
  a)): Prop := forall (x:a), (mem x s1) -> (mem x s2).

Axiom subset_refl : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (subset s s).

Axiom subset_trans : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (s3:(set a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1
  s3)).

Parameter empty: forall {a:Type} {a_WT:WhyType a}, (set a).

(* Why3 assumption *)
Definition is_empty {a:Type} {a_WT:WhyType a} (s:(set a)): Prop :=
  forall (x:a), ~ (mem x s).

Axiom empty_def1 : forall {a:Type} {a_WT:WhyType a}, (is_empty (empty : (set
  a))).

Axiom mem_empty : forall {a:Type} {a_WT:WhyType a}, forall (x:a), ~ (mem x
  (empty : (set a))).

Parameter add: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> (set a).

Axiom add_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a),
  forall (s:(set a)), (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> (set a).

Axiom remove_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a)
  (s:(set a)), (mem x (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom add_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), (mem x s) -> ((add x (remove x s)) = s).

Axiom remove_add : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), ((remove x (add x s)) = (remove x s)).

Axiom subset_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), (subset (remove x s) s).

Parameter union: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).

Axiom union_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).

Axiom inter_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).

Axiom diff_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (subset (diff s1 s2) s1).

Parameter choose: forall {a:Type} {a_WT:WhyType a}, (set a) -> a.

Axiom choose_def : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (~ (is_empty s)) -> (mem (choose s) s).

Parameter cardinal: forall {a:Type} {a_WT:WhyType a}, (set a) -> Z.

Axiom cardinal_nonneg : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (0%Z <= (cardinal s))%Z.

Axiom cardinal_empty : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  ((cardinal s) = 0%Z) <-> (is_empty s).

Axiom cardinal_add : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  forall (s:(set a)), (~ (mem x s)) -> ((cardinal (add x
  s)) = (1%Z + (cardinal s))%Z).

Axiom cardinal_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a),
  forall (s:(set a)), (mem x s) -> ((cardinal s) = (1%Z + (cardinal (remove x
  s)))%Z).

Axiom cardinal_subset : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (subset s1 s2) -> ((cardinal s1) <= (cardinal s2))%Z.

Axiom subset_eq : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (subset s1 s2) -> (((cardinal s1) = (cardinal s2)) ->
  (infix_eqeq s1 s2)).

Axiom cardinal1 : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  ((cardinal s) = 1%Z) -> forall (x:a), (mem x s) -> (x = (choose s)).

Axiom vertex : Type.
Parameter vertex_WhyType : WhyType vertex.
Existing Instance vertex_WhyType.

Parameter vertices: (set vertex).

Parameter edges: (set (vertex* vertex)%type).

(* Why3 assumption *)
Definition edge (x:vertex) (y:vertex): Prop := (mem (x, y) edges).

Axiom edges_def : forall (x:vertex) (y:vertex), (mem (x, y) edges) -> ((mem x
  vertices) /\ (mem y vertices)).

Parameter s: vertex.

Axiom s_in_graph : (mem s vertices).

Axiom vertices_cardinal_pos : (0%Z < (cardinal vertices))%Z.

(* Why3 assumption *)
Inductive path: vertex -> (list vertex) -> vertex -> Prop :=
  | Path_empty : forall (x:vertex), (path x Init.Datatypes.nil x)
  | Path_cons : forall (x:vertex) (y:vertex) (z:vertex) (l:(list vertex)),
      (edge x y) -> ((path y l z) -> (path x (Init.Datatypes.cons x l) z)).

Axiom path_right_extension : forall (x:vertex) (y:vertex) (z:vertex)
  (l:(list vertex)), (path x l y) -> ((edge y z) -> (path x
  (Init.Datatypes.app l (Init.Datatypes.cons y Init.Datatypes.nil)) z)).

Axiom path_right_inversion : forall (x:vertex) (z:vertex) (l:(list vertex)),
  (path x l z) -> (((x = z) /\ (l = Init.Datatypes.nil)) \/ exists y:vertex,
  exists l':(list vertex), (path x l' y) /\ ((edge y z) /\
  (l = (Init.Datatypes.app l' (Init.Datatypes.cons y Init.Datatypes.nil))))).

Axiom path_trans : forall (x:vertex) (y:vertex) (z:vertex) (l1:(list vertex))
  (l2:(list vertex)), (path x l1 y) -> ((path y l2 z) -> (path x
  (Init.Datatypes.app l1 l2) z)).

Axiom empty_path : forall (x:vertex) (y:vertex), (path x Init.Datatypes.nil
  y) -> (x = y).

Axiom path_decomposition : forall (x:vertex) (y:vertex) (z:vertex)
  (l1:(list vertex)) (l2:(list vertex)), (path x
  (Init.Datatypes.app l1 (Init.Datatypes.cons y l2)) z) -> ((path x l1 y) /\
  (path y (Init.Datatypes.cons y l2) z)).

Parameter weight: vertex -> vertex -> Z.

(* Why3 assumption *)
Fixpoint path_weight (l:(list vertex)) (dst:vertex) {struct l}: Z :=
  match l with
  | Init.Datatypes.nil => 0%Z
  | (Init.Datatypes.cons x Init.Datatypes.nil) => (weight x dst)
  | (Init.Datatypes.cons x ((Init.Datatypes.cons y _) as r)) => ((weight x
      y) + (path_weight r dst))%Z
  end.

Axiom path_weight_right_extension : forall (x:vertex) (y:vertex)
  (l:(list vertex)),
  ((path_weight (Init.Datatypes.app l (Init.Datatypes.cons x Init.Datatypes.nil))
  y) = ((path_weight l x) + (weight x y))%Z).

Axiom path_weight_decomposition : forall (y:vertex) (z:vertex)
  (l1:(list vertex)) (l2:(list vertex)),
  ((path_weight (Init.Datatypes.app l1 (Init.Datatypes.cons y l2))
  z) = ((path_weight l1 y) + (path_weight (Init.Datatypes.cons y l2) z))%Z).

Axiom path_in_vertices : forall (v1:vertex) (v2:vertex) (l:(list vertex)),
  (mem v1 vertices) -> ((path v1 l v2) -> (mem v2 vertices)).

(* Why3 assumption *)
Definition pigeon_set (s1:(set vertex)): Prop := forall (l:(list vertex)),
  (forall (e:vertex), (list.Mem.mem e l) -> (mem e s1)) ->
  (((cardinal s1) < (list.Length.length l))%Z -> exists e:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons e (Init.Datatypes.app l2 (Init.Datatypes.cons e l3)))))).

Axiom Induction : (forall (s1:(set vertex)), (is_empty s1) -> (pigeon_set
  s1)) -> ((forall (s1:(set vertex)), (pigeon_set s1) -> forall (t:vertex),
  (~ (mem t s1)) -> (pigeon_set (add t s1))) -> forall (s1:(set vertex)),
  (pigeon_set s1)).

Axiom corner : forall (s1:(set vertex)) (l:(list vertex)),
  ((list.Length.length l) = (cardinal s1)) -> ((forall (e:vertex),
  (list.Mem.mem e l) -> (mem e s1)) -> ((exists e:vertex,
  (exists l1:(list vertex), (exists l2:(list vertex),
  (exists l3:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons e (Init.Datatypes.app l2 (Init.Datatypes.cons e l3))))))))) \/
  forall (e:vertex), (mem e s1) -> (list.Mem.mem e l))).

Axiom pigeon_0 : (pigeon_set (empty : (set vertex))).

Axiom pigeon_1 : forall (s1:(set vertex)), (pigeon_set s1) ->
  forall (t:vertex), (pigeon_set (add t s1)).

Axiom pigeon_2 : forall (s1:(set vertex)), (pigeon_set s1).

Axiom pigeonhole : forall (s1:(set vertex)) (l:(list vertex)),
  (forall (e:vertex), (list.Mem.mem e l) -> (mem e s1)) ->
  (((cardinal s1) < (list.Length.length l))%Z -> exists e:vertex,
  exists l1:(list vertex), exists l2:(list vertex), exists l3:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons e (Init.Datatypes.app l2 (Init.Datatypes.cons e l3)))))).

Axiom long_path_decomposition_pigeon1 : forall (l:(list vertex)) (v:vertex),
  (path s l v) -> ((~ (l = Init.Datatypes.nil)) -> forall (v1:vertex),
  (list.Mem.mem v1 (Init.Datatypes.cons v l)) -> (mem v1 vertices)).

Axiom long_path_decomposition_pigeon2 : forall (l:(list vertex)) (v:vertex),
  (forall (v1:vertex), (list.Mem.mem v1 (Init.Datatypes.cons v l)) -> (mem v1
  vertices)) ->
  (((cardinal vertices) < (list.Length.length (Init.Datatypes.cons v l)))%Z ->
  exists e:vertex, exists l1:(list vertex), exists l2:(list vertex),
  exists l3:(list vertex),
  ((Init.Datatypes.cons v l) = (Init.Datatypes.app l1 (Init.Datatypes.cons e (Init.Datatypes.app l2 (Init.Datatypes.cons e l3)))))).

Axiom long_path_decomposition_pigeon3 : forall (l:(list vertex)) (v:vertex),
  (exists e:vertex, (exists l1:(list vertex), (exists l2:(list vertex),
  (exists l3:(list vertex),
  ((Init.Datatypes.cons v l) = (Init.Datatypes.app l1 (Init.Datatypes.cons e (Init.Datatypes.app l2 (Init.Datatypes.cons e l3))))))))) ->
  ((exists l1:(list vertex), (exists l2:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons v l2))))) \/
  exists n:vertex, exists l1:(list vertex), exists l2:(list vertex),
  exists l3:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons n (Init.Datatypes.app l2 (Init.Datatypes.cons n l3)))))).

Axiom long_path_decomposition : forall (l:(list vertex)) (v:vertex), (path s
  l v) -> (((cardinal vertices) <= (list.Length.length l))%Z ->
  ((exists l1:(list vertex), (exists l2:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons v l2))))) \/
  exists n:vertex, exists l1:(list vertex), exists l2:(list vertex),
  exists l3:(list vertex),
  (l = (Init.Datatypes.app l1 (Init.Datatypes.cons n (Init.Datatypes.app l2 (Init.Datatypes.cons n l3))))))).

Axiom simple_path : forall (v:vertex) (l:(list vertex)), (path s l v) ->
  exists l':(list vertex), (path s l' v) /\
  ((list.Length.length l') < (cardinal vertices))%Z.

(* Why3 assumption *)
Definition negative_cycle (v:vertex): Prop := (mem v vertices) /\
  ((exists l1:(list vertex), (path s l1 v)) /\ exists l2:(list vertex), (path
  v l2 v) /\ ((path_weight l2 v) < 0%Z)%Z).

Axiom key_lemma_1 : forall (v:vertex) (n:Z), (forall (l:(list vertex)), (path
  s l v) -> (((list.Length.length l) < (cardinal vertices))%Z ->
  (n <= (path_weight l v))%Z)) -> ((exists l:(list vertex), (path s l v) /\
  ((path_weight l v) < n)%Z) -> exists u:vertex, (negative_cycle u)).

(* Why3 assumption *)
Inductive t :=
  | Finite : Z -> t
  | Infinite : t.
Axiom t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 assumption *)
Definition add1 (x:t) (y:t): t :=
  match x with
  | Infinite => Infinite
  | (Finite x1) =>
      match y with
      | Infinite => Infinite
      | (Finite y1) => (Finite (x1 + y1)%Z)
      end
  end.

(* Why3 assumption *)
Definition lt (x:t) (y:t): Prop :=
  match x with
  | Infinite => False
  | (Finite x1) =>
      match y with
      | Infinite => True
      | (Finite y1) => (x1 < y1)%Z
      end
  end.

(* Why3 assumption *)
Definition le (x:t) (y:t): Prop := (lt x y) \/ (x = y).

Axiom Refl : forall (x:t), (le x x).

Axiom Trans : forall (x:t) (y:t) (z:t), (le x y) -> ((le y z) -> (le x z)).

Axiom Antisymm : forall (x:t) (y:t), (le x y) -> ((le y x) -> (x = y)).

Axiom Total : forall (x:t) (y:t), (le x y) \/ (le y x).

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Definition t1 (a:Type) := (ref (set a)).

(* Why3 assumption *)
Definition distmap := (map.Map.map vertex t).

(* Why3 assumption *)
Definition inv1 (m:(map.Map.map vertex t)) (pass:Z) (via:(set (vertex*
  vertex)%type)): Prop := forall (v:vertex), (mem v vertices) ->
  match (map.Map.get m
  v) with
  | (Finite n) => (exists l:(list vertex), (path s l v) /\ ((path_weight l
      v) = n)) /\ ((forall (l:(list vertex)), (path s l v) ->
      (((list.Length.length l) < pass)%Z -> (n <= (path_weight l v))%Z)) /\
      forall (u:vertex) (l:(list vertex)), (path s l u) ->
      (((list.Length.length l) < pass)%Z -> ((mem (u, v) via) ->
      (n <= ((path_weight l u) + (weight u v))%Z)%Z)))
  | Infinite => (forall (l:(list vertex)), (path s l v) ->
      (pass <= (list.Length.length l))%Z) /\ forall (u:vertex), (mem (u, v)
      via) -> forall (lu:(list vertex)), (path s lu u) ->
      (pass <= (list.Length.length lu))%Z
  end.

(* Why3 assumption *)
Definition inv2 (m:(map.Map.map vertex t)) (via:(set (vertex*
  vertex)%type)): Prop := forall (u:vertex) (v:vertex), (mem (u, v) via) ->
  (le (map.Map.get m v) (add1 (map.Map.get m u) (Finite (weight u v)))).

Axiom key_lemma_2 : forall (m:(map.Map.map vertex t)), (inv1 m
  (cardinal vertices) (empty : (set (vertex* vertex)%type))) -> ((inv2 m
  edges) -> forall (v:vertex), ~ (negative_cycle v)).

Require Import Why3.
Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem WP_parameter_bellman_ford : (((cardinal vertices) - 1%Z)%Z < 1%Z)%Z ->
  ((inv1 (map.Map.set (map.Const.const Infinite: (map.Map.map vertex t)) s
  (Finite 0%Z)) (cardinal vertices) (empty : (set (vertex* vertex)%type))) ->
  forall (es:(set (vertex* vertex)%type)), (es = edges) -> forall (es1:(set
  (vertex* vertex)%type)), ((subset es1 edges) /\ (inv2
  (map.Map.set (map.Const.const Infinite: (map.Map.map vertex t)) s
  (Finite 0%Z)) (diff edges es1))) -> forall (o:bool), ((o = true) <->
  (is_empty es1)) -> ((~ (o = true)) -> ((~ (is_empty es1)) ->
  forall (es2:(set (vertex* vertex)%type)), forall (result:vertex)
  (result1:vertex), let result2 := (result, result1) in (((mem result2
  es1) /\ (es2 = (remove result2 es1))) ->
  (match (map.Map.get (map.Map.set (map.Const.const Infinite: (map.Map.map
  vertex t)) s (Finite 0%Z))
  result) with
  | Infinite => False
  | (Finite x) =>
      match (map.Map.get (map.Map.set (map.Const.const Infinite: (map.Map.map
      vertex t)) s (Finite 0%Z))
      result1) with
      | Infinite => True
      | (Finite y) => ((x + (weight result result1))%Z < y)%Z
      end
  end -> exists v:vertex, (negative_cycle v)))))).
(* Why3 intros h1 h2 es h3 es1 (h4,h5) o h6 h7 h8 es2 result result1 result2
        (h9,h10) h11. *)
intros Hvertices _.
assert (Hs: (cardinal vertices = 1)%Z) by ae. clear Hvertices.
generalize (cardinal1 vertices Hs). clear Hs. intros H1.
assert (Hs: s = choose vertices) by ae.
intros result hresult. subst result.
intros es (Hes,_) _ _ _ _ es1.
intros u v res4. unfold res4.
intros (Huv, _).
assert (u = s) by ae. subst u.
assert (v = s) by ae. subst v.
rewrite Map.Select_eq; auto.
intros hneg.
exists s. red.
split. ae.
split. exists nil; ae.
exists (cons s nil); ae.
Qed.


From AsyncTest Require Export
     Classes
     Instances.
Open Scope string_scope.

Definition or_jexp' (e f : jexp) : string + jexp :=
  match normalise e, normalise f with
  | Jexp__Object el, Jexp__Object fl => inr $ Jexp__Object $ (el ++ fl)%list
  | Jexp__Object _, x
  | x, Jexp__Object _ => inl $ "Not an Object: " ++ to_string x
  | _, _ => inl $ "Neither is an Object: " ++ to_string e
               ++ "or: " ++ to_string f
  end.

Definition or_jexp (e f : jexp) : jexp :=
  if or_jexp' e f is inr x then x else e.

Declare Scope jexp_scope.

Module XNotations.
Infix "+" := or_jexp : jexp_scope.
End XNotations.


Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorShard.Tactics.

Lemma skipn_length_gt : forall T (ls : list T) n,
  length ls <= n ->
  skipn n ls = nil.
Proof.
  induction ls; destruct n; simpl; intuition; auto. exfalso; omega.
Qed.

Lemma skipn_length_all : forall T U (F : T -> U) ls ls',
  map F ls = ls' ->
  skipn (length ls) ls' = nil.
Proof.
  intros. eapply skipn_length_gt. rewrite <- H. rewrite map_length. omega.
Qed.

Lemma rw_skipn_app : forall T (ls ls' : list T) n,
  length ls = n ->
  skipn n (ls ++ ls') = ls'.
Proof.
  clear. induction ls; destruct n; simpl in *; intros; auto; congruence.
Qed.
Lemma length_equal_map_rev : forall T U (F : T -> U) ls ls',
  map F ls' = rev ls ->
  length ls = length ls'.
Proof.
  clear. intros. rewrite <- rev_length. rewrite <- H. rewrite map_length. auto.
Qed.
Hint Resolve length_equal_map_rev : list_length.
Lemma eq_proves_gt : forall a b,
  a = b -> a <= b.
Proof.
  clear. intros; omega.
Qed.
Lemma map_length_hint : forall T U (F : T -> U) a b,
  map F a = b -> length b = length a.
Proof.
  clear. intros. subst. rewrite map_length. auto.
Qed.
Hint Resolve eq_proves_gt map_length_hint skipn_length_gt : list_length.

Hint Resolve skipn_length_all : list_length.
Hint Rewrite skipn_length_all using (eauto with list_length) : list_length.

Lemma nth_error_None_length : forall (T : Type) (ls : list T) (n : nat),
  nth_error ls n = None -> length ls <= n.
Proof.
  induction ls; destruct n; simpl; intros; think; try omega. inversion H.
  eapply IHls in H. omega.
Qed.

Lemma map_nth_error_full : forall T U (F : T -> U) ls n,
  nth_error (map F ls) n = match nth_error ls n with
                             | None => None
                             | Some v => Some (F v)
                           end.
Proof.
  induction ls; destruct n; simpl; intros; think; auto.
Qed.

Lemma app_len_2 : forall T (a b c d : list T),
  a ++ b = c ++ d ->
  length b = length d ->
  a = c /\ b = d.
Proof.
  clear. induction a; destruct c; simpl; intuition; subst; auto;
  simpl in *; try rewrite app_length in H0;
    try solve [ try generalize dependent (length d); intros; exfalso; omega ].
  inversion H. subst. f_equal. eapply IHa in H3; eauto. intuition.
  inversion H. eapply IHa in H3; intuition.
Qed.

Lemma not_sure : forall T U (F : T -> U) vars X,
  map F vars = X ->
  map F nil = skipn (length vars) X.
Proof.
  induction vars; intros; simpl in *; intros; auto. destruct X; auto.  eapply IHvars.
  inversion H. auto.
Qed.
Lemma map_skipn_all_map : forall T U (F : T -> U) ls,
  map F nil = skipn (length ls) (map F ls).
Proof.
  clear. induction ls; auto.
Qed.
Lemma map_skipn_all_map_is_nil : forall T U (F : T -> U) ls ls',
  map F ls' = skipn (length ls) (map F ls) ->
  ls' = nil.
Proof.
  clear; intros. rewrite <- map_skipn_all_map in H. destruct ls'; simpl in *; congruence.
Qed.

Lemma firstn_app_exact : forall T n (a b : list T),
  length a = n ->
  firstn n (a ++ b) = a.
Proof.
  clear. intros; subst. induction a; simpl; eauto.
  f_equal. auto.
Qed.

Lemma app_inj_length : forall T (a b c d : list T),
  a ++ b = c ++ d ->
  length a = length c ->
  a = c /\ b = d.
Proof.
  induction a; destruct c; simpl; intros; think; try solve [ congruence | intuition ].
  inversion H; subst.  eapply IHa in H3. intuition; subst; auto. omega.
Qed.

Lemma skipn_length : forall T a (b : list T),
  length (skipn a b) = length b - a.
Proof. induction a; destruct b; simpl; intros; auto. Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Cat.Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat
        NatTrans.NatIso.

(** Facts about products of acategories involving natural transformations. *)

Local Obligation Tactic := idtac.

Section Prod_Functor_NatTrans.
  Context {C D : Category}
          {F G : (C –≻ D)%functor}
          (N : (F –≻ G)%nattrans)
          {C' D' : Category}
          {F' G' : (C' –≻ D')%functor}
          (N' : (F' –≻ G')%nattrans).

  Program Definition Prod_Functor_NatTrans :
    ((Prod_Functor F F') –≻ (Prod_Functor G G'))%nattrans :=
    {|
      Trans := fun c => (Trans N (fst c), Trans N' (snd c))
    |}.

  Next Obligation.
    basic_simpl.
    do 2 rewrite Trans_com; trivial.
  Qed.

  Next Obligation.
    symmetry.
    apply Prod_Functor_NatTrans_obligation_1.
  Qed.

End Prod_Functor_NatTrans.

Section Prod_Functor_NatTrans_id.
  Context {C D : Category} (F : (C –≻ D)%functor)
          {C' D' : Category} {F' : (C' –≻ D')%functor}.

  Theorem Prod_Functor_NatTrans_id :
    Prod_Functor_NatTrans (NatTrans_id F) (NatTrans_id F') =
    NatTrans_id (Prod_Functor F F').
  Proof.
    apply NatTrans_eq_simplify; trivial.
  Qed.

End Prod_Functor_NatTrans_id.

Section Prod_Functor_NatTrans_compose.
  Context {C D : Category}
          {F G H : (C –≻ D)%functor}
          (N1 : (F –≻ G)%nattrans)
          (N2 : (G –≻ H)%nattrans)
          {C' D' : Category}
          {F' G' H' : (C' –≻ D')%functor}
          (N1' : (F' –≻ G')%nattrans)
          (N2' : (G' –≻ H')%nattrans).

  Theorem Prod_Functor_NatTrans_compose :
    ((Prod_Functor_NatTrans N2 N2') ∘ (Prod_Functor_NatTrans N1 N1') =
     Prod_Functor_NatTrans (N2 ∘ N1) (N2' ∘ N1'))%nattrans.
  Proof.
    apply NatTrans_eq_simplify; trivial.
  Qed.

End Prod_Functor_NatTrans_compose.

Section Prod_Functor_NatIso.
  Context {C D : Category}
          {F G : (C –≻ D)%functor}
          (N : (F ≃ G)%natiso)
          {C' D' : Category}
          {F' G' : (C' –≻ D')%functor}
          (N' : (F' ≃ G')%natiso)
  .

  Program Definition Prod_Functor_NatIso :
    ((Prod_Functor F F') ≃ (Prod_Functor G G'))%natiso :=
    {|
      iso_morphism := Prod_Functor_NatTrans (iso_morphism N) (iso_morphism N');
      inverse_morphism :=
        Prod_Functor_NatTrans (inverse_morphism N) (inverse_morphism N')
    |}.

  Next Obligation.
    cbn.
    rewrite Prod_Functor_NatTrans_compose.
    change ((N ⁻¹)%morphism ∘ (iso_morphism N))%nattrans with (N⁻¹ ∘ N)%morphism.
    change ((N' ⁻¹)%morphism ∘ (iso_morphism N'))%nattrans with (N'⁻¹ ∘ N')%morphism.
    do 2 rewrite (left_inverse).
    apply Prod_Functor_NatTrans_id.
  Qed.

  Next Obligation.
    cbn.
    rewrite Prod_Functor_NatTrans_compose.
    change ((iso_morphism N) ∘ (N ⁻¹)%morphism)%nattrans with (N ∘ N⁻¹)%morphism.
    change ((iso_morphism N') ∘ (N' ⁻¹)%morphism)%nattrans with (N' ∘ N'⁻¹)%morphism.
    do 2 rewrite (right_inverse).
    apply Prod_Functor_NatTrans_id.
  Qed.

End Prod_Functor_NatIso.

Section Fix_Bi_Func_1_NatTrans.
  Context {B C D E : Category}
          {F F' : (((Func_Cat C D) × B) –≻ E)%functor}
          (N : (F –≻ F')%nattrans)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_1_NatTrans :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F) –≻ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F'))%nattrans
    :=
    {|
      Trans := fun c => Trans N (G, c)
    |}.

  Next Obligation.
  Proof.
    intros c c' h.
    apply (@Trans_com _ _ _ _ N (G, c) (G, c') (NatTrans_id _, h)).
  Qed.

  Next Obligation.
  Proof.
    intros c c' h.
    apply (@Trans_com_sym _ _ _ _ N (G, c) (G, c') (NatTrans_id _, h)).
  Qed.

End Fix_Bi_Func_1_NatTrans.

Section Fix_Bi_Func_1_NatIso.
  Context {B C D E : Category}
          {F F' : (((Func_Cat C D) × B) –≻ E)%functor}
          (N : (F ≃ F')%natiso)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_1_NatIso :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)
       ≃ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F'))%natiso
    :=
    {|
      iso_morphism := Fix_Bi_Func_1_NatTrans (iso_morphism N) G;
      inverse_morphism := Fix_Bi_Func_1_NatTrans (inverse_morphism N) G
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (inverse_morphism N) (G, c) ∘ Trans (iso_morphism N) (G, c))%morphism with (Trans ((inverse_morphism N) ∘ (iso_morphism N)) (G, c)).
    cbn_rewrite (left_inverse N); trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    change (Trans (iso_morphism N) (G, c) ∘ Trans (inverse_morphism N) (G, c))%morphism with (Trans ((iso_morphism N) ∘ (inverse_morphism N)) (G, c)).
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Fix_Bi_Func_1_NatIso.

Section Fix_Bi_Func_2_NatTrans.
  Context {B C D E : Category}
          {F F' : ((B × (Func_Cat C D)) –≻ E)%functor}
          (N : (F –≻ F')%nattrans)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_2_NatTrans :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F) –≻ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F'))%nattrans
    :=
    {|
      Trans := fun c => Trans N (c, G)
    |}.

  Next Obligation.
  Proof.
    intros; apply (@Trans_com _ _ _ _ N).
  Qed.

  Next Obligation.
  Proof.
    intros; apply (@Trans_com_sym _ _ _ _ N).
  Qed.

End Fix_Bi_Func_2_NatTrans.

Section Fix_Bi_Func_2_NatIso.
  Context {B C D E : Category}
          {F F' : ((B × (Func_Cat C D)) –≻ E)%functor}
          (N : (F ≃ F')%natiso)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_2_NatIso :
    (
      (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)
        ≃ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F'))%natiso
    :=
      {|
        iso_morphism := Fix_Bi_Func_2_NatTrans (iso_morphism N) G;
        inverse_morphism := Fix_Bi_Func_2_NatTrans (inverse_morphism N) G
      |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (inverse_morphism N) (c, G) ∘
                  Trans (iso_morphism N) (c, G))%morphism
    with (Trans ((inverse_morphism N) ∘ (iso_morphism N)) (c, G)).
    cbn_rewrite (left_inverse N); trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (iso_morphism N) (c, G) ∘
                  Trans (inverse_morphism N) (c, G))%morphism
    with (Trans ((iso_morphism N) ∘ (inverse_morphism N)) (c, G)).
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Fix_Bi_Func_2_NatIso.

Section Fix_Bi_Func_1_Functor_id_swap_NatIso.
  Context {B B' C D E E' : Category}
          (F : (B –≻ B')%functor)
          (F' : (((Func_Cat C D) × B') –≻ E)%functor)
          (G : (C –≻ D)%functor)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_Func_1_Functor_id_swap_NatIso :
    (
      (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G
                      ( F' ∘ (Prod_Functor (Functor_id _) F)))%functor
        ≃ ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F') ∘ F)%functor)%natiso :=
    {|
      iso_morphism :=
        {|
          Trans := fun c => id
        |};
      inverse_morphism :=
        {|
          Trans := fun c => id
        |}
    |}.

End Fix_Bi_Func_1_Functor_id_swap_NatIso.

Section Fix_Bi_Func_2_Functor_id_swap_NatIso.
  Context {B B' C D E E' : Category}
          (F : (B –≻ B')%functor)
          (F' : ((B' × (Func_Cat C D)) –≻ E)%functor)
          (G : (C –≻ D)%functor)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_Func_2_Functor_id_swap_NatIso :
    (
      ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G
                       (F' ∘ (Prod_Functor F (Functor_id _))))%functor)
        ≃((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F') ∘ F)%functor)%natiso :=
    {|
      iso_morphism :=
        {|
          Trans := fun c => id
        |};
      inverse_morphism :=
        {|
          Trans := fun c => id
        |}
    |}.

End Fix_Bi_Func_2_Functor_id_swap_NatIso.

Section Fix_Bi_1_Func_Prod_Func_NatIso.
  Context {A B C D E : Category}
          (F : (A –≻ C)%functor)
          (F' : (B –≻ D)%functor)
          (G : ((C × D) –≻ E)%functor)
          (x : A)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_1_Func_Prod_Func_NatIso :
    (
      ((Fix_Bi_Func_1 x (G ∘ (Prod_Functor F F')))%functor)
        ≃ ((Fix_Bi_Func_1 (F _o x)
                          (G ∘ (Prod_Functor (Functor_id C) F')))
          )%functor
    )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Fix_Bi_1_Func_Prod_Func_NatIso.

Section Fix_Bi_2_Func_Prod_Func_NatIso.
  Context {A B C D E : Category}
          (F : (A –≻ C)%functor)
          (F' : (B –≻ D)%functor)
          (G : ((C × D) –≻ E)%functor)
          (x : B)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_2_Func_Prod_Func_NatIso :
    (
      ((Fix_Bi_Func_2 x (G ∘ (Prod_Functor F F')))%functor)
        ≃ (Fix_Bi_Func_2 (F' _o x)
                         (G ∘  (Prod_Functor F (Functor_id D)))
          )%functor
    )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Fix_Bi_2_Func_Prod_Func_NatIso.

Section Func_Prod_of_ids_NatIso.
  Context {C D E : Category} (F : ((C × D) –≻ E)%functor).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Func_Prod_of_ids_NatIso :
    ((F ∘ (Prod_Functor (Functor_id C) (Functor_id D)))%functor ≃ F )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Func_Prod_of_ids_NatIso.

Section Fix_Bi_Func_1_object_NatTrans.
  Context {B C D E : Category}
          (F : (((Func_Cat C D) × B) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G –≻ G')%nattrans)
  .

  Program Definition Fix_Bi_Func_1_object_NatTrans :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)
       –≻ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G' F))%nattrans
     :=
    {|
      Trans := fun c => (F @_a (G, c) (G', c) (N, id))%morphism
    |}.

  Next Obligation.
  Proof.
    intros c c' h.
    cbn.
    repeat rewrite <- F_compose.
    cbn.
    rewrite NatTrans_id_unit_left, NatTrans_id_unit_right.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Fix_Bi_Func_1_object_NatTrans_obligation_1.
  Qed.

End Fix_Bi_Func_1_object_NatTrans.

Section Fix_Bi_Func_1_object_NatIso.
  Context {B C D E : Category}
          (F : (((Func_Cat C D) × B) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G ≃ G')%natiso)
  .

  Program Definition Fix_Bi_Func_1_object_NatIso :
    (
      ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)%functor)
        ≃ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G' F)%functor)%natiso :=
    {|
      iso_morphism := Fix_Bi_Func_1_object_NatTrans F (iso_morphism N);
      inverse_morphism := Fix_Bi_Func_1_object_NatTrans F (inverse_morphism N)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    cbn_rewrite (left_inverse N).
    simpl_ids.
    change (NatTrans_id G, id) with (id ((Func_Cat _ _) × B) (G, c)).
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    cbn_rewrite (right_inverse N).
    simpl_ids.
    change (NatTrans_id G', id) with (id ((Func_Cat _ _) × B) (G', c)).
    auto.
  Qed.

End Fix_Bi_Func_1_object_NatIso.

Section Fix_Bi_Func_2_object_NatTrans.
  Context {B C D E : Category} (F : ((B × (Func_Cat C D)) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G –≻ G')%nattrans)
  .

  Program Definition Fix_Bi_Func_2_object_NatTrans :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)
       –≻ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G' F))%nattrans
    :=
    {|
      Trans := fun c => (F @_a (c, G) (c, G') (id, N))%morphism
    |}.

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    repeat rewrite <- F_compose; cbn.
    rewrite NatTrans_id_unit_left, NatTrans_id_unit_right.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Fix_Bi_Func_2_object_NatTrans_obligation_1.
  Qed.

End Fix_Bi_Func_2_object_NatTrans.

Section Fix_Bi_Func_2_object_NatIso.
  Context {B C D E : Category}
          (F : ((B × (Func_Cat C D)) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G ≃ G')%natiso).

  Program Definition Fix_Bi_Func_2_object_NatIso :
    (((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)%functor)
       ≃ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G' F)%functor)%natiso :=
    {|
      iso_morphism := Fix_Bi_Func_2_object_NatTrans F (iso_morphism N);
      inverse_morphism := Fix_Bi_Func_2_object_NatTrans F (inverse_morphism N)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    simpl_ids.
    cbn_rewrite (left_inverse N).
    change (id, NatTrans_id G) with (id (B × (Func_Cat _ _)) (c, G)).
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    simpl_ids.
    cbn_rewrite (right_inverse N).
    change (id, NatTrans_id G') with (id (B × (Func_Cat _ _)) (c, G')).
    auto.
  Qed.

End Fix_Bi_Func_2_object_NatIso.


Require Import MetaCoq.Template.All.

Print tmQuote.
Print typing.
About typing_spine.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICSize
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

(* Require Import MetaCoq.Template.All. *)
Require Import List String.
Import ListNotations MonadNotation Nat.
Require Import MetaCoq.Template.Pretty.
Require Import MetaCoq.PCUIC.PCUICPretty.

Check size.

Require Import Lia.

Goal forall (P:nat->Prop),
  (forall n, (forall m, m<n -> P m) -> P n) ->
  forall n, P n.
Proof.
  intros P H n.
  apply H.

  induction n.
  - intros.
    lia.
  - intros.
    apply H.
    intros.
    apply IHn.
    lia.
Qed.

Lemma size_induction X (f:X->nat) (P:X->Type):
  (forall x, (forall y, f y<f x -> P y) -> P x) ->
  forall x, P x.
Proof.
  intros. apply X0.
  assert(forall n y, f y < n -> P y).
  {
    induction n.
    - lia.
    - intros.
      apply X0.
      intros.
      apply IHn.
      lia.
  }
  apply X1.
Defined.

Goal forall (P:term->Type),
  (forall t, (forall t2, size t2 < size t -> P t2) -> P t) ->
  forall t, P t.
Proof.
  apply size_induction.
Defined.

Print well_founded_induction.

(* Require Import Coq.Arith.Wf_nat. *)
Require Import Coq.Wellfounded.Wellfounded.

(* Print ltof. *)
(* Check (induction_ltof1 _ (@List.length term)). *)

(* Check (well_founded_induction *)
(*                      (wf_inverse_image _ nat _ (@List.length _) *)
(*                         PeanoNat.Nat.lt_wf_0)). *)

Definition term_size_ind := well_founded_induction
                     (wf_inverse_image _ nat _ (size)
                        PeanoNat.Nat.lt_wf_0).
Check term_size_ind.

Goal forall (P:term->Type),
  (forall t, (forall t2, size t2 < size t -> P t2) -> P t) ->
  forall t, P t.
Proof.
  apply size_induction.

  intros.
  apply X.

  induction t using term_forall_list_ind;simpl;intros.
  - assert(size t2=0) by lia.
    destruct t2;cbn in H0;congruence.
  - assert(size t2=0) by lia.
    destruct t2;cbn in H0;congruence.
  - admit.
  -


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Just the nearly working proof using Extends1D.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export FormalSyntax.
Require Export VarLemmas.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export ContextExtensionRelation.
Require Export StaticSemanticsKindingLemmas.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Require Export AlphaConversion.
Require Export GetLemmasRelation.

Inductive Extends1D : TVar -> Kappa -> Delta -> Delta -> Prop :=
   Extends1D_alpha_kappa :
      forall (alpha : TVar) (k : Kappa) (d : Delta) (d' : Delta),
        d' = ([(alpha,k)] ++ d) ->
        WFD d' ->
        getD d alpha = None ->
        Extends1D alpha k d d'.

Tactic Notation "Extends1D_ind_cases" tactic(first) ident(c) :=
 first;
[
Case_aux c "Extends1D_alpha_kappa"
].

Lemma getD_Extends1D_agreement_1:
  forall (d d0 : Delta) (alpha alpha0 : TVar) (k : Kappa) (O : option Kappa),
    Extends1D alpha0 k d0 d ->
    getD d alpha = O ->
    beq_tvar alpha0 alpha = false ->
    getD d0 alpha = O.
Proof.
  (* induction d/d0 looks unusable. *)
  intros d d0 alpha alpha0 k O ext.
  induction ext.
  intros.
  rewrite H in *.
  simpl in H2.
  rewrite beq_tvar_symmetric in H3.
  rewrite H3 in H2.
  assumption.
Qed.

Lemma getD_Extends1D_inversion:
  forall (d : Delta) (alpha : TVar) (d0 : Delta) (k k' : Kappa),
    Extends1D alpha k d0 d ->
    getD d alpha = Some k' ->
    k = k'.
Proof.
  intros d alpha d0 k k' ext.
  induction ext.
  intros.
  rewrite H in H2.
  simpl in H2.
  rewrite beq_tvar_reflexive in H2.
  inversion H2.
  reflexivity.
Qed.

Lemma WFD_weakening:
  forall (d0 : Delta) (alpha : TVar) (k : Kappa),
    WFD d0 ->
    getD d0 alpha = None ->
    WFD ([(alpha,k)] ++ d0).
Proof.
  intros d0 alpha k WFDder.
  WFD_ind_cases (induction WFDder) Case.
 Case "WFD []".
  intros.
  constructor; try assumption.
  constructor.
 Case "WFD ([(alpha, k)] ++ d)".
  intros.
  constructor; try assumption.
  constructor; try assumption.
Qed.

Lemma Extends1D_agreement:
  forall (d : Delta),
    WFD d ->
    forall (d0 : Delta),
      WFD d0 ->
      forall (beta : TVar) (k0 : Kappa),
        Extends1D beta k0 d0 d ->
        getD d beta = None ->
        forall (alpha : TVar),
          beq_tvar beta alpha = false ->
          forall (k : Kappa),
            getD d0 alpha = None ->
            getD d alpha = None ->
            Extends1D beta k0 ([(alpha, k)] ++ d0) ([(alpha, k)] ++ d).
Proof.
  intros d WFDd d0 WFDd0 alpha0 k0 ext.
  induction ext.
  intros.
  constructor.
  rewrite H.
  (* Okay, I'm stuck here because I'm not using a full definition of
     partial maps. *)
  admit.
  constructor; try assumption.
  (* Are these two goals correct? *)
  rewrite <- cons_is_append_singleton.
  unfold getD.
  fold getD.
  rewrite H3; try assumption.
Qed.

Lemma K_weakening1 :
  forall d0,
    WFD d0 ->
    forall t k',
      K d0 t k' ->
      forall alpha k,
        WFD ([(alpha, k)] ++ d0) ->
        K ([(alpha, k)] ++ d0) t k'.
Proof.
  intros.
  assert (Z: ExtendedByD d0 d0).
  apply ExtendedByD_reflexive.
  apply ExtendedByD_weakening with (alpha:= alpha) (k:= k) in Z.
  apply K_weakening with (d:= d0) (d':= ([(alpha, k)] ++ d0)) (tau:= t) (k:= k') in H; try assumption.
  assumption.
Qed.

(* IH cases working, variables and bindings unknown. *)
(* Lemmas and the variable cases hold.*)
(* Binding still uncertain. *)
Lemma A_6_Substitution_1_Extends1D:
  forall (d' : Delta) (t' : Tau) (k' : Kappa),
    WFD d' ->
    K d' t' k' ->
    forall (d : Delta) (t : Tau) (k : Kappa),
      WFD d ->
      AK d t k ->
      forall (alpha : TVar),
        getD d alpha = None ->
        getD d' alpha = None ->
        Extends1D alpha k d d' ->
        K d (subst_Tau t' t alpha) k'.
Proof.
  intros d' t' k' WFDd' Kder.
  K_ind_cases(induction Kder) Case.
 Case "K d cint B".
  intros.
  simpl.
  constructor.
 Case "K d (tv_t alpha) B".
  intros.
  simpl.
  case_eq (beq_tvar alpha0 alpha).
  SCase "(beq_tvar alpha0 alpha) = true".
   intros. (* The proof of the pudding is here. *)
   apply beq_tvar_eq in H5.
   rewrite H5 in *.
   clear H5.
   apply getD_Extends1D_inversion with (k':= B) in H4; try assumption.
   rewrite H4 in H1.
   inversion H1; try assumption.
  SCase "(beq_tvar alpha0 alpha) = false".
   intros.
   apply getD_Extends1D_agreement_1 with (alpha:= alpha) (O:= Some B) in H4; try assumption.
   apply K_B; try assumption.
 Case "K d (ptype (tv_t alpha)) B".
  intros.
  simpl.
  case_eq (beq_tvar alpha0 alpha).
  SCase "(beq_tvar alpha0 alpha) = true".
   intros.
   apply beq_tvar_eq in H5.
   rewrite H5 in *.
   clear H5.
   apply getD_Extends1D_inversion with (k':= A) in H4; try assumption.
   rewrite H4 in *.
   inversion H1; try assumption.
   apply K_ptype; try assumption.
   apply K_star_A; try assumption.
  SCase "(beq_tvar alpha0 alpha) = false".
   intros.
   apply K_star_A; try assumption.
   apply getD_Extends1D_agreement_1 with (alpha:= alpha) (O:= Some A) in H4; try assumption.
 Case "K d tau A".
  intros.
  apply IHKder with (alpha:= alpha) (t:= t) (k:= k) (d0:=d0) in WFDd'; try assumption.
  constructor; try assumption.
 Case "K d (cross t0 t1) A".
  intros.
  simpl.
  pose proof WFDd' as WFDd''.
  apply IHKder1 with (alpha:= alpha) (t:= t) (k:= k) (d0:=d0) in WFDd'; try assumption.
  apply IHKder2 with (alpha:= alpha) (t:= t) (k:= k) (d0:=d0) in WFDd''; try assumption.
  apply K_cross; try assumption.
 Case "K d (arrow t0 t1) A".
  intros.
  simpl.
  pose proof WFDd' as WFDd''.
  apply IHKder1 with (alpha:= alpha) (t:= t) (k:= k) (d0:=d0) in WFDd'; try assumption.
  apply IHKder2 with (alpha:= alpha) (t:= t) (k:= k) (d0:=d0) in WFDd''; try assumption.
  apply K_arrow; try assumption.
 Case "K d (ptype tau) B".
  intros.
  apply IHKder with (alpha:= alpha) (t:= t) (k:= k) (d0:=d0) in WFDd'; try assumption.
  simpl.
  apply K_ptype; try assumption.
 Case "K d (utype alpha k tau) A".
  intros.
  simpl.
  case_eq (beq_tvar alpha0 alpha).
  SCase "(beq_tvar alpha0 alpha) = true".
   intros. (* Can I do this without alpha conversion. *)
   AdmitAlphaConversion.
   (* Broken by lemma changes. *)
  SCase "(beq_tvar alpha0 alpha) = false".
   intros.
   pose proof H5 as H5'.
   apply getD_Extends1D_agreement_1 with (alpha:= alpha) (O:= None)
     in H5; try assumption.
   pose proof H1 as H1'.
   apply WFD_weakening with (alpha:= alpha) (k:= k) in H1; try assumption.
   apply K_utype; try assumption.
   apply IHKder with (alpha0:= alpha0) (t:= t) (k0:= k0)
     (d0:= [(alpha,k)] ++ d0)  in H; try assumption.
   apply AK_weakening with (d:= d0) (tau:= t) (k:= k0) in H1; try assumption.
   assert (Z: ExtendedByD d0 d0).
   apply ExtendedByD_reflexive.
   apply ExtendedByD_weakening with (alpha:= alpha) (k:= k) in Z; try assumption.
   rewrite <- cons_is_append_singleton.
   unfold getD.
   fold getD.
   rewrite H6; try assumption.
   rewrite <- cons_is_append_singleton.
   unfold getD.
   fold getD.
   rewrite H6; try assumption.
   apply Extends1D_agreement; try assumption.
 Case "K d (etype p alpha k tau) A)".
  intros.
  simpl.
  case_eq (beq_tvar alpha0 alpha).
  SCase "(beq_tvar alpha0 alpha) = true".
   intros. (* Can I do this without alpha conversion. *)
   AdmitAlphaConversion.
   (* Broken by lemma changes. *)
  SCase "(beq_tvar alpha0 alpha) = false".
   intros.
   pose proof H5 as H5'.
   apply getD_Extends1D_agreement_1 with (alpha:= alpha) (O:= None)
     in H5; try assumption.
   pose proof H1 as H1'.
   apply WFD_weakening with (alpha:= alpha) (k:= k) in H1; try assumption.
   apply K_etype; try assumption.
   apply IHKder with (alpha0:= alpha0) (t:= t) (k0:= k0)
     (d0:= [(alpha,k)] ++ d0)  in H; try assumption.
   apply AK_weakening with (d:= d0) (tau:= t) (k:= k0) in H1; try assumption.
   assert (Z: ExtendedByD d0 d0).
   apply ExtendedByD_reflexive.
   apply ExtendedByD_weakening with (alpha:= alpha) (k:= k) in Z; try assumption.
   rewrite <- cons_is_append_singleton.
   unfold getD.
   fold getD.
   rewrite H6; try assumption.
   rewrite <- cons_is_append_singleton.
   unfold getD.
   fold getD.
   rewrite H6; try assumption.
   apply Extends1D_agreement; try assumption.
Qed.