Require Import bedrock2.Syntax bedrock2.NotationsCustomEntry.
Require Import bedrock2.FE310CSemantics.

Import Syntax BinInt String Datatypes List List.ListNotations ZArith.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition silly1 := func! (a) ~> c {
  b = load4(a + $16);
  store4(a + $14, b);
  c = load4(a + $16)
}.

Require Import coqutil.Macros.symmetry.

Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import bedrock2.Semantics bedrock2.ProgramLogic bedrock2.Array.
Require Import bedrock2.Map.Separation bedrock2.Map.SeparationLogic.
Require Import Coq.Lists.List coqutil.Map.OfListWord.
Require Import coqutil.Z.Lia.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.letexists.
Require Import coqutil.Tactics.rdelta.
Require Import coqutil.Word.Bitwidth32.
Import Map.Interface Interface.map OfFunc.map OfListWord.map.
Require Import bedrock2.AbsintWordToZ.
Require Import bedrock2.groundcbv.
Require Import coqutil.Tactics.rewr.
Require Import AdmitAxiom.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.
  Add Ring wring : (Properties.word.ring_theory (word := word))
        (preprocess [autorewrite with rew_word_morphism],
         morphism (Properties.word.ring_morph (word := word)),
         constants [Properties.word_cst]).

  Local Instance spec_of_silly1 : spec_of "silly1" := fun functions =>
      forall t m a bs R, Z.of_nat (length bs) = 32 ->
      (sep (eq (map.of_list_word_at a bs)) R) m ->
      WeakestPrecondition.call functions "silly1" t m [a]
      (fun T M rets => True).

  Ltac ring_simplify_unsigned_goal :=
    match goal with
    |- context [word.unsigned ?x] =>
      let Hrw := fresh in
      eassert (let y := _ in x = y) as Hrw by (
        let y := fresh in
        intros y; ring_simplify;
        subst y; trivial);
      rewrite !Hrw; clear Hrw
    end.
  Ltac ring_simplify_unsigned_in H :=
    match type of H with context [word.unsigned ?x] =>
      let Hrw := fresh in
      eassert (let y := _ in x = y) as Hrw by (
        let y := fresh in
        intros y; ring_simplify;
        subst y; trivial);
      rewrite !Hrw in H; clear Hrw
    end.
  Ltac ring_simplify_unsigned :=
    try ring_simplify_unsigned_goal;
    repeat match goal with
           | H: context [word.unsigned ?x] |- _ => ring_simplify_unsigned_in H
           end.

  Ltac unify_and_change lhs rhs :=
    let rhs := match rhs with ?x => x end in
    let __ := constr:(eq_refl : lhs = rhs) in
    change lhs with rhs in *.

  Ltac change_with_Z_literal W :=
    first [ let e := open_constr:(BinInt.Zpos _) in
            unify_and_change W e;
            requireZcst e
          | unify_and_change W open_constr:(BinInt.Z0)
          | let e := open_constr:(BinInt.Zneg _) in
            unify_and_change W e;
            requireZcst e].

  Ltac simplify_ZcstExpr_goal :=
    match goal with
    |- context [?e] =>
        requireZcstExpr e;
        assert_fails (idtac; requireZcst e);
        let e' := eval vm_compute in e in
        let Hrw := fresh in
        assert (e = e') as Hrw by (vm_cast_no_check (eq_refl e'));
        (* idtac "simplified" e "in GOAL"; *)
        progress rewrite Hrw; clear Hrw
    end.

  Ltac simplify_ZcstExpr_in H :=
    match type of H with context [?e] =>
        requireZcstExpr e;
        assert_fails (idtac; requireZcst e);
        let e' := eval vm_compute in e in
        let Hrw := fresh in
        assert (e = e') as Hrw by (vm_cast_no_check (eq_refl e'));
        (* idtac "simplified" e "in" H; *)
        progress rewrite Hrw in H; clear Hrw
    end.

  Ltac simplify_ZcstExpr_hyps :=
    repeat match goal with H : _ |- _ => simplify_ZcstExpr_in H end.

  Ltac simplify_ZcstExpr :=
    simplify_ZcstExpr_hyps; try simplify_ZcstExpr_goal.

  Ltac rewrite_unsigned_of_Z_goal :=
    match goal with
    |- context [@word.unsigned ?w ?W ?X] =>
      let E := constr:(@word.unsigned w W X) in
      let x := rdelta X in
      let z := match x with word.of_Z ?z => z end in
      rewrite ((@word.unsigned_of_Z w W _ z) : E = z mod 2^w)
    end.

  Ltac rewrite_unsigned_of_Z_in H :=
    match type of H with context [@word.unsigned ?w ?W ?X] =>
      let E := constr:(@word.unsigned w W X) in
      let x := rdelta X in
      let z := match x with word.of_Z ?z => z end in
      rewrite ((@word.unsigned_of_Z w W _ z) : E = z mod 2^w) in H
    end.

  Ltac wordcstexpr_tac := (* hacky *)
    repeat first
          [ progress ring_simplify_unsigned
          | rewrite !word.unsigned_add; cbv [word.wrap]
          | rewrite_unsigned_of_Z_goal ];
    repeat simplify_ZcstExpr_goal; trivial.

  Lemma List__splitZ_spec [A] (xsys : list A) i (H : 0 <= i < Z.of_nat (length xsys)) :
    let xs := firstn (Z.to_nat i) xsys in
    let ys := skipn (Z.to_nat i) xsys in
    xsys = xs ++ ys /\
    Z.of_nat (length xs) = i /\
    Z.of_nat (length ys) = Z.of_nat (length xsys) - i.
  Proof.
    pose proof eq_sym (firstn_skipn (Z.to_nat i) xsys).
    split; trivial.
    rewrite length_firstn_inbounds, length_skipn; blia.
  Qed.

  Ltac lift_head_let_in H :=
    match type of H with
    | let x := ?v in ?C =>
        let X := fresh x in
        pose v as X;
        let C := constr:(match X with x => C end) in
        change C in H
    end.

  Ltac flatten_hyps :=
    repeat match goal with
           | H : let x := ?v in ?C |- _ =>
               let X := fresh x in
               pose v as X;
               let C := constr:(match X with x => C end) in
               change C in H
           | H : _ /\ _ |- _ => destruct H
           | H : exists _, _ |- _ => destruct H
           end.

  Lemma List__splitZ_spec_n [A] (xsys : list A) i n
    (Hn : Z.of_nat (length xsys) = n) (H : 0 <= i < n) :
    let xs := firstn (Z.to_nat i) xsys in
    let ys := skipn (Z.to_nat i) xsys in
    xsys = xs ++ ys /\
    Z.of_nat (length xs) = i /\
    Z.of_nat (length ys) = n - i.
  Proof.
    pose proof eq_sym (firstn_skipn (Z.to_nat i) xsys).
    split; trivial.
    rewrite length_firstn_inbounds, length_skipn; blia.
  Qed.

  Ltac List__splitZ bs n :=
      match goal with H: Z.of_nat (length bs) = _ |- _ =>
          pose proof List__splitZ_spec_n bs n _ H ltac:(blia);
          clear H; flatten_hyps; simplify_ZcstExpr;
          let Hrw := lazymatch goal with H : bs = _ ++ _ |- _ => H end in
          let eqn := type of Hrw in
          rewr ltac:(fun t => match t with
                              | eqn => fail 1
                              | _ => constr:(Hrw) end) in *
      end.

  Lemma map__of_list_word_at_app_n [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs)
    : map.of_list_word_at a (xs ++ ys)
    = putmany (map.of_list_word_at (word.add a (word.of_Z lxs)) ys) (map.of_list_word_at a xs).
  Proof. subst lxs; apply map.of_list_word_at_app. Qed.

  Lemma map__adjacent_arrays_disjoint_n [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs)
    (H :Z.of_nat (length xs) + Z.of_nat (length ys) <= 2 ^ 32)
    : disjoint (map.of_list_word_at (word.add a (word.of_Z lxs)) ys) (map.of_list_word_at a xs).
  Proof. subst lxs. auto using map.adjacent_arrays_disjoint. Qed.

      Declare Scope word_scope.
      Bind Scope word_scope with word.
      Delimit Scope word_scope with word.
      Local Notation "a + b" := (word.add a b) (at level 50, left associativity, format "a + b") : word_scope.
      Local Infix "-" := word.sub : word_scope.
      Local Coercion Z.of_nat : nat >-> Z.
      Local Infix "$+" := putmany (at level 70).
      Local Notation "xs $@ a" := (map.of_list_word_at a%word xs) (at level 10, format "xs $@ a").
      Local Notation "! x" := (word.of_Z x) (at level 10, format "! x").
      Local Notation "a * b" := (sep a%type b%type) : type_scope.
      Local Open Scope word_scope.

  Lemma sep_eq_putmany [key value] [map : map.map key value] (a b : map) (H : disjoint a b) : Lift1Prop.iff1 (eq (a $+ b)) (sep (eq a) (eq b)).
  Proof.
    split.
    { intros; subst. eexists _, _; eauto using Properties.map.split_disjoint_putmany. }
    { intros (?&?&(?&?)&?&?); subst; trivial. }
  Qed.

  Lemma sep_eq_of_list_word_at_app [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs) (Htotal : length xs + length ys <= 2^32)
    : Lift1Prop.iff1 (eq (map.of_list_word_at a (xs ++ ys)))
      (sep (eq (map.of_list_word_at a xs)) (eq (map.of_list_word_at (word.add a (word.of_Z lxs)) ys))).
  Proof.
    etransitivity.
    2: eapply sep_comm.
    etransitivity.
    2: eapply sep_eq_putmany, map__adjacent_arrays_disjoint_n; trivial.
    erewrite map__of_list_word_at_app_n by eauto; reflexivity.
  Qed.

  Lemma list_word_at_app_of_adjacent_eq [value] [map : map.map word value] {ok : map.ok map}
    (a b : word) (xs ys : list value)
    (Hl: word.unsigned (word.sub b a) = Z.of_nat (length xs))
    (Htotal : length xs + length ys <= 2^32)
    : Lift1Prop.iff1
        (sep (eq (map.of_list_word_at a xs)) (eq (map.of_list_word_at b ys)) )
        (eq (map.of_list_word_at a (xs ++ ys))).
  Proof.
    etransitivity.
    2:symmetry; eapply sep_eq_of_list_word_at_app; trivial.
    do 3 Morphisms.f_equiv. rewrite <-Hl, word.of_Z_unsigned. ring.
  Qed.

  Lemma of_list_word_nil
    [value] [map : map.map word value] {ok : map.ok map}
    k : []$@k = empty(map:=map).
  Proof. apply Properties.map.fold_empty. Qed.
  Lemma of_list_word_singleton
    [value] [map : map.map word value] {ok : map.ok map}
    (k : word) (v : value) : [v]$@k = put empty k v.
  Proof.
    cbv [of_list_word_at of_list_word seq length List.map of_func update].
    rewrite word.unsigned_of_Z_0, Z2Nat.inj_0; cbv [MapKeys.map.map_keys nth_error].
    rewrite Properties.map.fold_singleton.
    f_equal; cbn [Z.of_nat].
    eapply word.unsigned_inj; rewrite word.unsigned_add; cbv [word.wrap]; rewrite word.unsigned_of_Z_0, Z.add_0_r, Z.mod_small; trivial; eapply word.unsigned_range.
  Qed.

  Import ptsto_bytes Lift1Prop Morphisms.
  Lemma eq_of_list_word_iff_array1 [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (bs : list value)
    (H : length bs <= 2 ^ 32) :
    iff1 (eq (bs$@a)) (array ptsto (word.of_Z 1) a bs).
  Proof.
    revert H; revert a; induction bs; cbn [array]; intros.
    { rewrite of_list_word_nil; cbv [emp iff1]; intuition auto. }
    { etransitivity.
      2: eapply Proper_sep_iff1.
      3: eapply IHbs.
      2: reflexivity.
      2: cbn [length] in H; blia.
      change (a::bs) with ([a]++bs).
      rewrite of_list_word_at_app.
      etransitivity.
      1: eapply sep_eq_putmany, adjacent_arrays_disjoint; cbn [length] in *; blia.
      etransitivity.
      2:eapply sep_comm.
      f_equiv.
      rewrite of_list_word_singleton; try exact _.
      cbv [ptsto iff1]; intuition auto. }
  Qed.

  Ltac ring_simplify_address_in H :=
    match type of H with context [_ $@ ?x] =>
      let Hrw := fresh in
      eassert (let y := _ in x = y) as Hrw by (
        let y := fresh in
        intros y; ring_simplify;
        subst y; trivial);
      rewrite !Hrw in H; clear Hrw
    end.

  Ltac split_bytes_base_addr bs a0 ai :=
      let raw_i := constr:(word.unsigned (ai-a0)%word) in
      let Hidx := fresh "Hidx" in
      eassert (raw_i = _) as Hidx by (
        ring_simplify_unsigned_goal; repeat rewrite_unsigned_of_Z_goal;
        simplify_ZcstExpr; exact eq_refl);
      let i := match type of Hidx with _ = ?r => r end in
      let Happ := fresh "Happ" in
      match goal with H: Z.of_nat (length bs) = _ |- _ =>
          pose proof List__splitZ_spec_n bs i _ H ltac:(blia) as Happ;
          clear H
      end;
      repeat lift_head_let_in Happ; case Happ as (Happ&?H1l&?H2l);
      simplify_ZcstExpr;
      let eqn := type of Happ in
      rewr ltac:(fun t => match t with
                          | eqn => fail 1
                          | _ => constr:(Happ) end) in *;
      repeat match goal with Hsep : _ |- _ =>
        seprewrite_in_by sep_eq_of_list_word_at_app Hsep ltac:(
          try eassumption; try blia)
      end.

  Section __.
    Import WithoutTuples.
    Lemma load_bytes_of_putmany_bytes_at bs a (mR:mem) n (Hn : length bs = n) (Hl : Z.of_nat n < 2^32)
      : load_bytes (mR $+ bs$@a) a n = Some bs.
    Proof.
      destruct (load_bytes (mR $+ bs$@a) a n) eqn:HN in *; cycle 1.
      { exfalso; eapply load_bytes_None in HN; case HN as (i&?&?).
        case (Properties.map.putmany_spec mR (bs$@a) (a+!(BinIntDef.Z.of_nat i))%word) as [(?&?&?)| (?&?) ]; try congruence.
        rewrite get_of_list_word_at in H1; eapply nth_error_None in H1.
        revert H1.
        rewrite word.word_sub_add_l_same_l, word.unsigned_of_Z.
        cbv [word.wrap]; rewrite Z.mod_small, Nat2Z.id; eauto; blia. }
      transitivity (Some l); try congruence; f_equal; subst n.
      symmetry; eapply nth_error_ext_samelength.
      { symmetry; eauto using length_load_bytes. }
      intros.
      pose proof nth_error_load_bytes _ a _ _ HN i ltac:(trivial) as HH.
      epose proof H; eapply nth_error_nth' with (d:=Byte.x00) in H.
      erewrite Properties.map.get_putmany_right in HH; cycle 1.
      { rewrite get_of_list_word_at.
        rewrite word.word_sub_add_l_same_l, word.unsigned_of_Z.
        cbv [word.wrap]; rewrite Z.mod_small, Nat2Z.id; eauto; blia. }
      congruence.
    Qed.

    Lemma load_bytes_of_sep_bytes_at bs a R (m:mem) (Hsep: (eq(bs$@a)*R) m) n (Hn : length bs = n) (Hl : Z.of_nat n < 2^32)
      : load_bytes m a n = Some bs.
    Proof.
      eapply sep_comm in Hsep.
      destruct Hsep as (mR&?&(?&?)&?&?); subst.
      eapply load_bytes_of_putmany_bytes_at; eauto.
    Qed.
  End __.

  Lemma load_four_bytes_of_sep_at bs a R (m:mem) (Hsep: (eq(bs$@a)*R) m) (Hl : length bs = 4%nat) :
    load access_size.four m a = Some (word.of_Z (LittleEndianList.le_combine bs)).
  Proof.
    eapply Scalars.load_four_bytes_of_sep_at; try eassumption.
  Qed.

  Lemma uncurried_load_four_bytes_of_sep_at bs a R (m : mem)
    (H: (eq(bs$@a)*R) m /\ length bs = 4%nat) :
    load access_size.four m a = Some (word.of_Z (LittleEndianList.le_combine bs)).
  Proof. eapply Scalars.uncurried_load_four_bytes_of_sep_at; try eassumption. Qed.

  Lemma Z_uncurried_load_four_bytes_of_sep_at bs a R (m : mem)
    (H: (eq(bs$@a)*R) m /\ Z.of_nat (length bs) = 4) :
    load access_size.four m a = Some (word.of_Z (LittleEndianList.le_combine bs)).
  Proof. eapply Scalars.Z_uncurried_load_four_bytes_of_sep_at; try eassumption. Qed.

  (*
  Lemma store_four_of_sep addr (oldvalue : word32) (value : word) R m (post:_->Prop)
    (Hsep : sep (scalar32 addr oldvalue) R m)
    (Hpost : forall m, sep (scalar32 addr (word.of_Z (word.unsigned value))) R m -> post m)
    : exists m1, Memory.store Syntax.access_size.four m addr value = Some m1 /\ post m1.
  Proof.
  *)

  Ltac split_flat_memory_based_on_goal :=
    lazymatch goal with
    | |- load ?sz ?m ?a = _ =>
        let sz := eval cbv in (Z.of_nat (bytes_per (width:=32) sz)) in
        match goal with H : ?S m |- _ =>
        match S with context[?bs $@ ?a0] =>
        let a_r := constr:(word.add a (word.of_Z sz)) in
        split_bytes_base_addr bs a0 a_r end;
        match type of H with context[?bs $@ ?a0] =>
        split_bytes_base_addr bs a0 a end end
    | |- WeakestPrecondition.store ?sz ?m ?a _ _ =>
        let sz := eval cbv in (Z.of_nat (bytes_per (width:=32) sz)) in
        match goal with H : ?S m |- _ =>
        match S with context[?bs $@ ?a0] =>
        let a_r := constr:(word.add a (word.of_Z sz)) in
        split_bytes_base_addr bs a0 a_r end;
        match type of H with context[?bs $@ ?a0] =>
        split_bytes_base_addr bs a0 a end end
    end.

  Ltac subst_lets :=
    repeat match goal with x := ?v |- _ => assert_fails (is_evar v); subst x end.

  Ltac set_evars :=
    repeat match goal with
           | |- context [?e] => is_evar e; set e in *
           | H: context [?e] |- _ => is_evar e; set e in *
           end.
  Ltac subst_evars :=
    repeat match goal with
    x := ?e |- _ => is_evar e; subst x
           end.

  Lemma and_weaken_left (A A' B : Prop) : A -> A' -> A /\ B -> A' /\ B.
  Proof. tauto. Qed.

  Ltac on_left tac :=
      let A := open_constr:(_:Prop) in
      let k := open_constr:(_:A) in
      unshelve simple notypeclasses refine (and_weaken_left A _ _ k _ _);
        [> tac; try [> exact k ] | ];
      cbv delta [and_weaken_left] (* drop cast *);
      (* did tac solve the goal? *)
      (* "match A with ?A" strips outer casts *)
      tryif match A with ?A => is_evar A end
      then simple notypeclasses refine (conj I _)
      else idtac.
  Tactic Notation "on_left" tactic3(tac) := on_left tac.

  Import ProgramLogic.Coercions.

  (* note: do we want an Ltac coding rule that tactics must not start with a match? *)
  Local Ltac ecancel_assumption := idtac; SeparationLogic.ecancel_assumption.

(*
Import coqutil.Macros.subst.
Ltac flatten_hyps :=
  repeat match goal with
  | H : exists _, _ |- _ => destruct H as (?&H)
  | H : _ /\ _  |- _ => destruct H as (?&H)
  | H : let x := ?v in ?C |- _ =>
      let y := fresh x in pose v as y;
        change (subst! y for x in C) in H
  end.
*)
Ltac flatten_goal :=
  repeat match goal with
         | |- (_ /\ _) /\ _ => eapply and_assoc
         end.
Ltac flatten := flatten_hyps; flatten_goal.

Ltac simpl_lengths_step :=
  match goal with
  | _ => progress groundcbv_in_all
  | H : Z.of_nat (length ?x) = ?v |- _ =>
    let t' := type of H in
    assert_fails(t'); first [is_var v | is_ground v];
    progress rewr ltac:(fun t =>
      match t with
      | t' => fail 1
      | context[Z.of_nat (length x)] => H
      end) in *
  | _ => progress rewr ltac:(fun t =>
      match t with
      | context[@List.length ?A (List.app ?x ?y)] => constr:(@app_length A x y)
      end) in *
  end.
Ltac simpl_lengths := repeat simpl_lengths_step.

  Lemma silly1_ok : program_logic_goal_for_function! silly1.
  Proof.
    repeat (straightline || apply WeakestPreconditionProperties.dexpr_expr).

    eexists ?[v].

    on_left eapply Z_uncurried_load_four_bytes_of_sep_at.

    pose proof List__splitZ_spec_n bs 20 _ H ltac:(blia).
    flatten; simpl_lengths.
    set_evars; rewrite H1 in *; subst_evars.
    seprewrite_in_by sep_eq_of_list_word_at_app H0
      ltac:(trivial || blia); simpl_lengths.

    pose proof List__splitZ_spec_n _ 16 _ H2 ltac:(blia);
    flatten; simpl_lengths.
    set_evars; rewrite H4 in *; subst_evars; simpl_lengths.
    seprewrite_in_by sep_eq_of_list_word_at_app H0
      ltac:(trivial || blia); simpl_lengths.

    on_left ecancel_assumption. (*  this inlines definition of ys0, makes length proof annoying *)
    match goal with |- context[?x] => change x with ys0 end.

    split; [ trivial | ].

    repeat straightline. (* this inlines too many lets *)

    (* store4(a + $14, b); *)

    cbv [WeakestPrecondition.store].

    (* remerge *)
    seprewrite_in_by @list_word_at_app_of_adjacent_eq H0 ltac:(
      simpl_lengths; rewrite ?word.word_sub_add_l_same_l, ?word.unsigned_of_Z; trivial; clear;blia).
    repeat seprewrite_in_by @list_word_at_app_of_adjacent_eq H0 ltac:(
      rewrite ?app_length; wordcstexpr_tac; simpl_lengths; blia).

    Tactics.rapply (fun addr oldvalue value R m post H => Scalars.store_four_of_sep addr oldvalue value R m post (proj1 H) (proj2 H)).

    (* note: it would be nice to have a generalization of this /\-goal logic in on_left *)
    unshelve (
    let x := open_constr:(_ : _ /\ (_ /\ _)) in
    once (on_left (idtac; seprewrite (symmetry! (fun _: 32 <= 32 => @Scalars.scalar32_of_bytes)))); [exact (proj1 (proj2 x)) | exact (proj1 x) | exact (proj2 (proj2 x))]); shelve_unifiable.
    2: reflexivity. (* already in goal 1, but should only be there and not a second subgoal *)
    on_left (idtac; seprewrite @array1_iff_eq_of_list_word_at; cycle 1); cycle 1.

    (* frame calculation again, unclear what to subst before split_bytes_base_addr *)
    (* maybe make a rewrite that follows lets *)

    {
    eassert (Z.of_nat (length ((xs0 ++ ys0) ++ ys)) = _). {
      rewrite ?app_length.
      rewrite ?Nat2Z.inj_add.
      repeat match goal with
             | H: Z.of_nat (length ?x) = ?y |- context[length ?x] => rewrite H
             end.
      simplify_ZcstExpr.
      reflexivity.
    }

    repeat match goal with x := _ : word.rep |- _ => subst x end.
    set_evars.
    replace (length l1 = 4%nat) with (Z.of_nat (length l1) = 4) by case proof_admitted.

    match goal with |- context[?P m] =>
    match P with context[?e$@?a] =>
    match goal with | |- context[Z.of_nat (length e) = ?n] =>
    match goal with H : ?S m |- _ =>
    match S with context[?bs $@ ?a0] =>
    let a_r := constr:(word.add a (word.of_Z n)) in
    split_bytes_base_addr bs a0 a_r end;
    match type of H with context[?bs $@ ?a0] =>
    split_bytes_base_addr bs a0 a
end end
    end end end.

    on_left ecancel_assumption.
    split; [trivial|].
    split; [reflexivity|].

    repeat (straightline || apply WeakestPreconditionProperties.dexpr_expr).

    (* last line *)

    subst P.
    all: case proof_admitted. }

    Unshelve.
    all : case proof_admitted.

  Time Qed.

End WithParameters.

(* think of mempcpy/memmove within a packet rather than load and store, which are just "special cases" of memmove

operations on bytes

extend to other access_size?

 *)


Require Import FunctionApp.

Local Open Scope type_scope.

(** We apply AC_∞, the type-theoretic axiom of choice, so that
          we don't need to do higher order unification later. *)
Lemma emptiesStackStep' input world pf
      (H : forall i : input,
             { p' : stackProcess input world
             & emptiesStack (stackTransition i pf) p' *
               emptiesStackForever p' })
: @emptiesStackForever input world (Step pf).
Proof.
  econstructor.
  intro i.
  exists (projT1 (H i)).
  split; apply (projT2 (H _)).
Defined.

Definition stackProcess_eta input world (p : stackProcess input world)
: p = match p with
        | Step f => Step f
      end.
Proof.
  destruct p; reflexivity.
Defined.

Definition process_eta input world (p : process input world)
: p = match p with
        | Step f => Step f
      end.
Proof.
  destruct p; reflexivity.
Defined.

Lemma emptiesStackDone' input world p q (H : p = q) : @emptiesStack input world (stackDone, p) q.
Proof.
  subst.
  constructor.
Defined.

Lemma emptiesStackPush_sigT {input world} (m : input) (sw : stackWorld input world)
      (pf : stackStep) P
: { p2 : stackProcess input world & emptiesStack (stackTransition m pf) p2 * { p3 : _ & emptiesStack (sw, p2) p3 * P p3 } }
  -> { p3 : _ & emptiesStack (stackPush m sw, Step pf) p3 * P p3 }.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackPush | ];
  first [ apply (fst (projT2 H))
        | apply (fst (projT2 (snd (projT2 H))))
        | apply (snd (projT2 (snd (projT2 H)))) ].
Defined.

Lemma emptiesStackLift_sigT {input world} (a : action world) (sw : stackWorld input world)
      (p : stackProcess input world) P
: { p2 : _ & emptiesStack (sw, p) p2 * P p2 }
  -> { p2 : _ & emptiesStack (stackLift a sw, p) p2 * P p2 }.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackLift | ];
  first [ apply (fst (projT2 H))
        | apply (snd (projT2 H)) ].
Defined.

Lemma emptiesStackDone_sigT {input world} p (P : stackProcess input world -> Type)
: P p -> { p' : _ & emptiesStack (stackDone, p) p' * P p' }.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackDone | ]; eassumption.
Defined.

Lemma emptiesStackPush_ex {input world} (m : input) (sw : stackWorld input world)
      (pf : stackStep) P
: (exists p2 : stackProcess input world,
     emptiesStack (stackTransition m pf) p2
     /\ exists p3 : _, emptiesStack (sw, p2) p3 /\ P p3)
  -> exists p3 : _, emptiesStack (stackPush m sw, Step pf) p3 /\ P p3.
Proof.
  intros [? [? [? [? ?]]]].
  eexists.
  split; [ eapply emptiesStackPush | ];
  eassumption.
Defined.

Lemma emptiesStackLift_ex {input world} (a : action world) (sw : stackWorld input world)
      (p : stackProcess input world) P
: (exists p2 : _, emptiesStack (sw, p) p2 /\ P p2)
  -> exists p2 : _, emptiesStack (stackLift a sw, p) p2 /\ P p2.
Proof.
  intros [? [? ?]].
  eexists.
  split; [ eapply emptiesStackLift | ];
  eassumption.
Defined.

Lemma emptiesStackDone_ex {input world} p (P : stackProcess input world -> Prop)
: P p -> exists p' : _, emptiesStack (stackDone, p) p' /\ P p'.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackDone | ]; eassumption.
Defined.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                          PriorityDecode_Proof.v                          *)
(****************************************************************************)

Require Export PickSuccessfulInput.
Require Export Arbitration.
Require Export Moore_Mealy.

Set Implicit Arguments.
Unset Strict Implicit.

Section PriorityDecode_Correctness.

  Let Input_type :=
    (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4))%type.

  Let Output_type := d_list (d_list bool 4) 4.

  Inductive label_p : Set :=
    | START_p : label_p
    | DECODE_p : label_p.

  Definition STATE_p : Set := (label_p * d_list (d_list bool 4) 4)%type.

(** Automaton describing the transitions from a state to another **)

  Definition Convert_and_filter (i : Input_type) : Output_type :=
    let (act, p) := i in
    let (pri, route) := p in
    d_map (PriorityRequests act pri) (merge (d_map Convert_list2 route)).

  Definition Trans_PriorityDecode (i : Input_type)
    (s : STATE_p) : STATE_p := (DECODE_p, Convert_and_filter i).

(** Each state corresponds to a result **)

  Definition Out_PriorityDecode (s : STATE_p) : Output_type :=
    let (s', old) := s in old.

(** States stream **)

  Definition States_PRIORITY_DECODE := States_Mealy Trans_PriorityDecode.

(** Intented behaviour **)

  Definition Behaviour_PRIORITY_DECODE :=
    Moore Trans_PriorityDecode Out_PriorityDecode.

(** Transformation of Behaviour_PRIORITY_DECODE to a Mealy automaton **)

  Definition Out_PriorityDecode_Mealy :=
    Out_Mealy (Input_type:=Input_type) Out_PriorityDecode.

  Lemma equiv_out_PriorityDecode :
   forall (i : Input_type) (s : STATE_p),
   Out_PriorityDecode s = Out_PriorityDecode_Mealy i s.
  Proof.
  auto.
  Qed.

  Lemma Equiv_PriorityDecode_Moore_Mealy :
   forall (s : STATE_p) (i : Stream Input_type),
   EqS (Behaviour_PRIORITY_DECODE i s)
     (Mealy Trans_PriorityDecode Out_PriorityDecode_Mealy i s).
  Proof.
  intros s i.
  unfold Behaviour_PRIORITY_DECODE in |- *;
   unfold Out_PriorityDecode_Mealy in |- *; apply Equiv_Moore_Mealy.
  Qed.

  Definition States_Structure_PRIORITY_DECODE :=
    States_Mealy Trans_priority_decode.

 (** No invariant property *)

  Let Reg_type := d_list (d_list bool 4) 4. (* Type of the registers of PRIORITY_DECODE *)

  Let Cst_True (i : Input_type) (s : STATE_p) (reg : Reg_type) := True.

  Definition R_Priority_Decode (s : STATE_p) (reg : Reg_type) :=
    reg = Out_PriorityDecode s.

 (* Cst_True is an invariant *)

  Lemma Cst_True_inv_pdecode :
   forall (i : Stream Input_type) (s : STATE_p) (reg : Reg_type),
   Inv Cst_True i (States_PRIORITY_DECODE i s)
     (States_Structure_PRIORITY_DECODE i reg).

  Proof.
  cofix Cst_True_inv_pdecode.
  intros i s reg.
  apply Inv_Ok.
  unfold Cst_True in |- *; auto.
  Qed.

(** Because the unit is essentially combinational, we assume its correctness **)

  Axiom
    Invariant_relation_p :
      Inv_under_P Trans_PriorityDecode Trans_priority_decode Cst_True
        R_Priority_Decode.

  Lemma Output_relation_p :
   Output_rel Out_PriorityDecode_Mealy Out_priority_decode R_Priority_Decode.

  Proof.
  unfold Output_rel in |- *; auto.
  Qed.

(** Correctness lemma  **)

  Lemma Correct_PRIORITY_DECODE :
   forall (i : Stream Input_type) (reg : Reg_type) (s : STATE_p),
   R_Priority_Decode s reg ->
   EqS (Behaviour_PRIORITY_DECODE i s) (Structure_PRIORITY_DECODE i reg).

  Proof.
  intros i reg s HR.
  unfold Structure_PRIORITY_DECODE in |- *;
   unfold Behaviour_PRIORITY_DECODE in |- *.
  apply
   (Equiv_2_Mealy Invariant_relation_p Output_relation_p
      (Cst_True_inv_pdecode i s reg) HR).

  Qed.

End PriorityDecode_Correctness.


Require Import Coq.omega.Omega.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.ContextDefinitions.
Require Import Crypto.Reflection.Named.NameUtil.
Require Import Crypto.Reflection.Named.NameUtilProperties.
Require Import Crypto.Reflection.Named.ContextProperties.
Require Import Crypto.Reflection.Named.ContextProperties.Tactics.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.

Section with_context.
  Context {base_type_code Name var} (Context : @Context base_type_code Name var)
          (base_type_code_dec : DecidableRel (@eq base_type_code))
          (Name_dec : DecidableRel (@eq Name))
          (ContextOk : ContextOk Context).

  Local Notation find_Name := (@find_Name base_type_code Name Name_dec).
  Local Notation find_Name_and_val := (@find_Name_and_val base_type_code Name base_type_code_dec Name_dec).

  Hint Rewrite (@find_Name_and_val_default_to_None _ _ base_type_code_dec Name_dec) using congruence : ctx_db.
  Hint Rewrite (@find_Name_and_val_different _ _ base_type_code_dec Name_dec) using assumption : ctx_db.
  Hint Rewrite (@find_Name_and_val_wrong_type _ _ base_type_code_dec Name_dec) using congruence : ctx_db.
  Hint Rewrite (@snd_split_onames_skipn base_type_code Name) : ctx_db.

  Local Ltac misc_oname_t_step :=
    match goal with
    | [ H : oname_list_unique (List.skipn _ _) -> _ |- _ ]
      => specialize (fun pf => H (@oname_list_unique_skipn _ _ _ pf))
    | [ H : ((_, _) = (_, _))%core -> _ |- _ ]
      => specialize (fun a b => H (f_equal2 (@pair _ _) a b))
    | [ H : ?x = (_,_)%core -> _ |- _ ]
      => rewrite (surjective_pairing x) in H;
           specialize (fun a b => H (f_equal2 (@pair _ _) a b))
    end.

  Lemma split_onames_find_Name
        {n T N ls ls'}
        (H : split_onames _ ls = (Some N, ls')%core)
    : (exists t, @find_Name n T N = Some t)
      <-> List.In (Some n) (List.firstn (CountLets.count_pairs T) ls).
  Proof.
    revert dependent ls; intro ls; revert ls ls'; induction T; intros;
      [ | | specialize (IHT1 (fst N) ls (snd (split_onames T1 ls)));
            specialize (IHT2 (snd N) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ];
      repeat first [ misc_oname_t_step
                   | t_step
                   | progress split_iff
                   | progress specialize_by (eexists; eauto)
                   | solve [ eauto using In_skipn, In_firstn ]
                   | match goal with
                     | [ H : List.In ?x (List.firstn ?n ?ls) |- List.In ?x (List.firstn (?n + ?m) ?ls) ]
                       => apply (In_firstn n); rewrite firstn_firstn by omega
                     | [ H : _ |- _ ] => first [ rewrite firstn_skipn_add in H
                                               | rewrite firstn_firstn in H by omega ]
                     | [ H : List.In ?x' (List.firstn (?n + ?m) ?ls) |- List.In ?x' (List.firstn ?m (List.skipn ?n ?ls)) ]
                       => apply (In_firstn_skipn_split n) in H
                     end ].
  Qed.

  Lemma split_onames_find_Name_Some_unique_iff
        {n T N ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
    : (exists t, @find_Name n T N = Some t)
      <-> List.In (Some n) ls /\ ~List.In (Some n) ls'.
  Proof.
    rewrite (split_onames_find_Name (ls':=ls') (ls:=ls)) by assumption.
    rewrite (surjective_pairing (split_onames _ _)) in H.
    rewrite fst_split_onames_firstn, snd_split_onames_skipn in H.
    inversion_prod; subst.
    split; [ split | intros [? ?] ]; eauto using In_firstn, oname_list_unique_specialize.
    eapply In_firstn_skipn_split in H; destruct_head' or; eauto; exfalso; eauto.
  Qed.

  Lemma split_onames_find_Name_Some_unique
        {t n T N ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
        (Hfind : @find_Name n T N = Some t)
    : List.In (Some n) ls /\ ~List.In (Some n) ls'.
  Proof.
    eapply split_onames_find_Name_Some_unique_iff; eauto.
  Qed.

  Lemma flatten_binding_list_find_Name_and_val_unique
        {var' t n T N V v ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
    : @find_Name_and_val var' t n T N V None = Some v
      <-> List.In (existT (fun t => (Name * var' t)%type) t (n, v)) (Wf.flatten_binding_list N V).
  Proof.
    revert dependent ls; intro ls; revert ls ls'; induction T; intros;
      [ | | specialize (IHT1 (fst N) (fst V) ls (snd (split_onames T1 ls)));
            specialize (IHT2 (snd N) (snd V) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ];
      repeat first [ find_Name_and_val_default_to_None_step
                   | progress simpl in *
                   | rewrite List.in_app_iff
                   | misc_oname_t_step
                   | t_step
                   | progress split_iff
                   | lazymatch goal with
                     | [ H : find_Name ?n ?x = Some ?t, H' : find_Name_and_val ?t' ?n ?X ?V None = Some ?v |- _ ]
                       => apply find_Name_and_val_find_Name_Some in H'
                     | [ H : find_Name ?n ?x = Some ?t, H' : find_Name ?n ?x' = Some ?t' |- _ ]
                       => let apply_in_tac H :=
                              (eapply split_onames_find_Name_Some_unique in H;
                               [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ];
                               [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ]) in
                          first [ constr_eq x x'; fail 1
                                | apply_in_tac H; apply_in_tac H' ]
                     end ].
  Qed.

  Lemma fst_split_mnames__flatten_binding_list__find_Name
        (MName : Type) (force : MName -> option Name)
        {var' t n T N V v} {ls : list MName}
        (Hs : fst (split_mnames force T ls) = Some N)
        (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list (var2:=var') N V))
    : find_Name n N = Some t.
  Proof.
    revert dependent ls; induction T;
      [ | | specialize (IHT1 (fst N) (fst V));
            specialize (IHT2 (snd N) (snd V)) ];
      repeat first [ misc_oname_t_step
                   | t_step
                   | match goal with
                     | [ H : _ |- _ ] => first [ rewrite snd_split_mnames_skipn in H
                                               | rewrite List.in_app_iff in H ]
                     | [ H : context[fst (split_mnames _ _ ?ls)] |- _ ]
                       => is_var ls; rewrite (@fst_split_mnames_firstn _ _ _ _ _ ls) in H
                     end ].
  Abort.

  Lemma fst_split_mnames__find_Name__flatten_binding_list
        (MName : Type) (force : MName -> option Name)
        {var' t n T N V v default} {ls : list MName}
        (Hs : fst (split_mnames force T ls) = Some N)
        (Hfind : find_Name n N = Some t)
        (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list N V))
    : @find_Name_and_val var' t n T N V default = Some v.
  Proof.
    revert default; revert dependent ls; induction T;
      [ | | specialize (IHT1 (fst N) (fst V));
            specialize (IHT2 (snd N) (snd V)) ];
      repeat first [ find_Name_and_val_default_to_None_step
                   | rewrite List.in_app_iff in *
                   | t_step ].
  Abort.
End with_context.


Unset Strict Universe Declaration.
(* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *)
(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *)

Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V.
Module NonPrim.
  Record hProp := hp { hproptype :> Type ; isp : Set}.
  Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp)
              (C : Type) (h : C -> V) (b : B) (a : A) (c : C),
         H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c).
    intros A B H_f H_g C h b a c H3 H'.
    exact (@transport hProp (fun x => x) _ _ H' H3).
    Undo.
    Set Debug Unification.
    exact (H' # H3).
  Defined.
End NonPrim.

Module Prim.
  Set Primitive Projections.
  Set Universe Polymorphism.
  Record hProp := hp { hproptype :> Type ; isp : Set}.
  Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp)
              (C : Type) (h : C -> V) (b : B) (a : A) (c : C),
         H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c).
    intros A B H_f H_g C h b a c H3 H'.
    exact (@transport hProp (fun x => x) _ _ H' H3).
    Undo.
    Set Debug Unification.
    exact (H' # H3).
    (* Toplevel input, characters 7-14:
Error:
In environment
A : Type
B : Type
H_f : A -> V -> hProp
H_g : B -> V -> hProp
C : Type
h : C -> V
b : B
a : A
c : C
H3 : H_f a (h c)
H' : H_f a (h c) = H_g b (h c)
Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))".
 *)
  Defined.
End Prim.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Notations.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** These are the notations whose level and associativity are imposed by Coq *)

(** Notations for propositional connectives *)

Reserved Notation "x <-> y" (at level 95, no associativity).
Reserved Notation "x /\ y" (at level 80, right associativity).
Reserved Notation "x \/ y" (at level 85, right associativity).
Reserved Notation "~ x" (at level 75, right associativity).

(** Notations for equality and inequalities *)

Reserved Notation "x = y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x = y" (at level 70, no associativity).
Reserved Notation "x = y = z"
(at level 70, no associativity, y at next level).

Reserved Notation "x <> y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x <> y" (at level 70, no associativity).

Reserved Notation "x <= y" (at level 70, no associativity).
Reserved Notation "x < y" (at level 70, no associativity).
Reserved Notation "x >= y" (at level 70, no associativity).
Reserved Notation "x > y" (at level 70, no associativity).

Reserved Notation "x <= y <= z" (at level 70, y at next level).
Reserved Notation "x <= y < z" (at level 70, y at next level).
Reserved Notation "x < y < z" (at level 70, y at next level).
Reserved Notation "x < y <= z" (at level 70, y at next level).

(** Arithmetical notations (also used for type constructors) *)

Reserved Notation "x + y" (at level 50, left associativity).
Reserved Notation "x - y" (at level 50, left associativity).
Reserved Notation "x * y" (at level 40, left associativity).
Reserved Notation "x / y" (at level 40, left associativity).
Reserved Notation "- x" (at level 35, right associativity).
Reserved Notation "/ x" (at level 35, right associativity).
Reserved Notation "x ^ y" (at level 30, right associativity).

(** Notations for booleans *)

Reserved Notation "x || y" (at level 50, left associativity).
Reserved Notation "x && y" (at level 40, left associativity).

(** Notations for pairs *)

Reserved Notation "( x , y , .. , z )" (at level 0).

(** Notation "{ x }" is reserved and has a special status as component
    of other notations such as "{ A } + { B }" and "A + { B }" (which
    are at the same level than "x + y");
    "{ x }" is at level 0 to factor with "{ x : A | P }" *)

Reserved Notation "{ x }" (at level 0, x at level 99).

(** Notations for sigma-types or subsets *)

Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  & P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  & P  & Q }" (at level 0, x at level 99).

Delimit Scope type_scope with type.
Delimit Scope core_scope with core.

Open Scope core_scope.
Open Scope type_scope.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Reals.
Require Export Rfunction_def.

Open Scope Rfun_scope.

(** Compatibility of extensional equality *)

Ltac extensional_reflexivity H Heq :=
let swap H1 H2 :=
  clear H1;
  assert (H1 := H2);
  clear H2
in
let rec refl_aux H :=
match goal with
| |- forall x, _ =>
  let x := fresh "x" in
  let nH := fresh in
  intros x;
  assert (nH := H x);
  swap H nH;
  refl_aux H
| |- exists x, _ =>
  let x := fresh "x" in
  destruct H as [x H];
  exists x;
  refl_aux H
| |- ?P /\ ?Q =>
  let Hl := fresh "H" in
  let Hr := fresh "H" in
  destruct H as [Hl Hr];
  split; [refl_aux Hl|refl_aux Hr]
| |- ?P \/ ?Q =>
  let Hl := fresh "H" in
  let Hr := fresh "H" in
  destruct H as [Hl|Hr];
  [refl_aux Hl|refl_aux Hr]
| _ =>
  repeat (rewrite <- Heq); apply H
end in
compute in H |- *; refl_aux H.

Section Rfun_eq.

Variables f g : R -> R.
Hypothesis Heq : f == g.

Lemma Rfun_continuity_pt_eq_compat :
  forall x, continuity_pt f x -> continuity_pt g x.
Proof.
  intros x Hct eps H.
  specialize (Hct eps H).
  destruct Hct as (alp & pos & HH).
  exists alp. split; auto.
  intros x0 H0.
  specialize (HH x0 H0).
  eauto.
  repeat rewrite <-Heq.
  auto.
Qed.

Lemma Rfun_continuity_eq_compat :
  continuity f -> continuity g.
Proof.
  intros H i a p.
  destruct (H i a p).
  exists x. intuition.
  repeat rewrite <-Heq.
  eauto.
Qed.

End Rfun_eq.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* A set, with the axiom of decidability of the equality,               *)
(* is enumerable if it exists a list of its elements.                   *)

(* the following notions are defined :                                  *)
(*      - U_enumerable : set with a list of its elements                *)
(*      - U_canon : list with unique occurrence of its elements         *)
(*              constructors : U_canon_nil, U_canon_cons.               *)
(*      - U_sum : sommation of the images of a list.                    *)

Require Export Sets.
Require Export List.

Section ENUMERATION.

Variable U : Set.

Hypothesis U_separable : forall x y : U, {x = y} + {x <> y}.

Definition U_list := list U.

Definition U_enumerable (E : U_set U) :=
  {ul : U_list | forall x : U, E x -> In x ul}.

Inductive U_canon : U_list -> Prop :=
  | U_canon_nil : U_canon nil
  | U_canon_cons :
      forall (x : U) (ul : U_list),
      U_canon ul -> ~ In x ul -> U_canon (x :: ul).

Lemma U_in_dec : forall (x : U) (ul : U_list), {In x ul} + {~ In x ul}.
Proof.
        simple induction ul; intros.
        right; red in |- *; intros; inversion H.

        case (U_separable x a); intros.
        left; rewrite e; simpl in |- *; auto.

        case H; intros.
        left; simpl in |- *; auto.

        right; red in |- *; intros; inversion H0.
        elim n; auto.

        elim n0; auto.
Qed.

Variable f : U -> nat.

Fixpoint U_sum (ul : U_list) : nat :=
  match ul with
  | nil => 0
  | x :: ul' => f x + U_sum ul'
  end.

Lemma U_enumerable_sum : forall E : U_set U, U_enumerable E -> nat.
Proof.
        intros; elim H; intros.
        apply (U_sum x).
Defined.

End ENUMERATION.


(* Functions to print common data types. *)
Require Import Task.float_text_io.

Import FloatIO.

Module DebugIO.
Definition width := 22%nat.
Definition fdigs := 16%nat.
Definition print_float := float_to_string width fdigs.
Definition print_Z := Z_to_string_base10 1%nat.

End DebugIO.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************************)
(*                                                                          *)
(*  Proof of the three gap theorem.                                         *)
(*                                                                          *)
(*  Micaela Mayero (INRIA-Rocquencourt)                                     *)
(*  September 1998                                                          *)
(*                                                                          *)
(****************************************************************************)
(****************************************************************************)
(*                               preuve2.v                                  *)
(****************************************************************************)

(*********************************************************)
(*                 Intermediate proof 2                  *)
(*                                                       *)
(*********************************************************)

Require Export preuve1.
(*********************************************************)

Section Three.
Hypothesis alpha_irr : forall n p : Z, (alpha * IZR p)%R <> IZR n.
Hypothesis prop_alpha : (0 < alpha)%R /\ (alpha < 1)%R.
Hypothesis prop_N : forall N : nat, N >= 2.

(**********)
Lemma three_gap1 :
 forall N n : nat, 0 < n -> n < N - first N -> after N n = n + first N.
intros; generalize (inter31a alpha_irr prop_alpha prop_N N n); intros;
 generalize (eq_after_M_N1 alpha_irr prop_alpha prop_N N n H H0);
 intro; rewrite <- H2; cut (n < last (M N)).
intro;
 rewrite
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))); apply (H1 H H3).
generalize
 (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (first N + last N)));
 intro; generalize (le_lt_or_eq N (first N + last N) H3);
 intro; elim H4; intro.
cut (N - first N < last (M N)).
intro; apply (lt_trans n (N - first N) (last (M N)) H0 H6).
rewrite <-
 (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N)));
 apply (lt_plus_minus N (first N) (last N) (first_N N (prop_N N)) H5).
rewrite <-
 (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
    (refl_equal (first N + last N))); cut (M N = first N + last N).
intro; rewrite <- H6 in H5; rewrite H5 in H0;
 rewrite <-
  (first_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))) in H0;
 rewrite (plus_minus (M N) (first N) (last N) H6);
 auto with arith real.
auto with arith real.
Qed.

(**********)
Lemma three_gap2 :
 forall N n : nat,
 N - first N <= n -> n < last N -> after N n = n + first N - last N.
intros; apply sym_equal;
 apply (tech_after alpha_irr N n (n + first N - last N)).
generalize (first_N N (prop_N N)); intro;
 generalize (lt_minus2 (first N) N H1); intro;
 apply (lt_le_trans 0 (N - first N) n H2 H).
generalize (last_N N (prop_N N)); intro; apply (lt_trans n (last N) N H0 H1).
auto with arith real.
generalize (plus_lt_compat_r n (last N) (first N) H0); intro;
 generalize (lt_reg_minus (n + first N) (last N + first N) (last N) H1);
 intro; rewrite (minus_plus (last N) (first N)) in H2;
 cut (last N <= n + first N).
intro;
 apply
  (lt_trans (n + first N - last N) (first N) N (H2 H3) (first_N N (prop_N N))).
clear H1 H2; generalize (le_minus_plus N (first N) n H); intro;
 apply (le_trans (last N) N (n + first N) (last_N01 N) H1).
apply (tech1 alpha_irr prop_alpha prop_N N n H H0).
generalize (tech_suc_M alpha_irr prop_alpha prop_N N n H H0);
 auto with arith real.
Qed.

(**********)
Lemma three_gap3 :
 forall N n : nat, last N <= n -> n < N -> after N n = n - last N.
intros; generalize (inter31b alpha_irr prop_alpha prop_N N n); intros;
 generalize (eq_after_M_N2 alpha_irr prop_alpha prop_N N n H H0);
 intro; rewrite <- H2; cut (n < M N).
intro;
 rewrite
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N)));
 rewrite
  (last_eq_M_N alpha_irr prop_alpha prop_N N (M N)
     (refl_equal (first N + last N))) in H; apply (H1 H H3).
generalize
 (le_N_M alpha_irr prop_alpha prop_N N (M N) (refl_equal (first N + last N)));
 intro; unfold M in |- *; apply (lt_le_trans n N (first N + last N) H0 H3).
Qed.

End Three.


Require Import Classical.
(* Used in various places:
    - existence of a derivation in the axiomatic system for a sequent
      (should be decidable as Bi-Int is, but this would require extra work)
    - some set-theoretic arguments (maybe they can be constructivised *)

Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import BiInt_GHC.
Require Import BiInt_logics.
Require Import BiInt_extens_interactions.
Require Import wBIH_meta_interactions.
Require Import sBIH_meta_interactions.
Require Import BiInt_Kripke_sem.
Require Import BiInt_Lindenbaum_lem.

Definition CompNotDer (s: prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V))) : Prop :=
  (complete (fst s, snd s) /\ (wpair_derrec (fst s, snd s) -> False)).

Lemma clos_deriv : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) ->
                                (forall A, wBIH_rules (Γ, A) -> (In _ Γ A)).
Proof.
intros. destruct H. simpl in H. simpl in H1. pose (H A). destruct o.
auto. simpl in H2. exfalso. apply H1. exists [A]. repeat split.
apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H3. subst.
auto. inversion H4. simpl. apply MP with (ps:=[(Γ, Imp A (Or A (Bot V)));(Γ, A)]).
2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
apply RA2_I. exists A. exists (Bot V). auto. inversion H4. subst. 2: inversion H5.
assumption.
Qed.

Lemma primeness : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) ->
                                (forall A B, (In _ Γ (Or A B))  -> ((In _ Γ A) \/ (In _ Γ B))).
Proof.
intros. destruct H. simpl in H. simpl in H1. pose (H A). pose (H B).
destruct o ; destruct o0 ; auto. simpl in H2. simpl in H3. exfalso. apply H1.
destruct (eq_dec_form A B). subst. exists [B].
repeat split. apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H4.
subst. auto. inversion H5. simpl. apply MP with (ps:=[(Γ, Imp B (Or B (Bot V)));(Γ, B)]).
2: apply MPRule_I. intros. inversion H4. subst. apply Ax. apply AxRule_I.
apply RA2_I. exists B. exists (Bot V). auto. inversion H5. 2: inversion H6. subst.
apply MP with (ps:=[(Γ,(Or B B) → B);(Γ,(Or B B))]). 2: apply MPRule_I.
intros. inversion H6. subst.
apply MP with (ps:=[(Γ,(B → B) → (Or B B) → B);(Γ,(B → B))]). 2: apply MPRule_I.
intros. inversion H7. subst.
apply MP with (ps:=[(Γ,(B → B) → (B → B) → (Or B B) → B);(Γ,(B → B))]). 2: apply MPRule_I.
intros. inversion H8. subst. apply Ax. apply AxRule_I. apply RA4_I.
exists B. exists B. exists B. auto. inversion H9. 2: inversion H10.
subst. apply wimp_Id_gen. inversion H8. 2: inversion H9. subst. apply wimp_Id_gen.
inversion H7. subst. 2: inversion H8. apply Id. apply IdRule_I. auto.
exists (A :: [B]). repeat split. apply NoDup_cons. intro. inversion H4. auto.
inversion H5. apply NoDup_cons ; auto ; apply NoDup_nil. intros.
simpl. inversion H4. subst. auto. inversion H5. subst. auto. inversion H6.
simpl. apply MP with (ps:=[(Γ, Imp (Or A B) (Or A (Or B (Bot V))));(Γ, Or A B)]).
2: apply MPRule_I. intros. inversion H4. subst.
apply MP with (ps:=[(Γ,(B → Or A (Or B (Bot V))) → (Or A B → Or A (Or B (Bot V))));
(Γ, (B → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros. inversion H5. subst.
apply MP with (ps:=[(Γ,(A → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))) → (Or A B → Or A (Or B (Bot V))));
(Γ, (A → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros. inversion H6. subst.
apply Ax. apply AxRule_I. apply RA4_I. exists A. exists B. exists (Or A (Or B (Bot V))).
auto. inversion H7. subst. 2: inversion H8. apply Ax. apply AxRule_I.
apply RA2_I. exists A. exists (Or B (Bot V)). auto. inversion H6. 2: inversion H7.
subst.
apply MP with (ps:=[(Γ, ((Or B (Bot V)) → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))));
(Γ, ((Or B (Bot V)) → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros.
inversion H7. subst.
apply MP with (ps:=[(Γ, (B → (Or B (Bot V))) → ((Or B (Bot V)) → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))));
(Γ, (B → (Or B (Bot V))))]). 2: apply MPRule_I. intros.
inversion H8. subst. apply Ax. apply AxRule_I. apply RA1_I. exists B.
exists (Or B (Bot V)). exists (Or A (Or B (Bot V))). auto. inversion H9. subst.
2: inversion H10. apply Ax. apply AxRule_I. apply RA2_I. exists B. exists (Bot V). auto.
inversion H8. 2: inversion H9. subst. apply Ax. apply AxRule_I. apply RA3_I.
exists A. exists (Or B (Bot V)). auto. inversion H5. subst. 2: inversion H6.
apply Id. apply IdRule_I. auto.
Qed.

Lemma cp_Bot_R : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) -> (In _ Δ (Bot V)).
Proof.
intros. destruct H. simpl in H. simpl in H0. pose (H (Bot V)). destruct o ; auto.
simpl in H1. exfalso. apply H0. exists []. repeat split. apply NoDup_nil.
intros. inversion H2. simpl. apply Id. apply IdRule_I. auto.
Qed.

Definition Canon_worlds : Type :=
  {x : prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V)) | CompNotDer x}.

Definition Canon_rel (P0 P1 : Canon_worlds) : Prop :=
  Included _ (fst (proj1_sig P0)) (fst (proj1_sig P1)).

Definition Canon_val (P : Canon_worlds) (q : V) : Prop :=
  In _ (fst (proj1_sig P)) (# q).

Lemma C_R_refl u : Canon_rel u u.
Proof.
unfold Canon_rel. intro. auto.
Qed.

Lemma C_R_trans u v w: Canon_rel u v -> Canon_rel v w -> Canon_rel u w.
Proof.
intros. unfold Canon_rel.
intro. intros. unfold Canon_rel in H0. unfold Canon_rel in H.
apply H0. apply H. auto.
Qed.

Lemma C_val_persist : forall u v, Canon_rel u v -> forall p, Canon_val u p -> Canon_val v p.
Proof.
intros.
unfold Canon_val in H0. unfold Canon_rel in H.
unfold Canon_val. apply H. auto.
Qed.

Instance CM : model :=
      {|
        nodes := Canon_worlds ;
        reachable := Canon_rel ;
        val := Canon_val ;

        reach_refl := C_R_refl ;
        reach_tran := C_R_trans ;

        persist := C_val_persist;
      |}.

Lemma truth_lemma : forall A (cp : Canon_worlds),
  (wforces CM cp A) <-> (In _ (fst (proj1_sig cp)) A).
Proof.
induction A ; intro ; split ; intros ; destruct cp ; simpl ; try simpl in H ; auto.
(* Bot V *)
- inversion H.
- destruct x. simpl in H. unfold CompNotDer in c. destruct c. simpl in H1. apply H1.
  unfold wpair_derrec. simpl. exists []. repeat split. apply NoDup_nil. intros.
  inversion H2. simpl. apply Id. apply IdRule_I. auto.
(* Top V *)
- pose (classic (In (BPropF V) (fst x) (Top V))). destruct o. auto.
  exfalso. destruct x. simpl in H0. simpl in c. unfold CompNotDer in c.
  clear H. destruct c. simpl in H. simpl in H1. apply H1. unfold wpair_derrec.
  exists [Top V]. repeat split. apply NoDup_cons. auto. apply NoDup_nil.
  intros. inversion H2. subst. simpl. unfold complete in H. simpl in H. clear H2.
  pose (H (Top V)). destruct o. exfalso. apply H0. auto. auto. inversion H3.
  simpl. apply MP with (ps:=[(e, Imp (Top V) (Or (Top V) (Bot V))); (e, (Top V))]).
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA2_I.
  exists (Top V). exists (Bot V). auto. inversion H3. subst.
  apply MP with (ps:=[(e, Imp (Imp (Top V) (Top V)) (Top V)); (e, Imp (Top V) (Top V))]).
  intros. inversion H4. subst. apply Ax. apply AxRule_I. apply RA15_I.
  exists (Top V → Top V). auto. inversion H5. subst. apply wimp_Id_gen. inversion H6.
  apply MPRule_I. inversion H4. apply MPRule_I.
(* And A1 A2 *)
- destruct H. apply IHA1 in H. simpl in H. apply IHA2 in H0. simpl in H0.
  apply clos_deriv with (Δ:=snd x). auto.
  apply MP with (ps:=[(fst x, A1 → (And A1 A2));(fst x, A1)]).
  2: apply MPRule_I. intros. inversion H1. subst.
  apply MP with (ps:=[(fst x, (A1 → A2) → (A1 → (And A1 A2)));(fst x, (A1 → A2))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(fst x, (A1 → A1) → (A1 → A2) → (A1 → (And A1 A2)));(fst x, (A1 → A1))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
  apply RA7_I. exists A1. exists A1. exists A2. auto. inversion H4.
  subst. 2: inversion H5. apply wimp_Id_gen. inversion H3. subst. 2: inversion H4.
  apply MP with (ps:=[(fst x, A2 → (A1 → A2));(fst x, A2)]).
  2: apply MPRule_I. intros. inversion H4. subst. apply wThm_irrel.
  inversion H5. subst. 2: inversion H6. apply Id. apply IdRule_I. assumption.
  inversion H2. subst. apply Id. apply IdRule_I. assumption. inversion H3.
- split. apply IHA1. simpl. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp (And A1 A2) A1);(fst x, (And A1 A2))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA5_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
  apply IHA2. simpl. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp (And A1 A2) A2);(fst x, (And A1 A2))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA6_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
(* Or A1 A2 *)
- destruct H.
  apply IHA1 in H. simpl in H. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp A1 (Or A1 A2));(fst x, A1)]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA2_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
  apply IHA2 in H. simpl in H. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp A2 (Or A1 A2));(fst x, A2)]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA3_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
- apply primeness with (Δ:=snd x) in H ; auto. destruct H. left. apply IHA1 ; auto.
  right. apply IHA2 ; auto.
(* Imp A1 A2 *)
- destruct x. simpl. destruct (classic (In (BPropF V) e (A1 → A2))).
  auto. exfalso. unfold CompNotDer in c. simpl in c. destruct c.
  assert (wpair_derrec (Union _ e (Singleton _ A1), Singleton _ A2) -> False).
  intro. apply gen_wBIH_Deduction_Theorem in H1. apply H0.
  { apply clos_deriv with (Δ:=e0). unfold CompNotDer ; auto. destruct H1.
    destruct H1. destruct H2. destruct x. simpl in H3. simpl in H2.
    apply MP with (ps:=[(e, Imp (Bot V) (A1 → A2));(e, Bot V)]). 2: apply MPRule_I.
    intros. inversion H4. subst. apply wEFQ. inversion H5. 2: inversion H6. subst.
    assumption. inversion H1. subst. pose (H2 b). assert (List.In b (b :: x)). apply in_eq.
    apply s in H4. inversion H4. subst. destruct x. simpl in H3.
    apply absorp_Or1 in H3. auto. pose (H2 b). assert (List.In b (A1 → A2 :: b :: x)).
    apply in_cons. apply in_eq. apply s0 in H5. inversion H5. subst. inversion H1.
    subst. exfalso. apply H10. apply in_eq. }
  apply Lindenbaum_lemma in H1. destruct H1. destruct H1.
  destruct H1. destruct H2. destruct H3.
  assert (J1: complete (fst (x, x0), snd (x, x0)) /\ (wpair_derrec (fst (x, x0), snd (x, x0)) -> False)). auto.
  pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x,x0) J1).
  pose (H s).
  assert (J2: Canon_rel (exist (fun x : Ensemble (BPropF V) * Ensemble (BPropF V) =>
  CompNotDer x) (e, e0) (conj c f)) s). unfold Canon_rel. simpl.
  intro. intros. apply H1. apply Union_introl. auto. apply w in J2.
  apply IHA2 in J2. simpl in J2.
  apply H4. exists [A2]. repeat split. apply NoDup_cons. auto. apply NoDup_nil.
  intros. inversion H5. subst. simpl. apply H2. apply In_singleton. inversion H6.
  simpl. apply MP with (ps:=[(x, Imp A2 (Or A2 (Bot V)));(x, A2)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2. exists (Bot V).
  auto. inversion H6. 2: inversion H7. subst. apply Id. apply IdRule_I. auto.
  apply IHA1. simpl. apply H1. apply Union_intror. apply In_singleton.
- intros. destruct x. simpl in H. destruct v. simpl. destruct x. simpl.
  apply IHA1 in H1. simpl in H1. unfold Canon_rel in H0. simpl in H0.
  apply H0 in H. unfold CompNotDer in c0. destruct c0. simpl in f. simpl in c0.
  apply IHA2. simpl.
  assert (wpair_derrec (e1, Singleton _ A2)). exists [A2]. repeat split.
  apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H2. subst. apply In_singleton.
  inversion H3. simpl.
  apply MP with (ps:=[(e1, Imp A2 (Or A2 (Bot V)));(e1, A2)]). 2: apply MPRule_I.
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2. exists (Bot V).
  auto. inversion H3. subst.
  apply MP with (ps:=[(e1, Imp A1 A2);(e1, A1)]). 2: apply MPRule_I.
  intros. inversion H4. subst. apply Id. apply IdRule_I. auto.
  inversion H5. 2: inversion H6. subst. apply Id. apply IdRule_I. auto.
  inversion H4.
  apply clos_deriv with (Δ:=e2). unfold CompNotDer ; auto. destruct H2. destruct H2.
  destruct H3. destruct x. simpl in H4. apply MP with (ps:=[(e1, Imp (Bot V) A2);(e1, Bot V)]).
  2: apply MPRule_I. intros. inversion H5. subst. apply wEFQ. inversion H6. 2: inversion H7.
  subst. auto. inversion H2. subst. pose (H3 b). assert (List.In b (b :: x)).
  apply in_eq. apply s in H5. inversion H5. subst. destruct x. simpl in H4.
  apply absorp_Or1 in H4. auto. exfalso. pose (H3 b0). assert (List.In b0 (b :: b0 :: x)).
  apply in_cons. apply in_eq. apply s0 in H6. inversion H6. subst. apply H7. apply in_eq.
(* Excl A1 A2 *)
- destruct H. destruct H. destruct H0. apply IHA1 in H0.
  assert (In (BPropF V) (fst (proj1_sig x0)) (Or A2 (Excl A1 A2))).
  apply clos_deriv with (Δ:=(snd (proj1_sig x0))). unfold CompNotDer ; auto.
  destruct x0. simpl. auto. destruct x0. simpl.
  apply MP with (ps:=[(fst x0, Imp A1 (Or A2 (Excl A1 A2)));(fst x0, A1)]). 2: apply MPRule_I.
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA11_I. exists A1.
  exists A2. auto. inversion H3. 2: inversion H4. subst. apply Id. apply IdRule_I.
  auto. apply primeness with (Δ:=snd (proj1_sig x0)) in H2. destruct H2 ; auto. exfalso.
  apply H1. apply IHA2 ; auto. destruct x0. simpl in H2. auto.
- assert (wpair_derrec ((Singleton _ A1), Union _ (snd x) (Singleton _ A2)) -> False).
  intro. destruct H0. destruct H0. destruct H1. simpl in H2. simpl in H1.
  destruct x. simpl in H. simpl in H1. destruct c. simpl in H3. simpl in H4.
  pose (remove_disj x0 A2 (Singleton (BPropF V) A1)).
  assert (wBIH_rules (Singleton (BPropF V) A1, Or A2 (list_disj (remove eq_dec_form A2 x0)))).
  apply MP with (ps:=[(Singleton (BPropF V) A1, list_disj x0 → Or A2
   (list_disj (remove eq_dec_form A2 x0)));(Singleton (BPropF V) A1, list_disj x0)]).
  2: apply MPRule_I. intros. inversion H5. subst. auto. inversion H6. subst.
  auto. inversion H7. clear w. clear H2.
  assert (Singleton (BPropF V) A1 = Union _ (Empty_set _) (Singleton (BPropF V) A1)).
  apply Extensionality_Ensembles. split. intro. intros. inversion H2. subst.
  apply Union_intror. apply In_singleton. intro. intros. inversion H2.
  subst. inversion H6. inversion H6. subst. apply In_singleton. rewrite H2 in H5.
  assert (J1: Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1) =
  Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1)). auto.
  assert (J2: Or A2 (list_disj (remove eq_dec_form A2 x0)) = Or A2 (list_disj (remove eq_dec_form A2 x0))). auto.
  pose (wBIH_Deduction_Theorem (Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1),
  Or A2 (list_disj (remove eq_dec_form A2 x0))) H5 A1 (Or A2 (list_disj (remove eq_dec_form A2 x0)))
  (Empty_set _) J1 J2). apply wdual_residuation in w. clear J2. clear J1. clear H2.
  clear H5.
  apply H4. exists (remove eq_dec_form A2 x0). repeat split. apply NoDup_remove.
  auto. intros. simpl. pose (H1 A). assert (List.In A x0). apply In_remove with (B:= A2).
  auto. apply u in H5. inversion H5. subst. auto. subst. inversion H6.
  subst. exfalso. apply remove_In in H2. auto. simpl.
  apply MP with (ps:=[(e, Excl A1 A2 → list_disj (remove eq_dec_form A2 x0));(e, Excl A1 A2)]).
  2: apply MPRule_I. intros. inversion H2. subst.
  pose (wBIH_monot (Empty_set (BPropF V), Excl A1 A2 → list_disj (remove eq_dec_form A2 x0))
  w e). apply w0. clear w0. simpl. intro. intros. inversion H5. inversion H5.
  subst. 2: inversion H6. clear H2. clear H5. apply Id. apply IdRule_I. auto.
  apply Lindenbaum_lemma in H0. destruct H0. destruct H0. destruct H0.
  destruct H1. destruct H2.
  assert (J1: CompNotDer (x0, x1)). unfold CompNotDer. auto.
  pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x0,x1) J1).
  exists s. unfold Canon_rel. simpl. split. destruct x. simpl.
  intro. intros. destruct c. simpl in H5. pose (H5 x). destruct o.
  simpl in H7. auto. simpl in H7. exfalso. pose (H1 x). simpl in i.
  assert (In (BPropF V) (Union (BPropF V) e0 (Singleton (BPropF V) A2)) x).
  apply Union_introl. auto. apply i in H8. apply H3. exists [x].
  repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
  intros. inversion H9. subst. simpl. auto. inversion H10.
  simpl. apply MP with (ps:=[(x0, Imp x (Or x (Bot V))); (x0, x)]).
  2: apply MPRule_I. intros. inversion H9. subst.
  apply Ax. apply AxRule_I. apply RA2_I. exists x. exists (Bot V). auto.
  inversion H10. 2: inversion H11. subst. apply Id. apply IdRule_I.
  auto. split. apply IHA1. simpl. apply H0. apply In_singleton.
  intro. apply IHA2 in H4. simpl in H4. apply H3. exists [A2].
  repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
  intros. inversion H5. subst. simpl. apply H1. apply Union_intror.
  apply In_singleton. inversion H6. simpl.
  apply MP with (ps:=[(x0, Imp A2 (Or A2 (Bot V)));(x0, A2)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2.
  exists (Bot V). auto. inversion H6. 2: inversion H7. subst. clear H5.
  clear H6. apply Id. apply IdRule_I. auto.
Qed.

Theorem wCounterCompleteness : forall (Γ Δ : @Ensemble (BPropF V)),
    (wpair_derrec (Γ, Δ) -> False) -> ((loc_conseq Γ Δ) -> False).
Proof.
intros Γ Δ WD.
apply Lindenbaum_lemma in WD. destruct WD. destruct H. destruct H. destruct H0.
destruct H1. intro. unfold loc_conseq in H3.
assert (J1: complete (fst (x, x0), snd (x, x0)) /\ (wpair_derrec (fst (x, x0), snd (x, x0)) -> False)). auto.
pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x,x0) J1).
pose (H3 CM s).
assert ((forall A : BPropF V, In (BPropF V) Γ A -> wforces CM s A)). intros. apply truth_lemma. auto.
apply e in H4. destruct H4. destruct H4. apply truth_lemma in H5. simpl in H5.
apply H2. exists [x1]. repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
intros. inversion H6. simpl. subst. apply H0 ; auto. inversion H7. simpl.
apply MP with (ps:=[(x, Imp x1 (Or x1 (Bot V)));(x, x1)]). 2: apply MPRule_I.
intros. inversion H6. subst. apply Ax. apply AxRule_I. apply RA2_I. exists x1. exists (Bot V).
auto. inversion H7. subst. 2: inversion H8. apply Id. apply IdRule_I. auto.
Qed.

Theorem wCompleteness : forall (Γ Δ : @Ensemble (BPropF V)),
    (loc_conseq Γ Δ) -> wpair_derrec (Γ, Δ).
Proof.
intros Γ Δ LC. pose (wCounterCompleteness Γ Δ).
pose (classic (wpair_derrec (Γ, Δ))). destruct o. auto. exfalso.
apply f ; assumption.
Qed.