Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Coq.Program.Program.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.cms.p4ast.
Require Import ProD3.examples.cms.ConModel.

Open Scope func_spec.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Definition am_ge := ltac:(get_am_ge prog).
Definition ge := ltac:(get_ge am_ge prog).

(* Constants *)

Definition NOOP := 0.
Definition CLEAR := 1.
Definition INSERT := 2.
Definition QUERY := 3.
Definition INSQUERY := 4.

Definition index_w := 15%N.
Definition value_w := 32%N.
Definition num_slots := Eval compute in 2 ^ (Z.of_N index_w).
Definition num_rows := 5.
Definition num_frames := 3.
Definition frame_tick_tocks := 7034.
Definition tick_time := 4194304.
Definition frame_time := frame_tick_tocks * tick_time * 2.

Definition poly1 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 16;
    Tofino.CRCP_coeff := P4Arith.to_lbool 16 32773;
    Tofino.CRCP_reversed := true;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 16 0;
    Tofino.CRCP_xor := P4Arith.to_lbool 16 0
  |}.

Definition hash1 (v : Val) :=
  hash_Z 16 poly1 v mod 2 ^ (Z.of_N index_w).

Definition poly2 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 16;
    Tofino.CRCP_coeff := P4Arith.to_lbool 16 4129;
    Tofino.CRCP_reversed := false;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 16 65535;
    Tofino.CRCP_xor := P4Arith.to_lbool 16 0
  |}.

Definition hash2 (v : Val) :=
  hash_Z 16 poly2 v mod 2 ^ Z.of_N index_w.

Definition poly3 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 16;
    Tofino.CRCP_coeff := P4Arith.to_lbool 16 1417;
    Tofino.CRCP_reversed := false;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 16 1;
    Tofino.CRCP_xor := P4Arith.to_lbool 16 1
  |}.

Definition hash3 (v : Val) :=
  hash_Z 16 poly3 v mod 2 ^ Z.of_N index_w.

Definition poly4 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 16;
    Tofino.CRCP_coeff := P4Arith.to_lbool 16 15717;
    Tofino.CRCP_reversed := true;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 16 0;
    Tofino.CRCP_xor := P4Arith.to_lbool 16 65535
  |}.

Definition hash4 (v : Val) :=
  hash_Z 16 poly4 v mod 2 ^ Z.of_N index_w.

Definition poly5 : Tofino.CRC_polynomial :=
  {|
    Tofino.CRCP_width := 16;
    Tofino.CRCP_coeff := P4Arith.to_lbool 16 35767;
    Tofino.CRCP_reversed := false;
    Tofino.CRCP_msb := false;
    Tofino.CRCP_extended := false;
    Tofino.CRCP_init := P4Arith.to_lbool 16 0;
    Tofino.CRCP_xor := P4Arith.to_lbool 16 0
  |}.

Definition hash5 (v : Val) :=
  hash_Z 16 poly5 v mod 2 ^ Z.of_N index_w.

Definition header_type : Set := Z * Z.

Definition header_to_val '((x, y) : header_type) : Val :=
  ValBaseBit ((P4Arith.to_lbool 32 y) ++ (P4Arith.to_lbool 32 x)).

Definition hashes := [hash1 ∘ header_to_val; hash2 ∘ header_to_val; hash3 ∘ header_to_val; hash4 ∘ header_to_val; hash5 ∘ header_to_val].

Lemma H_Zlength_hashes : Zlength hashes = num_rows.
Proof. auto. Qed.

Lemma mod_bound_small : forall w n,
  0 <= n < 2 ^ (Z.of_N w) ->
  P4Arith.BitArith.mod_bound w n = n.
Proof.
  intros.
  apply Z.mod_small; auto.
Qed.

Lemma sat_bound_spec : forall w n,
  P4Arith.BitArith.sat_bound w n
    = Z.min (Z.max n 0) (2 ^ (Z.of_N w) - 1).
Proof.
  intros.
  unfold P4Arith.BitArith.sat_bound, P4Arith.BitArith.maxZ, P4Arith.BitArith.upper_bound.
  destruct (n >? 2 ^ Z.of_N w - 1) eqn:?;
  only 2 : destruct (n <? 0) eqn:?;
  lia.
Qed.

Lemma Zmin_shrink : forall a b c,
  Z.min (Z.min a c) (Z.min b c)
    = Z.min (Z.min a b) c.
Proof.
  lia.
Qed.

Lemma b2z_range : forall b,
  0 <= Z.b2z b < 2.
Proof.
  destruct b; simpl; lia.
Qed.

Ltac add_b2z_range b :=
  assert_fails (assert (0 <= Z.b2z b < 2) by assumption);
  pose proof (b2z_range b).

Ltac saturate_b2z :=
  repeat match goal with
  | H : context [Z.b2z ?b] |- _ =>
      add_b2z_range b
  | |- context [Z.b2z ?b] =>
      add_b2z_range b
  end.

Ltac Zify.zify_pre_hook ::=
  unfold is_true, index_w, num_slots, num_rows, num_frames, frame_tick_tocks,
    NOOP, CLEAR, INSERT, QUERY, INSQUERY in *;
  saturate_b2z.

Lemma ext_implies_trans : forall a1 a2 a3,
  ext_implies a1 a2 ->
  ext_implies a2 a3 ->
  ext_implies a1 a3.
Proof.
  unfold ext_implies; intros.
  auto.
Qed.

Definition rows := ["row_1"; "row_2"; "row_3"; "row_4"; "row_5"].
Definition panes := ["win_1"; "win_2"; "win_3"].

Definition H_num_slots : 0 < num_slots := eq_refl.
Definition H_num_rows : 0 < num_rows := eq_refl.
Definition H_num_frames : 1 < num_frames := eq_refl.

Notation row := (row num_slots).
Notation frame := (frame num_rows num_slots).

#[export] Instance Inhabitant_row : Inhabitant row :=
  Inhabitant_row H_num_slots.

#[export] Instance Inhabitant_frame : Inhabitant frame :=
  Inhabitant_frame H_num_rows H_num_slots.

(* NoAction *)

Definition NoAction_fundef : @fundef Info :=
  ltac:(get_fd ["NoAction"] ge).

Definition NoAction_spec : func_spec :=
  WITH,
    PATH []
    MOD None []
    WITH,
      PRE
        (ARG []
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM []
        (EXT []))).

Lemma NoAction_body :
  func_sound ge NoAction_fundef nil NoAction_spec.
Proof.
  start_function.
  step.
  entailer.
Qed.


Require Export Zorn_Lemma.

(** Well-Ordering Principle **)

Module Type WellOrdering_Theorem.

Declare Module Zorn : Zorn_Lemma.

Definition En_L X := \{\ λ Y le, Y ⊂ X /\ Y ≠ Φ /\ WellOrder le Y\}\.

Definition lee X: Class :=
  \{\ λ L1 L2, (L1 ∈ (En_L X) /\ L2 ∈ (En_L X)) /\
  (forall x y, x∈(First L1) /\ y∈(First L1) ->
  (Rrelation x (Second L1) y <-> Rrelation x (Second L2) y)) /\
  Initial_Segment (First L1) (First L2) (Second L2) \}\.

Definition En_Z K := \{ λ x, exists Y le, [Y,le] ∈ K /\ x∈Y \}.

Definition leeq K : Class :=
  \{\ λ u v, exists Y le, [Y,le] ∈ K /\ u∈Y /\ v∈Y /\ Rrelation u le v \}\.

Definition leep Y le x :=
  \{\ λ y1 y2, (y1∈Y /\ y2∈Y /\ Rrelation y1 le y2)\/(y1∈(Y∪[x])/\ y2=x) \}\.

Definition leq Y := \{\ λ y1 y2, y1∈Y /\ y2∈Y /\ y1 = y2 \}\.

Lemma Property_lee : forall Y1 Y2 le1 le2,
  Ensemble ([[Y1, le1],[Y2, le2]]) -> First ([Y1,le1]) = Y1 /\
  Second ([Y1,le1]) = le1 /\ First ([Y2,le2]) = Y2 /\ Second ([Y2,le2]) = le2.
Proof.
  intros.
  apply Theorem49 in H; destruct H.
  apply Theorem49 in H; apply Theorem54 in H; destruct H.
  apply Theorem49 in H0; apply Theorem54 in H0; destruct H0.
  repeat split; auto.
Qed.

Lemma LemmaW1 : forall X, Ensemble X -> PartialOrder (lee X) (En_L X).
Proof.
  intros.
  unfold PartialOrder; repeat split.
  - assert (Ensemble (pow(X)× pow(X×X))).
    { double H; apply Theorem38 in H0; auto; apply Theorem74.
      split; auto; apply Theorem38; auto; apply Theorem74; auto. }
    apply Theorem33 with (x:= pow(X)× pow(X×X)); auto.
    unfold Subclass; intros; PP H1 Y0 le0; apply Axiom_SchemeP in H2.
    destruct H2, H3, H4; unfold WellOrder in H5; destruct H5; clear H6.
    unfold TotalOrder in H5; destruct H5; clear H6.
    unfold PartialOrder in H5; destruct H5, H6, H6.
    unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
    + unfold PowerClass; apply Axiom_Scheme; split; auto.
    + unfold PowerClass; apply Axiom_Scheme; split; auto.
      * apply Theorem33 in H8; auto; apply Theorem74; auto.
      * unfold Subclass; intros; apply H8 in H9; PP H9 u v.
        apply Axiom_SchemeP in H10; destruct H10, H11.
        apply Axiom_SchemeP; repeat split; auto.
  - unfold Relation; intros; PP H0 x y; Ens.
  - unfold Subclass; intros; PP H0 u v; apply Axiom_SchemeP in H1.
    destruct H1, H2, H2; apply Axiom_SchemeP; auto.
  - unfold Reflexivity; intros; double H0; unfold En_L in H1.
    PP H1 u v; unfold Rrelation, lee; apply Axiom_SchemeP.
    assert (Ensemble ([u,v])). { Ens. }
    split; try apply Theorem49; auto; apply Theorem49 in H3.
    apply Theorem54 in H3; destruct H3; rewrite H3, H4; clear H3 H4.
    split; Ens; split; intros.
    + split; intros; auto.
    + unfold Initial_Segment; split; try (unfold Subclass; auto).
      apply Axiom_SchemeP in H2; destruct H2, H3, H4.
      split; try apply H5; intros; apply H6.
  - unfold Antisymmetry; intros; destruct H1.
    unfold Rrelation, lee in H1, H2; apply Axiom_SchemeP in H1.
    apply Axiom_SchemeP in H2; destruct H1, H2, H3, H4; clear H2 H3 H4.
    destruct H0; PP H0 Y1 le1; PP H2 Y2 le2; clear H0 H2 H3 H4.
    double H1; apply Property_lee in H1; destruct H1, H2, H3.
    rewrite H1, H2, H3, H4 in H5, H6; clear H1 H2 H3 H4.
    destruct H5, H6, H2, H4, H5, H6; apply Theorem49 in H0.
    destruct H0; clear H9; apply Theorem49 in H0.
    apply Theorem55; auto; split. 1: apply Theorem27; auto.
    clear H7 H8; unfold WellOrder in H5, H6; destruct H5, H6.
    clear H7 H8; unfold TotalOrder in H5, H6; destruct H5, H6.
    clear H7 H8; unfold PartialOrder in H5, H6; destruct H5, H6.
    clear H5 H6; destruct H7, H8; clear H6 H8; destruct H5, H7.
    clear x y; apply Axiom_Extent; split; intros.
    + double H9; unfold Subclass in H8; apply H8 in H10.
      PP H10 x y; apply Axiom_SchemeP in H11; destruct H11.
      apply H1 in H12; unfold Rrelation in H12; apply H12; auto.
    + double H9; unfold Subclass in H8; apply H6 in H10.
      PP H10 x y; apply Axiom_SchemeP in H11; destruct H11.
      apply H3 in H12; unfold Rrelation in H12; apply H12; auto.
  - clear H; unfold Transitivity; intros; destruct H, H0.
    elim H; intros; destruct H3; unfold En_L in H2, H3, H4.
    PP H2 Y1 le1; PP H3 Y2 le2; PP H4 Y3 le3; clear H H2 H3 H4 H5 H6 H7.
    unfold Rrelation; unfold lee; apply Axiom_SchemeP.
    unfold Rrelation in H0, H1; unfold lee in H0, H1.
    apply Axiom_SchemeP in H0; apply Axiom_SchemeP in H1; destruct H0,H1; split.
    + apply Theorem49 in H; apply Theorem49 in H1; destruct H, H1.
      apply Theorem49; split; auto.
    + apply Property_lee in H; apply Property_lee in H1.
      destruct H, H1, H3, H4, H5, H6; clear H1 H4.
      rewrite H, H3, H5, H7 in H0; rewrite H5, H6, H7, H8 in H2.
      rewrite H, H3, H6, H8; clear H H3 H5 H7 H6 H8; destruct H0, H2.
      destruct H, H1; split; auto; clear H H1 H3 H4; destruct H0, H2.
      unfold Initial_Segment in H0, H2; destruct H0, H2, H3, H4; split; intros.
      * elim H7; intros; unfold Subclass in H0; apply H0 in H8.
        apply H0 in H9; add (y ∈ Y2) H8; clear H9; apply H1 in H8.
        apply H in H7; split; intros; tauto.
      * double H0; add (Y2 ⊂ Y3) H7; apply Theorem28 in H7.
        unfold Initial_Segment; repeat split; try apply H4; auto; intros.
        apply H5 with (v:=v0); destruct H8, H9; assert (u0 ∈ Y2).
        { apply H6 with (v:=v0); unfold Subclass in H0.
          apply H0 in H9; repeat split; auto. }
        repeat split; auto; unfold Subclass in H0; apply H0 in H9.
        add (v0 ∈ Y2) H11; apply H1 in H11; apply H11; auto.
Qed.

Lemma LemmaW2 : forall (X K : Class),
  Ensemble X -> Chain K (En_L X) (lee X) -> WellOrder (leeq K) (En_Z K).
Proof.
  intros; double H.
  unfold Chain in H0; apply (LemmaW1 X) in H1; apply H0 in H1.
  clear H0; destruct H1; unfold WellOrder; split.
  - unfold TotalOrder; split; intros.
    { unfold PartialOrder; repeat split.
      - assert ((En_Z K) ⊂ X).
        { unfold Subclass; intros; unfold En_Z in H2.
          apply Axiom_Scheme in H2; destruct H2, H3 as [Y [le H3]], H3.
          destruct H0; unfold Subclass in H0; apply H0 in H3.
          unfold En_L in H3; apply Axiom_SchemeP in H3; destruct H3, H6.
          unfold Subclass in H6; apply H6 in H4; auto. }
        apply Theorem33 in H2; auto.
      - unfold Relation; intros; PP H2 Y0 le0; Ens.
      - unfold Subclass; intros; PP H2 Y0 le0; apply Axiom_SchemeP in H3.
        destruct H3, H4 as [Y1 [le1 H4]], H4, H5, H6; apply Axiom_SchemeP.
        repeat split; try (apply Axiom_Scheme; split); Ens.
      - unfold Reflexivity; intros; unfold En_Z in H2; apply Axiom_Scheme in H2.
        unfold Rrelation, leeq; apply Axiom_SchemeP; destruct H2.
        destruct H3 as [Y [le H3]], H3; split; try apply Theorem49; auto.
        exists Y, le; repeat split; auto; unfold Subclass in H0.
        apply H0 in H3; unfold En_L in H3; apply Axiom_SchemeP in H3.
        destruct H3, H5; unfold WellOrder in H6; destruct H6; clear H6.
        destruct H7; clear H7; unfold TotalOrder in H6; destruct H6; clear H7.
        unfold PartialOrder in H6; destruct H6, H7, H8; clear H9.
        unfold Reflexivity in H8; apply H8; auto.
      - unfold Antisymmetry; intros; destruct H3; apply Axiom_SchemeP in H3.
        apply Axiom_SchemeP in H4; destruct H3, H4; clear H4.
        destruct H5 as [Y1 [le1 H5]], H6 as [Y2 [le2 H6]].
        destruct H5, H6, H5, H7, H8, H9.
        generalize (classic ([Y1, le1] = [Y2, le2])); intros; destruct H12.
        + assert (Ensemble ([Y1,le1])). { Ens. }
          apply Theorem49 in H13; apply Theorem55 in H12; auto.
          clear H13; destruct H12; rewrite H13 in H10; clear H12.
          clear H13; destruct H0; clear H12; unfold Subclass in H0.
          apply H0 in H6; apply Axiom_SchemeP in H6; destruct H6, H12, H13.
          unfold WellOrder in H14; destruct H14; clear H15.
          unfold TotalOrder in H14; destruct H14; clear H15.
          unfold PartialOrder in H14; destruct H14, H15, H16, H17.
          unfold Antisymmetry in H17; apply H17; auto.
        + assert ([Y1, le1] ∈ K /\ [Y2, le2] ∈ K). { Ens. }
          clear H2; unfold TotalOrder in H1; destruct H1.
          apply H2 in H13; auto; clear H2 H12; destruct H13.
          * unfold Rrelation in H2; apply Theorem4' in H2; destruct H2.
            clear H12; unfold lee in H2; apply Axiom_SchemeP in H2; destruct H2.
            apply Property_lee in H2; destruct H2, H13, H14.
            rewrite H2, H13, H14, H15 in H12; clear H2 H13 H14 H15.
            destruct H12, H12; apply H12 in H10; auto; clear H2 H12 H13.
            destruct H0; unfold Subclass in H0; apply H0 in H6.
            apply Axiom_SchemeP in H6; destruct H6, H12, H13.
            unfold WellOrder in H14; destruct H14; clear H15.
            unfold TotalOrder in H14; destruct H14; clear H15.
            unfold PartialOrder in H14; destruct H14, H15, H16, H17.
            unfold Antisymmetry in H17; apply H17; auto.
          * unfold Rrelation in H2; apply Theorem4' in H2; destruct H2.
            clear H12; unfold lee in H2; apply Axiom_SchemeP in H2; destruct H2.
            apply Property_lee in H2; destruct H2, H13, H14.
            rewrite H2, H13, H14, H15 in H12; clear H2 H13 H14 H15.
            destruct H12, H12; apply H12 in H10; auto; clear H2 H12 H13.
            destruct H0; unfold Subclass in H0; apply H0 in H6.
            apply Axiom_SchemeP in H6; destruct H6, H12, H13.
            unfold WellOrder in H14; destruct H14; clear H15.
            unfold TotalOrder in H14; destruct H14; clear H15.
            unfold PartialOrder in H14; destruct H14, H15, H16, H17.
            unfold Antisymmetry in H17; apply H17; auto.
      - unfold Transitivity; intros; destruct H2; clear H2; destruct H3.
        unfold Rrelation, leeq in H2, H3; apply Axiom_SchemeP in H2.
        apply Axiom_SchemeP in H3; destruct H2, H3; destruct H4 as [Y1[le1 H4]].
        destruct H5 as [Y2 [le2 H5]], H4, H5, H6, H7, H8, H9.
        generalize (classic ([Y1, le1] = [Y2, le2])); intros; destruct H12.
        + assert (Ensemble ([Y1, le1])); Ens.
          apply Theorem49 in H13; apply Theorem55 in H12; auto.
          clear H13; destruct H12; rewrite H12 in H6; rewrite H13 in H10.
          unfold Rrelation, leeq; apply Axiom_SchemeP; split.
          * apply Theorem49; Ens.
          * exists Y2, le2; repeat split; auto.
            unfold Subclass in H0; apply H0 in H5; unfold En_L in H5.
            apply Axiom_SchemeP in H5; destruct H5, H14, H15 as [H16 H15].
            clear H16; unfold WellOrder in H15; destruct H15; clear H16.
            unfold TotalOrder in H15; destruct H15; clear H16.
            unfold PartialOrder in H15; destruct H15, H16, H17, H18.
            unfold Transitivity in H19; apply H19 with (v:=v); auto.
        + unfold TotalOrder in H1; destruct H1; apply H13 in H12; auto.
          clear H13; destruct H12.
          * unfold Rrelation, lee in H12; apply Theorem4' in H12; destruct H12.
            clear H13; apply Axiom_SchemeP in H12; destruct H12.
            apply Property_lee in H12; destruct H12, H14, H15.
            rewrite H12, H14, H15, H16 in H13; clear H12 H14 H15 H16.
            destruct H13, H13, H14; clear H15; unfold Rrelation, leeq.
            apply Axiom_SchemeP; split; try (apply Theorem49; Ens).
            exists Y2, le2; repeat split; auto; double H6.
            add (v∈Y1) H15; apply H13 in H15; apply H15 in H10; clear H13 H15.
            unfold Subclass in H0; apply H0 in H5; unfold En_L in H5.
            apply Axiom_SchemeP in H5; destruct H5, H13, H15 as [H16 H15].
            clear H16; unfold WellOrder in H15; destruct H15; clear H16.
            unfold TotalOrder in H15; destruct H15; clear H16.
            unfold PartialOrder in H15; destruct H15, H16, H17, H18.
            unfold Transitivity in H19; apply H19 with (v:=v); auto.
          * unfold Rrelation, lee in H12; apply Theorem4' in H12; destruct H12.
            clear H13; apply Axiom_SchemeP in H12; destruct H12.
            apply Property_lee in H12; destruct H12, H14, H15.
            rewrite H12, H14, H15, H16 in H13; clear H12 H14 H15 H16.
            destruct H13, H13, H14; clear H15; unfold Rrelation, leeq.
            apply Axiom_SchemeP; split; try (apply Theorem49; Ens).
            exists Y1, le1; repeat split; auto; double H7.
            add (w∈Y2) H15; apply H13 in H15; apply H15 in H11; clear H13 H15.
            unfold Subclass in H0; apply H0 in H4; unfold En_L in H4.
            apply Axiom_SchemeP in H4; destruct H4, H13, H15 as [H16 H15].
            clear H16; unfold WellOrder in H15; destruct H15; clear H16.
            unfold TotalOrder in H15; destruct H15; clear H16.
            unfold PartialOrder in H15; destruct H15, H16, H17, H18.
            unfold Transitivity in H19; apply H19 with (v:=v); auto. }
    { unfold En_Z in H2; destruct H2.
      apply Axiom_Scheme in H2; apply Axiom_Scheme in H4.
      destruct H2, H4, H5 as [Y1 [le1 H5]], H6 as [Y2 [le2 H6]], H5, H6.
      generalize (classic ([Y1, le1] = [Y2, le2])); intros; destruct H9.
      - assert (Ensemble ([Y1, le1])). { Ens. }
        apply Theorem49 in H10; apply Theorem55 in H9; auto.
        clear H10; destruct H9; rewrite H9 in H7; clear H9 H10; double H6.
        unfold Subclass in H0; apply H0 in H9; unfold En_L in H9.
        apply Axiom_SchemeP in H9; destruct H9, H10; clear H9; clear H10.
        destruct H11 as [H12 H11]; clear H12; unfold WellOrder in H11.
        destruct H11; clear H10; unfold TotalOrder in H9; destruct H9.
        clear H9; double H7; add (y∈Y2) H9; apply H10 in H9; auto.
        clear H10 H3; destruct H9.
        + left; unfold Rrelation, leeq; apply Axiom_SchemeP.
          split; try apply Theorem49; Ens.
          exists Y2, le2; repeat split; auto.
        + right; unfold Rrelation, leeq; apply Axiom_SchemeP.
          split; try apply Theorem49; Ens.
          exists Y2, le2; repeat split; auto.
      - unfold TotalOrder in H1; destruct H1; apply H10 in H9; auto.
        clear H10; destruct H9.
        + unfold Rrelation, lee in H9; apply Theorem4' in H9; destruct H9.
          clear H10; apply Axiom_SchemeP in H9; destruct H9.
          apply Property_lee in H9; destruct H9, H11, H12.
          rewrite H9, H11, H12, H13 in H10; clear H9 H11 H12 H13.
          destruct H10; clear H9; destruct H10, H10, H11.
          clear H12; unfold WellOrder in H11; destruct H11.
          clear H12; unfold TotalOrder in H11; destruct H11.
          unfold Subclass in H10; apply H10 in H7; double H7.
          add (y∈Y2) H13; apply H12 in H13; auto; clear H12; destruct H13.
          * left; unfold Rrelation, leeq; apply Axiom_SchemeP.
            split; try apply Theorem49; Ens.
            exists Y2, le2; repeat split; auto.
          * right; unfold Rrelation, leeq; apply Axiom_SchemeP.
            split; try apply Theorem49; Ens.
            exists Y2, le2; repeat split; auto.
        + unfold Rrelation, lee in H9; apply Theorem4' in H9; destruct H9.
          clear H10; apply Axiom_SchemeP in H9; destruct H9.
          apply Property_lee in H9; destruct H9, H11, H12.
          rewrite H9, H11, H12, H13 in H10; clear H9 H11 H12 H13.
          destruct H10; clear H9; destruct H10, H10, H11.
          clear H12; unfold WellOrder in H11; destruct H11.
          clear H12; unfold TotalOrder in H11; destruct H11.
          unfold Subclass in H10; apply H10 in H8; double H7.
          add (y∈Y1) H13; apply H12 in H13; auto; clear H12; destruct H13.
          * left; unfold Rrelation, leeq; apply Axiom_SchemeP.
            split; try apply Theorem49; Ens.
            exists Y1, le1; repeat split; auto.
          * right; unfold Rrelation, leeq; apply Axiom_SchemeP.
            split; try apply Theorem49; Ens.
            exists Y1, le1; repeat split; auto. }
  - intro P; intros; destruct H2; apply Property_NotEmpty in H3.
    destruct H3 as [p H3]; double H3; unfold Subclass in H2.
    apply H2 in H4; clear H2; unfold En_Z in H4; apply Axiom_Scheme in H4.
    destruct H4, H4 as [Y [le H4]], H4; clear H2; double H4.
    apply H0 in H4; unfold En_L in H4; apply Axiom_SchemeP in H4.
    destruct H4, H6; clear H4; clear H6; unfold WellOrder in H7.
    destruct H7; clear H4; assert ((Y ∩ P) ⊂ Y /\ (Y ∩ P) ≠ Φ).
    { split.
      - unfold Subclass; intros; apply Theorem4' in H4; apply H4.
      - apply Property_NotEmpty; exists p; apply Theorem4'; auto. }
    clear H3; clear H5; elim H4; intros; apply H6 in H4; clear H6.
    clear H3; destruct H4 as [q H3]; unfold MinElement in H3.
    apply H3 in H5; clear H3; destruct H5; apply Theorem4' in H3.
    destruct H3; exists q; unfold MinElement; split; auto; clear H6.
    intro r; intros; intro; unfold Rrelation in H7; destruct H7.
    unfold leeq in H7; apply Axiom_SchemeP in H7; destruct H7.
    clear H7; destruct H9 as [Y1 [le1 H7]], H7, H9, H10.
    unfold TotalOrder in H1; destruct H1; unfold Connect in H11.
    generalize (classic ([Y,le] = [Y1,le1])); intros; destruct H13.
    + assert (Ensemble ([Y, le])). { Ens. }
      apply Theorem49 in H14; apply Theorem55 in H13; auto.
      clear H14; destruct H13; rewrite <- H13 in H9; rewrite H14 in H4.
      apply H4 with (y:=r); try apply Theorem4'; auto.
    + apply H12 in H13; auto; clear H12; destruct H13.
      * unfold Rrelation in H12; apply Theorem4' in H12; destruct H12.
        clear H13; unfold lee in H12; apply Axiom_SchemeP in H12.
        destruct H12; apply Property_lee in H12; destruct H12, H14, H15.
        rewrite H12, H14, H15, H16 in H13; clear H12 H14 H15 H16.
        destruct H13; unfold Initial_Segment in H13; destruct H13, H14.
        assert (r∈Y1 /\ q∈Y /\ Rrelation r le1 q).
        { repeat split; auto. } apply H15 in H16; clear H15.
        apply H4 with (y:=r); try apply Theorem4'; auto.
        split; auto; apply H13; auto.
      * unfold Rrelation in H12; apply Theorem4' in H12; destruct H12.
        clear H13; unfold lee in H12; apply Axiom_SchemeP in H12.
        destruct H12; apply Property_lee in H12; destruct H12, H14, H15.
        rewrite H12, H14, H15, H16 in H13; clear H12 H14 H15 H16.
        destruct H13; unfold Initial_Segment in H13; destruct H13, H14.
        clear H15; double H9; unfold Subclass in H14; apply H14 in H15.
        apply H4 with (y:=r); try apply Theorem4'; auto.
        split; auto; apply H13; auto.
Qed.

Lemma LemmaW3 : forall (K X: Class),
  Ensemble X -> Chain K (En_L X) (lee X) -> exists y, BoundU y K (En_L X) (lee X).
Proof.
  intros; double H; double H0.
  apply LemmaW2 in H0; auto; exists ([(En_Z K),(leeq K)]).
  unfold Chain in H2; apply (LemmaW1 X) in H1; apply H2 in H1.
  clear H2; destruct H1; unfold BoundU; intros; destruct H3.
  assert ([En_Z K, leeq K] ∈ (En_L X)).
  { unfold En_L; apply Axiom_SchemeP; split.
    - apply Theorem49; split.
      + assert ((En_Z K) ⊂ X).
        { unfold Subclass; intros; unfold En_Z in H5.
          apply Axiom_Scheme in H5; destruct H5, H6 as [Y [le H6]], H6.
          unfold Subclass in H1; apply H1 in H6; unfold En_L in H6.
          apply Axiom_SchemeP in H6; destruct H6, H8; auto. }
        apply Theorem33 in H5; auto.
      + assert ((leeq K) ⊂ X × X ).
        { unfold Subclass; intros; unfold leeq in H5.
          PP H5 u v; apply Axiom_SchemeP in H6; destruct H6.
          destruct H7 as [Y [le H7]], H7, H8, H9.
          unfold Subclass in H1; apply H1 in H7; unfold En_L in H7.
          apply Axiom_SchemeP in H7; destruct H7, H11; unfold Subclass in H11.
          apply H11 in H8; apply H11 in H9; unfold Cartesian.
          apply Axiom_SchemeP; repeat split; auto. }
        assert (Ensemble X /\ Ensemble X). { auto. }
        apply Theorem74 in H6; apply Theorem33 in H5; auto.
    - split.
      + unfold Subclass; intros; unfold En_Z in H5.
        apply Axiom_Scheme in H5; destruct H5, H6 as [Y [le H6]], H6.
        unfold Subclass in H1; apply H1 in H6; unfold En_L in H6.
        apply Axiom_SchemeP in H6; destruct H6, H8; auto.
      + split; try apply H0; destruct H1; apply Property_NotEmpty in H5.
        destruct H5; apply Property_NotEmpty; double H5.
        unfold Subclass in H1; apply H1 in H6; PP H6 Y0 le0.
        apply Axiom_SchemeP in H7; destruct H7, H8, H9.
        apply Property_NotEmpty in H9; destruct H9.
        exists x0; unfold En_Z; apply Axiom_Scheme; split; Ens. }
  repeat split; auto; try apply H1; intros.
  double H6; unfold Subclass in H1; apply H1 in H7.
  double H7; unfold En_L in H8; PP H8 Y1 le1; clear H9.
  unfold Rrelation; unfold lee; apply Axiom_SchemeP.
  assert (Ensemble ([Y1,le1]) /\ Ensemble ([En_Z K,leeq K])). { Ens. }
  split; try apply Theorem49; auto; destruct H9.
  apply Theorem49 in H9; apply Theorem54 in H9; destruct H9.
  apply Theorem49 in H10; apply Theorem54 in H10; destruct H10.
  rewrite H9, H10, H11, H12; clear H9; clear H10; clear H11; clear H12.
  clear H3; clear H4; split; auto; split; intros.
  - destruct H3; split; intros.
    + unfold Rrelation, leeq; apply Axiom_SchemeP.
      split; try apply Theorem49; Ens.
      exists Y1, le1; repeat split; auto.
    + unfold Rrelation, leeq in H9; apply Axiom_SchemeP in H9.
      destruct H9, H10 as [Y2 [le2 H10]], H10, H11, H12, H2.
      generalize (classic ([Y1,le1] = [Y2,le2])); intros; destruct H15.
      * assert (Ensemble ([Y1, le1])). { Ens. }
        apply Theorem49 in H16; apply Theorem55 in H15; auto.
        clear H16; destruct H15; rewrite H16; auto.
      * apply H14 in H15; auto; clear H14; destruct H15.
        -- unfold Rrelation in H14; apply Theorem4' in H14; destruct H14.
           clear H15; unfold lee in H14; apply Axiom_SchemeP in H14.
           destruct H14; apply Property_lee in H14; destruct H14, H16, H17.
           rewrite H14, H16, H17, H18 in H15; clear H14; clear H16.
           clear H17; clear H18; destruct H15, H15; apply H15; auto.
        -- unfold Rrelation in H14; apply Theorem4' in H14; destruct H14.
           clear H15; unfold lee in H14; apply Axiom_SchemeP in H14.
           destruct H14; apply Property_lee in H14; destruct H14, H16, H17.
           rewrite H14, H16, H17, H18 in H15; clear H14; clear H16.
           clear H17; clear H18; destruct H15, H15; apply H15; auto.
  - unfold Initial_Segment; split.
    + unfold Subclass; intros; apply Axiom_Scheme; split; Ens.
    + split; try apply H0; intros; destruct H3, H4.
      unfold Rrelation, leeq in H9; apply Axiom_SchemeP in H9.
      destruct H9, H10 as [Y2 [le2 H10]], H10, H11, H12, H2.
      generalize (classic ([Y1,le1] = [Y2,le2])); intros; destruct H15.
      * assert (Ensemble ([Y1, le1])). { Ens. }
        apply Theorem49 in H16; apply Theorem55 in H15; auto.
        clear H16; destruct H15; rewrite H15; auto.
      * apply H14 in H15; auto; clear H14; destruct H15.
        -- unfold Rrelation in H14; apply Theorem4' in H14; destruct H14.
           clear H15; unfold lee in H14; apply Axiom_SchemeP in H14.
           destruct H14; apply Property_lee in H14; destruct H14, H16, H17.
           rewrite H14, H16, H17, H18 in H15; clear H14 H16 H17 H18.
           destruct H15; clear H14; unfold Initial_Segment in H15.
           destruct H15, H15, H16; apply H17 with (v:=v); auto.
        -- unfold Rrelation in H14; apply Theorem4' in H14; destruct H14.
           clear H15; unfold lee in H14; apply Axiom_SchemeP in H14.
           destruct H14; apply Property_lee in H14; destruct H14, H16, H17.
           rewrite H14, H16, H17, H18 in H15; clear H14 H16 H17 H18.
           destruct H15; clear H14; unfold Initial_Segment in H15.
           destruct H15, H15; auto.
Qed.

Theorem WellOrdering : forall (X: Class),
  Ensemble X -> exists le: Class, WellOrder le X.
Proof.
  intros.
  assert (PartialOrderSet (En_L X) (lee X)).
  { unfold PartialOrderSet; try apply LemmaW1; auto. }
  double H0; apply Zorn.Zorn in H1; intros; try apply LemmaW3; auto.
  destruct H1 as [Y H1]; unfold MaxElement in H1.
  generalize (classic (X = Φ)); intros; destruct H2.
  { rewrite H2; exists Φ; unfold WellOrder; split; intros.
    - unfold TotalOrder; split; intros.
      + unfold PartialOrder; repeat split; intros.
        * apply Theorem33 with (x:=X); auto; unfold Subclass; intros.
          generalize (Theorem16 z); intros; contradiction.
        * unfold Relation; intros.
          generalize (Theorem16 z); intros; contradiction.
        * unfold Subclass; intros.
          generalize (Theorem16 z); intros; contradiction.
        * unfold Reflexivity; intros.
          generalize (Theorem16 a); intros; contradiction.
        * unfold Antisymmetry; intros; destruct H3.
          generalize (Theorem16 x); intros; contradiction.
        * unfold Transitivity; intros; destruct H3, H3.
          generalize (Theorem16 u); intros; contradiction.
      + destruct H3; generalize (Theorem16 x); contradiction.
    - destruct H3; generalize (Theorem26 A); intros.
      absurd (A = Φ); auto; apply Theorem27; auto. }
  assert (En_L X ≠ Φ).
  { apply Property_NotEmpty in H2; destruct H2.
    apply Property_NotEmpty; exists ([[x],leq ([x])]).
    unfold En_L; apply Axiom_SchemeP; repeat split; intros.
    - assert (Ensemble ([x])). { apply Theorem42; Ens. }
      apply Theorem49; split; auto.
      apply Theorem33 with (x:= ([x])×([x])); auto.
      + apply Theorem74; auto.
      + unfold Subclass; intros; PP H4 a b; unfold leq in H5.
        apply Axiom_SchemeP in H5; destruct H5, H6, H7.
        unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
    - unfold Subclass; intros; unfold Singleton in H3.
      apply Axiom_Scheme in H3; destruct H3; rewrite H4; auto.
      apply Theorem19; Ens.
    - apply Property_NotEmpty; exists x; apply Axiom_Scheme; Ens.
    - apply Theorem33 with (x:=X); auto; unfold Subclass; intros.
      unfold Singleton in H3; apply Axiom_Scheme in H3; destruct H3.
      rewrite H4; auto; apply Theorem19; Ens.
    - unfold Relation; intros; PP H3 a b; exists a, b; auto.
    - unfold Subclass; intros; PP H3 a b; unfold leq in H4.
      apply Axiom_SchemeP in H4; destruct H4, H5, H6.
      unfold Cartesian; apply Axiom_SchemeP; repeat split; auto.
    - unfold Reflexivity; intros; unfold Rrelation, leq.
      apply Axiom_SchemeP; repeat split; auto; apply Theorem49; Ens.
    - unfold Antisymmetry; intros; destruct H3.
      unfold Singleton in H3, H5; apply Axiom_Scheme in H3.
      apply Axiom_Scheme in H5; destruct H3, H5.
      rewrite H6, H7; try apply Theorem19; Ens.
    - unfold Transitivity; intros; destruct H3, H3, H5.
      apply Axiom_Scheme in H3; apply Axiom_Scheme in H6; destruct H3, H6.
      rewrite H7, H8; try apply Theorem19; Ens.
      unfold Rrelation, leq; apply Axiom_SchemeP; repeat split; auto.
      + apply Theorem49; split; Ens.
      + unfold Singleton; apply Axiom_Scheme; Ens.
      + unfold Singleton; apply Axiom_Scheme; Ens.
    - destruct H3; apply Axiom_Scheme in H3; apply Axiom_Scheme in H5.
      destruct H3, H5; rewrite H6, H7 in H4; try apply Theorem19; Ens.
      contradiction.
    - destruct H3; apply Property_NotEmpty in H4; destruct H4.
      exists x0; unfold MinElement; intros; split; auto; intros.
      intro; destruct H7; unfold Rrelation, leq in H7.
      apply Axiom_SchemeP in H7; destruct H7, H9, H10.
      rewrite H11 in H8; contradiction. }
  apply H1 in H3; clear H1 H2; destruct H3.
  unfold En_L in H1; PP H1 Y0 le0; apply Axiom_SchemeP in H3.
  destruct H3, H4, H5; apply Property_ProperSubclass in H4; destruct H4.
  - double H4; unfold ProperSubclass in H7; destruct H7; clear H8.
    apply Property_ProperSubclass' in H4; destruct H4, H4.
    assert (([Y0∪[x],(leep Y0 le0 x)]) ∈ (En_L X)).
    { unfold WellOrder in H6; destruct H6; unfold TotalOrder in H6; destruct H6.
      double H6; unfold PartialOrder in H11; destruct H11 as [H12 H11].
      clear H12; destruct H11; apply Axiom_SchemeP; repeat split; intros.
      - apply Theorem49 in H3; destruct H3; apply Theorem49; split.
        + apply Axiom_Union; split; auto; apply Theorem42; Ens.
        + assert ((leep Y0 le0 x) ⊂ le0∪(X×X)).
          { unfold Subclass; intros; PP H14 y1 y2; apply Axiom_SchemeP in H15.
            destruct H15; apply Theorem4; destruct H16.
            - left; destruct H16, H17; auto.
            - right; unfold Cartesian; apply Axiom_SchemeP; destruct H16.
              rewrite H17; repeat split; try apply Theorem49; Ens.
              apply Theorem4 in H16; destruct H16; auto.
              unfold Singleton in H16; apply Axiom_Scheme in H16; destruct H16.
              rewrite H18; auto; apply Theorem19; Ens. }
          apply Theorem33 in H14; auto; apply Axiom_Union; split; auto.
          apply Theorem74; auto.
      - unfold Subclass; intros; apply Theorem4 in H13; destruct H13.
        + unfold Subclass in H7; apply H7 in H13; auto.
        + unfold Singleton in H13; apply Axiom_Scheme in H13; destruct H13.
          rewrite H14; auto; apply Theorem19; Ens.
      - apply Property_NotEmpty in H5; destruct H5.
        apply Property_NotEmpty; exists x0; apply Theorem4; tauto.
      - apply Theorem33 with (x:=X); auto; unfold Subclass; intros.
        apply Theorem4 in H13; destruct H13; auto; unfold Singleton in H13.
        apply Axiom_Scheme in H13; destruct H13; rewrite H14; auto.
        apply Theorem19; Ens.
      - unfold Relation; intros; unfold leep in H13; PP H13 y1 y2; Ens.
      - unfold Subclass; intros; PP H13 y1 y2; apply Axiom_SchemeP in H14.
        destruct H14; apply Axiom_SchemeP; split; auto; destruct H15.
        + destruct H15, H16; split; try apply Theorem4; auto.
        + destruct H15; split; auto; rewrite H16; apply Theorem4.
          right; unfold Singleton; apply Axiom_Scheme; Ens.
      - unfold Reflexivity; intros; unfold Rrelation, leep; apply Axiom_SchemeP.
        split; try apply Theorem49; Ens; apply Theorem4 in H13; destruct H13.
        + left; repeat split; auto; destruct H12.
          unfold Reflexivity in H12; auto.
        + right; unfold Singleton in H13.
          apply Axiom_Scheme in H13; destruct H13.
          rewrite H14; try apply Theorem19; Ens; split; auto.
          apply Theorem4; right; apply Axiom_Scheme; Ens.
      - unfold Antisymmetry; intros; clear H13; destruct H14.
        unfold Rrelation, leep in H13, H14; apply Axiom_SchemeP in H13.
        apply Axiom_SchemeP in H14; destruct H13, H14, H15, H16.
        + destruct H15, H16, H17, H18, H12, H21; clear H22.
          unfold Antisymmetry in H21; apply H21; auto.
        + destruct H15, H16; rewrite H18 in H15; contradiction.
        + destruct H15, H16; rewrite H17 in H16; contradiction.
        + destruct H15, H16; rewrite H17, H18; auto.
      - clear H11; destruct H12; clear H11; destruct H12; unfold Transitivity.
        intros; unfold Transitivity in H12; destruct H13, H14, H13, H16.
        unfold Rrelation; apply Axiom_SchemeP; split; try apply Theorem49; Ens.
        unfold Rrelation, leep in H14, H15; apply Axiom_SchemeP in H14.
        apply Axiom_SchemeP in H15; destruct H14, H15, H18, H19.
        + left; destruct H18, H19, H20, H21; repeat split; auto.
          apply H12 with (v:=v); auto.
        + right; destruct H19; split; auto.
        + destruct H18, H19; rewrite H20 in H19; contradiction.
        + right; destruct H19; split; auto.
      - destruct H13; apply Theorem4 in H13.
        apply Theorem4 in H15; destruct H13, H15.
        + double H13; add (y∈Y0) H16; apply H10 in H16; auto.
          clear H10; destruct H16.
          * left; unfold Rrelation, leep; apply Axiom_SchemeP.
            repeat split; try apply Theorem49; Ens.
          * right; unfold Rrelation, leep; apply Axiom_SchemeP.
            repeat split; try apply Theorem49; Ens.
        + left; unfold Rrelation, leep; apply Axiom_SchemeP.
          split; try apply Theorem49; Ens; right; split.
          * apply Theorem4; tauto.
          * apply Axiom_Scheme in H15; destruct H15; apply H16.
            apply Theorem19; Ens.
        + right; unfold Rrelation, leep; apply Axiom_SchemeP.
          split; try apply Theorem49; Ens; right; split.
          * apply Theorem4; tauto.
          * apply Axiom_Scheme in H13; destruct H13; apply H16.
            apply Theorem19; Ens.
        + left; unfold Rrelation, leep; apply Axiom_SchemeP.
          split; try apply Theorem49; Ens; right; split.
          * apply Theorem4; tauto.
          * apply Axiom_Scheme in H15; destruct H15; apply H16.
            apply Theorem19; Ens.
      - destruct H13; assert (A ⊂ Y0 \/ (exists B, B⊂Y0 /\ A = B∪[x])).
        { generalize (classic (x ∈ A)); intros; destruct H15.
          - right; exists (A ~ [x]); split.
            + unfold Subclass; intros; unfold Setminus in H16.
              apply Axiom_Scheme in H16; destruct H16, H17.
              unfold Complement in H18; apply Axiom_Scheme in H18; destruct H18.
              unfold NotIn in H19; unfold Subclass in H13; apply H13 in H17.
              apply Theorem4 in H17; tauto.
            + unfold Setminus; apply Axiom_Extent; split; intros.
              * unfold Subclass in H13; double H16; apply H13 in H17.
                apply Theorem4; apply Theorem4 in H17; destruct H17; try tauto.
                left; apply Theorem4'; split; auto; unfold Complement.
                apply Axiom_Scheme; split; Ens; unfold NotIn; intro.
                apply Axiom_Scheme in H18; destruct H18.
                rewrite H19 in H17; try contradiction; try apply Theorem19; Ens.
              * apply Theorem4 in H16; destruct H16.
                -- apply Theorem4' in H16; apply H16.
                -- apply Axiom_Scheme in H16; destruct H16; rewrite H17; auto.
                   apply Theorem19; Ens.
          - left; unfold Subclass; intros; unfold Subclass in H13.
            double H16; apply H13 in H17; apply Theorem4 in H17.
            destruct H17; auto; apply Axiom_Scheme in H17; destruct H17.
            rewrite H18 in H16; try contradiction; apply Theorem19; Ens. }
        destruct H15.
        + double H15; add (A≠Φ) H16; apply H9 in H16; clear H9.
          destruct H16; exists x0; unfold MinElement in H9.
          apply H9 in H14; clear H9; destruct H14; unfold MinElement; intros.
          split; auto; intros; apply H14 in H17; intro; elim H17; clear H17.
          destruct H18; split; auto; unfold Rrelation, leep in H17.
          apply Axiom_SchemeP in H17; destruct H17, H19; try apply H19.
          destruct H19; rewrite H20 in H9; apply H15 in H9; contradiction.
        + destruct H15 as [B H15], H15.
          generalize (classic (B = Φ)); intros; destruct H17.
          * rewrite H17 in H16; rewrite Theorem17 in H16; clear H17.
            rewrite H16; exists x; unfold MinElement; intros; split; intros.
            -- unfold Singleton; apply Axiom_Scheme; split; Ens.
            -- unfold Singleton in H18; apply Axiom_Scheme in H18; destruct H18.
               intro; destruct H20; rewrite H19 in H21; try contradiction.
               apply Theorem19; Ens.
          * rewrite H16; double H15; add (B≠Φ) H18; clear H16; apply H9 in H18.
            clear H9; destruct H18; exists x0; unfold MinElement in H9.
            apply H9 in H17; clear H9; destruct H17; unfold MinElement; intros.
            clear H17; split; try (apply Theorem4; tauto); intros.
            apply Theorem4 in H17; destruct H17.
            -- apply H16 in H17; intro; elim H17; clear H17.
               destruct H18; split; auto; unfold Rrelation, leep in H17.
               apply Axiom_SchemeP in H17; destruct H17, H19; try apply H19.
               destruct H19; rewrite H20 in H9; apply H15 in H9; contradiction.
            -- intro; destruct H18; apply Axiom_Scheme in H17; destruct H17.
               rewrite H20 in H18, H19; try apply Theorem19; Ens.
               apply Axiom_SchemeP in H18; destruct H18, H21, H21.
               ++ destruct H22; contradiction.
               ++ contradiction. }
    double H9; apply H2 in H10; elim H10; clear H10; split.
    + unfold Rrelation, lee; apply Axiom_SchemeP.
      assert (Ensemble ([[Y0,le0],[Y0∪[x],leep Y0 le0 x]])).
      { apply Theorem49; Ens. } split; auto.
      apply Property_lee in H10; destruct H10, H11, H12.
      rewrite H10, H11, H12, H13; clear H10 H11 H12 H13.
      split; try (split; auto; apply Axiom_SchemeP; Ens); split; intros.
      * split; intros.
        -- destruct H10; unfold Rrelation, leep; apply Axiom_SchemeP.
           split; try apply Theorem49; Ens; try tauto.
        -- unfold Rrelation, leep in H11; apply Axiom_SchemeP in H11.
           destruct H11; destruct H12, H12; try apply H13.
           destruct H10; rewrite H13 in H14; contradiction.
      * unfold Initial_Segment; split.
        -- unfold Subclass; intros; apply Theorem4; tauto.
        -- unfold En_L in H9; apply Axiom_SchemeP in H9; destruct H9, H10, H11.
           split; try apply H12; intros; destruct H13, H14.
           unfold Rrelation, leep; apply Axiom_SchemeP in H15; destruct H15.
           destruct H16; try apply H16; destruct H16.
           rewrite H17 in H14; contradiction.
    + intro; apply Theorem49 in H3; apply Theorem55 in H10; auto.
      destruct H10; elim H8; rewrite H10; apply Theorem4; right.
      apply Axiom_Scheme; split; Ens.
  - rewrite H4 in H6; exists le0; auto.
Qed.

Hint Resolve WellOrdering : Axiom_of_Choice.

End WellOrdering_Theorem.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Key_Properties
        Subtyping_inversion
        Deterministic.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Coq.Strings.String.

Lemma TypedReduce_trans : forall v v1 v2 A B,
    TypedReduce v A v1 -> ord B -> TypedReduce v1 B v2 -> TypedReduce v B v2.
Proof.
  introv Red1 Ord Red2.
  gen B v2.
  induction* Red1;
    introv Ord Red2.
  - (* v1 = v_topv v *)
    remember (v_topv v).
    induction* Red2;
      try solve [inversion Heqv0];
      try solve [inversion Ord].
  - (* v1 = v_absv e A D *)
    remember (v_absv e A D).
    induction* Red2;
      try solve [inversion Heqv];
      try solve [inversion Ord].
    inverts* Heqv.
    constructor*.
    auto_sub.
  - (* and *)
    inverts* Red2;
      try solve [inverts* Ord].
Qed.

Lemma consistent_afterTR : forall v A B C v1 v2, Vtyping v C -> TypedReduce v A v1 -> TypedReduce v B v2 -> consistencySpec v1 v2.
Proof.
  intros v A B C v1 v2 Typ Red1 Red2.
  unfold consistencySpec.
  intros D v1' v2' Ord Red1' Red2'.
  lets Lc: typing_regular_1_val Typ.
  forwards*: TypedReduce_trans Red1 Red1'.
  forwards*: TypedReduce_trans Red2 Red2'.
  forwards*: TypedReduce_unique H H0.
Qed.

Lemma TypedReduce_preservation: forall v A v',
    TypedReduce v A v'-> forall B, Vtyping v B -> sub B A -> Vtyping v' A.
Proof.
  introv Red.
  induction Red; introv Typ Sub;
    lets Lc  : typing_regular_1_val Typ;
    try solve [constructor*].
  - Case "topv".
    eapply Vtyp_topv.
    eauto.
  - Case "absv".
    inverts Typ.
    apply~ Vtyp_absv.
    auto_sub.
  - Case "mergel".
    inverts Typ.
    lets: TypedReduce_sub Red.
    lets: principal_type_checks H3.
    forwards*: IHRed.
  - Case "merger".
    inverts Typ.
    lets: TypedReduce_sub Red.
    lets: principal_type_checks H4.
    forwards*: IHRed.
  - Case "merge_and".
    assert (sub B0 A) by auto_sub.
    assert (sub B0 B) by auto_sub.
    forwards*: IHRed1.
    forwards*: IHRed2.
    constructor*.
    lets* Con: consistent_afterTR Typ Red1 Red2.
Qed.

Theorem preservation : forall e e' A,
    Etyping nil e A ->
    step e e' ->
    Etyping nil e' A.
Proof.
  introv Typ. gen e'.
  lets Typ' : Typ.
  inductions Typ;
    try solve [introv J; inverts* J].
  - Case "typing_app".
    introv J.
    inverts* J.
    (* e_absv A0 . e : B0->D  v *)
    inverts Typ2.
    inverts H4.
    eapply Etyp_anno.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    remember nil as G.
    rewrite_env(nil++G).
    sapply* Etyping_subst.
    subst.
    inverts Typ1.
    forwards*: TypedReduce_preservation H3.
    auto.
  - Case "typing_merge".
    introv J.
    inverts J.
    + forwards*: IHTyp1.
    + forwards*: IHTyp2.
    + inverts Typ1.
      inverts Typ2.
      constructor*.
      constructor*.
      forwards*: disjoint_val_consistent.
  - Case "typing_anno".
    introv J.
    inverts* J.
    + SCase "e:A".
      inverts Typ.
      forwards*: TypedReduce_preservation H3 H4.
  - Case "typing_fix".
    introv J.
    inverts* J.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    remember nil as G.
    rewrite_env(nil++G).
    sapply* Etyping_subst.
Qed.

Lemma TypedReduce_progress: forall v A B,
    Vtyping v A -> sub A B -> exists v', TypedReduce v B v'.
Proof.
  introv Typ Sub.
  gen A B.
  induction v; try solve [inverts* Val];
    intros.
  - Case "e_top".
    inverts Typ.
    induction B; inverts* Sub.
    destruct~ IHB1 as [v1 Tyr1].
    destruct~ IHB2 as [v2 Tyr2].
    exists*.
  - Case "e_lit".
    inverts Typ.
    induction B; inverts* Sub.
    destruct~ IHB1 as [v1 Tyr1].
    destruct~ IHB2 as [v2 Tyr2].
    exists*.
  - Case "v_topv".
    inverts Typ.
    induction B; inverts* Sub.
    destruct~ IHB1 as [v1 Tyr1].
    destruct~ IHB2 as [v2 Tyr2].
    exists*.
  - Case "e_absv".
    lets S: principal_type_sub Typ.
    lets T: principal_type_checks Typ.
    simpl in S. simpl in T.
    lets S2: sub_transtivity S Sub.
    induction B0; inverts* S2.
    + SCase "t_and".
      destruct~ IHB0_1 as [v1 Tyr1].
      auto_sub.
      destruct~ IHB0_2 as [v2 Tyr2].
      auto_sub.
      exists*.
  - Case "e_merge".
    lets Typ' : Typ.
    inverts* Typ.
    + SCase "consistent merge".
      lets Lc  : typing_regular_1_val H1.
      lets Lc2  : typing_regular_1_val H2.
      induction B.
      * SSCase "B:=Int".
        inverts Sub.
        lets* [? ?]: IHv1 H5.
        lets* [? ?]: IHv2 H5.
      * SSCase "B:=Top".
        assert (sub A0 t_top) by auto.
        lets* [? ?]: IHv1 H1 H.
      * SSCase "B:=Arrow".
        inverts Sub.
        lets* [? ?]: IHv1 H1 H5.
        lets* [? ?]: IHv2 H2 H5.
      * SSCase "B:=B1&B2".
        lets* [vb1' Tyrb1] : IHB1.
        auto_sub.
        lets* [vb2' Tyrb2] : IHB2.
        auto_sub.
Qed.

Theorem progress : forall e A,
    Etyping nil e A ->
    (exists v, e = (e_val v)) \/ exists e', step e e'.
Proof.
  introv Typ. lets Typ': Typ.
  inductions Typ;
      lets Lc  : typing_regular_1_exp Typ';
      try solve [left*];
      try solve [right*].
  - Case "var".
    invert H0.
  - Case "app".
    right.
    destruct~ IHTyp2 as [Val1 | [e1' Red2]].
    destruct~ IHTyp1 as [Val2 | [e2' Red1]].
    inverts* Typ2;
      try solve [
      lets (v1' & Eqn): Val1;
      inverts* Eqn ].
    + SCase "e_app (e_absv _ _) v2".
      inverts Val2.
      inverts H0.
      inverts Typ1.
      lets* (v2' & Tyr): TypedReduce_progress H4 H6.
    + SCase "e_app v1 e2".
      destruct Val1.
      subst.
      inverts Lc.
      inverts* H1.
    + SCase "e_app e1 e2".
      forwards*: typing_regular_1_exp Typ1.
  - Case "merge".
    forwards*: typing_regular_1_exp Typ1.
    forwards*: typing_regular_1_exp Typ2.
    destruct~ IHTyp1 as [ (v1' & Val1) | [t1' Red1]];
      destruct~ IHTyp2 as [ (v2' & Val2) | [t2' Red2]];
      subst.
    + SCase "v1 v2".
      right.
      inverts* Typ1.
      inverts* Typ2.
    + SCase "e_merge v1 e2".
      inverts* Typ1.
    + SCase "e_merge e1 v2".
      inverts* Typ2.
    + SCase "e_merge e1 e2".
      inverts* Typ2.
  - Case "anno".
    right.
    destruct~ IHTyp as [ (v' & Val) | [t' Red]].
    + SCase "e_anno v A".
      subst.
      inverts* Typ.
      lets* (v1' & Tyr) : TypedReduce_progress H3 H.
    + SCase "e_anno e A".
      forwards*: Step_anno Red.
Qed.

Theorem preservation_multi_step : forall e e' A,
    nil |= e ~: A ->
    e ->* e' ->
    nil |= e' ~: A.
Proof.
  introv Typ Red.
  induction* Red.
  lets*: preservation Typ H.
Qed.

Theorem type_safety : forall e e' A,
    nil |= e ~: A ->
    e ->* e' ->
    (exists v, e' = (e_val v)) \/ exists e'', step e e''.
Proof.
  introv Typ Red.
  induction Red.
  lets*: progress Typ.
  lets*: preservation Typ H.
Qed.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import Coq.Program.Basics.

Inductive Name : Set := Object | A | B | N | C1 | T | Iterable | List.

Unset Elimination Schemes.

Inductive DartType : Set :=
| dt_void : DartType
| dt_dynamic : DartType
| dt_class : NameDartTypes -> DartType (* Incl. all clausal supertypes *)
| dt_function : DartType -> DartTypes -> DartType
| dt_variable : Name -> DartType (* Type parameter with no bound: can be void *)
| dt_bottom : DartType

with DartTypes : Set :=
| dts_nil : DartTypes
| dts_cons : DartType -> DartTypes -> DartTypes

with NameDartTypes : Set :=
| ndts_nil : NameDartTypes
| ndts_cons : Name -> DartTypes -> NameDartTypes -> NameDartTypes.

Scheme DartType_ind := Induction for DartType Sort Prop
  with DartTypes_ind := Induction for DartTypes Sort Prop
  with NameDartTypes_ind := Induction for NameDartTypes Sort Prop.

Combined Scheme DartType_mutind from
  DartType_ind, DartTypes_ind, NameDartTypes_ind.

Set Elimination Schemes.


Require Import IRMisc.LegacyIRRing.
Require Export icreate.

Open Scope mc_scope.

(* in general, the type of [te] should be [Time] *)
Lemma DI0 : ∀ (F F' : Cart2D TContR) (LD : TContR) (te : QTime),
  isDerivativeOf (X F') (X F)
  -> isDerivativeOf (Y F') (Y F)
  -> isDerivativeOf LD ((X F)* (X F) + (Y F)* (Y F) - 1)
  -> (getF ((X F)* (X F) + (Y F)* (Y F) - 1)) 0 = 0
  -> (∀ (t : QTime), ((mkQTime 0 I) <= t <= te )
      -> {X F'} t = - {Y F} t
          ∧ {Y F'} t =  {X F} t
          ∧ {LD} t = 0
          )
  -> (getF ((X F)* (X F) + (Y F)* (Y F) - 1)) te = 0.
Proof.
  intros ? ? ? ? H1d H2d Hld Heq0 Ht.
  rewrite <- Heq0.
  eapply TDerivativeEqQ0; eauto.
  - simpl. eauto 1 with ROSCOQ.
  - apply Ht.
Qed.

Lemma DI : ∀ (Inv LD : TContR) (te : QTime),
  isDerivativeOf LD Inv
  -> {Inv} (mkQTime 0 I) = 0
  -> (∀ (t : QTime), (0 <= t <= te) ->  {LD} t = 0)
  -> {Inv} te = 0.
Proof.
  intros ? ? ? Hld Heq0 Ht.
  rewrite <- Heq0.
  eapply TDerivativeEqQ0; eauto.
  simpl. eauto 1 with ROSCOQ.
Qed.

Lemma DI' : ∀ (F F' : Cart2D TContR) (LD : TContR) (te : QTime),
  isDerivativeOf (X F') (X F)
  -> isDerivativeOf (Y F') (Y F)
  -> isDerivativeOf LD ((X F) * (X F) + (Y F) * (Y F) - 1)
  -> ∀ (t : QTime),
        {X F'} t = - {Y F} t
        -> {Y F'} t =  {X F} t
        -> {LD} t = 0.
Proof.
  intros? ? ? ?  H1d H2d H3d ? H1eq H2eq.
  eapply DerivativeNormSqr with (Y':=(Y F')) in H1d; eauto.
  clear H2d.
  pose proof (TContRDerivativeConst (closel [0]) I (-1)) as Hconst.
  pose proof (TContRDerivativePlus  H1d Hconst) as Hadd.
  clear H1d Hconst.
  eapply isIDerivativeOfWdl in Hadd;
    [|apply cm_rht_unit_unfolded].
  unfold canonical_names.negate, Negate_instance_IR in Hadd.
  eapply isIDerivativeOfWdr in Hadd;
    [ | rewrite <- FConstOppIn; reflexivity].
  eapply isDerivativeUnique in Hadd; [| exact H3d].
  clear H3d.
  unfold canonical_names.equiv.
  rewrite Hadd.
  autorewrite with IContRApDown.
  rewrite H1eq.
  rewrite H2eq.
  autounfold with IRMC.
  ring.
Qed.

Lemma DIEx : ∀ (F F' : Cart2D TContR) (LD : TContR) (te : QTime),
  isDerivativeOf (X F') (X F)
  -> isDerivativeOf (Y F') (Y F)
  -> isDerivativeOf LD ((X F)* (X F) + (Y F)* (Y F) - 1)
  -> (getF ((X F)* (X F) + (Y F)* (Y F) - 1)) 0 = 0
  -> (∀ (t : QTime), (0 <= t <= te )
      -> {X F'} t = - {Y F} t
          ∧ {Y F'} t =  {X F} t)
  -> (getF ((X F)* (X F) + (Y F)* (Y F) - 1)) te = 0.
Proof.
  intros ? ? ? ? H1d H2d Hld Heq0 Ht.
  eapply DI; eauto.
  intros ? Hb.
  apply Ht in Hb. clear Ht.
  destruct Hb as [Htl Htr].
  eapply DI'; eauto.
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section TruthLemma.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimumSequentCalculus L Gamma}
        {andpSC: AndSequentCalculus L Gamma}
        {orpSC: OrSequentCalculus L Gamma}
        {falsepSC: FalseSequentCalculus L Gamma}
        {inegpSC: IntuitionisticNegSequentCalculus L Gamma}
        {iffpSC: IffSequentCalculus L Gamma}
        {truepSC: TrueSequentCalculus L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {SM: Semantics L MD}
        {kminSM: KripkeMinimumSemantics L MD M SM}
        {kandpSM: KripkeAndSemantics L MD M SM}
        {korpSM: KripkeOrSemantics L MD M SM}
        {kfalsepSM: KripkeFalseSemantics L MD M SM}
        {ktruepSM: KripkeTrueSemantics L MD M SM}
        {kiffpSM: KripkeIffSemantics L MD M SM}
        {knegpSM: KripkeNegSemantics L MD M SM}.

Context (P: context -> Prop)
        (rel: bijection (Kworlds M) (sig P)).

Hypothesis H_R: forall m n Phi Psi, rel m Phi -> rel n Psi -> (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).

Lemma truth_lemma_falsep (AL_CONSI: at_least consistent P):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= falsep <-> proj1_sig Phi falsep).
Proof.
  intros.
  rewrite sat_falsep.
  pose proof proj2_sig Phi.
  pose proof AL_CONSI _ H0.
  rewrite consistent_spec in H1.
  split; [intros [] |].
  intro; apply H1.
  apply derivable_assum; auto.
Qed.

Lemma truth_lemma_andp
      (AL_DC: at_least derivable_closed P)
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x && y <-> proj1_sig Phi (x && y)).
Proof.
  intros.
  rewrite sat_andp.
  rewrite DCS_andp_iff by (apply AL_DC, (proj2_sig Phi)).
  apply Morphisms_Prop.and_iff_morphism; auto.
Qed.

Lemma truth_lemma_orp
      (AL_DC: at_least derivable_closed P)
      (AL_OW: at_least orp_witnessed P)
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x || y <-> proj1_sig Phi (x || y)).
Proof.
  intros.
  rewrite sat_orp.
  rewrite DCS_orp_iff.
    2: apply AL_DC, (proj2_sig Phi).
    2: apply AL_OW, (proj2_sig Phi).
  apply Morphisms_Prop.or_iff_morphism; auto.
Qed.

End TruthLemma.


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

 This defines the static semantics of statements and expressions, pg. 63.

*)
Set Implicit Arguments.
Require Export TLC.LibEnv.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_LN_Env.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* This is equivalent to OK from LibEnv. *)
Inductive WFD : Delta -> Prop :=
  | WFD_empty   : WFD empty
  | WFD_xtau   : forall (d : Delta) (alpha : var) (k : Kappa),
                 get alpha d = None ->
                 WFD  d ->
                 WFD (d & alpha ~ k).
Hint Constructors WFD.

Inductive K : Delta -> Tau -> Kappa -> Prop :=
 | K_cint   : forall (d : Delta),
                  K d cint B

 | K_B     : forall (alpha : var) (d : Delta),
               get alpha d = Some B ->
               K d (ftvar alpha) B

 | K_star_A  : forall (alpha : var) (d : Delta),
                 get alpha d = Some A ->
                 K  d (ptype (ftvar alpha)) B

 | K_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (cross t0 t1) A

 | K_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (arrow t0 t1) A

 | K_ptype    :  forall (d : Delta) (tau : Tau),
                    K d tau A ->
                    K d (ptype tau) B

 | K_utype  : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
                (forall (alpha : var),
                   alpha \notin L ->
                   ok (d & alpha ~ k) ->
                   K  (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
                K d (utype k tau) A

 | K_etype  : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau) (p : Phi),
              (forall (alpha : var),
                 alpha \notin L ->
                 ok (d & alpha ~ k) ->
                 K (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
              K d (etype p k tau) A

 | K_B_A     : forall (d : Delta) (tau : Tau),
     K d tau B ->
     K d tau A.

Ltac K_constructors :=
  match goal with
   | H: K _ ?t B |- K _ ?t A => try apply K_B_A
   | |-  (K _ _ _)  =>
    try apply K_cint; try apply K_B; try apply K_star_A; try apply K_cross;
    try apply K_arrow; try apply K_ptype
  end.
Hint Extern 3 (K _ _ _) => (* idtac "(K _ _ _)";*) trace_goal; try K_constructors.

Inductive AK : Delta -> Tau -> Kappa -> Prop :=

 | AK_AK_K  : forall (d : Delta) (tau : Tau) (k : Kappa),
                   K  d tau k ->
                   AK d tau k

 | AK_A     : forall (d : Delta) (alpha : var),
                get alpha d = Some A ->
                AK d (ftvar alpha) A.

Hint Constructors AK.

Inductive ASGN : Delta -> Tau -> Prop :=

  | ASGN_cint  : forall (d : Delta),
                      ASGN d cint

  | ASGN_B     : forall (d : Delta) (alpha : var),
                   get alpha d = Some B ->
                   ASGN d (ftvar alpha)

  | ASGN_ptype : forall (d : Delta) (tau : Tau),
                   ASGN d (ptype tau)

  | ASGN_cross : forall (d : Delta) (t0 t1 : Tau),
                   ASGN d t0 ->
                   ASGN d t1 ->
                   ASGN d (cross t0 t1)

  | ASGN_arrow : forall (d : Delta) (t0 t1 : Tau),
                   ASGN d t0 ->
                   ASGN d t1 ->
                   ASGN d (arrow t0 t1)

  | ASGN_utype : forall (L : vars) (d : Delta)  (k : Kappa) (tau : Tau),
                 (forall (alpha : var),
                     alpha \notin L ->
                   ASGN (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau)) ->
                   ASGN d (utype k tau)

  | ASGN_etype : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
                 (forall (alpha : var),
                     alpha \notin L ->
                     ASGN (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau)) ->
                   ASGN d (etype witnesschanges k tau).
Hint Constructors ASGN.

Inductive WFU : Upsilon -> Prop :=
  | WFU_empty : WFU LVPE.V.empty
  | WFU_A   : forall (u : Upsilon) (tau : Tau) (p : Path) (x : var),
                 LVPE.okp u ->
                 LVPE.V.get (x,p) u = None ->
                 WFU  u ->
                 K empty tau A ->
                 WFU (u &p ((x,p) ~p tau)).
Hint Constructors WFU.

Inductive WFDG : Delta -> Gamma -> Prop :=
  | WFDG_d_empty : forall (d: Delta),
                     ok d ->
                     WFDG d empty
  | WFDG_xt      : forall (d: Delta) (g: Gamma) (x : var) (tau : Tau),
                     ok g ->
                     ok d ->
                     get x g = None ->
                     K d tau A ->
                     WFDG d g ->
                     WFDG d (g & (x ~ tau)).

Hint Constructors WFDG.
Hint Extern 1 (WFDG _ empty) => (* idtac "(WFDG _ _)";*) trace_goal; try apply WFDG_d_empty; auto.

Inductive WFC : Delta -> Upsilon -> Gamma -> Prop :=
  | WFC_DUG : forall (d : Delta) (g: Gamma) (u : Upsilon),
                WFDG d g ->
                WFU u ->
                WFC d u g.
Hint Constructors WFC.

(* Automation for judgements with LN constructors. *)

Ltac fv_of_kinding_goal :=
  match goal with
    | |- K ?d (utype _ ?tau) _   => constr:((fv_delta d) \u  (T.fv tau))
    | |- K ?d (etype _ _ ?tau) _ => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (utype _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (etype _ _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (etype _ _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
  end.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Coq.ZArith.ZArith
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Formats.Base.FixFormat.

Require Export
        Coq.Lists.List.

Notation "| ls |" := (Datatypes.length ls) : format_scope.

Section FixList.
  Context {A : Type}.
  Context {T : Type}.
  Context {cache : Cache}.
  Context {monoid : Monoid T}.

  Variable A_predicate : A -> Prop.
  Variable format_A : A -> CacheFormat -> Comp (T * CacheFormat).
  Variable A_decode : T -> CacheDecode -> Hopefully (A * T * CacheDecode).
  Variable A_cache_inv : CacheDecode -> Prop.
  Variable A_decode_pf : CorrectDecoder monoid A_predicate A_predicate
                                        eq format_A A_decode A_cache_inv
                                        format_A.

  Open Scope vector_scope.

  (* Could do this with a FixComp instead? *)
  Fixpoint format_list (xs : list A) (ce : CacheFormat)
    : Comp (T * CacheFormat) :=
    match xs with
    | nil => ret (mempty, ce)
    | x :: xs' => `(b1, env1) <- format_A x ce;
                  `(b2, env2) <- format_list xs' env1;
                  ret (mappend b1 b2, env2)
    end%comp.

  Fixpoint encode_list
           (encode_A : A -> CacheFormat -> T * CacheFormat)
           (xs : list A) (ce : CacheFormat)
    : T * CacheFormat :=
    match xs with
    | nil => (mempty, ce)
    | x :: xs' =>  let (b1, env1) := encode_A x ce in
                   let (b2, env2) := encode_list encode_A xs' env1 in
                   (mappend b1 b2, env2)
    end%comp.

  Fixpoint decode_list (s : nat) (b : T) (cd : CacheDecode) : Hopefully (list A * T * CacheDecode) :=
    match s with
    | O => Ok (nil, b, cd)
    | S s' => `(x, b1, e1) <- A_decode b cd;
              `(xs, b2, e2) <- decode_list s' b1 e1;
              Ok (x :: xs, b2, e2)
    end.

  Theorem FixList_decode_correct
    :
    forall sz ,
      CorrectDecoder
         monoid
         (fun ls => |ls| = sz /\ forall x, In x ls -> A_predicate x)
         (fun ls => |ls| = sz /\ forall x, In x ls -> A_predicate x)
         eq
         format_list (decode_list sz) A_cache_inv
         format_list.
  Proof.
    split.
    {
      intros env env' xenv l l' ext ? Eeq Ppred Penc.
      intuition; subst.
      revert H0.
      generalize dependent env. generalize dependent env'.
      generalize dependent xenv.
      generalize dependent l'. induction l.
      { intros.
        simpl in *; intuition; computes_to_inv;
          injections; simpl.
        rewrite mempty_left; eexists _, _; intuition eauto.
        simpl; computes_to_econstructor.
      }
      { intros; simpl in *.
        assert (A_predicate a) by eauto.
        unfold Bind2 in Penc; computes_to_inv; subst.
        destruct v; destruct v0; simpl in *.
        injections.
        destruct (proj1 A_decode_pf _ _ _ _ _ (mappend t0 ext) env_OK Eeq H Penc) as [ ? [? [? xenv_OK] ] ].
        intuition; destruct_ex.
        setoid_rewrite <- mappend_assoc; setoid_rewrite H1;
          simpl; subst.
        destruct (IHl t0 xenv _ H6 c) as [? [? ?] ];
          intuition eauto; subst.
        setoid_rewrite H5; simpl.
        eexists _, _; intuition.
        simpl; unfold Bind2; eauto.
      }
    }
    { induction sz; simpl; intros.
      - injections; simpl; repeat eexists; simpl; intuition eauto.
        symmetry; apply mempty_left.
      - destruct (A_decode t env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_list sz t0 c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 A_decode_pf) in Heqh; eauto;
          destruct Heqh; destruct_ex; intuition; subst;
            eapply IHsz in Heqh0; eauto; destruct Heqh0;
              destruct_ex; intuition; subst.
        simpl.
        eexists _, _; simpl; unfold id; intuition eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        simpl. rewrite mappend_assoc; reflexivity.
        subst; eauto.
    }
  Qed.

  Definition format_list_body
               (A_format_Impl : A -> CacheFormat -> T * CacheFormat)
:= (fun (acc: T * CacheFormat) x =>
                                    let (bacc, env) := acc in
                                       let (b1, env1) := A_format_Impl x env in
                                       (mappend bacc b1, env1)).

  Import Fiat.Computation.FixComp.LeastFixedPointFun.

  Definition format_list' : FormatM (store := cache) (list A) T :=
    LeastFixedPoint
      (fDom := [list A; CacheFormat])
      (fun format_list' xs =>
         match xs with
         | nil => fun env => ret (mempty, env)
         | x :: xs' =>
           format_A x ThenC format_list' xs'
         end).

  Lemma format_list_body_characterization A_format_Impl :
    forall xs base env,
      fold_left (format_list_body A_format_Impl) xs (base, env) =
      (let (b2, env2) := fold_left (format_list_body A_format_Impl) xs (mempty, env) in
       (mappend base b2, env2)).
  Proof.
    induction xs; simpl.
    + intros; rewrite mempty_right; reflexivity.
    + intros; destruct (A_format_Impl _ _).
      rewrite IHxs, mempty_left, (IHxs t).
      destruct (fold_left _ _ _).
      rewrite mappend_assoc; reflexivity.
  Qed.

  Lemma format_list_as_foldl encode_A :
    forall xs env,
      encode_list encode_A xs env =
      fold_left (format_list_body encode_A) xs (mempty, env).
  Proof.
    induction xs; simpl.
    + reflexivity.
    + intros; destruct (encode_A _ _).
      rewrite IHxs, mempty_left, (format_list_body_characterization encode_A xs t c).
      destruct (fold_left _ _ _); reflexivity.
  Qed.

  Lemma measure_format_length_Spec n :
    (forall (a : A) b ctx ctx',
        computes_to (format_A a ctx) (b, ctx')
        -> bin_measure b = n)
    -> forall l b ctx ctx',
      computes_to (format_list l ctx) (b, ctx') ->
      bin_measure b = n * (length l).
  Proof.
    induction l; simpl; intros.
    - computes_to_inv; injections.
      pose proof (mappend_measure mempty mempty) as H';
        rewrite mempty_left in H'.
      simpl bin_measure in H'; simpl mempty in H'; lia.
    - unfold Bind2 in *; computes_to_inv; injections.
      destruct v; destruct v0; simpl in *.
      rewrite mappend_measure.
      apply H in H0; rewrite H0.
      apply IHl in H0'; rewrite H0'.
      rewrite Mult.mult_succ_r.
      auto with arith.
  Qed.

End FixList.