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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal8.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq lst (drop (Zero) (drop (Zero) (Nil))) (drop (Zero) (drop (Zero) (Nil)))).
Admitted.
QuickChick lfind_hyp_test.


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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj11eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus Zero (plus lv1 lv0))).
Admitted.
QuickChick conj11eqsynthconj2.


(* 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.